Функция переопределения в пакете R

Question

Итак, я пытаюсь внести изменения в пакет ctree (часть пакета partykit). В частности, я хочу удалить объект в глобальной среде и запустить gc(), чтобы помочь сохранить память (R работает очень медленно, когда он доходит до точки использования файла страницы Windows). Я сделал это так далеко, как с помощью fixInNamespace:

fixInNamespace(ctree,"partykit") 

я заметил, что мои изменения не работал, так что я даже пошел в меру делать это как код замены:

function(formula, data, weights, subset, na.action = na.pass, 
        control = ctree_control(...), ytrafo = NULL, 
        scores = NULL, ...) { 

    return("foo") 
} 

Я также попытался использовать это:

tmpfun <- get("ctree", envir = asNamespace("partykit")) 
environment(ctree) <- environment(tmpfun) 
attributes(ctree) <- attributes(tmpfun) # don't know if this is really needed 
assignInNamespace("ctree", ctree, ns="partykit") 

Независимо от того, что я, кажется, делать, я застрял с версией библиотеки из Ctree. Кстати, я использую RStudio 0.98.507 и R 3.1.1 в Windows 8.1.

Связано ли это с внешним кодом C в вызове .ctree_fit?

Кроме того, прежде чем мы спустимся по пути «R копирует только записи ...» Я уже подтвердил, что мы закончили с несколькими копиями набора данных. См:

> d2<-iris 
> tracemem(iris) 
[1] "<0x0000000019c7f5f8>" 
> tracemem(d2) 
[1] "<0x0000000019c7f5f8>" 
> cttest<-ctree(Species~.,data=d2) 
> tracemem(cttest$data) 
[1] "<0x0000000008af8e30>" 

Спасибо за пост до сих пор, но когда я пытаюсь что я пытаюсь, я получаю следующее сообщение об ошибке:

> cttest<-ctree(Species~.,data=d2) 
Error in environment(partykit) : object 'partykit' not found 

Вот уже фрагмент кода, который показывает, что я пытаясь достичь:

require(partykit) 

ctree(Species~.,data=iris) 

package_name<-"partykit" 
function_name<-"ctree" 


# 
# Borrowed: https://github.com/robertzk/testthatsomemore/blob/master/R/stub.R 
# 

namespaces <- 
    list(as.environment(paste0('package:', package_name)), 
     getNamespace(package_name)) 
if (!exists(function_name, envir = namespaces[[1]], inherits = FALSE)) 
    namespaces <- namespaces[-1] 
if (!exists(function_name, envir = tail(namespaces,1)[[1]], inherits = FALSE)) 
    stop(gettextf("Cannot stub %s::%s because it must exist in the package", 
       package_name, function_name)) 
lapply(namespaces, unlockBinding, sym = function_name) 
# Clean up our stubbing on exit 
previous_object <- get(function_name, envir = tail(namespaces,1)[[1]]) 
on.exit({ 
    lapply(namespaces, function(ns) { 
    tryCatch(error = function(.) NULL, assign(function_name, previous_object, envir = ns)) 
    lockBinding(function_name, ns) 
    }) 
}) 
lapply(namespaces, function(ns) 
    assign(function_name, 
     # 
     # Modified ctree - kill original data variable prior to running longer-running algorithm 
     # 

     function(formula, data, weights, subset, na.action = na.pass, 
           control = ctree_control(...), ytrafo = NULL, 
           scores = NULL, ...) { 



    if (missing(data)) 
     data <- environment(formula) 
    mf <- match.call(expand.dots = FALSE) 
    m <- match(c("formula", "data", "subset", "weights", "na.action"), 
       names(mf), 0) 
    mf <- mf[c(1, m)] 

    ### only necessary for extended model formulae 
    ### e.g. multivariate responses 
    formula <- Formula::Formula(formula) 
    mf$formula <- formula 
    mf$drop.unused.levels <- FALSE 
    mf$na.action <- na.action 
    mf[[1]] <- as.name("model.frame") 
    mf <- eval(mf, parent.frame()) 

    response <- names(Formula::model.part(formula, mf, lhs = 1)) 
    weights <- model.weights(mf) 
    dat <- mf[, colnames(mf) != "(weights)"] 
    if (!is.null(scores)) { 
     for (n in names(scores)) { 
     sc <- scores[[n]] 
     if (is.ordered(dat[[n]]) && 
       nlevels(dat[[n]]) == length(sc)) { 
      attr(dat[[n]], "scores") <- as.numeric(sc) 
     } else { 
      warning("scores for variable ", sQuote(n), " ignored") 
     } 
     } 
    } 

    if (is.null(weights)) 
     weights <- rep(1, nrow(mf)) 
    storage.mode(weights) <- "integer" 

    nvar <- sum(!(colnames(dat) %in% response)) 

    control$cfun <- function(...) { 
     if (control$teststat == "quad") 
     p <- .pX2(..., pval = (control$testtype != "Teststatistic")) 
     if (control$teststat == "max") 
     p <- .pmaxT(..., pval = (control$testtype != "Teststatistic")) 
     names(p) <- c("statistic", "p.value") 

     if (control$testtype == "Bonferroni") 
     p["p.value"] <- p["p.value"] * min(nvar, control$mtry) 
     crit <- p["statistic"] 
     if (control$testtype != "Teststatistic") 
     crit <- p["p.value"] 
     c(crit, p) 
    } 

    #require(partykit) 
    environment(partykit) 

    if (!is.null(get("delvar",envir=globalenv()))) { 
     eval(parse(text=paste("rm (", get("delvar",envir=globalenv()), ",envir=globalenv())"))) 
    } 


    tree <- .ctree_fit(dat, response, weights = weights, ctrl = control, 
         ytrafo = ytrafo) 

    fitted <- data.frame("(fitted)" = fitted_node(tree, dat), 
         "(weights)" = weights, 
         check.names = FALSE) 
    fitted[[3]] <- dat[, response, drop = length(response) == 1] 
    names(fitted)[3] <- "(response)" 
    ret <- party(tree, data = dat, fitted = fitted) 
    class(ret) <- c("constparty", class(ret)) 

    ### doesn't work for Surv objects 
    # ret$terms <- terms(formula, data = mf) 
    ret$terms <- terms(mf) 
    ### need to adjust print and plot methods 
    ### for multivariate responses 
    ### if (length(response) > 1) class(ret) <- "party" 
    return(ret) 
    } 
    , envir = ns)) 

