そこで、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のライブラリバージョンにこだわっています。ところで、私は Windows 8.1 で RStudio 0.98.507 と R 3.1.1 を使用しています。
これは、.ctree_fit 呼び出しの外部 C コードと関係がありますか?
また、「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)
更新: 可能な解決策を見つけましたが、誰かがこれを行うためのよりクリーンな方法を持っていることを願っています. partykit パッケージのソース コードをダウンロードし、すべてをグローバル環境にインポートするスクリプトを作成しました (partykit パッケージが CRAN からインストールされたときにインストールされたコンパイル済みの C 関数を除く)。
これが基本的に私がたどり着いた場所です：
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