Question

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

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)))

fisherz2r的输出值保留了weightedMeanZr结果中的names属性。是否有任何方法可以使该属性变得脆弱，以便由fisherz2r之类的函数处理，从而删除names属性？

修改像这样的东西：

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称之为特定方法......是否有更通用的方法？

Answer 1

您可以使用unname删除姓名

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

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

Answer 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")

有没有办法在R中创建“脆弱”属性？

2 个答案: