3

別の関数によって処理されたときに削除されるオブジェクトに属性を設定する方法はありますか? たとえば、次のように書きます。

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

一連の相関関係について加重フィッシャー変換 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 の結果からの名前属性を保持しています。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 に答える