# 
# End Borrowed 
# 


d2<-iris 
delvar="d2" 
cttest<-ctree(Species~.,data=d2) 

UPDATE: Я нашел возможное решение, но я надеюсь, что кто-то имеет более чистый способ сделать это. Я загрузил исходный код пакета partykit и написал сценарий для импорта всего в глобальную среду (за исключением скомпилированных функций C, которые были установлены, когда пакет сторонних пакетов был установлен из CRAN).

Здесь в основном я оказался:

files<-c("as.party.R", 
     "ctree.R", 
     "glmtree.R", 
     "lmtree.R", 
     "mob-plot.R", 
     "mob-pvalue.R", 
     "modelparty.R", 
     "node.R", 
     "party.R", 
     "plot.R", 
     "pmmlTreeModel.R", 
     "print.R", 
     "simpleparty.R", 
     "split.R", 
     "utils.R") 

for (i in 1:length(files)) { 
    source(paste("c:\\cygwin64\\home\\Mike\\partykit\\R\\",files[i],sep="")) 

} 

ctree <- function(formula, data, weights, subset, na.action = na.pass, 
        control = ctree_control(...), ytrafo = NULL, 
        scores = NULL, ...) { 



    if (missing(data)) 
    data <- environment(formula) 
    mf <- match.call(expand.dots = FALSE) 
    m <- match(c("formula", "data", "subset", "weights", "na.action"), 
      names(mf), 0) 
    mf <- mf[c(1, m)] 

    ### only necessary for extended model formulae 
    ### e.g. multivariate responses 
    formula <- Formula::Formula(formula) 
    mf$formula <- formula 
    mf$drop.unused.levels <- FALSE 
    mf$na.action <- na.action 
    mf[[1]] <- as.name("model.frame") 
    mf <- eval(mf, parent.frame()) 

    response <- names(Formula::model.part(formula, mf, lhs = 1)) 
    weights <- model.weights(mf) 
    dat <- mf[, colnames(mf) != "(weights)"] 
    if (!is.null(scores)) { 
    for (n in names(scores)) { 
     sc <- scores[[n]] 
     if (is.ordered(dat[[n]]) && 
      nlevels(dat[[n]]) == length(sc)) { 
     attr(dat[[n]], "scores") <- as.numeric(sc) 
     } else { 
     warning("scores for variable ", sQuote(n), " ignored") 
     } 
    } 
    } 

    if (is.null(weights)) 
    weights <- rep(1, nrow(mf)) 
    storage.mode(weights) <- "integer" 

    nvar <- sum(!(colnames(dat) %in% response)) 

    control$cfun <- function(...) { 
    if (control$teststat == "quad") 
     p <- .pX2(..., pval = (control$testtype != "Teststatistic")) 
    if (control$teststat == "max") 
     p <- .pmaxT(..., pval = (control$testtype != "Teststatistic")) 
    names(p) <- c("statistic", "p.value") 

    if (control$testtype == "Bonferroni") 
     p["p.value"] <- p["p.value"] * min(nvar, control$mtry) 
    crit <- p["statistic"] 
    if (control$testtype != "Teststatistic") 
     crit <- p["p.value"] 
    c(crit, p) 
    } 

    #require(partykit) 
    #environment(partykit) 

    if (!is.null(get("delvar",envir=globalenv()))) { 
    eval(parse(text=paste("rm (", get("delvar",envir=globalenv()), ",envir=globalenv())"))) 
    } 


    tree <- .ctree_fit(dat, response, weights = weights, ctrl = control, 
        ytrafo = ytrafo) 

    fitted <- data.frame("(fitted)" = fitted_node(tree, dat), 
         "(weights)" = weights, 
         check.names = FALSE) 
    fitted[[3]] <- dat[, response, drop = length(response) == 1] 
    names(fitted)[3] <- "(response)" 
    ret <- party(tree, data = dat, fitted = fitted) 
    class(ret) <- c("constparty", class(ret)) 

    ### doesn't work for Surv objects 
    # ret$terms <- terms(formula, data = mf) 
    ret$terms <- terms(mf) 
    ### need to adjust print and plot methods 
    ### for multivariate responses 
    ### if (length(response) > 1) class(ret) <- "party" 
    return(ret) 
} 

d2<-iris 
delvar="d2" 
cttest<-ctree(Species~.,data=d2) 

cttest 

Answer 1

Работает на моей системе. Возможно, вам придется позвонить по телефону unlockBinding. Это то, что делает пакет testthatsomemore под капотом; посмотрите, работает ли это для вас.

install_github('robertzk/testthatsomemore') 
testthatsomemore::package_stub("partykit", "ctree", function(...) return("foo"), { 
    # Your code that makes use of partykit::ctree should go here. The below will print "foo" 
    print(partykit::ctree("I have been overwritten")) 
}) 

Вы можете, конечно, поместить измененную функцию в третий аргумент вместо заглушки выше.