R에 "깨지기 쉬운"속성을 만들 수있는 방법이 있습니까?

Question

다른 함수에 의해 처리 될 때 제거되는 개체에 특성을 설정할 수있는 방법이 있습니까? 예를 들어, 다음과 같이 쓸 수 있습니다.

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 때문에?

Answer 1

당신은 이름

이 경우 이름

을 제거합니다

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

또는 as.vector을 제거 할 unname을 사용할 수 있습니다

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