R rfe feature selection caret - r

I am using R and the caret package for a classification task. For feature elimination I am using rfe, which has different options, among them, what is the metric that I want to maximize/minimize.
The problem is that rfe accepts metrics such as RMSE, kappa, and I want to use a different metric to maximize, in mi case I want to maximize ScoreQuadraticWeightedKappa from the Metrics library, but I don't know how to do that.
I have the following code:
control <- rfeControl(functions = rfFuncs, method="cv", number=2)
results <- rfe(dataset[, -59], dataset[, 59],
sizes = c(1:58), rfeControl = control)
How do I edit it, for rfe to maximize ScoreQuadraticWeightedKappa?

You need to modify the postResample function, or create your own function that's similar, and then insert it into rfFuncs$summary. The default postResample function here below:
> postResample
function (pred, obs)
{
isNA <- is.na(pred)
pred <- pred[!isNA]
obs <- obs[!isNA]
if (!is.factor(obs) & is.numeric(obs)) {
if (length(obs) + length(pred) == 0) {
out <- rep(NA, 2)
}
else {
if (length(unique(pred)) < 2 || length(unique(obs)) <
2) {
resamplCor <- NA
}
else {
resamplCor <- try(cor(pred, obs, use = "pairwise.complete.obs"),
silent = TRUE)
if (class(resamplCor) == "try-error")
resamplCor <- NA
}
mse <- mean((pred - obs)^2)
n <- length(obs)
out <- c(sqrt(mse), resamplCor^2)
}
names(out) <- c("RMSE", "Rsquared")
}
else {
if (length(obs) + length(pred) == 0) {
out <- rep(NA, 2)
}
else {
pred <- factor(pred, levels = levels(obs))
requireNamespaceQuietStop("e1071")
out <- unlist(e1071::classAgreement(table(obs, pred)))[c("diag",
"kappa")]
}
names(out) <- c("Accuracy", "Kappa")
}
if (any(is.nan(out)))
out[is.nan(out)] <- NA
out
}
More specifically, since you are doing classification, you will need to modify the portion of postResample that says:
else {
if (length(obs) + length(pred) == 0) {
out <- rep(NA, 2)
}
else {
pred <- factor(pred, levels = levels(obs))
requireNamespaceQuietStop("e1071")
out <- unlist(e1071::classAgreement(table(obs, pred)))[c("diag",
"kappa")]
}
names(out) <- c("Accuracy", "Kappa")
}
After you've edited postResample, or created your own equivalent function, you can run:
rfFuncs$summary <- function (data, lev = NULL, model = NULL) {
if (is.character(data$obs))
data$obs <- factor(data$obs, levels = lev)
postResample(data[, "pred"], data[, "obs"])
}
Just make sure postResample has been edited or replace it with the name of your equivalent function.

Related

An equivalent for the excel If error for lme4 glmer in r

