CODEWITHSUNDEEP
rclassattributes
russellpierce
russellpierce

Reputation: 4711

Is there any way to create "fragile" attributes in R?

Is there any way to set an attribute on an object that is removed when it is processed by another function? For example, I might write:

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

To calculated the weighted fisher transformed Z average for a set of correlations. However, if I convert it back into an r, e.g.

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

The output value from fisherz2r has retained the names attribute from the results of weightedMeanZr. Is there any way to make that attribute fragile such that being processed by functions like fisherz2r removes the names attribute?

Edit Something like what this accomplishes:

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

... but this only works because fisherz2r calls those particular methods... is there a more general approach?

Upvotes: 3

Views: 106

Answers (2)

russellpierce
russellpierce

Reputation: 4711

No, there isn't a way to automatically do what I am trying to do (at least as of R 2.15.2 as far as I can tell). There is a callback system in R (thanks go to @JoshuaUlrich for bringing that keyword to mind), but trying to implement the desired behavior may be computationally expensive.

However, here is a (working) example:

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

Upvotes: 2

mnel
mnel

Reputation: 115435

You can use unname to remove names

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

or as.vector, which in this case will strip the names

Upvotes: 4

Related Questions