3

有没有办法在另一个函数处理时删除的对象上设置属性？例如，我可能会写：

weightedMeanZr <- function(r,n) {
   require(psych)
   Zr <- fisherz(r) 
   ZrBar <- sum(Zr*(n-3))/(sum(n-3))
   attr(ZrBar,"names") <- "ZrBar"
   return(ZrBar)
}

计算一组相关性的加权 Fisher 变换 Z 平均值。但是，如果我将其转换回 r，例如

require(psych)
bdata <- structure(list(Sample = 1:6, n = c(4L, 13L, 9L, 5L, 11L, 14L), 
    r = c(0.93, 0.57, 0.46, -0.09, 0.12, 0.32)), .Names = c("Sample", 
"n", "r"), class = "data.frame", row.names = c(NA, -6L))

fisherz2r(with(bdata,weightedMeanZr(r,n)))

from 的输出值fisherz2r保留了 weightedMeanZr 结果中的 names 属性。有什么方法可以使该属性变得脆弱，以便由诸如fisherz2r删除名称属性之类的函数处理？

编辑 类似这样的东西：

weightedMeanZr <- function(r,n) {
   require(psych)
   Zr <- fisherz(r) 
   ZrBar <- sum(Zr*(n-3))/(sum(n-3))
   class(ZrBar) <- "ZrBar"
   return(ZrBar)
}
"+.ZrBar" <- function(e1,e2) {
    return(unclass(e1)+unclass(e2))
}
"-.ZrBar" <- function(e1,e2) {
    return(unclass(e1)-unclass(e2))
}
"*.ZrBar" <- function(e1,e2) {
    return(unclass(e1)*unclass(e2))
}
"/.ZrBar" <- function(e1,e2) {
    return(unclass(e1)/unclass(e2))
}
weightedMeanZr(bdata$r,bdata$n)
weightedMeanZr(bdata$r,bdata$n)+1
weightedMeanZr(bdata$r,bdata$n)-1
weightedMeanZr(bdata$r,bdata$n)*2
weightedMeanZr(bdata$r,bdata$n)/2
fisherz2r(weightedMeanZr(bdata$r,bdata$n))

...但这仅适用于fisherz2r调用这些特定方法...是否有更通用的方法？

4

2 回答 2

4

您可以使用unname删除名称

 fisherz2r(with(bdata,unname(weightedMeanZr(r,n))))
 # or
 unname(fisherz2(with(bdata,weightedMeanZr(r,n))))

或as.vector，在这种情况下将删除名称

于 2013-03-14T21:43:03.600 回答
2

不，没有办法自动做我想做的事情（据我所知，至少从 R 2.15.2 开始）。R 中有一个回调系统（感谢@JoshuaUlrich 让我想到了这个关键字），但是尝试实现所需的行为可能在计算上很昂贵。

但是，这是一个（工作）示例：

require(psych)
bdata <- structure(list(Sample = 1:6, n = c(4L, 13L, 9L, 5L, 11L, 14L), 
                        r = c(0.93, 0.57, 0.46, -0.09, 0.12, 0.32)), .Names = c("Sample", 
                                                                                "n", "r"), class = "data.frame", row.names = c(NA, -6L))

weightedMeanZr <- function(r,n) {
  require(psych)
  Zr <- fisherz(r) 
  ZrBar <- sum(Zr*(n-3))/(sum(n-3))
  attr(ZrBar,"original.value") <- ZrBar
  class(ZrBar) <- "ZrBar"
  attr(ZrBar,"names") <- "ZrBar"
  return(ZrBar)
}

h <- taskCallbackManager() #create the callback system

# add a callback
h$add(function(expr, value, ok, visible) {
  cat("In handler",george,"\n")
  ZrBars <- names(which(lapply(sapply(ls(name=.GlobalEnv,all=TRUE),get),class) == "ZrBar"))
  for (i in ZrBars) {
    thisone <- get(i)
    if(!attr(thisone,"original.value") == thisone) {
      attr(thisone,"names") <- NULL
      attr(thisone,"class") <- NULL
      attr(thisone,"original.value") <- NULL
      assign(i,thisone,envir=.GlobalEnv)
    }
  }
  return(TRUE)
}, name = "simpleHandler")

#create some objects of the class
thisone <- weightedMeanZr(runif(10),4:13)
thistoo <- weightedMeanZr(runif(10),4:13)

thisone + 1 #class kept, a print method could be added to resolve this issue
#if we store the result, it goes away as desired
(um <- thisone + 1) #class gone\

#clean out workspace so the callback system doesn't linger
removeTaskCallback("R-taskCallbackManager")
于 2013-03-15T19:10:51.133 回答