I'm writing a loop that fits models across several datasets and outcome variables. I'm saving the results in a matrix. in the current version, I accounted for potential errors such as missing covariates. The more data I include the more errors I get and I need to account for in the loop. I would like to modify the code below so it record "NA" when the model stops due to an error regardless of the error type.
I would appreciate any thoughts.
datasets <- list('data_01','data_02','data_03','data_04')
outcomes <- list('var_01','var_02','var_03','var_04','var_05')
results <- vector("list", length(datasets))
for (i in 1:length(datasets)) {
results [[i]] <- matrix(NA, nrow=length(outcomes), ncol=2)
}
for (j in seq_along(outcomes)) {
for (i in seq_along(surveys)) {
if ("TRUE" %in% (!(outcomes[[j]] %in% names(datasets[[i]]))))
{
results[[i]][j, 1] <- outcomes[[j]]
results[[i]][j, 2] <- "NA"
}
else
{
results[[i]][j, 1] <- outcomes[[j]]
fit <- glmer(~ RS_AGE + RS_MARITAL + (1|FW_ID) + (1|RS_CLID), data = datasets[[i]], family =
binomial, nAGQ=0, control = glmerControl(optimizer = "nloptwrap"))
SI <- getME(fit,"theta")^2
ICC <- SI[[2]] /(SI[[1]]+SI[[2]]+3.29)
results[[i]][j, 2] <- ICC
}
}
}
Without the data I can't test, but this should work:
atasets <- list('data_01','data_02','data_03','data_04')
outcomes <- list('var_01','var_02','var_03','var_04','var_05')
results <- vector("list", length(datasets))
for (i in 1:length(datasets)) {
results [[i]] <- matrix(NA, nrow=length(outcomes), ncol=2)
}
for (j in seq_along(outcomes)) {
for (i in seq_along(surveys)) {
if (any(!(outcomes[[j]] %in% names(datasets[[i]]))))
{
results[[i]][j, 1] <- outcomes[[j]]
results[[i]][j, 2] <- NA
}
else
{
results[[i]][j, 1] <- outcomes[[j]]
form <- reformulate(c("RS_AGE", "RS_MARITAL", "(1|FW_ID)", "(1|RS_CLID)"),
response = outcomes[[j]])
fit <- try(glmer(form, data = datasets[[i]], family =
binomial, nAGQ=0, control = glmerControl(optimizer = "nloptwrap")))
if(!inherits(fit, "try-error")){
SI <- getME(fit,"theta")^2
ICC <- SI[[2]] /(SI[[1]]+SI[[2]]+3.29)
results[[i]][j, 2] <- ICC
}else{
results[[i]][j,2] <- NA
}
}
}
}
Try replacing
fit <- glmer(~ RS_AGE + RS_MARITAL + (1|FW_ID) + (1|RS_CLID), data = datasets[[i]], family =
binomial, nAGQ=0, control = glmerControl(optimizer = "nloptwrap"))
SI <- getME(fit,"theta")^2
ICC <- SI[[2]] /(SI[[1]]+SI[[2]]+3.29)
results[[i]][j, 2] <- ICC
by
fit <- tryCatch(glmer(~ RS_AGE + RS_MARITAL + (1|FW_ID) + (1|RS_CLID), data = datasets[[i]], family =
binomial, nAGQ=0, control = glmerControl(optimizer = "nloptwrap")),error = function(e) e)
if(!inherits(fit,"error")){
SI <- getME(fit,"theta")^2
ICC <- SI[[2]] /(SI[[1]]+SI[[2]]+3.29)
}else{
ICC <- NA
}

Add a progress bar to boot function in R

