如何修补 R 包中的 S4 方法？答案

【问题标题】：How to patch an S4 method in an R package?如何修补 R 包中的 S4 方法？
【发布时间】：2010-05-14 15:29:07
【问题描述】：

如果您在包中发现错误，通常可以使用fixInNamespace 修补问题，例如fixInNamespace("mean.default", "base").

对于 S4 方法，我不知道该怎么做。我正在查看的方法在 gWidgetstcltk 包中。您可以查看源代码

getMethod(".svalue", c("gTabletcltk", "guiWidgetsToolkittcltk"))

我找不到fixInNamespace 的方法。

fixInNamespace(".svalue", "gWidgetstcltk")

Error in get(subx, envir = ns, inherits = FALSE) : 
  object '.svalue' not found

我认为setMethod 可能会成功，但是

setMethod(".svalue", c("gTabletcltk", "guiWidgetsToolkittcltk"),
  definition = function (obj, toolkit, index = NULL, drop = NULL, ...) 
  {
      widget = getWidget(obj)
      sel <- unlist(strsplit(tclvalue(tcl(widget, "selection")), 
          " "))
      if (length(sel) == 0) {
          return(NA)
      }
      theChildren <- .allChildren(widget)
      indices <- sapply(sel, function(i) match(i, theChildren))
      inds <- which(visible(obj))[indices]
      if (!is.null(index) && index == TRUE) {
          return(inds)
      }
      if (missing(drop) || is.null(drop)) 
          drop = TRUE
      chosencol <- tag(obj, "chosencol")
      if (drop) 
          return(obj[inds, chosencol, drop = drop])
      else return(obj[inds, ])
  },
  where = "package:gWidgetstcltk"  
)

Error in setMethod(".svalue", c("gTabletcltk", "guiWidgetsToolkittcltk"),  : 
  the environment "gWidgetstcltk" is locked; cannot assign methods for function ".svalue"

有什么想法吗？

【问题讨论】：

我建议将补丁提交给软件包作者。
@Shane：我已经完成了，但我很不耐烦，想立即看到更改后的版本。

标签： r s4 gwidgets

【解决方案1】：

获取源、应用更改和重建的老式方法怎么样？

【讨论】：

我感觉这可能是唯一的答案。不过看起来很费劲。

【解决方案2】：

你可以先取出泛型，然后在你的全局环境中通过 setMethod 修复泛型，然后将它分配回那个命名空间

.svalue <- gWidgetstcltk:::.svalue
setMethod(".svalue", c("gTabletcltk", "guiWidgetsToolkittcltk"),
  definition = function (obj, toolkit, index = NULL, drop = NULL, ...) 
  {
      widget = getWidget(obj)
      sel <- unlist(strsplit(tclvalue(tcl(widget, "selection")), 
          " "))
      if (length(sel) == 0) {
          return(NA)
      }
      theChildren <- .allChildren(widget)
      indices <- sapply(sel, function(i) match(i, theChildren))
      inds <- which(visible(obj))[indices]
      if (!is.null(index) && index == TRUE) {
          return(inds)
      }
      if (missing(drop) || is.null(drop)) 
          drop = TRUE
      chosencol <- tag(obj, "chosencol")
      if (drop) 
          return(obj[inds, chosencol, drop = drop])
      else return(obj[inds, ])
  }#,
  #where = "package:gWidgetstcltk"  
)
assignInNamespace(".svalue", .svalue, ns = "gWidgetstcltk")

【讨论】：