I am trying to add a progress bar to a bootstrap function in R.
I tried to make the example function as simple as possible (hence i'm using mean in this example).
library(boot)
v1 <- rnorm(1000)
rep_count = 1
m.boot <- function(data, indices) {
d <- data[indices]
setWinProgressBar(pb, rep_count)
rep_count <- rep_count + 1
Sys.sleep(0.01)
mean(d, na.rm = T)
}
tot_rep <- 200
pb <- winProgressBar(title = "Bootstrap in progress", label = "",
min = 0, max = tot_rep, initial = 0, width = 300)
b <- boot(v1, m.boot, R = tot_rep)
close(pb)
The bootstrap functions properly, but the problem is that the value of rep_count does not increase in the loop and the progress bar stays frozen during the process.
If I check the value of rep_count after the bootstrap is complete, it is still 1.
What am i doing wrong? maybe the boot function does not simply insert the m.boot function in a loop and so the variables in it are not increased?
Thank you.
You could use the package progress as below:
library(boot)
library(progress)
v1 <- rnorm(1000)
#add progress bar as parameter to function
m.boot <- function(data, indices, prog) {
#display progress with each run of the function
prog$tick()
d <- data[indices]
Sys.sleep(0.01)
mean(d, na.rm = T)
}
tot_rep <- 200
#initialize progress bar object
pb <- progress_bar$new(total = tot_rep + 1)
#perform bootstrap
boot(data = v1, statistic = m.boot, R = tot_rep, prog = pb)
I haven't quite figured out yet why it's necessary to set the number of iterations for progress_bar to be +1 the total bootstrap replicates (parameter R), but this is what was necessary in my own code, otherwise it throws an error. It seems like the bootstrap function is run one more time than you specify in parameter R, so if the progress bar is set to only run R times, it thinks the job is finished before it really is.
The pbapply package was designed to work with vectorized functions. There are 2 ways to achieve that in the context of this question: (1) write a wrapper as was suggested, which will not produce the same object of class 'boot'; (2) alternatively, the line lapply(seq_len(RR), fn) can be written as pblapply(seq_len(RR), fn). Option 2 can happen either by locally copying/updating the boot function as shown in the example below, or asking the package maintainer, Brian Ripley, if he would consider adding a progress bar directly or through pbapply as dependency.
My solution (changes indicated by comments):
library(boot)
library(pbapply)
boot2 <- function (data, statistic, R, sim = "ordinary", stype = c("i",
"f", "w"), strata = rep(1, n), L = NULL, m = 0, weights = NULL,
ran.gen = function(d, p) d, mle = NULL, simple = FALSE, ...,
parallel = c("no", "multicore", "snow"), ncpus = getOption("boot.ncpus",
1L), cl = NULL)
{
call <- match.call()
stype <- match.arg(stype)
if (missing(parallel))
parallel <- getOption("boot.parallel", "no")
parallel <- match.arg(parallel)
have_mc <- have_snow <- FALSE
if (parallel != "no" && ncpus > 1L) {
if (parallel == "multicore")
have_mc <- .Platform$OS.type != "windows"
else if (parallel == "snow")
have_snow <- TRUE
if (!have_mc && !have_snow)
ncpus <- 1L
loadNamespace("parallel")
}
if (simple && (sim != "ordinary" || stype != "i" || sum(m))) {
warning("'simple=TRUE' is only valid for 'sim=\"ordinary\", stype=\"i\", n=0', so ignored")
simple <- FALSE
}
if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE))
runif(1)
seed <- get(".Random.seed", envir = .GlobalEnv, inherits = FALSE)
n <- NROW(data)
if ((n == 0) || is.null(n))
stop("no data in call to 'boot'")
temp.str <- strata
strata <- tapply(seq_len(n), as.numeric(strata))
t0 <- if (sim != "parametric") {
if ((sim == "antithetic") && is.null(L))
L <- empinf(data = data, statistic = statistic, stype = stype,
strata = strata, ...)
if (sim != "ordinary")
m <- 0
else if (any(m < 0))
stop("negative value of 'm' supplied")
if ((length(m) != 1L) && (length(m) != length(table(strata))))
stop("length of 'm' incompatible with 'strata'")
if ((sim == "ordinary") || (sim == "balanced")) {
if (isMatrix(weights) && (nrow(weights) != length(R)))
stop("dimensions of 'R' and 'weights' do not match")
}
else weights <- NULL
if (!is.null(weights))
weights <- t(apply(matrix(weights, n, length(R),
byrow = TRUE), 2L, normalize, strata))
if (!simple)
i <- index.array(n, R, sim, strata, m, L, weights)
original <- if (stype == "f")
rep(1, n)
else if (stype == "w") {
ns <- tabulate(strata)[strata]
1/ns
}
else seq_len(n)
t0 <- if (sum(m) > 0L)
statistic(data, original, rep(1, sum(m)), ...)
else statistic(data, original, ...)
rm(original)
t0
}
else statistic(data, ...)
pred.i <- NULL
fn <- if (sim == "parametric") {
ran.gen
data
mle
function(r) {
dd <- ran.gen(data, mle)
statistic(dd, ...)
}
}
else {
if (!simple && ncol(i) > n) {
pred.i <- as.matrix(i[, (n + 1L):ncol(i)])
i <- i[, seq_len(n)]
}
if (stype %in% c("f", "w")) {
f <- freq.array(i)
rm(i)
if (stype == "w")
f <- f/ns
if (sum(m) == 0L)
function(r) statistic(data, f[r, ], ...)
else function(r) statistic(data, f[r, ], pred.i[r,
], ...)
}
else if (sum(m) > 0L)
function(r) statistic(data, i[r, ], pred.i[r, ],
...)
else if (simple)
function(r) statistic(data, index.array(n, 1, sim,
strata, m, L, weights), ...)
else function(r) statistic(data, i[r, ], ...)
}
RR <- sum(R)
res <- if (ncpus > 1L && (have_mc || have_snow)) {
if (have_mc) {
parallel::mclapply(seq_len(RR), fn, mc.cores = ncpus)
}
else if (have_snow) {
list(...)
if (is.null(cl)) {
cl <- parallel::makePSOCKcluster(rep("localhost",
ncpus))
if (RNGkind()[1L] == "L'Ecuyer-CMRG")
parallel::clusterSetRNGStream(cl)
res <- parallel::parLapply(cl, seq_len(RR), fn)
parallel::stopCluster(cl)
res
}
else parallel::parLapply(cl, seq_len(RR), fn)
}
}
else pblapply(seq_len(RR), fn) #### changed !!!
t.star <- matrix(, RR, length(t0))
for (r in seq_len(RR)) t.star[r, ] <- res[[r]]
if (is.null(weights))
weights <- 1/tabulate(strata)[strata]
boot.return(sim, t0, t.star, temp.str, R, data, statistic,
stype, call, seed, L, m, pred.i, weights, ran.gen, mle)
}
## Functions not exported by boot
isMatrix <- boot:::isMatrix
index.array <- boot:::index.array
boot.return <- boot:::boot.return
## Now the example
m.boot <- function(data, indices) {
d <- data[indices]
mean(d, na.rm = T)
}
tot_rep <- 200
v1 <- rnorm(1000)
b <- boot2(v1, m.boot, R = tot_rep)
The increased rep_count is a local variable and lost after each function call. In the next iteration the function gets rep_count from the global environment again, i.e., its value is 1.
You can use <<-:
rep_count <<- rep_count + 1
This assigns to the rep_count first found on the search path outside the function. Of course, using <<- is usually not recommended because side effects of functions should be avoided, but here you have a legitimate use case. However, you should probably wrap the whole thing in a function to avoid a side effect on the global environment.
There might be better solutions ...
I think i found a possible solution. This merges the answer of #Roland with the convenience of the pbapply package, using its functions startpb(), closepb(), etc..
library(boot)
library(pbapply)
v1 <- rnorm(1000)
rep_count = 1
tot_rep = 200
m.boot <- function(data, indices) {
d <- data[indices]
setpb(pb, rep_count)
rep_count <<- rep_count + 1
Sys.sleep(0.01) #Just to slow down the process
mean(d, na.rm = T)
}
pb <- startpb(min = 0, max = tot_rep)
b <- boot(v1, m.boot, R = tot_rep)
closepb(pb)
rep_count = 1
As previously suggested, wrapping everything in a function avoids messing with the rep_count variable.
The progress bar from the package dplyr works well:
library(dplyr)
library(boot)
v1 <- rnorm(1000)
m.boot <- function(data, indices) {
d <- data[indices]
p$tick()$print() # update progress bar
Sys.sleep(0.01)
mean(d, na.rm = T)
}
tot_rep <- 200
p <- progress_estimated(tot_rep+1) # init progress bar
b <- boot(v1, m.boot, R = tot_rep)
You can use the package pbapply
library(boot)
library(pbapply)
v1 <- rnorm(1000)
rep_count = 1
# your m.boot function ....
m.boot <- function(data, indices) {
d <- data[indices]
mean(d, na.rm = T)
}
# ... wraped in `bootfunc`
bootfunc <- function(x) { boot(x, m.boot, R = 200) }
# apply function to v1 , returning progress bar
pblapply(v1, bootfunc)
# > b <- pblapply(v1, bootfunc)
# > |++++++++++++++++++++++++++++++++++++++++++++++++++| 100% Elapsed time: 02s

R: can `assign` be used for models?

Can the assign function in R be used to assign object names to models (e.g., gls models)? I'm guessing not b/c I keep getting a warning:
> Warning messages:
In assign(paste0(deparse(substitute(mod)), "_", i, j), update(mod, :
only the first element is used as variable name
As a result the objects are not created
Is there a way to do this?
Here is my fucntion code if it helps:
#Choose best corARMA structure for model of choice:
corARMA.chooser <- function(mod,min = 0,max = 3 ) {
#This function creates 1. object for each combo of ARMA {0:3} 2. AIC table comparing all of these models
mod <- get('mod')
aic.arma <- AIC(mod)
ps <- 0
qs <- 0
for(i in min:max) {
js <- if(i == 0) c(1:max) else c(min:max)
for(j in js) {
arma <- corARMA(p = i, q = j)
assign(paste0(deparse(substitute(mod)),'_',i,j), update(mod, .~., correlation = arma), envir = .GlobalEnv)
aic.arma <- c(aic.arma, AIC(get(paste0(deparse(substitute(mod)),'_',i,j))))
ps <- c(ps, i)
qs <- c(qs, i)
}
aic.arma.out <- data.frame(ps, qs, aic.arma)
aic.arma.out
}
}
Update:
I tried using the list approach, but I get the error:
Error in names(mod.list) <- c(names(mod.list), paste0(deparse(substitute(mod)), :
'names' attribute [1275] must be the same length as the vector [1]
EDIT: what actually tears your variable name apart is this line mod <- get('mod') where you overwrite your named instance of mod why do you actually do this? If change your function to this it behaves as I'd expect it to:
corARMA.chooser <- function(modIn,min = 0,max = 3 ) {
#This function creates 1. object for each combo of ARMA {0:3} 2. AIC table comparing all of these models mod <- get('modIn') aic.arma <- AIC(modIn) ps <- 0 qs <- 0 for(i in min:max) {
js <- if(i == 0) c(1:max) else c(min:max)
for(j in js) {
arma <- corARMA(p = i, q = j)
browser()
assign(paste0(deparse(substitute(modIn)),'_',i,j), update(mod, .~., correlation = arma), envir = .GlobalEnv)
aic.arma <- c(aic.arma, AIC(get(paste0(deparse(substitute(mod)),'_',i,j))))
ps <- c(ps, i)
qs <- c(qs, i)
}
aic.arma.out <- data.frame(ps, qs, aic.arma)
aic.arma.out
}
}
hope this is what you were trying to achieve.
Still not sure why the code works alone but not in the function, but it is clear that the deparse(substitute(mod)) is for some reason pulls mod apart to all of its parts first in the function, vs. simply creating a name of the object itself.
Here is my new code that works:
corARMA.chooser <- function(mod,p = 1,q = 0 ) {
#This function creates 1. object for each combo of ARMA {0:3} 2. AIC table comparing all of these models
mod.list <- NULL
nms <- NULL
aic.arma <- AIC(mod)
ps <- 0
qs <- 0
for(i in c(p)) {
js <- if(i == 0) c(q[q>0]) else c(q)
for(j in c(js)) {
arma <- corARMA(p = i, q = j)
mod.list <- c(mod.list, list(update(mod, .~., correlation = arma)))
names(mod.list) <- c(names(mod.list), paste0(deparse(substitute(mod)),'_',i,j))
aic.arma <- c(aic.arma, AIC(eval(parse(text=(paste0('mod.list$',deparse(substitute(mod)),'_',i,j))))))
ps <- c(ps, i)
qs <- c(qs, j)
}
}
assign(paste0(deparse(substitute(mod)),'_','ARMA'),mod.list, envir = .GlobalEnv)
aic.arma.out <- data.frame(p = ps, q = qs, AIC = aic.arma)
aic.arma.out
}

Number of imputations attribute wrong when using as.mids() from the {mice} package?

I'm relatively new to R and absolutely new to the forum, so I may be unaware of some posting rules (be kind).
The issue i have relates to the as.mids() function in the mice package by Stef van Buuren: when using it the data in the new mids object is fine, but the number of imputations in the attributes is the original + 1.
Example (making use of the original as.mids() example and data in the mice package):
imp <- mice(boys, print = FALSE, maxit = 1) #using the default number of imputations m = 5
X <- complete(imp, action = "long", include = TRUE)
test <- as.mids(X)
The created object now shows: number of imputations = 6 (instead of 5), somehow also influencing analysis as demonstrated by the difference between
fit <- with(imp, lm(bmi ~ age))
round(summary(pool(fit)), 2)
fit2 <- with(test, lm(bmi ~ age))
round(summary(pool(fit2)), 2).
When looking through the code of as.mids() one minor change seems to solve this, but my R knowledge really requires a second opinion.
Original as.mids() code as below:
function (data, .imp = 1, .id = 2)
{
ini <- mice(data[data[, .imp] == 0, -c(.imp, .id)], m = max(as.numeric(data[,
.imp])), maxit = 0)
names <- names(ini$imp)
if (!is.null(.id)) {
rownames(ini$data) <- data[data[, .imp] == 0, .id]
}
for (i in 1:length(names)) {
for (m in 1:(max(as.numeric(data[, .imp])) - 1)) {
if (!is.null(ini$imp[[i]])) {
indic <- data[, .imp] == m & is.na(data[data[,
.imp] == 0, names[i]])
ini$imp[[names[i]]][m] <- data[indic, names[i]]
}
}
}
return(ini)
}
Now modifying the m parameter in the call for mice in the definition of ini (3 row) seems to solve it (only acounting for the fact that max(as.numeric()) gives the number of levels, thus including the original data, which is probably not ment):
as.mids.mod <- function(data, .imp = 1, .id = 2){
ini <- mice(data[data[, .imp] == 0, -c(.imp, .id)], m = (max(as.numeric(data[, .imp])) -1), maxit = 0)
names <- names(ini$imp)
if (!is.null(.id)) {
rownames(ini$data) <- data[data[, .imp] == 0, .id]
}
for (i in 1:length(names)) {
for (m in 1:(max(as.numeric(data[, .imp])) - 1)) {
if (!is.null(ini$imp[[i]])) {
indic <- data[, .imp] == m & is.na(data[data[, .imp] == 0, names[i]])
ini$imp[[names[i]]][m] <- data[indic, names[i]]
}
}
}
return(ini)
Using as.mids.mod in the example now gives similar analysis results:
imp <- mice(boys, print = FALSE, maxit = 1)
data <- complete(imp, action = "long", include = TRUE)
test <- as.mids(data)
test2 <- as.mids.mod(data)
fit <- with(imp, lm(bmi ~ age))
round(summary(pool(fit)), 2)
fit3 <- with(test2, lm(bmi ~ age))
round(summary(pool(fit3)), 2)
Am I doing something wrong in my use of the function and/or problem solving or should the as.mids() function be very slightly modified?
Thanks for raising this issue. The function as.mids2() from the following working example yields the desired mids object.
as.mids2 <- function(data2, .imp=1, .id=2){
ini <- mice(data2[data2[, .imp] == 0, - c(.imp, .id)], m = max(as.numeric(levels(data2[, .imp]))), maxit=0)
names <- names(ini$imp)
if (!is.null(.id)){
rownames(ini$data) <- data2[data2[, .imp] == 0, .id]
}
for (i in 1:length(names)){
for(m in 1:(max(as.numeric(levels(data2[, .imp]))))){
if(!is.null(ini$imp[[i]])){
indic <- data2[, .imp] == m & is.na(data2[data2[, .imp]==0, names[i]])
ini$imp[[names[i]]][m] <- data2[indic, names[i]]
}
}
}
return(ini)
}
require(mice)
imp <- mice(nhanes)
com <- complete(imp, "long", include = TRUE)
imp2 <- as.mids2(com)
com2 <- complete(imp2, "long", include = TRUE)
all(na.omit(com == com2))

Modified package function produces new error

I would like to modify the function party / varimp.
The function takes a very long time to run, and I would like to print the progress inside the main loop.
I took the code from the function after calling it in R; I edited the code and pasted in in R to override the package original code.
My new code is (the only modif is a small part at the bottom marked 'MY EDIT'):
varimp <- function (object, mincriterion = 0, conditional = FALSE, threshold = 0.2,
nperm = 1, OOB = TRUE, pre1.0_0 = conditional)
{
response <- object#responses
if (length(response#variables) == 1 && inherits(response#variables[[1]],
"Surv"))
return(varimpsurv(object, mincriterion, conditional,
threshold, nperm, OOB, pre1.0_0))
input <- object#data#get("input")
xnames <- colnames(input)
inp <- initVariableFrame(input, trafo = NULL)
y <- object#responses#variables[[1]]
if (length(response#variables) != 1)
stop("cannot compute variable importance measure for multivariate response")
if (conditional || pre1.0_0) {
if (!all(complete.cases(inp#variables)))
stop("cannot compute variable importance measure with missing values")
}
CLASS <- all(response#is_nominal)
ORDERED <- all(response#is_ordinal)
if (CLASS) {
error <- function(x, oob) mean((levels(y)[sapply(x, which.max)] !=
y)[oob])
}
else {
if (ORDERED) {
error <- function(x, oob) mean((sapply(x, which.max) !=
y)[oob])
}
else {
error <- function(x, oob) mean((unlist(x) - y)[oob]^2)
}
}
w <- object#initweights
if (max(abs(w - 1)) > sqrt(.Machine$double.eps))
warning(sQuote("varimp"), " with non-unity weights might give misleading results")
perror <- matrix(0, nrow = nperm * length(object#ensemble),
ncol = length(xnames))
colnames(perror) <- xnames
for (b in 1:length(object#ensemble)) {
tree <- object#ensemble[[b]]
if (OOB) {
oob <- object#weights[[b]] == 0
}
else {
oob <- rep(TRUE, length(y))
}
p <- .Call("R_predict", tree, inp, mincriterion, -1L,
PACKAGE = "party")
eoob <- error(p, oob)
for (j in unique(varIDs(tree))) {
for (per in 1:nperm) {
if (conditional || pre1.0_0) {
tmp <- inp
ccl <- create_cond_list(conditional, threshold,
xnames[j], input)
if (is.null(ccl)) {
perm <- sample(which(oob))
}
else {
perm <- conditional_perm(ccl, xnames, input,
tree, oob)
}
tmp#variables[[j]][which(oob)] <- tmp#variables[[j]][perm]
p <- .Call("R_predict", tree, tmp, mincriterion,
-1L, PACKAGE = "party")
}
else {
p <- .Call("R_predict", tree, inp, mincriterion,
as.integer(j), PACKAGE = "party")
}
perror[(per + (b - 1) * nperm), j] <- (error(p,
oob) - eoob)
}
}
######################
# MY EDIT
print(b)
flush.console()
######################
}
perror <- as.data.frame(perror)
return(MeanDecreaseAccuracy = colMeans(perror))
}
But when using it, I now get an error:
> data.cforest.varimp <- varimp(data.cforest, conditional = TRUE)
Error in unique(varIDs(tree)) : could not find function "varIDs"
This error comes in a part of the code that I did not modify, so I do not understand.
Is the problem in my new code, or in the way I try to modify an existing package?
Yes Joran's tip worked:
environment(varimp) <- asNamespace('party')

Resources