Last updated on 2024-12-27 15:49:06 CET.
| Flavor | Version | Tinstall | Tcheck | Ttotal | Status | Flags |
|---|---|---|---|---|---|---|
| r-devel-linux-x86_64-debian-clang | 1.0.8 | 45.80 | 106.37 | 152.17 | ERROR | |
| r-devel-linux-x86_64-debian-gcc | 1.0.8 | 29.77 | 69.17 | 98.94 | ERROR | |
| r-devel-linux-x86_64-fedora-clang | 1.0.8 | 242.26 | ERROR | |||
| r-devel-linux-x86_64-fedora-gcc | 1.0.8 | 240.94 | ERROR | |||
| r-devel-windows-x86_64 | 1.0.8 | 42.00 | 110.00 | 152.00 | ERROR | |
| r-patched-linux-x86_64 | 1.0.8 | 45.19 | 114.37 | 159.56 | OK | |
| r-release-linux-x86_64 | 1.0.8 | 46.29 | 114.06 | 160.35 | OK | |
| r-release-macos-arm64 | 1.0.8 | 62.00 | OK | |||
| r-release-macos-x86_64 | 1.0.8 | 103.00 | OK | |||
| r-release-windows-x86_64 | 1.0.8 | 45.00 | 119.00 | 164.00 | OK | |
| r-oldrel-macos-arm64 | 1.0.8 | 71.00 | OK | |||
| r-oldrel-macos-x86_64 | 1.0.8 | 159.00 | OK | |||
| r-oldrel-windows-x86_64 | 1.0.8 | 59.00 | 154.00 | 213.00 | OK |
Version: 1.0.8
Check: compiled code
Result: NOTE
File ‘RFpredInterval/libs/RFpredInterval.so’:
Found non-API call to R: ‘STRING_PTR’
Compiled code should not call non-API entry points in R.
See ‘Writing portable packages’ in the ‘Writing R Extensions’ manual,
and section ‘Moving into C API compliance’ for issues with the use of
non-API entry points.
Flavors: r-devel-linux-x86_64-debian-clang, r-devel-linux-x86_64-debian-gcc, r-devel-linux-x86_64-fedora-clang, r-devel-linux-x86_64-fedora-gcc
Version: 1.0.8
Check: tests
Result: ERROR
Running ‘testthat.R’ [12s/17s]
Running the tests in ‘tests/testthat.R’ failed.
Complete output:
> library(testthat)
> library(RFpredInterval)
RFpredInterval 1.0.8
>
> test_check("RFpredInterval")
*** caught segfault ***
address 0x1, cause 'memory not mapped'
Traceback:
1: doTryCatch(return(expr), name, parentenv, handler)
2: tryCatchOne(expr, names, parentenv, handlers[[1L]])
3: tryCatchList(expr, classes, parentenv, handlers)
4: tryCatch({ .Call("rfsrcGrow", as.integer(do.trace), as.integer(seed), as.integer(ensemble.bits + impute.only.bits + var.used.bits + split.depth.bits + importance.bits + bootstrap.bits + forest.bits + proximity.bits + perf.bits + rfq.bits + gk.quantile.bits + statistics.bits + empirical.risk.bits), as.integer(samptype.bits + forest.wt.bits + distance.bits + na.action.bits + split.cust.bits + membership.bits + terminal.qualts.bits + terminal.quants.bits + tdc.rule.bits + cse.bits + csv.bits), as.integer(splitinfo$index), as.integer(splitinfo$nsplit), as.integer(mtry), lot, base.learner, as.integer(vtry), as.integer(holdout.array), holdout.specs, as.integer(formulaDetail$ytry), as.integer(nodesize), as.integer(nodedepth), as.integer(length(cause.wt)), as.double(cause.wt), as.integer(ntree), as.integer(n), list(as.integer(length(yvar.types)), if (is.null(yvar.types)) NULL else as.character(yvar.types), if (is.null(yvar.types)) NULL else as.integer(yvar.nlevels), if (is.null(yvar.numeric.levels)) NULL else sapply(1:length(yvar.numeric.levels), function(nn) { as.integer(length(yvar.numeric.levels[[nn]])) }), if (is.null(subj)) NULL else as.integer(subj), if (is.null(event.info)) NULL else as.integer(length(event.info$event.type)), if (is.null(event.info)) NULL else as.integer(event.info$event.type), if (is.null(yvar)) NULL else as.double(as.vector(yvar))), if (is.null(yvar.numeric.levels)) { NULL } else { lapply(1:length(yvar.numeric.levels), function(nn) { as.integer(yvar.numeric.levels[[nn]]) }) }, list(as.integer(n.xvar), as.character(xvar.types), if (is.null(xvar.types)) NULL else as.integer(xvar.nlevels), if (is.null(xvar.numeric.levels)) NULL else sapply(1:length(xvar.numeric.levels), function(nn) { as.integer(length(xvar.numeric.levels[[nn]])) }), if (is.null(xvar.time)) NULL else as.integer(xvar.time), if (is.null(subj.time)) NULL else as.integer(subj.time), as.double(as.vector(xvar))), if (is.null(xvar.numeric.levels)) { NULL } else { lapply(1:length(xvar.numeric.levels), function(nn) { as.integer(xvar.numeric.levels[[nn]]) }) }, list(as.integer(length(case.wt)), if (is.null(case.wt)) NULL else as.double(case.wt), as.integer(sampsize), if (is.null(samp)) NULL else as.integer(samp)), as.double(split.wt), as.double(yvar.wt), as.double(xvar.wt), as.integer(length(event.info$time.interest)), as.double(event.info$time.interest), as.integer(nimpute), as.integer(block.size), as.integer(length(prob)), as.double(prob), as.double(prob.epsilon), as.integer(get.rf.cores()))}, error = function(e) { print(e) NULL})
5: (function (formula, data, ntree = 1000, mtry = NULL, ytry = NULL, nodesize = NULL, nodedepth = NULL, splitrule = NULL, nsplit = 10, importance = c(FALSE, TRUE, "none", "permute", "random", "anti"), block.size = if (any(is.element(as.character(importance), c("none", "FALSE")))) NULL else 10, ensemble = c("all", "oob", "inbag"), bootstrap = c("by.root", "none", "by.user"), samptype = c("swor", "swr"), samp = NULL, membership = FALSE, sampsize = if (samptype == "swor") function(x) { x * 0.632 } else function(x) { x }, na.action = c("na.omit", "na.impute"), nimpute = 1, ntime, cause, proximity = FALSE, distance = FALSE, forest.wt = FALSE, xvar.wt = NULL, yvar.wt = NULL, split.wt = NULL, case.wt = NULL, forest = TRUE, var.used = c(FALSE, "all.trees", "by.tree"), split.depth = c(FALSE, "all.trees", "by.tree"), seed = NULL, do.trace = FALSE, statistics = FALSE, ...) { univariate.nomenclature = TRUE user.option <- list(...) impute.only <- is.hidden.impute.only(user.option) terminal.qualts <- is.hidden.terminal.qualts(user.option) terminal.quants <- is.hidden.terminal.quants(user.option) cse <- is.hidden.cse(user.option) csv <- is.hidden.csv(user.option) perf.type <- is.hidden.perf.type(user.option) rfq <- is.hidden.rfq(user.option) gk.quantile <- is.hidden.gk.quantile(user.option) quantile.regr <- is.hidden.quantile.regr(user.option) prob <- is.hidden.prob(user.option) prob.epsilon <- is.hidden.prob.epsilon(user.option) lot <- is.hidden.lot(user.option) hdim <- lot$hdim base.learner <- is.hidden.base.learner(user.option) vtry <- is.hidden.vtry(user.option) holdout.array <- is.hidden.holdout.array(user.option) holdout.specs <- is.hidden.holdout.specs(user.option) empirical.risk <- is.hidden.empirical.risk(user.option) tdc.rule <- is.hidden.tdc.rule(user.option) ensemble <- match.arg(ensemble, c("all", "oob", "inbag")) bootstrap <- match.arg(bootstrap, c("by.root", "none", "by.user")) if (bootstrap == "none") { ensemble <- "inbag" } importance <- match.arg(as.character(importance), c(FALSE, TRUE, "none", "permute", "random", "anti")) na.action <- match.arg(na.action, c("na.omit", "na.impute")) proximity <- match.arg(as.character(proximity), c(FALSE, TRUE, "inbag", "oob", "all")) distance <- match.arg(as.character(distance), c(FALSE, TRUE, "inbag", "oob", "all")) var.used <- match.arg(as.character(var.used), c("FALSE", "all.trees", "by.tree")) split.depth <- match.arg(as.character(split.depth), c("FALSE", "all.trees", "by.tree")) if (var.used == "FALSE") var.used <- FALSE if (split.depth == "FALSE") split.depth <- FALSE if (missing(data)) stop("data is missing") if (any(is.infinite(unlist(data)))) stop("data contains Inf or -Inf values") if (missing(formula) | (!missing(formula) && is.null(formula))) { if (is.null(ytry)) { formula <- as.formula("Unsupervised() ~ .") } else { formula <- as.formula(paste("Unsupervised(", ytry, ")~.")) } } formulaPrelim <- parseFormula(formula, data, ytry) my.call <- match.call() my.call$formula <- eval(formula) if (any(is.na(data))) { data <- parseMissingData(formulaPrelim, data) miss.flag <- TRUE } else { miss.flag <- FALSE } formulaDetail <- finalizeFormula(formulaPrelim, data) ntree <- round(ntree) if (ntree < 1) stop("Invalid choice of 'ntree'. Cannot be less than 1.") if (!is.null(nodesize) && nodesize < 1) stop("Invalid choice of 'nodesize'. Cannot be less than 1.") if (!is.null(nodedepth)) nodedepth = round(nodedepth) else nodedepth = -1 nimpute <- round(nimpute) if (nimpute < 1) stop("Invalid choice of 'nimpute'. Cannot be less than 1.") seed <- get.seed(seed) family <- formulaDetail$family xvar.names <- formulaDetail$xvar.names yvar.names <- formulaDetail$yvar.names subj.names <- formulaDetail$subj.names if (length(xvar.names) == 0) { stop("something seems wrong: your formula did not define any x-variables") } if (family != "unsupv" && length(yvar.names) == 0) { stop("something seems wrong: your formula did not define any y-variables") } if (family == "class") { if (length(setdiff(levels(data[, yvar.names]), unique(data[, yvar.names]))) > 0) { warning("empty classes found when implementing classification\n") } } data <- rm.na.levels(data, xvar.names) data <- rm.na.levels(data, yvar.names) yfactor <- extract.factor(data, yvar.names) yfactor$types <- yvar.types <- get.yvar.type(family, yfactor$generic.types, yvar.names) yfactor$nlevels <- yvar.nlevels <- get.yvar.nlevels(family, yfactor$nlevels, yvar.names, data) xfactor <- extract.factor(data, xvar.names) xfactor$types <- xvar.types <- xfactor$generic.types xvar.nlevels <- xfactor$nlevels data <- finalizeData(c(subj.names, yvar.names, xvar.names), data, na.action, miss.flag) data.row.names <- rownames(data) xvar <- as.matrix(data[, xvar.names, drop = FALSE]) rownames(xvar) <- colnames(xvar) <- NULL xfactor$numeric.levels <- xvar.numeric.levels <- get.numeric.levels(family, xfactor$nlevels, xvar) n <- nrow(xvar) n.xvar <- length(xvar.names) mtry <- get.grow.mtry(mtry, n.xvar, family) samptype <- match.arg(samptype, c("swor", "swr")) subj.unique.count <- n subj <- NULL xvar.time <- NULL subj.time <- NULL if (bootstrap == "by.root") { if (!is.function(sampsize) && !is.numeric(sampsize)) { stop("sampsize must be a function or number specifying size of subsampled data") } if (is.function(sampsize)) { sampsize.function <- sampsize } else { sampsize.function <- make.samplesize.function(sampsize/subj.unique.count) } sampsize <- round(sampsize.function(subj.unique.count)) if (sampsize < 1) { stop("sampsize must be greater than zero") } if (samptype == "swor" && (sampsize > subj.unique.count)) { sampsize.function <- function(x) { x } sampsize <- subj.unique.count } samp <- NULL case.wt <- get.weight(case.wt, subj.unique.count) } else if (bootstrap == "by.user") { if (is.null(samp)) { stop("samp must not be NULL when bootstrapping by user") } ntree <- ncol(samp) sampsize <- colSums(samp) if (sum(sampsize == sampsize[1]) != ntree) { stop("sampsize must be identical for each tree") } sampsize <- sampsize[1] sampsize.function <- make.samplesize.function(sampsize[1]/subj.unique.count) case.wt <- get.weight(NULL, subj.unique.count) } else { sampsize <- subj.unique.count sampsize.function <- function(x) { x } case.wt <- get.weight(case.wt, sampsize) } split.wt <- get.weight(split.wt, n.xvar) forest.wt <- match.arg(as.character(forest.wt), c(FALSE, TRUE, "inbag", "oob", "all")) if (family == "unspv") { yvar.wt <- NULL } else { yvar.wt <- get.weight(yvar.wt, length(yvar.types)) } xvar.wt <- get.weight(xvar.wt, n.xvar) yvar <- as.matrix(data[, yvar.names, drop = FALSE]) if (dim(yvar)[2] == 0) { yvar <- yvar.nlevels <- yvar.numeric.levels <- yfactor <- NULL } else { yfactor$numeric.levels <- yvar.numeric.levels <- get.numeric.levels(family, yfactor$nlevels, yvar) } if (miss.flag) { n.miss <- get.nmiss(xvar, yvar) } else { n.miss <- 0 } if (impute.only && n.miss == 0) { return(data) } remove(data) big.data <- FALSE event.info <- get.grow.event.info(yvar, family, ntime = ntime) splitinfo <- get.grow.splitinfo(formulaDetail, splitrule, hdim, nsplit, event.info) if (family == "surv" || family == "surv-CR") { if (length(event.info$event.type) > 1) { if (missing(cause) || is.null(cause)) { cause <- NULL cause.wt <- rep(1, length(event.info$event.type)) } else { if (length(cause) == 1) { if (cause >= 1 && cause <= length(event.info$event.type)) { cause.wt <- rep(0, length(event.info$event.type)) cause.wt[cause] <- 1 } else { cause.wt <- rep(1, length(event.info$event.type)) } } else { if (length(cause) == length(event.info$event.type) && all(cause >= 0) && !all(cause == 0)) { cause.wt <- cause/sum(cause) } else { cause.wt <- rep(1, length(event.info$event.type)) } } } } else { cause <- NULL cause.wt = 1 } family <- get.coerced.survival.fmly(family, subj, event.info$event.type, splitinfo$name) } else { cause <- cause.wt <- NULL } nodesize <- get.grow.nodesize(family, nodesize) if ((bootstrap != "by.root") && (bootstrap != "by.user")) { importance <- "none" perf.type <- "none" } if (family == "unsupv") { importance <- "none" perf.type <- "none" } if (impute.only) { forest <- FALSE proximity <- FALSE distance <- FALSE var.used <- FALSE split.depth <- FALSE membership <- FALSE perf.type <- "none" importance <- "none" terminal.qualts <- FALSE terminal.quants <- FALSE cse <- FALSE csv <- FALSE } if (!is.null(holdout.array)) { if (nrow(holdout.array) != n.xvar | ncol(holdout.array) != ntree) { stop("dimension of holdout.array does not conform to p x ntree") } vtry <- 1 } gk.quantile <- get.gk.quantile(gk.quantile) prob.assign <- global.prob.assign(prob, prob.epsilon, gk.quantile, quantile.regr, splitinfo$name, n) prob <- prob.assign$prob prob.epsilon <- prob.assign$prob.epsilon if (terminal.qualts | terminal.quants) { forest <- TRUE } ensemble.bits <- get.ensemble(ensemble) impute.only.bits <- get.impute.only(impute.only, n.miss) var.used.bits <- get.var.used(var.used) split.depth.bits <- get.split.depth(split.depth) importance.bits <- get.importance(importance) bootstrap.bits <- get.bootstrap(bootstrap) forest.bits <- get.forest(forest) proximity.bits <- get.proximity(TRUE, proximity) distance.bits <- get.distance(TRUE, distance) membership.bits <- get.membership(membership) statistics.bits <- get.statistics(statistics) split.cust.bits <- get.split.cust(splitinfo$cust) perf.type <- get.perf(perf.type, impute.only, family) perf.bits <- get.perf.bits(perf.type) rfq <- get.rfq(rfq) rfq.bits <- get.rfq.bits(rfq, family) gk.quantile.bits <- get.gk.quantile.bits(gk.quantile) empirical.risk.bits <- get.empirical.risk.bits(empirical.risk) tdc.rule.bits <- get.tdc.rule.bits(tdc.rule) samptype.bits <- get.samptype(samptype) forest.wt.bits <- get.forest.wt(TRUE, bootstrap, forest.wt) na.action.bits <- get.na.action(na.action) block.size <- get.block.size(block.size, ntree) terminal.qualts.bits <- get.terminal.qualts(terminal.qualts, FALSE) terminal.quants.bits <- get.terminal.quants(terminal.quants, FALSE) cse.bits = get.cse(cse) csv.bits = get.csv(csv) do.trace <- get.trace(do.trace) nativeOutput <- tryCatch({ .Call("rfsrcGrow", as.integer(do.trace), as.integer(seed), as.integer(ensemble.bits + impute.only.bits + var.used.bits + split.depth.bits + importance.bits + bootstrap.bits + forest.bits + proximity.bits + perf.bits + rfq.bits + gk.quantile.bits + statistics.bits + empirical.risk.bits), as.integer(samptype.bits + forest.wt.bits + distance.bits + na.action.bits + split.cust.bits + membership.bits + terminal.qualts.bits + terminal.quants.bits + tdc.rule.bits + cse.bits + csv.bits), as.integer(splitinfo$index), as.integer(splitinfo$nsplit), as.integer(mtry), lot, base.learner, as.integer(vtry), as.integer(holdout.array), holdout.specs, as.integer(formulaDetail$ytry), as.integer(nodesize), as.integer(nodedepth), as.integer(length(cause.wt)), as.double(cause.wt), as.integer(ntree), as.integer(n), list(as.integer(length(yvar.types)), if (is.null(yvar.types)) NULL else as.character(yvar.types), if (is.null(yvar.types)) NULL else as.integer(yvar.nlevels), if (is.null(yvar.numeric.levels)) NULL else sapply(1:length(yvar.numeric.levels), function(nn) { as.integer(length(yvar.numeric.levels[[nn]])) }), if (is.null(subj)) NULL else as.integer(subj), if (is.null(event.info)) NULL else as.integer(length(event.info$event.type)), if (is.null(event.info)) NULL else as.integer(event.info$event.type), if (is.null(yvar)) NULL else as.double(as.vector(yvar))), if (is.null(yvar.numeric.levels)) { NULL } else { lapply(1:length(yvar.numeric.levels), function(nn) { as.integer(yvar.numeric.levels[[nn]]) }) }, list(as.integer(n.xvar), as.character(xvar.types), if (is.null(xvar.types)) NULL else as.integer(xvar.nlevels), if (is.null(xvar.numeric.levels)) NULL else sapply(1:length(xvar.numeric.levels), function(nn) { as.integer(length(xvar.numeric.levels[[nn]])) }), if (is.null(xvar.time)) NULL else as.integer(xvar.time), if (is.null(subj.time)) NULL else as.integer(subj.time), as.double(as.vector(xvar))), if (is.null(xvar.numeric.levels)) { NULL } else { lapply(1:length(xvar.numeric.levels), function(nn) { as.integer(xvar.numeric.levels[[nn]]) }) }, list(as.integer(length(case.wt)), if (is.null(case.wt)) NULL else as.double(case.wt), as.integer(sampsize), if (is.null(samp)) NULL else as.integer(samp)), as.double(split.wt), as.double(yvar.wt), as.double(xvar.wt), as.integer(length(event.info$time.interest)), as.double(event.info$time.interest), as.integer(nimpute), as.integer(block.size), as.integer(length(prob)), as.double(prob), as.double(prob.epsilon), as.integer(get.rf.cores())) }, error = function(e) { print(e) NULL }) if (is.null(nativeOutput)) { if (impute.only) { return(NULL) } else { stop("An error has occurred in the grow algorithm. Please turn trace on for further analysis.") } } if (n.miss > 0) { imputed.data <- matrix(nativeOutput$imputation, nrow = n.miss, byrow = FALSE) imputed.indv <- imputed.data[, 1] imputed.data <- as.matrix(imputed.data[, -1, drop = FALSE]) nativeOutput$imputation <- NULL if (nimpute > 1) { if (grepl("surv", family)) { yvar[imputed.indv, 1] <- imputed.data[, 1] yvar[imputed.indv, 2] <- imputed.data[, 2] xvar[imputed.indv, ] <- imputed.data[, -c(1:2), drop = FALSE] } else { if (!is.null(yvar.types)) { yvar[imputed.indv, ] <- imputed.data[, 1:length(yvar.types), drop = FALSE] xvar[imputed.indv, ] <- imputed.data[, -c(1:length(yvar.types)), drop = FALSE] } else { xvar[imputed.indv, ] <- imputed.data } } imputed.indv <- NULL imputed.data <- NULL imputedOOBData <- NULL na.action = "na.omit" } else { colnames(imputed.data) <- c(yvar.names, xvar.names) imputed.data <- as.data.frame(imputed.data) } } xvar <- as.data.frame(xvar) rownames(xvar) <- data.row.names colnames(xvar) <- xvar.names xvar <- map.factor(xvar, xfactor) if (family != "unsupv") { yvar <- as.data.frame(yvar) colnames(yvar) <- yvar.names } else { yvar <- NULL } if (family != "unsupv") { if (family == "regr+" | family == "class+" | family == "mix+") { yvar <- map.factor(yvar, yfactor) } else { yvar <- amatrix.remove.names(map.factor(yvar, yfactor)) } } pi.hat <- NULL if (family == "class" && rfq) { pi.hat <- table(yvar)/length(yvar) } if ((n.miss > 0) & (nimpute < 2)) { imputed.data <- map.factor(imputed.data, xfactor) if (family != "unsupv") { imputed.data <- map.factor(imputed.data, yfactor) } } if (forest) { nativeArraySize = 0 if (hdim == 0) { mwcpCountSummary <- rep(0, 1) nativeFactorArray <- vector("list", 1) } else { mwcpCountSummary = rep(0, hdim) nativeFactorArray <- vector("list", hdim) } pivot <- which(names(nativeOutput) == "treeID") if (hdim == 0) { offset = 0 } else { offset = 7 if (!is.null(base.learner)) { if (base.learner$interact.depth > 1) { offset = offset + 3 } } if (!is.null(base.learner)) { if (base.learner$synthetic.depth > 1) { offset = offset + 2 } } } if (!is.null(base.learner)) { if (base.learner$synthetic.depth > 1) { mwcpCountSummarySyth <- rep(0, 1) nullO <- lapply(1:ntree, function(b) { mwcpCountSummarySyth[1] <<- mwcpCountSummarySyth[1] + nativeOutput$mwcpCTsyth[b] NULL }) } } nullO <- lapply(1:ntree, function(b) { if (nativeOutput$leafCount[b] > 0) { nativeArraySize <<- nativeArraySize + (2 * nativeOutput$leafCount[b]) - 1 mwcpCountSummary[1] <<- mwcpCountSummary[1] + nativeOutput$mwcpCT[b] if (hdim > 1) { for (i in 2:hdim) { mwcpCountSummary[i] <<- mwcpCountSummary[i] + nativeOutput[[pivot + (offset + 2) + (5 * (hdim - 1)) + (i - 2)]][b] } } } else { nativeArraySize <<- nativeArraySize + 1 } NULL }) rm(nullO) nativeArray <- as.data.frame(cbind(nativeOutput$treeID[1:nativeArraySize], nativeOutput$nodeID[1:nativeArraySize])) nativeArrayHeader <- c("treeID", "nodeID") nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput$parmID[1:nativeArraySize], nativeOutput$contPT[1:nativeArraySize], nativeOutput$mwcpSZ[1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, "parmID", "contPT", "mwcpSZ") if (mwcpCountSummary[1] > 0) { nativeFactorArray[[1]] <- nativeOutput$mwcpPT[1:mwcpCountSummary[1]] } nativeFactorArrayHeader <- "mwcpPT" if (hdim > 0) { if (!is.null(base.learner)) { if (base.learner$interact.depth > 1) { nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput$pairCT[1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, "pairCT") } if (base.learner$synthetic.depth > 1) { nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput$sythSZ[1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, "sythSZ") } if (base.learner$interact.depth > 1) { nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput$augmXone[1:nativeArraySize], nativeOutput$augmXtwo[1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, "augmXone", "augmXtwo") } if (base.learner$synthetic.depth > 1) { nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput$augmXS[1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, "augmXS") } } nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, "hcDim") nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset + 1]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, "contPTR") offset = offset + 2 } if (hdim > 1) { for (i in 2:hdim) { nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset + (0 * (hdim - 1)) + i - 2]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, paste("parmID", i, sep = "")) nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset + (1 * (hdim - 1)) + i - 2]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, paste("contPT", i, sep = "")) nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset + (2 * (hdim - 1)) + i - 2]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, paste("contPTR", i, sep = "")) nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset + (3 * (hdim - 1)) + i - 2]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, paste("mwcpSZ", i, sep = "")) if (mwcpCountSummary[i] > 0) { nativeFactorArray[[i]] <- nativeOutput[[pivot + offset + (4 * (hdim - 1)) + i - 2]][1:mwcpCountSummary[i]] } nativeFactorArrayHeader <- c(nativeFactorArrayHeader, paste("mwcpPT", i, sep = "")) if (!is.null(base.learner)) { hdim.multiplier <- 6 if (base.learner$interact.depth > 1) { nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset + (hdim.multiplier * (hdim - 1)) + i - 2]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, paste("augmXone", i, sep = "")) hdim.multiplier <- hdim.multiplier + 1 nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset + (hdim.multiplier * (hdim - 1)) + i - 2]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, paste("augmXtwo", i, sep = "")) hdim.multiplier <- hdim.multiplier + 1 } if (base.learner$synthetic.depth > 1) { nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset + (hdim.multiplier * (hdim - 1)) + i - 2]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, paste("augmXS", i, sep = "")) } } } } nativeArraySyth <- nativeFactorArraySyth <- NULL nodeCountSyth <- NULL totalNodeCountSyth = 0 if (!is.null(base.learner)) { if (base.learner$synthetic.depth > 1) { if (!is.null(nativeOutput$treeIDsyth)) { nativeArraySyth <- as.data.frame(cbind(nativeOutput$treeIDsyth, nativeOutput$nodeIDsyth, nativeOutput$hcDimsyth, nativeOutput$parmIDsyth, nativeOutput$contPTsyth, nativeOutput$contPTRsyth, nativeOutput$mwcpSZsyth)) nativeArrayHeaderSyth <- c("treeID", "nodeID", "hcDim", "parmID", "contPT", "contPTR", "mwcpSZ") names(nativeArraySyth) = nativeArrayHeaderSyth totalNodeCountSyth <- length(nativeOutput$treeIDsyth) nodeCountSyth <- nativeOutput$nodeCountSyth if (mwcpCountSummarySyth[1] > 0) { nativeFactorArraySyth <- nativeOutput$mwcpPTsyth[1:mwcpCountSummarySyth[1]] nativeFactorArrayHeaderSyth <- "mwcpPT" names(nativeFactorArraySyth) = nativeFactorArrayHeaderSyth } } } } names(nativeArray) <- nativeArrayHeader names(nativeFactorArray) <- nativeFactorArrayHeader if (terminal.qualts | terminal.quants) { totalLeafCount <- sum(nativeOutput$leafCount) valid.mcnt.indices <- 1:totalLeafCount if (terminal.quants) { if (grepl("surv", family)) { valid.2D.surv.indices <- 1:(totalLeafCount * length(event.info$event.type) * length(event.info$time.interest)) valid.1D.surv.indices <- 1:(totalLeafCount * length(event.info$time.interest)) valid.mort.indices <- 1:(totalLeafCount * length(event.info$event.type)) } else { class.index <- which(yvar.types != "R") class.count <- length(class.index) regr.index <- which(yvar.types == "R") regr.count <- length(regr.index) if (class.count > 0) { levels.count <- array(0, class.count) counter <- 0 for (i in class.index) { counter <- counter + 1 levels.count[counter] <- yvar.nlevels[i] } valid.clas.indices <- 1:(totalLeafCount * sum(levels.count)) } if (regr.count > 0) { valid.regr.indices <- 1:(totalLeafCount * regr.count) } } } nativeArrayTNDS <- list(if (!is.null(nativeOutput$tnSURV)) nativeOutput$tnSURV[valid.1D.surv.indices] else NULL, if (!is.null(nativeOutput$tnMORT)) nativeOutput$tnMORT[valid.mort.indices] else NULL, if (!is.null(nativeOutput$tnNLSN)) nativeOutput$tnNLSN[valid.1D.surv.indices] else NULL, if (!is.null(nativeOutput$tnCSHZ)) nativeOutput$tnCSHZ[valid.2D.surv.indices] else NULL, if (!is.null(nativeOutput$tnCIFN)) nativeOutput$tnCIFN[valid.2D.surv.indices] else NULL, if (!is.null(nativeOutput$tnREGR)) nativeOutput$tnREGR[valid.regr.indices] else NULL, if (!is.null(nativeOutput$tnCLAS)) nativeOutput$tnCLAS[valid.clas.indices] else NULL, nativeOutput$rmbrMembership, nativeOutput$ambrMembership, nativeOutput$tnRCNT[valid.mcnt.indices], nativeOutput$tnACNT[valid.mcnt.indices]) names(nativeArrayTNDS) <- c("tnSURV", "tnMORT", "tnNLSN", "tnCSHZ", "tnCIFN", "tnREGR", "tnCLAS", "tnRMBR", "tnAMBR", "tnRCNT", "tnACNT") } else { nativeArrayTNDS <- NULL } if (statistics) { node.stats <- as.data.frame(cbind(nativeOutput$spltST[1:nativeArraySize], nativeOutput$dpthST[1:nativeArraySize])) names(node.stats) <- c("spltST", "dpthST") } else { node.stats <- NULL } forest.out <- list(forest = TRUE, hdim = hdim, base.learner = base.learner, nativeArray = nativeArray, nativeFactorArray = nativeFactorArray, totalNodeCount = dim(nativeArray)[1], nativeArraySyth = nativeArraySyth, nativeFactorArraySyth = nativeFactorArraySyth, nodeCountSyth = nodeCountSyth, nodesize = nodesize, nodedepth = nodedepth, ntree = ntree, family = family, n = n, splitrule = splitinfo$name, yvar = yvar, yvar.names = yvar.names, yvar.factor = yfactor, xvar = xvar, xvar.names = xvar.names, xvar.factor = xfactor, event.info = event.info, subj = subj, subj.names = subj.names, seed = nativeOutput$seed, bootstrap = bootstrap, sampsize = sampsize.function, samptype = samptype, samp = samp, case.wt = case.wt, terminal.qualts = terminal.qualts, terminal.quants = terminal.quants, nativeArrayTNDS = nativeArrayTNDS, version = "2.11.0", na.action = na.action, perf.type = perf.type, rfq = rfq, gk.quantile = gk.quantile, quantile.regr = quantile.regr, prob = prob, prob.epsilon = prob.epsilon, block.size = block.size) if (grepl("surv", family)) { forest.out$time.interest <- event.info$time.interest } class(forest.out) <- c("rfsrc", "forest", family) if (big.data) { class(forest.out) <- c(class(forest.out), "bigdata") } } else { node.stats <- NULL forest.out <- list(forest = FALSE, hdim = hdim, base.learner = base.learner, nodesize = nodesize, nodedepth = nodedepth, ntree = ntree, family = family, n = n, splitrule = splitinfo$name, yvar = yvar, yvar.names = yvar.names, xvar = xvar, xvar.names = xvar.names, subj = subj, subj.names = subj.names, seed = nativeOutput$seed, bootstrap = bootstrap, sampsize = sampsize.function, samptype = samptype, samp = samp, case.wt = case.wt, version = "2.11.0", na.action = na.action, perf.type = perf.type, rfq = rfq, gk.quantile = gk.quantile, quantile.regr = quantile.regr, prob = prob, prob.epsilon = prob.epsilon, block.size = block.size) } if (proximity != FALSE) { proximity.out <- matrix(0, n, n) count <- 0 for (k in 1:n) { proximity.out[k, 1:k] <- nativeOutput$proximity[(count + 1):(count + k)] proximity.out[1:k, k] <- proximity.out[k, 1:k] count <- count + k } nativeOutput$proximity <- NULL } else { proximity.out <- NULL } if (distance != FALSE) { distance.out <- matrix(0, n, n) count <- 0 for (k in 1:n) { distance.out[k, 1:k] <- nativeOutput$distance[(count + 1):(count + k)] distance.out[1:k, k] <- distance.out[k, 1:k] count <- count + k } nativeOutput$distance <- NULL } else { distance.out <- NULL } if (forest.wt != FALSE) { forest.wt.out <- matrix(nativeOutput$weight, c(n, n), byrow = TRUE) nativeOutput$weight <- NULL } else { forest.wt.out <- NULL } if (membership) { membership.out <- matrix(nativeOutput$nodeMembership, c(n, ntree)) inbag.out <- matrix(nativeOutput$bootMembership, c(n, ntree)) nativeOutput$nodeMembership <- NULL nativeOutput$bootMembership <- NULL if (!is.null(subj)) { tdc.membership.cnt <- matrix(nativeOutput$nodeMembershipTDC[[1]], c(n, ntree)) tdc.membership.out <- vector("list", ntree) begin.indx <- 0 end.indx <- 0 for (i in 1:ntree) { temp <- vector("list", n) for (j in 1:n) { begin.indx <- end.indx + 1 end.indx <- end.indx + tdc.membership.cnt[j, i] temp[[j]] <- nativeOutput$nodeMembershipTDC[[2]][begin.indx:end.indx] } tdc.membership.out[[i]] <- temp } } else { tdc.membership.out <- NULL } } else { membership.out <- NULL inbag.out <- NULL tdc.membership.out <- NULL } if (var.used != FALSE) { if (var.used == "all.trees") { var.used.out <- nativeOutput$varUsed names(var.used.out) <- xvar.names } else { var.used.out <- matrix(nativeOutput$varUsed, nrow = ntree, byrow = TRUE) colnames(var.used.out) <- xvar.names } nativeOutput$varUsed <- NULL } else { var.used.out <- NULL } if (split.depth != FALSE) { if (split.depth == "all.trees") { split.depth.out <- array(nativeOutput$splitDepth, c(n, n.xvar)) } else { split.depth.out <- array(nativeOutput$splitDepth, c(n, n.xvar, ntree)) } nativeOutput$splitDepth <- NULL } else { split.depth.out <- NULL } empr.risk <- NULL oob.empr.risk <- NULL if (empirical.risk) { if (!is.null(nativeOutput$emprRisk)) { empr.risk <- array(nativeOutput$emprRisk, c(lot$treesize, ntree)) nativeOutput$emprRisk <- NULL } if (!is.null(nativeOutput$oobEmprRisk)) { oob.empr.risk <- array(nativeOutput$oobEmprRisk, c(lot$treesize, ntree)) nativeOutput$oobEmprRisk <- NULL } } if (!is.null(holdout.specs)) { holdout.blk <- nativeOutput$holdoutBlk nativeOutput$holdoutBlk <- NULL } else { holdout.blk = NULL } rfsrcOutput <- list(call = my.call, family = family, n = n, ntree = ntree, nimpute = nimpute, mtry = mtry, nodesize = nodesize, nodedepth = nodedepth, nsplit = splitinfo$nsplit, yvar = yvar, yvar.names = yvar.names, xvar = xvar, xvar.names = xvar.names, event.info = event.info, subj = subj, subj.names = subj.names, xvar.wt = xvar.wt, split.wt = split.wt, cause.wt = cause.wt, leaf.count = nativeOutput$leafCount, proximity = proximity.out, forest = forest.out, forest.wt = forest.wt.out, distance = distance.out, membership = membership.out, tdc.membership = tdc.membership.out, splitrule = splitinfo$name, inbag = inbag.out, var.used = var.used.out, imputed.indv = (if (n.miss > 0) imputed.indv else NULL), imputed.data = (if (n.miss > 0) imputed.data else NULL), split.depth = split.depth.out, node.stats = node.stats, ensemble = ensemble, holdout.array = holdout.array, block.size = block.size, holdout.blk = holdout.blk, empr.risk = empr.risk, oob.empr.risk = oob.empr.risk) remove(yvar) remove(xvar) nativeOutput$leafCount <- NULL remove(proximity.out) remove(forest.out) remove(forest.wt.out) remove(distance.out) remove(membership.out) remove(inbag.out) remove(var.used.out) if (n.miss > 0) remove(imputed.indv) if (n.miss > 0) remove(imputed.data) remove(split.depth.out) remove(holdout.array) remove(empr.risk) remove(oob.empr.risk) survOutput <- NULL classOutput <- NULL regrOutput <- NULL if (!impute.only) { if (grepl("surv", family)) { if ((length(event.info$event.type) > 1) && (splitinfo$name != "l2.impute") && (splitinfo$name != "logrankscore")) { coerced.event.count <- length(event.info$event.type) } else { coerced.event.count <- 1 } if (family == "surv") { ens.names <- list(NULL, NULL) mortality.names <- list(NULL, NULL) err.names <- list(NULL, NULL) vimp.names <- list(NULL, xvar.names) } else if (family == "surv-CR") { ens.names <- list(NULL, NULL, c(paste("condCHF.", 1:length(event.info$event.type), sep = ""))) mortality.names <- list(NULL, paste("event.", 1:length(event.info$event.type), sep = "")) cif.names <- list(NULL, NULL, c(paste("CIF.", 1:length(event.info$event.type), sep = ""))) err.names <- list(c(paste("event.", 1:length(event.info$event.type), sep = "")), NULL) vimp.names <- list(paste("event.", 1:length(event.info$event.type), sep = ""), xvar.names) } else { ens.names <- list(NULL, NULL) } chf <- (if (!is.null(nativeOutput$allEnsbCHF)) adrop3d.last(array(nativeOutput$allEnsbCHF, c(n, length(event.info$time.interest), length(event.info$event.type)), dimnames = ens.names), coerced.event.count) else NULL) nativeOutput$allEnsbCHF <- NULL survOutput <- list(chf = chf) remove(chf) chf.oob <- (if (!is.null(nativeOutput$oobEnsbCHF)) adrop3d.last(array(nativeOutput$oobEnsbCHF, c(n, length(event.info$time.interest), length(event.info$event.type)), dimnames = ens.names), coerced.event.count) else NULL) nativeOutput$oobEnsbCHF <- NULL survOutput = c(survOutput, chf.oob = list(chf.oob)) remove(chf.oob) predicted <- (if (!is.null(nativeOutput$allEnsbMRT)) adrop2d.last(array(nativeOutput$allEnsbMRT, c(n, length(event.info$event.type)), dimnames = mortality.names), coerced.event.count) else NULL) nativeOutput$allEnsbMRT <- NULL survOutput = c(survOutput, predicted = list(predicted)) remove(predicted) predicted.oob <- (if (!is.null(nativeOutput$oobEnsbMRT)) adrop2d.last(array(nativeOutput$oobEnsbMRT, c(n, length(event.info$event.type)), dimnames = mortality.names), coerced.event.count) else NULL) nativeOutput$oobEnsbMRT <- NULL survOutput <- c(survOutput, predicted.oob = list(predicted.oob)) remove(predicted.oob) hazard <- (if (!is.null(nativeOutput$allEnsbKHZ)) matrix(nativeOutput$allEnsbKHZ, c(subj.unique.count, length(event.info$time.interest))) else NULL) nativeOutput$allEnsbKHZ <- NULL survOutput <- c(survOutput, hazard = list(hazard)) remove(hazard) hazard.oob <- (if (!is.null(nativeOutput$oobEnsbKHZ)) matrix(nativeOutput$oobEnsbKHZ, c(subj.unique.count, length(event.info$time.interest))) else NULL) nativeOutput$oobEnsbKHZ <- NULL survOutput <- c(survOutput, hazard.oob = list(hazard.oob)) remove(hazard.oob) survival <- (if (!is.null(nativeOutput$allEnsbSRV)) matrix(nativeOutput$allEnsbSRV, c(n, length(event.info$time.interest))) else NULL) nativeOutput$allEnsbSRV <- NULL survOutput <- c(survOutput, survival = list(survival)) remove(survival) survival.oob <- (if (!is.null(nativeOutput$oobEnsbSRV)) matrix(nativeOutput$oobEnsbSRV, c(n, length(event.info$time.interest))) else NULL) nativeOutput$oobEnsbSRV <- NULL survOutput <- c(survOutput, survival.oob = list(survival.oob)) remove(survival.oob) cif <- (if (!is.null(nativeOutput$allEnsbCIF)) array(nativeOutput$allEnsbCIF, c(n, length(event.info$time.interest), length(event.info$event.type)), dimnames = cif.names) else NULL) nativeOutput$allEnsbCIF <- NULL survOutput <- c(survOutput, cif = list(cif)) remove(cif) cif.oob <- (if (!is.null(nativeOutput$oobEnsbCIF)) array(nativeOutput$oobEnsbCIF, c(n, length(event.info$time.interest), length(event.info$event.type)), dimnames = cif.names) else NULL) nativeOutput$oobEnsbCIF <- NULL survOutput = c(survOutput, cif.oob = list(cif.oob)) remove(cif.oob) if (!is.null(nativeOutput$perfSurv)) { err.rate <- adrop2d.first(array(nativeOutput$perfSurv, c(length(event.info$event.type), ntree), dimnames = err.names), coerced.event.count) nativeOutput$perfSurv <- NULL if (family == "surv-CR") { survOutput = c(survOutput, err.rate = list(t(err.rate))) } else { survOutput = c(survOutput, err.rate = list(err.rate)) } remove(err.rate) } if (!is.null(nativeOutput$blockSurv)) { err.block.rate <- adrop2d.first(array(nativeOutput$blockSurv, c(length(event.info$event.type), floor(ntree/block.size)), dimnames = err.names), coerced.event.count) nativeOutput$blockSurv <- NULL if (family == "surv-CR") { survOutput = c(survOutput, err.block.rate = list(t(err.block.rate))) } else { survOutput = c(survOutput, err.block.rate = list(err.block.rate)) } remove(err.block.rate) } if (!is.null(nativeOutput$vimpSurv)) { importance <- adrop2d.first(array(nativeOutput$vimpSurv, c(length(event.info$event.type), n.xvar), dimnames = vimp.names), coerced.event.count) nativeOutput$vimpSurv <- NULL if (family == "surv-CR") { survOutput = c(survOutput, importance = list(t(importance))) } else { survOutput = c(survOutput, importance = list(importance)) } remove(importance) } survOutput = c(survOutput, list(time.interest = event.info$time.interest, ndead = sum(na.omit(event.info$cens) != 0))) if (!is.null(nativeOutput$holdoutSurv)) { holdout.vimp <- vector("list", length(rfsrcOutput$holdout.blk)) names(holdout.vimp) <- xvar.names holdout.offset <- rfsrcOutput$holdout.blk * length(event.info$event.type) holdout.offset.sum <- c(0, cumsum(holdout.offset)) for (i in 1:length(holdout.vimp)) { if (rfsrcOutput$holdout.blk[i] > 0) { if (length(event.info$event.type) > 1) { holdout.vimp[[i]] <- array(nativeOutput$holdoutSurv[(holdout.offset.sum[i] + 1):holdout.offset.sum[i + 1]], c(length(event.info$event.type), rfsrcOutput$holdout.blk[i])) } else { holdout.vimp[[i]] <- nativeOutput$holdoutSurv[(holdout.offset.sum[i] + 1):holdout.offset.sum[i + 1]] } } else { holdout.vimp[[i]] = NA } } survOutput = c(survOutput, holdout.vimp = list(holdout.vimp)) remove(holdout.vimp) } if (univariate.nomenclature) { rfsrcOutput <- c(rfsrcOutput, survOutput) } else { rfsrcOutput <- c(rfsrcOutput, survOutput = list(survOutput)) } } else { class.index <- which(yvar.types != "R") resp.clas.count <- length(class.index) regr.index <- which(yvar.types == "R") resp.regr.count <- length(regr.index) if (resp.clas.count > 0) { classOutput <- vector("list", resp.clas.count) names(classOutput) <- yvar.names[class.index] levels.count <- array(0, resp.clas.count) levels.names <- vector("list", resp.clas.count) counter <- 0 for (i in class.index) { counter <- counter + 1 levels.count[counter] <- yvar.nlevels[i] if (yvar.types[i] == "C") { levels.names[[counter]] <- yfactor$levels[[which(yfactor$factor == yvar.names[i])]] } else { levels.names[[counter]] <- yfactor$order.levels[[which(yfactor$order == yvar.names[i])]] } } tree.offset <- array(1, ntree) if (ntree > 1) { tree.offset[2:ntree] <- sum(1 + levels.count) } tree.offset <- cumsum(tree.offset) block.offset <- array(1, floor(ntree/block.size)) if (floor(ntree/block.size) > 1) { block.offset[2:floor(ntree/block.size)] <- sum(1 + levels.count) } block.offset <- cumsum(block.offset) vimp.offset <- array(1, n.xvar) if (n.xvar > 1) { vimp.offset[2:n.xvar] <- sum(1 + levels.count) } vimp.offset <- cumsum(vimp.offset) iter.ensb.start <- 0 iter.ensb.end <- 0 if (!is.null(nativeOutput$holdoutClas)) { holdout.offset.x <- rfsrcOutput$holdout.blk * (sum(1 + levels.count)) holdout.offset.sum.x <- c(0, cumsum(holdout.offset.x)) holdout.offset.r <- 0 } for (i in 1:resp.clas.count) { iter.ensb.start <- iter.ensb.end iter.ensb.end <- iter.ensb.end + (levels.count[i] * n) ens.names <- list(NULL, levels.names[[i]]) err.names <- c("all", levels.names[[i]]) vimp.names <- list(c("all", levels.names[[i]]), xvar.names) predicted <- (if (!is.null(nativeOutput$allEnsbCLS)) array(nativeOutput$allEnsbCLS[(iter.ensb.start + 1):iter.ensb.end], c(n, levels.count[i]), dimnames = ens.names) else NULL) classOutput[[i]] <- list(predicted = predicted) response <- (if (!is.null(predicted)) get.bayes.rule(predicted, pi.hat) else NULL) classOutput[[i]] <- c(classOutput[[i]], class = list(response)) remove(predicted) remove(response) predicted.oob <- (if (!is.null(nativeOutput$oobEnsbCLS)) array(nativeOutput$oobEnsbCLS[(iter.ensb.start + 1):iter.ensb.end], c(n, levels.count[i]), dimnames = ens.names) else NULL) classOutput[[i]] <- c(classOutput[[i]], predicted.oob = list(predicted.oob)) response.oob <- (if (!is.null(predicted.oob)) get.bayes.rule(predicted.oob, pi.hat) else NULL) classOutput[[i]] <- c(classOutput[[i]], class.oob = list(response.oob)) remove(predicted.oob) remove(response.oob) cse.num <- (if (!is.null(nativeOutput$cseClas)) array(nativeOutput$cseClas[(iter.ensb.start + 1):iter.ensb.end], n) else NULL) classOutput[[i]] <- c(classOutput[[i]], cse.num = list(cse.num)) remove(cse.num) cse.den <- (if (!is.null(nativeOutput$cseDen)) array(nativeOutput$cseDen[1:n], n) else NULL) classOutput[[i]] <- c(classOutput[[i]], cse.den = list(cse.den)) if (!is.null(nativeOutput$perfClas)) { err.rate <- array(0, c(1 + levels.count[i], ntree)) for (j in 1:(1 + levels.count[i])) { err.rate[j, ] <- nativeOutput$perfClas[tree.offset] tree.offset <- tree.offset + 1 } row.names(err.rate) <- err.names classOutput[[i]] <- c(classOutput[[i]], err.rate = list(t(err.rate))) remove(err.rate) } if (!is.null(nativeOutput$blockClas)) { err.block.rate <- array(0, c(1 + levels.count[i], floor(ntree/block.size))) for (j in 1:(1 + levels.count[i])) { err.block.rate[j, ] <- nativeOutput$blockClas[block.offset] block.offset <- block.offset + 1 } row.names(err.block.rate) <- err.names classOutput[[i]] <- c(classOutput[[i]], err.block.rate = list(t(err.block.rate))) remove(err.block.rate) } csv.idx <- array(0, n * n.xvar) for (j in 1:n.xvar) { csv.idx[(((j - 1) * n) + 1):(((j - 1) * n) + n)] <- (((i - 1) * n) + ((j - 1) * n * resp.clas.count) + 1):(((i - 1) * n) + ((j - 1) * n * resp.clas.count) + n) } csv.num <- (if (!is.null(nativeOutput$csvClas)) array(nativeOutput$csvClas[csv.idx], c(n, n.xvar)) else NULL) classOutput[[i]] <- c(classOutput[[i]], csv.num = list(csv.num)) remove(csv.num) csv.den <- (if (!is.null(nativeOutput$csvDen)) array(nativeOutput$csvDen, c(n, n.xvar)) else NULL) classOutput[[i]] <- c(classOutput[[i]], csv.den = list(csv.den)) remove(csv.den) if (!is.null(nativeOutput$vimpClas)) { importance <- array(0, c(1 + levels.count[i], n.xvar), dimnames = vimp.names) for (j in 1:(1 + levels.count[i])) { importance[j, ] <- nativeOutput$vimpClas[vimp.offset] vimp.offset <- vimp.offset + 1 } classOutput[[i]] <- c(classOutput[[i]], importance = list(t(importance))) remove(importance) } if (!is.null(nativeOutput$holdoutClas)) { holdout.vimp <- vector("list", length(rfsrcOutput$holdout.blk)) names(holdout.vimp) <- xvar.names if (i > 1) { holdout.offset.r <- holdout.offset.r + (1 + levels.count[i - 1]) } for (k in 1:length(holdout.vimp)) { if (rfsrcOutput$holdout.blk[k] > 0) { offset.x <- holdout.offset.sum.x[k] offset.b <- 0 index.m <- NULL for (m in 1:rfsrcOutput$holdout.blk[k]) { if (m > 1) { offset.b <- offset.b + (sum(1 + levels.count)) } index.m <- c(index.m, seq(from = offset.x + offset.b + holdout.offset.r + 1, by = 1, length.out = levels.count[i] + 1)) } holdout.vimp[[k]] = array(nativeOutput$holdoutClas[index.m], c(levels.count[i] + 1, rfsrcOutput$holdout.blk[k])) } else { holdout.vimp[[k]] = NA } } classOutput[[i]] = c(classOutput[[i]], holdout.vimp = list(holdout.vimp)) remove(holdout.vimp) } } nativeOutput$allEnsbCLS <- NULL nativeOutput$oobEnsbCLS <- NULL nativeOutput$perfClas <- NULL nativeOutput$blockClas <- NULL nativeOutput$vimpClas <- NULL nativeOutput$holdoutClas <- NULL if (univariate.nomenclature) { if ((resp.clas.count == 1) & (resp.regr.count == 0)) { names(classOutput) <- NULL rfsrcOutput <- c(rfsrcOutput, unlist(classOutput, recursive = FALSE)) } else { rfsrcOutput <- c(rfsrcOutput, classOutput = list(classOutput)) } } else { rfsrcOutput <- c(rfsrcOutput, classOutput = list(classOutput)) } } if (resp.regr.count > 0) { regrOutput <- vector("list", resp.regr.count) names(regrOutput) <- yvar.names[regr.index] tree.offset <- array(1, ntree) if (ntree > 1) { tree.offset[2:ntree] <- length(regr.index) } tree.offset <- cumsum(tree.offset) block.offset <- array(1, floor(ntree/block.size)) if (floor(ntree/block.size) > 1) { block.offset[2:floor(ntree/block.size)] <- length(regr.index) } block.offset <- cumsum(block.offset) vimp.offset <- array(1, n.xvar) if (n.xvar > 1) { vimp.offset[2:n.xvar] <- length(regr.index) } vimp.offset <- cumsum(vimp.offset) iter.ensb.start <- 0 iter.ensb.end <- 0 iter.qntl.start <- 0 iter.qntl.end <- 0 if (!is.null(nativeOutput$holdoutRegr)) { holdout.offset.x <- rfsrcOutput$holdout.blk * resp.regr.count holdout.offset.sum.x <- c(0, cumsum(holdout.offset.x)) holdout.offset.r <- 0 } for (i in 1:resp.regr.count) { iter.ensb.start <- iter.ensb.end iter.ensb.end <- iter.ensb.end + n iter.qntl.start <- iter.qntl.end iter.qntl.end <- iter.qntl.end + (length(prob) * n) vimp.names <- xvar.names predicted <- (if (!is.null(nativeOutput$allEnsbRGR)) array(nativeOutput$allEnsbRGR[(iter.ensb.start + 1):iter.ensb.end], n) else NULL) regrOutput[[i]] <- list(predicted = predicted) remove(predicted) predicted.oob <- (if (!is.null(nativeOutput$oobEnsbRGR)) array(nativeOutput$oobEnsbRGR[(iter.ensb.start + 1):iter.ensb.end], n) else NULL) regrOutput[[i]] <- c(regrOutput[[i]], predicted.oob = list(predicted.oob)) remove(predicted.oob) cse.num <- (if (!is.null(nativeOutput$cseRegr)) array(nativeOutput$cseRegr[(iter.ensb.start + 1):iter.ensb.end], n) else NULL) regrOutput[[i]] <- c(regrOutput[[i]], cse.num = list(cse.num)) remove(cse.num) cse.den <- (if (!is.null(nativeOutput$cseDen)) array(nativeOutput$cseDen[1:n], n) else NULL) regrOutput[[i]] <- c(regrOutput[[i]], cse.den = list(cse.den)) quantile <- (if (!is.null(nativeOutput$allEnsbQNT)) array(nativeOutput$allEnsbQNT[(iter.qntl.start + 1):iter.qntl.end], c(n, length(prob))) else NULL) regrOutput[[i]] <- c(regrOutput[[i]], quantile = list(quantile)) remove(quantile) quantile.oob <- (if (!is.null(nativeOutput$oobEnsbQNT)) array(nativeOutput$oobEnsbQNT[(iter.qntl.start + 1):iter.qntl.end], c(n, length(prob))) else NULL) regrOutput[[i]] <- c(regrOutput[[i]], quantile.oob = list(quantile.oob)) remove(quantile.oob) if (!is.null(nativeOutput$perfRegr)) { err.rate <- nativeOutput$perfRegr[tree.offset] tree.offset <- tree.offset + 1 regrOutput[[i]] <- c(regrOutput[[i]], err.rate = list(err.rate)) remove(err.rate) } if (!is.null(nativeOutput$blockRegr)) { err.block.rate <- nativeOutput$blockRegr[block.offset] block.offset <- block.offset + 1 regrOutput[[i]] <- c(regrOutput[[i]], err.block.rate = list(err.block.rate)) remove(err.block.rate) } if (!is.null(nativeOutput$vimpRegr)) { importance <- nativeOutput$vimpRegr[vimp.offset] names(importance) <- xvar.names vimp.offset <- vimp.offset + 1 regrOutput[[i]] <- c(regrOutput[[i]], importance = list(importance)) remove(importance) } csv.idx <- array(0, n * n.xvar) for (j in 1:n.xvar) { csv.idx[(((j - 1) * n) + 1):(((j - 1) * n) + n)] <- (((i - 1) * n) + ((j - 1) * n * resp.regr.count) + 1):(((i - 1) * n) + ((j - 1) * n * resp.regr.count) + n) } csv.num <- (if (!is.null(nativeOutput$csvRegr)) array(nativeOutput$csvRegr[csv.idx], c(n, n.xvar)) else NULL) regrOutput[[i]] <- c(regrOutput[[i]], csv.num = list(csv.num)) remove(csv.num) csv.den <- (if (!is.null(nativeOutput$csvDen)) array(nativeOutput$csvDen, c(n, n.xvar)) else NULL) regrOutput[[i]] <- c(regrOutput[[i]], csv.den = list(csv.den)) remove(csv.den) if (!is.null(nativeOutput$holdoutRegr)) { holdout.vimp <- vector("list", length(rfsrcOutput$holdout.blk)) names(holdout.vimp) <- xvar.names if (i > 1) { holdout.offset.r <- holdout.offset.r + 1 } for (k in 1:length(holdout.vimp)) { if (rfsrcOutput$holdout.blk[k] > 0) { offset.x <- holdout.offset.sum.x[k] offset.b <- 0 index.m <- NULL for (m in 1:rfsrcOutput$holdout.blk[k]) { if (m > 1) { offset.b <- offset.b + resp.regr.count } index.m <- c(index.m, offset.x + offset.b + holdout.offset.r + 1) } holdout.vimp[[k]] <- nativeOutput$holdoutRegr[index.m] } else { holdout.vimp[[k]] <- NA } } regrOutput[[i]] <- c(regrOutput[[i]], holdout.vimp = list(holdout.vimp)) } } nativeOutput$allEnsbRGR <- NULL nativeOutput$oobEnsbRGR <- NULL nativeOutput$allEnsbQNT <- NULL nativeOutput$oobEnsbQNT <- NULL nativeOutput$perfRegr <- NULL nativeOutput$blockRegr <- NULL nativeOutput$vimpRegr <- NULL nativeOutput$holdoutRegr <- NULL if (univariate.nomenclature) { if ((resp.clas.count == 0) & (resp.regr.count == 1)) { names(regrOutput) <- NULL rfsrcOutput <- c(rfsrcOutput, unlist(regrOutput, recursive = FALSE)) } else { rfsrcOutput <- c(rfsrcOutput, regrOutput = list(regrOutput)) } } else { rfsrcOutput <- c(rfsrcOutput, regrOutput = list(regrOutput)) } } } } class(rfsrcOutput) <- c("rfsrc", "grow", family) if (big.data) { class(rfsrcOutput) <- c(class(rfsrcOutput), "bigdata") } return(rfsrcOutput)})(ntree = 50, mtry = 5, nodesize = 5, samptype = "swr", formula = medv ~ ., data = list(crim = c(2.81838, 0.27957, 4.26131, 0.37578, 73.5341, 0.03961, 0.02009, 6.39312, 0.05789, 0.04379, 0.03445, 14.4208, 0.02187, 0.08187, 0.07978, 2.73397, 0.05479, 0.14103, 0.35809, 0.05735, 0.46296, 2.24236, 41.5292, 0.44178, 9.96654, 0.32264, 0.21124, 0.12269, 0.1146, 0.84054, 0.25356, 0.02729, 0.12204, 5.66637, 0.01538, 0.15936, 0.02055, 0.01501, 18.4982, 0.05023, 0.03584, 0.22188, 2.63548, 0.22489, 0.07886, 0.04684, 0.12083, 0.10084, 0.06417, 11.9511), zn = c(0, 0, 0, 0, 0, 0, 95, 0, 12.5, 80, 82.5, 0, 60, 0, 40, 0, 33, 0, 0, 0, 0, 0, 0, 0, 0, 0, 12.5, 0, 20, 0, 0, 0, 0, 0, 90, 0, 85, 90, 0, 35, 80, 20, 0, 12.5, 80, 0, 0, 0, 0, 0), indus = c(18.1, 9.69, 18.1, 10.59, 18.1, 5.19, 2.68, 18.1, 6.07, 3.37, 2.03, 18.1, 2.93, 2.89, 6.41, 19.58, 2.18, 13.92, 6.2, 4.49, 6.2, 19.58, 18.1, 6.2, 18.1, 21.89, 7.87, 6.91, 6.96, 8.14, 9.9, 7.07, 2.89, 18.1, 3.75, 6.91, 0.74, 1.21, 18.1, 6.06, 3.37, 6.96, 9.9, 7.87, 4.95, 3.41, 2.89, 10.01, 5.96, 18.1), chas = c(1L, 1L, 1L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 1L, 1L, 1L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L), nox = c(0.532, 0.585, 0.77, 0.489, 0.679, 0.515, 0.4161, 0.584, 0.409, 0.398, 0.415, 0.74, 0.401, 0.445, 0.447, 0.871, 0.472, 0.437, 0.507, 0.449, 0.504, 0.605, 0.693, 0.504, 0.74, 0.624, 0.524, 0.448, 0.464, 0.538, 0.544, 0.469, 0.445, 0.74, 0.394, 0.448, 0.41, 0.401, 0.668, 0.4379, 0.398, 0.464, 0.544, 0.524, 0.411, 0.489, 0.445, 0.547, 0.499, 0.659), rm = c(5.762, 5.926, 6.112, 5.404, 5.957, 6.037, 8.034, 6.162, 5.878, 5.787, 6.162, 6.461, 6.8, 7.82, 6.482, 5.597, 6.616, 5.79, 6.951, 6.63, 7.412, 5.854, 5.531, 6.552, 6.485, 5.942, 5.631, 6.069, 6.538, 5.599, 5.705, 7.185, 6.625, 6.219, 7.454, 6.211, 6.383, 7.923, 4.138, 5.706, 6.29, 7.691, 4.973, 6.377, 7.148, 6.417, 8.069, 6.715, 5.933, 5.608), age = c(40.3, 42.6, 81.3, 88.6, 100, 34.5, 31.9, 97.4, 21.4, 31.1, 38.4, 93.3, 9.9, 36.9, 32.1, 94.9, 58.1, 58, 88.5, 56.1, 76.9, 91.8, 85.4, 21.4, 100, 93.5, 100, 40, 58.7, 85.7, 77.7, 61.1, 57.8, 100, 34.2, 6.5, 35.7, 24.8, 100, 28.4, 17.8, 51.8, 37.8, 94.3, 27.7, 66.1, 76, 81.6, 68.2, 100), dis = c(4.0983, 2.3817, 2.5091, 3.665, 1.8026, 5.9853, 5.118, 2.206, 6.498, 6.6115, 6.27, 2.0026, 6.2196, 3.4952, 4.1403, 1.5257, 3.37, 6.32, 2.8617, 4.4377, 3.6715, 2.422, 1.6074, 3.3751, 1.9784, 1.9669, 6.0821, 5.7209, 3.9175, 4.4546, 3.945, 4.9671, 3.4952, 2.0048, 6.3361, 5.7209, 9.1876, 5.885, 1.137, 6.6407, 6.6115, 4.3665, 2.5194, 6.3467, 5.1167, 3.0923, 3.4952, 2.6775, 3.3603, 1.2852), rad = c(24, 6, 24, 4, 24, 5, 4, 24, 4, 4, 2, 24, 1, 2, 4, 5, 7, 4, 8, 3, 8, 5, 24, 8, 24, 4, 5, 3, 3, 4, 4, 2, 2, 24, 3, 3, 2, 1, 24, 1, 4, 3, 4, 5, 4, 2, 2, 6, 5, 24), tax = c(666, 391, 666, 277, 666, 224, 224, 666, 345, 337, 348, 666, 265, 276, 254, 403, 222, 289, 307, 247, 307, 403, 666, 307, 666, 437, 311, 233, 223, 307, 304, 242, 276, 666, 244, 233, 313, 198, 666, 304, 337, 223, 304, 311, 245, 270, 276, 432, 279, 666), ptratio = c(20.2, 19.2, 20.2, 18.6, 20.2, 20.2, 14.7, 20.2, 18.9, 16.1, 14.7, 20.2, 15.6, 18, 17.6, 14.7, 18.4, 16, 17.4, 18.5, 17.4, 14.7, 20.2, 17.4, 20.2, 21.2, 15.2, 17.9, 18.6, 21, 18.4, 17.8, 18, 20.2, 15.9, 17.9, 17.3, 13.6, 20.2, 16.9, 16.1, 18.6, 18.4, 15.2, 19.2, 17.8, 18, 17.8, 19.2, 20.2), b = c(392.92, 396.9, 390.74, 395.24, 16.45, 396.9, 390.55, 302.76, 396.21, 396.9, 393.77, 27.49, 393.37, 393.53, 396.9, 351.85, 393.36, 396.9, 391.7, 392.3, 376.14, 395.11, 329.46, 380.34, 386.73, 378.25, 386.63, 389.39, 394.96, 303.42, 396.42, 392.83, 357.98, 395.69, 386.34, 394.46, 396.9, 395.52, 396.9, 394.02, 396.9, 390.77, 350.45, 392.52, 396.9, 392.18, 396.9, 395.59, 396.9, 332.09), lstat = c(10.42, 13.59, 12.67, 23.98, 20.62, 8.01, 2.88, 24.1, 8.1, 10.24, 7.43, 18.05, 5.03, 3.57, 7.19, 21.45, 8.93, 15.84, 9.71, 6.53, 5.25, 11.64, 27.38, 3.76, 18.85, 16.9, 29.93, 9.55, 7.73, 16.51, 11.5, 4.03, 6.65, 16.59, 3.11, 7.44, 5.77, 3.16, 37.97, 12.43, 4.67, 6.58, 12.64, 20.45, 3.56, 8.81, 4.21, 10.16, 9.68, 12.13), medv = c(21.8, 24.5, 22.6, 19.3, 8.8, 21.1, 50, 13.3, 22, 19.4, 24.1, 9.6, 31.1, 43.8, 29.1, 15.4, 28.4, 20.3, 26.7, 26.6, 31.7, 22.7, 8.5, 31.5, 15.4, 17.4, 16.5, 21.2, 24.4, 13.9, 16.2, 34.7, 28.4, 18.4, 44, 24.7, 24.7, 50, 13.8, 17.1, 23.5, 35.2, 16.1, 15, 37.3, 22.6, 38.7, 22.8, 18.9, 27.9)), membership = TRUE, split_rule = "custom2")
6: do.call(rfsrc, params_rfsrc)
7: rfpi(formula, traindata, testdata, alpha, split_rule = "l1", pi_method = pi_method, rf_package = "rfsrc", params_rfsrc = params_rfsrc)
8: piall(formula, traindata = traindata2, testdata = testdata2[, xvar.names], num.trees = 50)
9: eval(code, test_env)
10: eval(code, test_env)
11: withCallingHandlers({ eval(code, test_env) if (!handled && !is.null(test)) { skip_empty() }}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning, message = handle_message, error = handle_error)
12: doTryCatch(return(expr), name, parentenv, handler)
13: tryCatchOne(expr, names, parentenv, handlers[[1L]])
14: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
15: doTryCatch(return(expr), name, parentenv, handler)
16: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), names[nh], parentenv, handlers[[nh]])
17: tryCatchList(expr, classes, parentenv, handlers)
18: tryCatch(withCallingHandlers({ eval(code, test_env) if (!handled && !is.null(test)) { skip_empty() }}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning, message = handle_message, error = handle_error), error = handle_fatal, skip = function(e) { })
19: test_code(test = NULL, code = exprs, env = env, reporter = get_reporter() %||% StopReporter$new())
20: source_file(path, env = env(env), desc = desc, error_call = error_call)
21: FUN(X[[i]], ...)
22: lapply(test_paths, test_one_file, env = env, desc = desc, error_call = error_call)
23: doTryCatch(return(expr), name, parentenv, handler)
24: tryCatchOne(expr, names, parentenv, handlers[[1L]])
25: tryCatchList(expr, classes, parentenv, handlers)
26: tryCatch(code, testthat_abort_reporter = function(cnd) { cat(conditionMessage(cnd), "\n") NULL})
27: with_reporter(reporters$multi, lapply(test_paths, test_one_file, env = env, desc = desc, error_call = error_call))
28: test_files_serial(test_dir = test_dir, test_package = test_package, test_paths = test_paths, load_helpers = load_helpers, reporter = reporter, env = env, stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning, desc = desc, load_package = load_package, error_call = error_call)
29: test_files(test_dir = path, test_paths = test_paths, test_package = package, reporter = reporter, load_helpers = load_helpers, env = env, stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning, load_package = load_package, parallel = parallel)
30: test_dir("testthat", package = package, reporter = reporter, ..., load_package = "installed")
31: test_check("RFpredInterval")
An irrecoverable exception occurred. R is aborting now ...
Segmentation fault
Flavor: r-devel-linux-x86_64-debian-clang
Version: 1.0.8
Check: tests
Result: ERROR
Running ‘testthat.R’ [9s/11s]
Running the tests in ‘tests/testthat.R’ failed.
Complete output:
> library(testthat)
> library(RFpredInterval)
RFpredInterval 1.0.8
>
> test_check("RFpredInterval")
*** caught segfault ***
address 0x1, cause 'memory not mapped'
Traceback:
1: doTryCatch(return(expr), name, parentenv, handler)
2: tryCatchOne(expr, names, parentenv, handlers[[1L]])
3: tryCatchList(expr, classes, parentenv, handlers)
4: tryCatch({ .Call("rfsrcGrow", as.integer(do.trace), as.integer(seed), as.integer(ensemble.bits + impute.only.bits + var.used.bits + split.depth.bits + importance.bits + bootstrap.bits + forest.bits + proximity.bits + perf.bits + rfq.bits + gk.quantile.bits + statistics.bits + empirical.risk.bits), as.integer(samptype.bits + forest.wt.bits + distance.bits + na.action.bits + split.cust.bits + membership.bits + terminal.qualts.bits + terminal.quants.bits + tdc.rule.bits + cse.bits + csv.bits), as.integer(splitinfo$index), as.integer(splitinfo$nsplit), as.integer(mtry), lot, base.learner, as.integer(vtry), as.integer(holdout.array), holdout.specs, as.integer(formulaDetail$ytry), as.integer(nodesize), as.integer(nodedepth), as.integer(length(cause.wt)), as.double(cause.wt), as.integer(ntree), as.integer(n), list(as.integer(length(yvar.types)), if (is.null(yvar.types)) NULL else as.character(yvar.types), if (is.null(yvar.types)) NULL else as.integer(yvar.nlevels), if (is.null(yvar.numeric.levels)) NULL else sapply(1:length(yvar.numeric.levels), function(nn) { as.integer(length(yvar.numeric.levels[[nn]])) }), if (is.null(subj)) NULL else as.integer(subj), if (is.null(event.info)) NULL else as.integer(length(event.info$event.type)), if (is.null(event.info)) NULL else as.integer(event.info$event.type), if (is.null(yvar)) NULL else as.double(as.vector(yvar))), if (is.null(yvar.numeric.levels)) { NULL } else { lapply(1:length(yvar.numeric.levels), function(nn) { as.integer(yvar.numeric.levels[[nn]]) }) }, list(as.integer(n.xvar), as.character(xvar.types), if (is.null(xvar.types)) NULL else as.integer(xvar.nlevels), if (is.null(xvar.numeric.levels)) NULL else sapply(1:length(xvar.numeric.levels), function(nn) { as.integer(length(xvar.numeric.levels[[nn]])) }), if (is.null(xvar.time)) NULL else as.integer(xvar.time), if (is.null(subj.time)) NULL else as.integer(subj.time), as.double(as.vector(xvar))), if (is.null(xvar.numeric.levels)) { NULL } else { lapply(1:length(xvar.numeric.levels), function(nn) { as.integer(xvar.numeric.levels[[nn]]) }) }, list(as.integer(length(case.wt)), if (is.null(case.wt)) NULL else as.double(case.wt), as.integer(sampsize), if (is.null(samp)) NULL else as.integer(samp)), as.double(split.wt), as.double(yvar.wt), as.double(xvar.wt), as.integer(length(event.info$time.interest)), as.double(event.info$time.interest), as.integer(nimpute), as.integer(block.size), as.integer(length(prob)), as.double(prob), as.double(prob.epsilon), as.integer(get.rf.cores()))}, error = function(e) { print(e) NULL})
5: (function (formula, data, ntree = 1000, mtry = NULL, ytry = NULL, nodesize = NULL, nodedepth = NULL, splitrule = NULL, nsplit = 10, importance = c(FALSE, TRUE, "none", "permute", "random", "anti"), block.size = if (any(is.element(as.character(importance), c("none", "FALSE")))) NULL else 10, ensemble = c("all", "oob", "inbag"), bootstrap = c("by.root", "none", "by.user"), samptype = c("swor", "swr"), samp = NULL, membership = FALSE, sampsize = if (samptype == "swor") function(x) { x * 0.632 } else function(x) { x }, na.action = c("na.omit", "na.impute"), nimpute = 1, ntime, cause, proximity = FALSE, distance = FALSE, forest.wt = FALSE, xvar.wt = NULL, yvar.wt = NULL, split.wt = NULL, case.wt = NULL, forest = TRUE, var.used = c(FALSE, "all.trees", "by.tree"), split.depth = c(FALSE, "all.trees", "by.tree"), seed = NULL, do.trace = FALSE, statistics = FALSE, ...) { univariate.nomenclature = TRUE user.option <- list(...) impute.only <- is.hidden.impute.only(user.option) terminal.qualts <- is.hidden.terminal.qualts(user.option) terminal.quants <- is.hidden.terminal.quants(user.option) cse <- is.hidden.cse(user.option) csv <- is.hidden.csv(user.option) perf.type <- is.hidden.perf.type(user.option) rfq <- is.hidden.rfq(user.option) gk.quantile <- is.hidden.gk.quantile(user.option) quantile.regr <- is.hidden.quantile.regr(user.option) prob <- is.hidden.prob(user.option) prob.epsilon <- is.hidden.prob.epsilon(user.option) lot <- is.hidden.lot(user.option) hdim <- lot$hdim base.learner <- is.hidden.base.learner(user.option) vtry <- is.hidden.vtry(user.option) holdout.array <- is.hidden.holdout.array(user.option) holdout.specs <- is.hidden.holdout.specs(user.option) empirical.risk <- is.hidden.empirical.risk(user.option) tdc.rule <- is.hidden.tdc.rule(user.option) ensemble <- match.arg(ensemble, c("all", "oob", "inbag")) bootstrap <- match.arg(bootstrap, c("by.root", "none", "by.user")) if (bootstrap == "none") { ensemble <- "inbag" } importance <- match.arg(as.character(importance), c(FALSE, TRUE, "none", "permute", "random", "anti")) na.action <- match.arg(na.action, c("na.omit", "na.impute")) proximity <- match.arg(as.character(proximity), c(FALSE, TRUE, "inbag", "oob", "all")) distance <- match.arg(as.character(distance), c(FALSE, TRUE, "inbag", "oob", "all")) var.used <- match.arg(as.character(var.used), c("FALSE", "all.trees", "by.tree")) split.depth <- match.arg(as.character(split.depth), c("FALSE", "all.trees", "by.tree")) if (var.used == "FALSE") var.used <- FALSE if (split.depth == "FALSE") split.depth <- FALSE if (missing(data)) stop("data is missing") if (any(is.infinite(unlist(data)))) stop("data contains Inf or -Inf values") if (missing(formula) | (!missing(formula) && is.null(formula))) { if (is.null(ytry)) { formula <- as.formula("Unsupervised() ~ .") } else { formula <- as.formula(paste("Unsupervised(", ytry, ")~.")) } } formulaPrelim <- parseFormula(formula, data, ytry) my.call <- match.call() my.call$formula <- eval(formula) if (any(is.na(data))) { data <- parseMissingData(formulaPrelim, data) miss.flag <- TRUE } else { miss.flag <- FALSE } formulaDetail <- finalizeFormula(formulaPrelim, data) ntree <- round(ntree) if (ntree < 1) stop("Invalid choice of 'ntree'. Cannot be less than 1.") if (!is.null(nodesize) && nodesize < 1) stop("Invalid choice of 'nodesize'. Cannot be less than 1.") if (!is.null(nodedepth)) nodedepth = round(nodedepth) else nodedepth = -1 nimpute <- round(nimpute) if (nimpute < 1) stop("Invalid choice of 'nimpute'. Cannot be less than 1.") seed <- get.seed(seed) family <- formulaDetail$family xvar.names <- formulaDetail$xvar.names yvar.names <- formulaDetail$yvar.names subj.names <- formulaDetail$subj.names if (length(xvar.names) == 0) { stop("something seems wrong: your formula did not define any x-variables") } if (family != "unsupv" && length(yvar.names) == 0) { stop("something seems wrong: your formula did not define any y-variables") } if (family == "class") { if (length(setdiff(levels(data[, yvar.names]), unique(data[, yvar.names]))) > 0) { warning("empty classes found when implementing classification\n") } } data <- rm.na.levels(data, xvar.names) data <- rm.na.levels(data, yvar.names) yfactor <- extract.factor(data, yvar.names) yfactor$types <- yvar.types <- get.yvar.type(family, yfactor$generic.types, yvar.names) yfactor$nlevels <- yvar.nlevels <- get.yvar.nlevels(family, yfactor$nlevels, yvar.names, data) xfactor <- extract.factor(data, xvar.names) xfactor$types <- xvar.types <- xfactor$generic.types xvar.nlevels <- xfactor$nlevels data <- finalizeData(c(subj.names, yvar.names, xvar.names), data, na.action, miss.flag) data.row.names <- rownames(data) xvar <- as.matrix(data[, xvar.names, drop = FALSE]) rownames(xvar) <- colnames(xvar) <- NULL xfactor$numeric.levels <- xvar.numeric.levels <- get.numeric.levels(family, xfactor$nlevels, xvar) n <- nrow(xvar) n.xvar <- length(xvar.names) mtry <- get.grow.mtry(mtry, n.xvar, family) samptype <- match.arg(samptype, c("swor", "swr")) subj.unique.count <- n subj <- NULL xvar.time <- NULL subj.time <- NULL if (bootstrap == "by.root") { if (!is.function(sampsize) && !is.numeric(sampsize)) { stop("sampsize must be a function or number specifying size of subsampled data") } if (is.function(sampsize)) { sampsize.function <- sampsize } else { sampsize.function <- make.samplesize.function(sampsize/subj.unique.count) } sampsize <- round(sampsize.function(subj.unique.count)) if (sampsize < 1) { stop("sampsize must be greater than zero") } if (samptype == "swor" && (sampsize > subj.unique.count)) { sampsize.function <- function(x) { x } sampsize <- subj.unique.count } samp <- NULL case.wt <- get.weight(case.wt, subj.unique.count) } else if (bootstrap == "by.user") { if (is.null(samp)) { stop("samp must not be NULL when bootstrapping by user") } ntree <- ncol(samp) sampsize <- colSums(samp) if (sum(sampsize == sampsize[1]) != ntree) { stop("sampsize must be identical for each tree") } sampsize <- sampsize[1] sampsize.function <- make.samplesize.function(sampsize[1]/subj.unique.count) case.wt <- get.weight(NULL, subj.unique.count) } else { sampsize <- subj.unique.count sampsize.function <- function(x) { x } case.wt <- get.weight(case.wt, sampsize) } split.wt <- get.weight(split.wt, n.xvar) forest.wt <- match.arg(as.character(forest.wt), c(FALSE, TRUE, "inbag", "oob", "all")) if (family == "unspv") { yvar.wt <- NULL } else { yvar.wt <- get.weight(yvar.wt, length(yvar.types)) } xvar.wt <- get.weight(xvar.wt, n.xvar) yvar <- as.matrix(data[, yvar.names, drop = FALSE]) if (dim(yvar)[2] == 0) { yvar <- yvar.nlevels <- yvar.numeric.levels <- yfactor <- NULL } else { yfactor$numeric.levels <- yvar.numeric.levels <- get.numeric.levels(family, yfactor$nlevels, yvar) } if (miss.flag) { n.miss <- get.nmiss(xvar, yvar) } else { n.miss <- 0 } if (impute.only && n.miss == 0) { return(data) } remove(data) big.data <- FALSE event.info <- get.grow.event.info(yvar, family, ntime = ntime) splitinfo <- get.grow.splitinfo(formulaDetail, splitrule, hdim, nsplit, event.info) if (family == "surv" || family == "surv-CR") { if (length(event.info$event.type) > 1) { if (missing(cause) || is.null(cause)) { cause <- NULL cause.wt <- rep(1, length(event.info$event.type)) } else { if (length(cause) == 1) { if (cause >= 1 && cause <= length(event.info$event.type)) { cause.wt <- rep(0, length(event.info$event.type)) cause.wt[cause] <- 1 } else { cause.wt <- rep(1, length(event.info$event.type)) } } else { if (length(cause) == length(event.info$event.type) && all(cause >= 0) && !all(cause == 0)) { cause.wt <- cause/sum(cause) } else { cause.wt <- rep(1, length(event.info$event.type)) } } } } else { cause <- NULL cause.wt = 1 } family <- get.coerced.survival.fmly(family, subj, event.info$event.type, splitinfo$name) } else { cause <- cause.wt <- NULL } nodesize <- get.grow.nodesize(family, nodesize) if ((bootstrap != "by.root") && (bootstrap != "by.user")) { importance <- "none" perf.type <- "none" } if (family == "unsupv") { importance <- "none" perf.type <- "none" } if (impute.only) { forest <- FALSE proximity <- FALSE distance <- FALSE var.used <- FALSE split.depth <- FALSE membership <- FALSE perf.type <- "none" importance <- "none" terminal.qualts <- FALSE terminal.quants <- FALSE cse <- FALSE csv <- FALSE } if (!is.null(holdout.array)) { if (nrow(holdout.array) != n.xvar | ncol(holdout.array) != ntree) { stop("dimension of holdout.array does not conform to p x ntree") } vtry <- 1 } gk.quantile <- get.gk.quantile(gk.quantile) prob.assign <- global.prob.assign(prob, prob.epsilon, gk.quantile, quantile.regr, splitinfo$name, n) prob <- prob.assign$prob prob.epsilon <- prob.assign$prob.epsilon if (terminal.qualts | terminal.quants) { forest <- TRUE } ensemble.bits <- get.ensemble(ensemble) impute.only.bits <- get.impute.only(impute.only, n.miss) var.used.bits <- get.var.used(var.used) split.depth.bits <- get.split.depth(split.depth) importance.bits <- get.importance(importance) bootstrap.bits <- get.bootstrap(bootstrap) forest.bits <- get.forest(forest) proximity.bits <- get.proximity(TRUE, proximity) distance.bits <- get.distance(TRUE, distance) membership.bits <- get.membership(membership) statistics.bits <- get.statistics(statistics) split.cust.bits <- get.split.cust(splitinfo$cust) perf.type <- get.perf(perf.type, impute.only, family) perf.bits <- get.perf.bits(perf.type) rfq <- get.rfq(rfq) rfq.bits <- get.rfq.bits(rfq, family) gk.quantile.bits <- get.gk.quantile.bits(gk.quantile) empirical.risk.bits <- get.empirical.risk.bits(empirical.risk) tdc.rule.bits <- get.tdc.rule.bits(tdc.rule) samptype.bits <- get.samptype(samptype) forest.wt.bits <- get.forest.wt(TRUE, bootstrap, forest.wt) na.action.bits <- get.na.action(na.action) block.size <- get.block.size(block.size, ntree) terminal.qualts.bits <- get.terminal.qualts(terminal.qualts, FALSE) terminal.quants.bits <- get.terminal.quants(terminal.quants, FALSE) cse.bits = get.cse(cse) csv.bits = get.csv(csv) do.trace <- get.trace(do.trace) nativeOutput <- tryCatch({ .Call("rfsrcGrow", as.integer(do.trace), as.integer(seed), as.integer(ensemble.bits + impute.only.bits + var.used.bits + split.depth.bits + importance.bits + bootstrap.bits + forest.bits + proximity.bits + perf.bits + rfq.bits + gk.quantile.bits + statistics.bits + empirical.risk.bits), as.integer(samptype.bits + forest.wt.bits + distance.bits + na.action.bits + split.cust.bits + membership.bits + terminal.qualts.bits + terminal.quants.bits + tdc.rule.bits + cse.bits + csv.bits), as.integer(splitinfo$index), as.integer(splitinfo$nsplit), as.integer(mtry), lot, base.learner, as.integer(vtry), as.integer(holdout.array), holdout.specs, as.integer(formulaDetail$ytry), as.integer(nodesize), as.integer(nodedepth), as.integer(length(cause.wt)), as.double(cause.wt), as.integer(ntree), as.integer(n), list(as.integer(length(yvar.types)), if (is.null(yvar.types)) NULL else as.character(yvar.types), if (is.null(yvar.types)) NULL else as.integer(yvar.nlevels), if (is.null(yvar.numeric.levels)) NULL else sapply(1:length(yvar.numeric.levels), function(nn) { as.integer(length(yvar.numeric.levels[[nn]])) }), if (is.null(subj)) NULL else as.integer(subj), if (is.null(event.info)) NULL else as.integer(length(event.info$event.type)), if (is.null(event.info)) NULL else as.integer(event.info$event.type), if (is.null(yvar)) NULL else as.double(as.vector(yvar))), if (is.null(yvar.numeric.levels)) { NULL } else { lapply(1:length(yvar.numeric.levels), function(nn) { as.integer(yvar.numeric.levels[[nn]]) }) }, list(as.integer(n.xvar), as.character(xvar.types), if (is.null(xvar.types)) NULL else as.integer(xvar.nlevels), if (is.null(xvar.numeric.levels)) NULL else sapply(1:length(xvar.numeric.levels), function(nn) { as.integer(length(xvar.numeric.levels[[nn]])) }), if (is.null(xvar.time)) NULL else as.integer(xvar.time), if (is.null(subj.time)) NULL else as.integer(subj.time), as.double(as.vector(xvar))), if (is.null(xvar.numeric.levels)) { NULL } else { lapply(1:length(xvar.numeric.levels), function(nn) { as.integer(xvar.numeric.levels[[nn]]) }) }, list(as.integer(length(case.wt)), if (is.null(case.wt)) NULL else as.double(case.wt), as.integer(sampsize), if (is.null(samp)) NULL else as.integer(samp)), as.double(split.wt), as.double(yvar.wt), as.double(xvar.wt), as.integer(length(event.info$time.interest)), as.double(event.info$time.interest), as.integer(nimpute), as.integer(block.size), as.integer(length(prob)), as.double(prob), as.double(prob.epsilon), as.integer(get.rf.cores())) }, error = function(e) { print(e) NULL }) if (is.null(nativeOutput)) { if (impute.only) { return(NULL) } else { stop("An error has occurred in the grow algorithm. Please turn trace on for further analysis.") } } if (n.miss > 0) { imputed.data <- matrix(nativeOutput$imputation, nrow = n.miss, byrow = FALSE) imputed.indv <- imputed.data[, 1] imputed.data <- as.matrix(imputed.data[, -1, drop = FALSE]) nativeOutput$imputation <- NULL if (nimpute > 1) { if (grepl("surv", family)) { yvar[imputed.indv, 1] <- imputed.data[, 1] yvar[imputed.indv, 2] <- imputed.data[, 2] xvar[imputed.indv, ] <- imputed.data[, -c(1:2), drop = FALSE] } else { if (!is.null(yvar.types)) { yvar[imputed.indv, ] <- imputed.data[, 1:length(yvar.types), drop = FALSE] xvar[imputed.indv, ] <- imputed.data[, -c(1:length(yvar.types)), drop = FALSE] } else { xvar[imputed.indv, ] <- imputed.data } } imputed.indv <- NULL imputed.data <- NULL imputedOOBData <- NULL na.action = "na.omit" } else { colnames(imputed.data) <- c(yvar.names, xvar.names) imputed.data <- as.data.frame(imputed.data) } } xvar <- as.data.frame(xvar) rownames(xvar) <- data.row.names colnames(xvar) <- xvar.names xvar <- map.factor(xvar, xfactor) if (family != "unsupv") { yvar <- as.data.frame(yvar) colnames(yvar) <- yvar.names } else { yvar <- NULL } if (family != "unsupv") { if (family == "regr+" | family == "class+" | family == "mix+") { yvar <- map.factor(yvar, yfactor) } else { yvar <- amatrix.remove.names(map.factor(yvar, yfactor)) } } pi.hat <- NULL if (family == "class" && rfq) { pi.hat <- table(yvar)/length(yvar) } if ((n.miss > 0) & (nimpute < 2)) { imputed.data <- map.factor(imputed.data, xfactor) if (family != "unsupv") { imputed.data <- map.factor(imputed.data, yfactor) } } if (forest) { nativeArraySize = 0 if (hdim == 0) { mwcpCountSummary <- rep(0, 1) nativeFactorArray <- vector("list", 1) } else { mwcpCountSummary = rep(0, hdim) nativeFactorArray <- vector("list", hdim) } pivot <- which(names(nativeOutput) == "treeID") if (hdim == 0) { offset = 0 } else { offset = 7 if (!is.null(base.learner)) { if (base.learner$interact.depth > 1) { offset = offset + 3 } } if (!is.null(base.learner)) { if (base.learner$synthetic.depth > 1) { offset = offset + 2 } } } if (!is.null(base.learner)) { if (base.learner$synthetic.depth > 1) { mwcpCountSummarySyth <- rep(0, 1) nullO <- lapply(1:ntree, function(b) { mwcpCountSummarySyth[1] <<- mwcpCountSummarySyth[1] + nativeOutput$mwcpCTsyth[b] NULL }) } } nullO <- lapply(1:ntree, function(b) { if (nativeOutput$leafCount[b] > 0) { nativeArraySize <<- nativeArraySize + (2 * nativeOutput$leafCount[b]) - 1 mwcpCountSummary[1] <<- mwcpCountSummary[1] + nativeOutput$mwcpCT[b] if (hdim > 1) { for (i in 2:hdim) { mwcpCountSummary[i] <<- mwcpCountSummary[i] + nativeOutput[[pivot + (offset + 2) + (5 * (hdim - 1)) + (i - 2)]][b] } } } else { nativeArraySize <<- nativeArraySize + 1 } NULL }) rm(nullO) nativeArray <- as.data.frame(cbind(nativeOutput$treeID[1:nativeArraySize], nativeOutput$nodeID[1:nativeArraySize])) nativeArrayHeader <- c("treeID", "nodeID") nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput$parmID[1:nativeArraySize], nativeOutput$contPT[1:nativeArraySize], nativeOutput$mwcpSZ[1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, "parmID", "contPT", "mwcpSZ") if (mwcpCountSummary[1] > 0) { nativeFactorArray[[1]] <- nativeOutput$mwcpPT[1:mwcpCountSummary[1]] } nativeFactorArrayHeader <- "mwcpPT" if (hdim > 0) { if (!is.null(base.learner)) { if (base.learner$interact.depth > 1) { nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput$pairCT[1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, "pairCT") } if (base.learner$synthetic.depth > 1) { nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput$sythSZ[1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, "sythSZ") } if (base.learner$interact.depth > 1) { nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput$augmXone[1:nativeArraySize], nativeOutput$augmXtwo[1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, "augmXone", "augmXtwo") } if (base.learner$synthetic.depth > 1) { nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput$augmXS[1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, "augmXS") } } nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, "hcDim") nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset + 1]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, "contPTR") offset = offset + 2 } if (hdim > 1) { for (i in 2:hdim) { nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset + (0 * (hdim - 1)) + i - 2]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, paste("parmID", i, sep = "")) nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset + (1 * (hdim - 1)) + i - 2]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, paste("contPT", i, sep = "")) nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset + (2 * (hdim - 1)) + i - 2]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, paste("contPTR", i, sep = "")) nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset + (3 * (hdim - 1)) + i - 2]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, paste("mwcpSZ", i, sep = "")) if (mwcpCountSummary[i] > 0) { nativeFactorArray[[i]] <- nativeOutput[[pivot + offset + (4 * (hdim - 1)) + i - 2]][1:mwcpCountSummary[i]] } nativeFactorArrayHeader <- c(nativeFactorArrayHeader, paste("mwcpPT", i, sep = "")) if (!is.null(base.learner)) { hdim.multiplier <- 6 if (base.learner$interact.depth > 1) { nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset + (hdim.multiplier * (hdim - 1)) + i - 2]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, paste("augmXone", i, sep = "")) hdim.multiplier <- hdim.multiplier + 1 nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset + (hdim.multiplier * (hdim - 1)) + i - 2]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, paste("augmXtwo", i, sep = "")) hdim.multiplier <- hdim.multiplier + 1 } if (base.learner$synthetic.depth > 1) { nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset + (hdim.multiplier * (hdim - 1)) + i - 2]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, paste("augmXS", i, sep = "")) } } } } nativeArraySyth <- nativeFactorArraySyth <- NULL nodeCountSyth <- NULL totalNodeCountSyth = 0 if (!is.null(base.learner)) { if (base.learner$synthetic.depth > 1) { if (!is.null(nativeOutput$treeIDsyth)) { nativeArraySyth <- as.data.frame(cbind(nativeOutput$treeIDsyth, nativeOutput$nodeIDsyth, nativeOutput$hcDimsyth, nativeOutput$parmIDsyth, nativeOutput$contPTsyth, nativeOutput$contPTRsyth, nativeOutput$mwcpSZsyth)) nativeArrayHeaderSyth <- c("treeID", "nodeID", "hcDim", "parmID", "contPT", "contPTR", "mwcpSZ") names(nativeArraySyth) = nativeArrayHeaderSyth totalNodeCountSyth <- length(nativeOutput$treeIDsyth) nodeCountSyth <- nativeOutput$nodeCountSyth if (mwcpCountSummarySyth[1] > 0) { nativeFactorArraySyth <- nativeOutput$mwcpPTsyth[1:mwcpCountSummarySyth[1]] nativeFactorArrayHeaderSyth <- "mwcpPT" names(nativeFactorArraySyth) = nativeFactorArrayHeaderSyth } } } } names(nativeArray) <- nativeArrayHeader names(nativeFactorArray) <- nativeFactorArrayHeader if (terminal.qualts | terminal.quants) { totalLeafCount <- sum(nativeOutput$leafCount) valid.mcnt.indices <- 1:totalLeafCount if (terminal.quants) { if (grepl("surv", family)) { valid.2D.surv.indices <- 1:(totalLeafCount * length(event.info$event.type) * length(event.info$time.interest)) valid.1D.surv.indices <- 1:(totalLeafCount * length(event.info$time.interest)) valid.mort.indices <- 1:(totalLeafCount * length(event.info$event.type)) } else { class.index <- which(yvar.types != "R") class.count <- length(class.index) regr.index <- which(yvar.types == "R") regr.count <- length(regr.index) if (class.count > 0) { levels.count <- array(0, class.count) counter <- 0 for (i in class.index) { counter <- counter + 1 levels.count[counter] <- yvar.nlevels[i] } valid.clas.indices <- 1:(totalLeafCount * sum(levels.count)) } if (regr.count > 0) { valid.regr.indices <- 1:(totalLeafCount * regr.count) } } } nativeArrayTNDS <- list(if (!is.null(nativeOutput$tnSURV)) nativeOutput$tnSURV[valid.1D.surv.indices] else NULL, if (!is.null(nativeOutput$tnMORT)) nativeOutput$tnMORT[valid.mort.indices] else NULL, if (!is.null(nativeOutput$tnNLSN)) nativeOutput$tnNLSN[valid.1D.surv.indices] else NULL, if (!is.null(nativeOutput$tnCSHZ)) nativeOutput$tnCSHZ[valid.2D.surv.indices] else NULL, if (!is.null(nativeOutput$tnCIFN)) nativeOutput$tnCIFN[valid.2D.surv.indices] else NULL, if (!is.null(nativeOutput$tnREGR)) nativeOutput$tnREGR[valid.regr.indices] else NULL, if (!is.null(nativeOutput$tnCLAS)) nativeOutput$tnCLAS[valid.clas.indices] else NULL, nativeOutput$rmbrMembership, nativeOutput$ambrMembership, nativeOutput$tnRCNT[valid.mcnt.indices], nativeOutput$tnACNT[valid.mcnt.indices]) names(nativeArrayTNDS) <- c("tnSURV", "tnMORT", "tnNLSN", "tnCSHZ", "tnCIFN", "tnREGR", "tnCLAS", "tnRMBR", "tnAMBR", "tnRCNT", "tnACNT") } else { nativeArrayTNDS <- NULL } if (statistics) { node.stats <- as.data.frame(cbind(nativeOutput$spltST[1:nativeArraySize], nativeOutput$dpthST[1:nativeArraySize])) names(node.stats) <- c("spltST", "dpthST") } else { node.stats <- NULL } forest.out <- list(forest = TRUE, hdim = hdim, base.learner = base.learner, nativeArray = nativeArray, nativeFactorArray = nativeFactorArray, totalNodeCount = dim(nativeArray)[1], nativeArraySyth = nativeArraySyth, nativeFactorArraySyth = nativeFactorArraySyth, nodeCountSyth = nodeCountSyth, nodesize = nodesize, nodedepth = nodedepth, ntree = ntree, family = family, n = n, splitrule = splitinfo$name, yvar = yvar, yvar.names = yvar.names, yvar.factor = yfactor, xvar = xvar, xvar.names = xvar.names, xvar.factor = xfactor, event.info = event.info, subj = subj, subj.names = subj.names, seed = nativeOutput$seed, bootstrap = bootstrap, sampsize = sampsize.function, samptype = samptype, samp = samp, case.wt = case.wt, terminal.qualts = terminal.qualts, terminal.quants = terminal.quants, nativeArrayTNDS = nativeArrayTNDS, version = "2.11.0", na.action = na.action, perf.type = perf.type, rfq = rfq, gk.quantile = gk.quantile, quantile.regr = quantile.regr, prob = prob, prob.epsilon = prob.epsilon, block.size = block.size) if (grepl("surv", family)) { forest.out$time.interest <- event.info$time.interest } class(forest.out) <- c("rfsrc", "forest", family) if (big.data) { class(forest.out) <- c(class(forest.out), "bigdata") } } else { node.stats <- NULL forest.out <- list(forest = FALSE, hdim = hdim, base.learner = base.learner, nodesize = nodesize, nodedepth = nodedepth, ntree = ntree, family = family, n = n, splitrule = splitinfo$name, yvar = yvar, yvar.names = yvar.names, xvar = xvar, xvar.names = xvar.names, subj = subj, subj.names = subj.names, seed = nativeOutput$seed, bootstrap = bootstrap, sampsize = sampsize.function, samptype = samptype, samp = samp, case.wt = case.wt, version = "2.11.0", na.action = na.action, perf.type = perf.type, rfq = rfq, gk.quantile = gk.quantile, quantile.regr = quantile.regr, prob = prob, prob.epsilon = prob.epsilon, block.size = block.size) } if (proximity != FALSE) { proximity.out <- matrix(0, n, n) count <- 0 for (k in 1:n) { proximity.out[k, 1:k] <- nativeOutput$proximity[(count + 1):(count + k)] proximity.out[1:k, k] <- proximity.out[k, 1:k] count <- count + k } nativeOutput$proximity <- NULL } else { proximity.out <- NULL } if (distance != FALSE) { distance.out <- matrix(0, n, n) count <- 0 for (k in 1:n) { distance.out[k, 1:k] <- nativeOutput$distance[(count + 1):(count + k)] distance.out[1:k, k] <- distance.out[k, 1:k] count <- count + k } nativeOutput$distance <- NULL } else { distance.out <- NULL } if (forest.wt != FALSE) { forest.wt.out <- matrix(nativeOutput$weight, c(n, n), byrow = TRUE) nativeOutput$weight <- NULL } else { forest.wt.out <- NULL } if (membership) { membership.out <- matrix(nativeOutput$nodeMembership, c(n, ntree)) inbag.out <- matrix(nativeOutput$bootMembership, c(n, ntree)) nativeOutput$nodeMembership <- NULL nativeOutput$bootMembership <- NULL if (!is.null(subj)) { tdc.membership.cnt <- matrix(nativeOutput$nodeMembershipTDC[[1]], c(n, ntree)) tdc.membership.out <- vector("list", ntree) begin.indx <- 0 end.indx <- 0 for (i in 1:ntree) { temp <- vector("list", n) for (j in 1:n) { begin.indx <- end.indx + 1 end.indx <- end.indx + tdc.membership.cnt[j, i] temp[[j]] <- nativeOutput$nodeMembershipTDC[[2]][begin.indx:end.indx] } tdc.membership.out[[i]] <- temp } } else { tdc.membership.out <- NULL } } else { membership.out <- NULL inbag.out <- NULL tdc.membership.out <- NULL } if (var.used != FALSE) { if (var.used == "all.trees") { var.used.out <- nativeOutput$varUsed names(var.used.out) <- xvar.names } else { var.used.out <- matrix(nativeOutput$varUsed, nrow = ntree, byrow = TRUE) colnames(var.used.out) <- xvar.names } nativeOutput$varUsed <- NULL } else { var.used.out <- NULL } if (split.depth != FALSE) { if (split.depth == "all.trees") { split.depth.out <- array(nativeOutput$splitDepth, c(n, n.xvar)) } else { split.depth.out <- array(nativeOutput$splitDepth, c(n, n.xvar, ntree)) } nativeOutput$splitDepth <- NULL } else { split.depth.out <- NULL } empr.risk <- NULL oob.empr.risk <- NULL if (empirical.risk) { if (!is.null(nativeOutput$emprRisk)) { empr.risk <- array(nativeOutput$emprRisk, c(lot$treesize, ntree)) nativeOutput$emprRisk <- NULL } if (!is.null(nativeOutput$oobEmprRisk)) { oob.empr.risk <- array(nativeOutput$oobEmprRisk, c(lot$treesize, ntree)) nativeOutput$oobEmprRisk <- NULL } } if (!is.null(holdout.specs)) { holdout.blk <- nativeOutput$holdoutBlk nativeOutput$holdoutBlk <- NULL } else { holdout.blk = NULL } rfsrcOutput <- list(call = my.call, family = family, n = n, ntree = ntree, nimpute = nimpute, mtry = mtry, nodesize = nodesize, nodedepth = nodedepth, nsplit = splitinfo$nsplit, yvar = yvar, yvar.names = yvar.names, xvar = xvar, xvar.names = xvar.names, event.info = event.info, subj = subj, subj.names = subj.names, xvar.wt = xvar.wt, split.wt = split.wt, cause.wt = cause.wt, leaf.count = nativeOutput$leafCount, proximity = proximity.out, forest = forest.out, forest.wt = forest.wt.out, distance = distance.out, membership = membership.out, tdc.membership = tdc.membership.out, splitrule = splitinfo$name, inbag = inbag.out, var.used = var.used.out, imputed.indv = (if (n.miss > 0) imputed.indv else NULL), imputed.data = (if (n.miss > 0) imputed.data else NULL), split.depth = split.depth.out, node.stats = node.stats, ensemble = ensemble, holdout.array = holdout.array, block.size = block.size, holdout.blk = holdout.blk, empr.risk = empr.risk, oob.empr.risk = oob.empr.risk) remove(yvar) remove(xvar) nativeOutput$leafCount <- NULL remove(proximity.out) remove(forest.out) remove(forest.wt.out) remove(distance.out) remove(membership.out) remove(inbag.out) remove(var.used.out) if (n.miss > 0) remove(imputed.indv) if (n.miss > 0) remove(imputed.data) remove(split.depth.out) remove(holdout.array) remove(empr.risk) remove(oob.empr.risk) survOutput <- NULL classOutput <- NULL regrOutput <- NULL if (!impute.only) { if (grepl("surv", family)) { if ((length(event.info$event.type) > 1) && (splitinfo$name != "l2.impute") && (splitinfo$name != "logrankscore")) { coerced.event.count <- length(event.info$event.type) } else { coerced.event.count <- 1 } if (family == "surv") { ens.names <- list(NULL, NULL) mortality.names <- list(NULL, NULL) err.names <- list(NULL, NULL) vimp.names <- list(NULL, xvar.names) } else if (family == "surv-CR") { ens.names <- list(NULL, NULL, c(paste("condCHF.", 1:length(event.info$event.type), sep = ""))) mortality.names <- list(NULL, paste("event.", 1:length(event.info$event.type), sep = "")) cif.names <- list(NULL, NULL, c(paste("CIF.", 1:length(event.info$event.type), sep = ""))) err.names <- list(c(paste("event.", 1:length(event.info$event.type), sep = "")), NULL) vimp.names <- list(paste("event.", 1:length(event.info$event.type), sep = ""), xvar.names) } else { ens.names <- list(NULL, NULL) } chf <- (if (!is.null(nativeOutput$allEnsbCHF)) adrop3d.last(array(nativeOutput$allEnsbCHF, c(n, length(event.info$time.interest), length(event.info$event.type)), dimnames = ens.names), coerced.event.count) else NULL) nativeOutput$allEnsbCHF <- NULL survOutput <- list(chf = chf) remove(chf) chf.oob <- (if (!is.null(nativeOutput$oobEnsbCHF)) adrop3d.last(array(nativeOutput$oobEnsbCHF, c(n, length(event.info$time.interest), length(event.info$event.type)), dimnames = ens.names), coerced.event.count) else NULL) nativeOutput$oobEnsbCHF <- NULL survOutput = c(survOutput, chf.oob = list(chf.oob)) remove(chf.oob) predicted <- (if (!is.null(nativeOutput$allEnsbMRT)) adrop2d.last(array(nativeOutput$allEnsbMRT, c(n, length(event.info$event.type)), dimnames = mortality.names), coerced.event.count) else NULL) nativeOutput$allEnsbMRT <- NULL survOutput = c(survOutput, predicted = list(predicted)) remove(predicted) predicted.oob <- (if (!is.null(nativeOutput$oobEnsbMRT)) adrop2d.last(array(nativeOutput$oobEnsbMRT, c(n, length(event.info$event.type)), dimnames = mortality.names), coerced.event.count) else NULL) nativeOutput$oobEnsbMRT <- NULL survOutput <- c(survOutput, predicted.oob = list(predicted.oob)) remove(predicted.oob) hazard <- (if (!is.null(nativeOutput$allEnsbKHZ)) matrix(nativeOutput$allEnsbKHZ, c(subj.unique.count, length(event.info$time.interest))) else NULL) nativeOutput$allEnsbKHZ <- NULL survOutput <- c(survOutput, hazard = list(hazard)) remove(hazard) hazard.oob <- (if (!is.null(nativeOutput$oobEnsbKHZ)) matrix(nativeOutput$oobEnsbKHZ, c(subj.unique.count, length(event.info$time.interest))) else NULL) nativeOutput$oobEnsbKHZ <- NULL survOutput <- c(survOutput, hazard.oob = list(hazard.oob)) remove(hazard.oob) survival <- (if (!is.null(nativeOutput$allEnsbSRV)) matrix(nativeOutput$allEnsbSRV, c(n, length(event.info$time.interest))) else NULL) nativeOutput$allEnsbSRV <- NULL survOutput <- c(survOutput, survival = list(survival)) remove(survival) survival.oob <- (if (!is.null(nativeOutput$oobEnsbSRV)) matrix(nativeOutput$oobEnsbSRV, c(n, length(event.info$time.interest))) else NULL) nativeOutput$oobEnsbSRV <- NULL survOutput <- c(survOutput, survival.oob = list(survival.oob)) remove(survival.oob) cif <- (if (!is.null(nativeOutput$allEnsbCIF)) array(nativeOutput$allEnsbCIF, c(n, length(event.info$time.interest), length(event.info$event.type)), dimnames = cif.names) else NULL) nativeOutput$allEnsbCIF <- NULL survOutput <- c(survOutput, cif = list(cif)) remove(cif) cif.oob <- (if (!is.null(nativeOutput$oobEnsbCIF)) array(nativeOutput$oobEnsbCIF, c(n, length(event.info$time.interest), length(event.info$event.type)), dimnames = cif.names) else NULL) nativeOutput$oobEnsbCIF <- NULL survOutput = c(survOutput, cif.oob = list(cif.oob)) remove(cif.oob) if (!is.null(nativeOutput$perfSurv)) { err.rate <- adrop2d.first(array(nativeOutput$perfSurv, c(length(event.info$event.type), ntree), dimnames = err.names), coerced.event.count) nativeOutput$perfSurv <- NULL if (family == "surv-CR") { survOutput = c(survOutput, err.rate = list(t(err.rate))) } else { survOutput = c(survOutput, err.rate = list(err.rate)) } remove(err.rate) } if (!is.null(nativeOutput$blockSurv)) { err.block.rate <- adrop2d.first(array(nativeOutput$blockSurv, c(length(event.info$event.type), floor(ntree/block.size)), dimnames = err.names), coerced.event.count) nativeOutput$blockSurv <- NULL if (family == "surv-CR") { survOutput = c(survOutput, err.block.rate = list(t(err.block.rate))) } else { survOutput = c(survOutput, err.block.rate = list(err.block.rate)) } remove(err.block.rate) } if (!is.null(nativeOutput$vimpSurv)) { importance <- adrop2d.first(array(nativeOutput$vimpSurv, c(length(event.info$event.type), n.xvar), dimnames = vimp.names), coerced.event.count) nativeOutput$vimpSurv <- NULL if (family == "surv-CR") { survOutput = c(survOutput, importance = list(t(importance))) } else { survOutput = c(survOutput, importance = list(importance)) } remove(importance) } survOutput = c(survOutput, list(time.interest = event.info$time.interest, ndead = sum(na.omit(event.info$cens) != 0))) if (!is.null(nativeOutput$holdoutSurv)) { holdout.vimp <- vector("list", length(rfsrcOutput$holdout.blk)) names(holdout.vimp) <- xvar.names holdout.offset <- rfsrcOutput$holdout.blk * length(event.info$event.type) holdout.offset.sum <- c(0, cumsum(holdout.offset)) for (i in 1:length(holdout.vimp)) { if (rfsrcOutput$holdout.blk[i] > 0) { if (length(event.info$event.type) > 1) { holdout.vimp[[i]] <- array(nativeOutput$holdoutSurv[(holdout.offset.sum[i] + 1):holdout.offset.sum[i + 1]], c(length(event.info$event.type), rfsrcOutput$holdout.blk[i])) } else { holdout.vimp[[i]] <- nativeOutput$holdoutSurv[(holdout.offset.sum[i] + 1):holdout.offset.sum[i + 1]] } } else { holdout.vimp[[i]] = NA } } survOutput = c(survOutput, holdout.vimp = list(holdout.vimp)) remove(holdout.vimp) } if (univariate.nomenclature) { rfsrcOutput <- c(rfsrcOutput, survOutput) } else { rfsrcOutput <- c(rfsrcOutput, survOutput = list(survOutput)) } } else { class.index <- which(yvar.types != "R") resp.clas.count <- length(class.index) regr.index <- which(yvar.types == "R") resp.regr.count <- length(regr.index) if (resp.clas.count > 0) { classOutput <- vector("list", resp.clas.count) names(classOutput) <- yvar.names[class.index] levels.count <- array(0, resp.clas.count) levels.names <- vector("list", resp.clas.count) counter <- 0 for (i in class.index) { counter <- counter + 1 levels.count[counter] <- yvar.nlevels[i] if (yvar.types[i] == "C") { levels.names[[counter]] <- yfactor$levels[[which(yfactor$factor == yvar.names[i])]] } else { levels.names[[counter]] <- yfactor$order.levels[[which(yfactor$order == yvar.names[i])]] } } tree.offset <- array(1, ntree) if (ntree > 1) { tree.offset[2:ntree] <- sum(1 + levels.count) } tree.offset <- cumsum(tree.offset) block.offset <- array(1, floor(ntree/block.size)) if (floor(ntree/block.size) > 1) { block.offset[2:floor(ntree/block.size)] <- sum(1 + levels.count) } block.offset <- cumsum(block.offset) vimp.offset <- array(1, n.xvar) if (n.xvar > 1) { vimp.offset[2:n.xvar] <- sum(1 + levels.count) } vimp.offset <- cumsum(vimp.offset) iter.ensb.start <- 0 iter.ensb.end <- 0 if (!is.null(nativeOutput$holdoutClas)) { holdout.offset.x <- rfsrcOutput$holdout.blk * (sum(1 + levels.count)) holdout.offset.sum.x <- c(0, cumsum(holdout.offset.x)) holdout.offset.r <- 0 } for (i in 1:resp.clas.count) { iter.ensb.start <- iter.ensb.end iter.ensb.end <- iter.ensb.end + (levels.count[i] * n) ens.names <- list(NULL, levels.names[[i]]) err.names <- c("all", levels.names[[i]]) vimp.names <- list(c("all", levels.names[[i]]), xvar.names) predicted <- (if (!is.null(nativeOutput$allEnsbCLS)) array(nativeOutput$allEnsbCLS[(iter.ensb.start + 1):iter.ensb.end], c(n, levels.count[i]), dimnames = ens.names) else NULL) classOutput[[i]] <- list(predicted = predicted) response <- (if (!is.null(predicted)) get.bayes.rule(predicted, pi.hat) else NULL) classOutput[[i]] <- c(classOutput[[i]], class = list(response)) remove(predicted) remove(response) predicted.oob <- (if (!is.null(nativeOutput$oobEnsbCLS)) array(nativeOutput$oobEnsbCLS[(iter.ensb.start + 1):iter.ensb.end], c(n, levels.count[i]), dimnames = ens.names) else NULL) classOutput[[i]] <- c(classOutput[[i]], predicted.oob = list(predicted.oob)) response.oob <- (if (!is.null(predicted.oob)) get.bayes.rule(predicted.oob, pi.hat) else NULL) classOutput[[i]] <- c(classOutput[[i]], class.oob = list(response.oob)) remove(predicted.oob) remove(response.oob) cse.num <- (if (!is.null(nativeOutput$cseClas)) array(nativeOutput$cseClas[(iter.ensb.start + 1):iter.ensb.end], n) else NULL) classOutput[[i]] <- c(classOutput[[i]], cse.num = list(cse.num)) remove(cse.num) cse.den <- (if (!is.null(nativeOutput$cseDen)) array(nativeOutput$cseDen[1:n], n) else NULL) classOutput[[i]] <- c(classOutput[[i]], cse.den = list(cse.den)) if (!is.null(nativeOutput$perfClas)) { err.rate <- array(0, c(1 + levels.count[i], ntree)) for (j in 1:(1 + levels.count[i])) { err.rate[j, ] <- nativeOutput$perfClas[tree.offset] tree.offset <- tree.offset + 1 } row.names(err.rate) <- err.names classOutput[[i]] <- c(classOutput[[i]], err.rate = list(t(err.rate))) remove(err.rate) } if (!is.null(nativeOutput$blockClas)) { err.block.rate <- array(0, c(1 + levels.count[i], floor(ntree/block.size))) for (j in 1:(1 + levels.count[i])) { err.block.rate[j, ] <- nativeOutput$blockClas[block.offset] block.offset <- block.offset + 1 } row.names(err.block.rate) <- err.names classOutput[[i]] <- c(classOutput[[i]], err.block.rate = list(t(err.block.rate))) remove(err.block.rate) } csv.idx <- array(0, n * n.xvar) for (j in 1:n.xvar) { csv.idx[(((j - 1) * n) + 1):(((j - 1) * n) + n)] <- (((i - 1) * n) + ((j - 1) * n * resp.clas.count) + 1):(((i - 1) * n) + ((j - 1) * n * resp.clas.count) + n) } csv.num <- (if (!is.null(nativeOutput$csvClas)) array(nativeOutput$csvClas[csv.idx], c(n, n.xvar)) else NULL) classOutput[[i]] <- c(classOutput[[i]], csv.num = list(csv.num)) remove(csv.num) csv.den <- (if (!is.null(nativeOutput$csvDen)) array(nativeOutput$csvDen, c(n, n.xvar)) else NULL) classOutput[[i]] <- c(classOutput[[i]], csv.den = list(csv.den)) remove(csv.den) if (!is.null(nativeOutput$vimpClas)) { importance <- array(0, c(1 + levels.count[i], n.xvar), dimnames = vimp.names) for (j in 1:(1 + levels.count[i])) { importance[j, ] <- nativeOutput$vimpClas[vimp.offset] vimp.offset <- vimp.offset + 1 } classOutput[[i]] <- c(classOutput[[i]], importance = list(t(importance))) remove(importance) } if (!is.null(nativeOutput$holdoutClas)) { holdout.vimp <- vector("list", length(rfsrcOutput$holdout.blk)) names(holdout.vimp) <- xvar.names if (i > 1) { holdout.offset.r <- holdout.offset.r + (1 + levels.count[i - 1]) } for (k in 1:length(holdout.vimp)) { if (rfsrcOutput$holdout.blk[k] > 0) { offset.x <- holdout.offset.sum.x[k] offset.b <- 0 index.m <- NULL for (m in 1:rfsrcOutput$holdout.blk[k]) { if (m > 1) { offset.b <- offset.b + (sum(1 + levels.count)) } index.m <- c(index.m, seq(from = offset.x + offset.b + holdout.offset.r + 1, by = 1, length.out = levels.count[i] + 1)) } holdout.vimp[[k]] = array(nativeOutput$holdoutClas[index.m], c(levels.count[i] + 1, rfsrcOutput$holdout.blk[k])) } else { holdout.vimp[[k]] = NA } } classOutput[[i]] = c(classOutput[[i]], holdout.vimp = list(holdout.vimp)) remove(holdout.vimp) } } nativeOutput$allEnsbCLS <- NULL nativeOutput$oobEnsbCLS <- NULL nativeOutput$perfClas <- NULL nativeOutput$blockClas <- NULL nativeOutput$vimpClas <- NULL nativeOutput$holdoutClas <- NULL if (univariate.nomenclature) { if ((resp.clas.count == 1) & (resp.regr.count == 0)) { names(classOutput) <- NULL rfsrcOutput <- c(rfsrcOutput, unlist(classOutput, recursive = FALSE)) } else { rfsrcOutput <- c(rfsrcOutput, classOutput = list(classOutput)) } } else { rfsrcOutput <- c(rfsrcOutput, classOutput = list(classOutput)) } } if (resp.regr.count > 0) { regrOutput <- vector("list", resp.regr.count) names(regrOutput) <- yvar.names[regr.index] tree.offset <- array(1, ntree) if (ntree > 1) { tree.offset[2:ntree] <- length(regr.index) } tree.offset <- cumsum(tree.offset) block.offset <- array(1, floor(ntree/block.size)) if (floor(ntree/block.size) > 1) { block.offset[2:floor(ntree/block.size)] <- length(regr.index) } block.offset <- cumsum(block.offset) vimp.offset <- array(1, n.xvar) if (n.xvar > 1) { vimp.offset[2:n.xvar] <- length(regr.index) } vimp.offset <- cumsum(vimp.offset) iter.ensb.start <- 0 iter.ensb.end <- 0 iter.qntl.start <- 0 iter.qntl.end <- 0 if (!is.null(nativeOutput$holdoutRegr)) { holdout.offset.x <- rfsrcOutput$holdout.blk * resp.regr.count holdout.offset.sum.x <- c(0, cumsum(holdout.offset.x)) holdout.offset.r <- 0 } for (i in 1:resp.regr.count) { iter.ensb.start <- iter.ensb.end iter.ensb.end <- iter.ensb.end + n iter.qntl.start <- iter.qntl.end iter.qntl.end <- iter.qntl.end + (length(prob) * n) vimp.names <- xvar.names predicted <- (if (!is.null(nativeOutput$allEnsbRGR)) array(nativeOutput$allEnsbRGR[(iter.ensb.start + 1):iter.ensb.end], n) else NULL) regrOutput[[i]] <- list(predicted = predicted) remove(predicted) predicted.oob <- (if (!is.null(nativeOutput$oobEnsbRGR)) array(nativeOutput$oobEnsbRGR[(iter.ensb.start + 1):iter.ensb.end], n) else NULL) regrOutput[[i]] <- c(regrOutput[[i]], predicted.oob = list(predicted.oob)) remove(predicted.oob) cse.num <- (if (!is.null(nativeOutput$cseRegr)) array(nativeOutput$cseRegr[(iter.ensb.start + 1):iter.ensb.end], n) else NULL) regrOutput[[i]] <- c(regrOutput[[i]], cse.num = list(cse.num)) remove(cse.num) cse.den <- (if (!is.null(nativeOutput$cseDen)) array(nativeOutput$cseDen[1:n], n) else NULL) regrOutput[[i]] <- c(regrOutput[[i]], cse.den = list(cse.den)) quantile <- (if (!is.null(nativeOutput$allEnsbQNT)) array(nativeOutput$allEnsbQNT[(iter.qntl.start + 1):iter.qntl.end], c(n, length(prob))) else NULL) regrOutput[[i]] <- c(regrOutput[[i]], quantile = list(quantile)) remove(quantile) quantile.oob <- (if (!is.null(nativeOutput$oobEnsbQNT)) array(nativeOutput$oobEnsbQNT[(iter.qntl.start + 1):iter.qntl.end], c(n, length(prob))) else NULL) regrOutput[[i]] <- c(regrOutput[[i]], quantile.oob = list(quantile.oob)) remove(quantile.oob) if (!is.null(nativeOutput$perfRegr)) { err.rate <- nativeOutput$perfRegr[tree.offset] tree.offset <- tree.offset + 1 regrOutput[[i]] <- c(regrOutput[[i]], err.rate = list(err.rate)) remove(err.rate) } if (!is.null(nativeOutput$blockRegr)) { err.block.rate <- nativeOutput$blockRegr[block.offset] block.offset <- block.offset + 1 regrOutput[[i]] <- c(regrOutput[[i]], err.block.rate = list(err.block.rate)) remove(err.block.rate) } if (!is.null(nativeOutput$vimpRegr)) { importance <- nativeOutput$vimpRegr[vimp.offset] names(importance) <- xvar.names vimp.offset <- vimp.offset + 1 regrOutput[[i]] <- c(regrOutput[[i]], importance = list(importance)) remove(importance) } csv.idx <- array(0, n * n.xvar) for (j in 1:n.xvar) { csv.idx[(((j - 1) * n) + 1):(((j - 1) * n) + n)] <- (((i - 1) * n) + ((j - 1) * n * resp.regr.count) + 1):(((i - 1) * n) + ((j - 1) * n * resp.regr.count) + n) } csv.num <- (if (!is.null(nativeOutput$csvRegr)) array(nativeOutput$csvRegr[csv.idx], c(n, n.xvar)) else NULL) regrOutput[[i]] <- c(regrOutput[[i]], csv.num = list(csv.num)) remove(csv.num) csv.den <- (if (!is.null(nativeOutput$csvDen)) array(nativeOutput$csvDen, c(n, n.xvar)) else NULL) regrOutput[[i]] <- c(regrOutput[[i]], csv.den = list(csv.den)) remove(csv.den) if (!is.null(nativeOutput$holdoutRegr)) { holdout.vimp <- vector("list", length(rfsrcOutput$holdout.blk)) names(holdout.vimp) <- xvar.names if (i > 1) { holdout.offset.r <- holdout.offset.r + 1 } for (k in 1:length(holdout.vimp)) { if (rfsrcOutput$holdout.blk[k] > 0) { offset.x <- holdout.offset.sum.x[k] offset.b <- 0 index.m <- NULL for (m in 1:rfsrcOutput$holdout.blk[k]) { if (m > 1) { offset.b <- offset.b + resp.regr.count } index.m <- c(index.m, offset.x + offset.b + holdout.offset.r + 1) } holdout.vimp[[k]] <- nativeOutput$holdoutRegr[index.m] } else { holdout.vimp[[k]] <- NA } } regrOutput[[i]] <- c(regrOutput[[i]], holdout.vimp = list(holdout.vimp)) } } nativeOutput$allEnsbRGR <- NULL nativeOutput$oobEnsbRGR <- NULL nativeOutput$allEnsbQNT <- NULL nativeOutput$oobEnsbQNT <- NULL nativeOutput$perfRegr <- NULL nativeOutput$blockRegr <- NULL nativeOutput$vimpRegr <- NULL nativeOutput$holdoutRegr <- NULL if (univariate.nomenclature) { if ((resp.clas.count == 0) & (resp.regr.count == 1)) { names(regrOutput) <- NULL rfsrcOutput <- c(rfsrcOutput, unlist(regrOutput, recursive = FALSE)) } else { rfsrcOutput <- c(rfsrcOutput, regrOutput = list(regrOutput)) } } else { rfsrcOutput <- c(rfsrcOutput, regrOutput = list(regrOutput)) } } } } class(rfsrcOutput) <- c("rfsrc", "grow", family) if (big.data) { class(rfsrcOutput) <- c(class(rfsrcOutput), "bigdata") } return(rfsrcOutput)})(ntree = 50, mtry = 5, nodesize = 5, samptype = "swr", formula = medv ~ ., data = list(crim = c(2.81838, 0.27957, 4.26131, 0.37578, 73.5341, 0.03961, 0.02009, 6.39312, 0.05789, 0.04379, 0.03445, 14.4208, 0.02187, 0.08187, 0.07978, 2.73397, 0.05479, 0.14103, 0.35809, 0.05735, 0.46296, 2.24236, 41.5292, 0.44178, 9.96654, 0.32264, 0.21124, 0.12269, 0.1146, 0.84054, 0.25356, 0.02729, 0.12204, 5.66637, 0.01538, 0.15936, 0.02055, 0.01501, 18.4982, 0.05023, 0.03584, 0.22188, 2.63548, 0.22489, 0.07886, 0.04684, 0.12083, 0.10084, 0.06417, 11.9511), zn = c(0, 0, 0, 0, 0, 0, 95, 0, 12.5, 80, 82.5, 0, 60, 0, 40, 0, 33, 0, 0, 0, 0, 0, 0, 0, 0, 0, 12.5, 0, 20, 0, 0, 0, 0, 0, 90, 0, 85, 90, 0, 35, 80, 20, 0, 12.5, 80, 0, 0, 0, 0, 0), indus = c(18.1, 9.69, 18.1, 10.59, 18.1, 5.19, 2.68, 18.1, 6.07, 3.37, 2.03, 18.1, 2.93, 2.89, 6.41, 19.58, 2.18, 13.92, 6.2, 4.49, 6.2, 19.58, 18.1, 6.2, 18.1, 21.89, 7.87, 6.91, 6.96, 8.14, 9.9, 7.07, 2.89, 18.1, 3.75, 6.91, 0.74, 1.21, 18.1, 6.06, 3.37, 6.96, 9.9, 7.87, 4.95, 3.41, 2.89, 10.01, 5.96, 18.1), chas = c(1L, 1L, 1L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 1L, 1L, 1L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L), nox = c(0.532, 0.585, 0.77, 0.489, 0.679, 0.515, 0.4161, 0.584, 0.409, 0.398, 0.415, 0.74, 0.401, 0.445, 0.447, 0.871, 0.472, 0.437, 0.507, 0.449, 0.504, 0.605, 0.693, 0.504, 0.74, 0.624, 0.524, 0.448, 0.464, 0.538, 0.544, 0.469, 0.445, 0.74, 0.394, 0.448, 0.41, 0.401, 0.668, 0.4379, 0.398, 0.464, 0.544, 0.524, 0.411, 0.489, 0.445, 0.547, 0.499, 0.659), rm = c(5.762, 5.926, 6.112, 5.404, 5.957, 6.037, 8.034, 6.162, 5.878, 5.787, 6.162, 6.461, 6.8, 7.82, 6.482, 5.597, 6.616, 5.79, 6.951, 6.63, 7.412, 5.854, 5.531, 6.552, 6.485, 5.942, 5.631, 6.069, 6.538, 5.599, 5.705, 7.185, 6.625, 6.219, 7.454, 6.211, 6.383, 7.923, 4.138, 5.706, 6.29, 7.691, 4.973, 6.377, 7.148, 6.417, 8.069, 6.715, 5.933, 5.608), age = c(40.3, 42.6, 81.3, 88.6, 100, 34.5, 31.9, 97.4, 21.4, 31.1, 38.4, 93.3, 9.9, 36.9, 32.1, 94.9, 58.1, 58, 88.5, 56.1, 76.9, 91.8, 85.4, 21.4, 100, 93.5, 100, 40, 58.7, 85.7, 77.7, 61.1, 57.8, 100, 34.2, 6.5, 35.7, 24.8, 100, 28.4, 17.8, 51.8, 37.8, 94.3, 27.7, 66.1, 76, 81.6, 68.2, 100), dis = c(4.0983, 2.3817, 2.5091, 3.665, 1.8026, 5.9853, 5.118, 2.206, 6.498, 6.6115, 6.27, 2.0026, 6.2196, 3.4952, 4.1403, 1.5257, 3.37, 6.32, 2.8617, 4.4377, 3.6715, 2.422, 1.6074, 3.3751, 1.9784, 1.9669, 6.0821, 5.7209, 3.9175, 4.4546, 3.945, 4.9671, 3.4952, 2.0048, 6.3361, 5.7209, 9.1876, 5.885, 1.137, 6.6407, 6.6115, 4.3665, 2.5194, 6.3467, 5.1167, 3.0923, 3.4952, 2.6775, 3.3603, 1.2852), rad = c(24, 6, 24, 4, 24, 5, 4, 24, 4, 4, 2, 24, 1, 2, 4, 5, 7, 4, 8, 3, 8, 5, 24, 8, 24, 4, 5, 3, 3, 4, 4, 2, 2, 24, 3, 3, 2, 1, 24, 1, 4, 3, 4, 5, 4, 2, 2, 6, 5, 24), tax = c(666, 391, 666, 277, 666, 224, 224, 666, 345, 337, 348, 666, 265, 276, 254, 403, 222, 289, 307, 247, 307, 403, 666, 307, 666, 437, 311, 233, 223, 307, 304, 242, 276, 666, 244, 233, 313, 198, 666, 304, 337, 223, 304, 311, 245, 270, 276, 432, 279, 666), ptratio = c(20.2, 19.2, 20.2, 18.6, 20.2, 20.2, 14.7, 20.2, 18.9, 16.1, 14.7, 20.2, 15.6, 18, 17.6, 14.7, 18.4, 16, 17.4, 18.5, 17.4, 14.7, 20.2, 17.4, 20.2, 21.2, 15.2, 17.9, 18.6, 21, 18.4, 17.8, 18, 20.2, 15.9, 17.9, 17.3, 13.6, 20.2, 16.9, 16.1, 18.6, 18.4, 15.2, 19.2, 17.8, 18, 17.8, 19.2, 20.2), b = c(392.92, 396.9, 390.74, 395.24, 16.45, 396.9, 390.55, 302.76, 396.21, 396.9, 393.77, 27.49, 393.37, 393.53, 396.9, 351.85, 393.36, 396.9, 391.7, 392.3, 376.14, 395.11, 329.46, 380.34, 386.73, 378.25, 386.63, 389.39, 394.96, 303.42, 396.42, 392.83, 357.98, 395.69, 386.34, 394.46, 396.9, 395.52, 396.9, 394.02, 396.9, 390.77, 350.45, 392.52, 396.9, 392.18, 396.9, 395.59, 396.9, 332.09), lstat = c(10.42, 13.59, 12.67, 23.98, 20.62, 8.01, 2.88, 24.1, 8.1, 10.24, 7.43, 18.05, 5.03, 3.57, 7.19, 21.45, 8.93, 15.84, 9.71, 6.53, 5.25, 11.64, 27.38, 3.76, 18.85, 16.9, 29.93, 9.55, 7.73, 16.51, 11.5, 4.03, 6.65, 16.59, 3.11, 7.44, 5.77, 3.16, 37.97, 12.43, 4.67, 6.58, 12.64, 20.45, 3.56, 8.81, 4.21, 10.16, 9.68, 12.13), medv = c(21.8, 24.5, 22.6, 19.3, 8.8, 21.1, 50, 13.3, 22, 19.4, 24.1, 9.6, 31.1, 43.8, 29.1, 15.4, 28.4, 20.3, 26.7, 26.6, 31.7, 22.7, 8.5, 31.5, 15.4, 17.4, 16.5, 21.2, 24.4, 13.9, 16.2, 34.7, 28.4, 18.4, 44, 24.7, 24.7, 50, 13.8, 17.1, 23.5, 35.2, 16.1, 15, 37.3, 22.6, 38.7, 22.8, 18.9, 27.9)), membership = TRUE, split_rule = "custom2")
6: do.call(rfsrc, params_rfsrc)
7: rfpi(formula, traindata, testdata, alpha, split_rule = "l1", pi_method = pi_method, rf_package = "rfsrc", params_rfsrc = params_rfsrc)
8: piall(formula, traindata = traindata2, testdata = testdata2[, xvar.names], num.trees = 50)
9: eval(code, test_env)
10: eval(code, test_env)
11: withCallingHandlers({ eval(code, test_env) if (!handled && !is.null(test)) { skip_empty() }}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning, message = handle_message, error = handle_error)
12: doTryCatch(return(expr), name, parentenv, handler)
13: tryCatchOne(expr, names, parentenv, handlers[[1L]])
14: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
15: doTryCatch(return(expr), name, parentenv, handler)
16: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), names[nh], parentenv, handlers[[nh]])
17: tryCatchList(expr, classes, parentenv, handlers)
18: tryCatch(withCallingHandlers({ eval(code, test_env) if (!handled && !is.null(test)) { skip_empty() }}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning, message = handle_message, error = handle_error), error = handle_fatal, skip = function(e) { })
19: test_code(test = NULL, code = exprs, env = env, reporter = get_reporter() %||% StopReporter$new())
20: source_file(path, env = env(env), desc = desc, error_call = error_call)
21: FUN(X[[i]], ...)
22: lapply(test_paths, test_one_file, env = env, desc = desc, error_call = error_call)
23: doTryCatch(return(expr), name, parentenv, handler)
24: tryCatchOne(expr, names, parentenv, handlers[[1L]])
25: tryCatchList(expr, classes, parentenv, handlers)
26: tryCatch(code, testthat_abort_reporter = function(cnd) { cat(conditionMessage(cnd), "\n") NULL})
27: with_reporter(reporters$multi, lapply(test_paths, test_one_file, env = env, desc = desc, error_call = error_call))
28: test_files_serial(test_dir = test_dir, test_package = test_package, test_paths = test_paths, load_helpers = load_helpers, reporter = reporter, env = env, stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning, desc = desc, load_package = load_package, error_call = error_call)
29: test_files(test_dir = path, test_paths = test_paths, test_package = package, reporter = reporter, load_helpers = load_helpers, env = env, stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning, load_package = load_package, parallel = parallel)
30: test_dir("testthat", package = package, reporter = reporter, ..., load_package = "installed")
31: test_check("RFpredInterval")
An irrecoverable exception occurred. R is aborting now ...
Segmentation fault
Flavor: r-devel-linux-x86_64-debian-gcc
Version: 1.0.8
Check: tests
Result: ERROR
Running ‘testthat.R’ [17s/32s]
Running the tests in ‘tests/testthat.R’ failed.
Complete output:
> library(testthat)
> library(RFpredInterval)
RFpredInterval 1.0.8
>
> test_check("RFpredInterval")
*** caught segfault ***
address 0x1, cause 'memory not mapped'
Traceback:
1: doTryCatch(return(expr), name, parentenv, handler)
2: tryCatchOne(expr, names, parentenv, handlers[[1L]])
3: tryCatchList(expr, classes, parentenv, handlers)
4: tryCatch({ .Call("rfsrcGrow", as.integer(do.trace), as.integer(seed), as.integer(ensemble.bits + impute.only.bits + var.used.bits + split.depth.bits + importance.bits + bootstrap.bits + forest.bits + proximity.bits + perf.bits + rfq.bits + gk.quantile.bits + statistics.bits + empirical.risk.bits), as.integer(samptype.bits + forest.wt.bits + distance.bits + na.action.bits + split.cust.bits + membership.bits + terminal.qualts.bits + terminal.quants.bits + tdc.rule.bits + cse.bits + csv.bits), as.integer(splitinfo$index), as.integer(splitinfo$nsplit), as.integer(mtry), lot, base.learner, as.integer(vtry), as.integer(holdout.array), holdout.specs, as.integer(formulaDetail$ytry), as.integer(nodesize), as.integer(nodedepth), as.integer(length(cause.wt)), as.double(cause.wt), as.integer(ntree), as.integer(n), list(as.integer(length(yvar.types)), if (is.null(yvar.types)) NULL else as.character(yvar.types), if (is.null(yvar.types)) NULL else as.integer(yvar.nlevels), if (is.null(yvar.numeric.levels)) NULL else sapply(1:length(yvar.numeric.levels), function(nn) { as.integer(length(yvar.numeric.levels[[nn]])) }), if (is.null(subj)) NULL else as.integer(subj), if (is.null(event.info)) NULL else as.integer(length(event.info$event.type)), if (is.null(event.info)) NULL else as.integer(event.info$event.type), if (is.null(yvar)) NULL else as.double(as.vector(yvar))), if (is.null(yvar.numeric.levels)) { NULL } else { lapply(1:length(yvar.numeric.levels), function(nn) { as.integer(yvar.numeric.levels[[nn]]) }) }, list(as.integer(n.xvar), as.character(xvar.types), if (is.null(xvar.types)) NULL else as.integer(xvar.nlevels), if (is.null(xvar.numeric.levels)) NULL else sapply(1:length(xvar.numeric.levels), function(nn) { as.integer(length(xvar.numeric.levels[[nn]])) }), if (is.null(xvar.time)) NULL else as.integer(xvar.time), if (is.null(subj.time)) NULL else as.integer(subj.time), as.double(as.vector(xvar))), if (is.null(xvar.numeric.levels)) { NULL } else { lapply(1:length(xvar.numeric.levels), function(nn) { as.integer(xvar.numeric.levels[[nn]]) }) }, list(as.integer(length(case.wt)), if (is.null(case.wt)) NULL else as.double(case.wt), as.integer(sampsize), if (is.null(samp)) NULL else as.integer(samp)), as.double(split.wt), as.double(yvar.wt), as.double(xvar.wt), as.integer(length(event.info$time.interest)), as.double(event.info$time.interest), as.integer(nimpute), as.integer(block.size), as.integer(length(prob)), as.double(prob), as.double(prob.epsilon), as.integer(get.rf.cores()))}, error = function(e) { print(e) NULL})
5: (function (formula, data, ntree = 1000, mtry = NULL, ytry = NULL, nodesize = NULL, nodedepth = NULL, splitrule = NULL, nsplit = 10, importance = c(FALSE, TRUE, "none", "permute", "random", "anti"), block.size = if (any(is.element(as.character(importance), c("none", "FALSE")))) NULL else 10, ensemble = c("all", "oob", "inbag"), bootstrap = c("by.root", "none", "by.user"), samptype = c("swor", "swr"), samp = NULL, membership = FALSE, sampsize = if (samptype == "swor") function(x) { x * 0.632 } else function(x) { x }, na.action = c("na.omit", "na.impute"), nimpute = 1, ntime, cause, proximity = FALSE, distance = FALSE, forest.wt = FALSE, xvar.wt = NULL, yvar.wt = NULL, split.wt = NULL, case.wt = NULL, forest = TRUE, var.used = c(FALSE, "all.trees", "by.tree"), split.depth = c(FALSE, "all.trees", "by.tree"), seed = NULL, do.trace = FALSE, statistics = FALSE, ...) { univariate.nomenclature = TRUE user.option <- list(...) impute.only <- is.hidden.impute.only(user.option) terminal.qualts <- is.hidden.terminal.qualts(user.option) terminal.quants <- is.hidden.terminal.quants(user.option) cse <- is.hidden.cse(user.option) csv <- is.hidden.csv(user.option) perf.type <- is.hidden.perf.type(user.option) rfq <- is.hidden.rfq(user.option) gk.quantile <- is.hidden.gk.quantile(user.option) quantile.regr <- is.hidden.quantile.regr(user.option) prob <- is.hidden.prob(user.option) prob.epsilon <- is.hidden.prob.epsilon(user.option) lot <- is.hidden.lot(user.option) hdim <- lot$hdim base.learner <- is.hidden.base.learner(user.option) vtry <- is.hidden.vtry(user.option) holdout.array <- is.hidden.holdout.array(user.option) holdout.specs <- is.hidden.holdout.specs(user.option) empirical.risk <- is.hidden.empirical.risk(user.option) tdc.rule <- is.hidden.tdc.rule(user.option) ensemble <- match.arg(ensemble, c("all", "oob", "inbag")) bootstrap <- match.arg(bootstrap, c("by.root", "none", "by.user")) if (bootstrap == "none") { ensemble <- "inbag" } importance <- match.arg(as.character(importance), c(FALSE, TRUE, "none", "permute", "random", "anti")) na.action <- match.arg(na.action, c("na.omit", "na.impute")) proximity <- match.arg(as.character(proximity), c(FALSE, TRUE, "inbag", "oob", "all")) distance <- match.arg(as.character(distance), c(FALSE, TRUE, "inbag", "oob", "all")) var.used <- match.arg(as.character(var.used), c("FALSE", "all.trees", "by.tree")) split.depth <- match.arg(as.character(split.depth), c("FALSE", "all.trees", "by.tree")) if (var.used == "FALSE") var.used <- FALSE if (split.depth == "FALSE") split.depth <- FALSE if (missing(data)) stop("data is missing") if (any(is.infinite(unlist(data)))) stop("data contains Inf or -Inf values") if (missing(formula) | (!missing(formula) && is.null(formula))) { if (is.null(ytry)) { formula <- as.formula("Unsupervised() ~ .") } else { formula <- as.formula(paste("Unsupervised(", ytry, ")~.")) } } formulaPrelim <- parseFormula(formula, data, ytry) my.call <- match.call() my.call$formula <- eval(formula) if (any(is.na(data))) { data <- parseMissingData(formulaPrelim, data) miss.flag <- TRUE } else { miss.flag <- FALSE } formulaDetail <- finalizeFormula(formulaPrelim, data) ntree <- round(ntree) if (ntree < 1) stop("Invalid choice of 'ntree'. Cannot be less than 1.") if (!is.null(nodesize) && nodesize < 1) stop("Invalid choice of 'nodesize'. Cannot be less than 1.") if (!is.null(nodedepth)) nodedepth = round(nodedepth) else nodedepth = -1 nimpute <- round(nimpute) if (nimpute < 1) stop("Invalid choice of 'nimpute'. Cannot be less than 1.") seed <- get.seed(seed) family <- formulaDetail$family xvar.names <- formulaDetail$xvar.names yvar.names <- formulaDetail$yvar.names subj.names <- formulaDetail$subj.names if (length(xvar.names) == 0) { stop("something seems wrong: your formula did not define any x-variables") } if (family != "unsupv" && length(yvar.names) == 0) { stop("something seems wrong: your formula did not define any y-variables") } if (family == "class") { if (length(setdiff(levels(data[, yvar.names]), unique(data[, yvar.names]))) > 0) { warning("empty classes found when implementing classification\n") } } data <- rm.na.levels(data, xvar.names) data <- rm.na.levels(data, yvar.names) yfactor <- extract.factor(data, yvar.names) yfactor$types <- yvar.types <- get.yvar.type(family, yfactor$generic.types, yvar.names) yfactor$nlevels <- yvar.nlevels <- get.yvar.nlevels(family, yfactor$nlevels, yvar.names, data) xfactor <- extract.factor(data, xvar.names) xfactor$types <- xvar.types <- xfactor$generic.types xvar.nlevels <- xfactor$nlevels data <- finalizeData(c(subj.names, yvar.names, xvar.names), data, na.action, miss.flag) data.row.names <- rownames(data) xvar <- as.matrix(data[, xvar.names, drop = FALSE]) rownames(xvar) <- colnames(xvar) <- NULL xfactor$numeric.levels <- xvar.numeric.levels <- get.numeric.levels(family, xfactor$nlevels, xvar) n <- nrow(xvar) n.xvar <- length(xvar.names) mtry <- get.grow.mtry(mtry, n.xvar, family) samptype <- match.arg(samptype, c("swor", "swr")) subj.unique.count <- n subj <- NULL xvar.time <- NULL subj.time <- NULL if (bootstrap == "by.root") { if (!is.function(sampsize) && !is.numeric(sampsize)) { stop("sampsize must be a function or number specifying size of subsampled data") } if (is.function(sampsize)) { sampsize.function <- sampsize } else { sampsize.function <- make.samplesize.function(sampsize/subj.unique.count) } sampsize <- round(sampsize.function(subj.unique.count)) if (sampsize < 1) { stop("sampsize must be greater than zero") } if (samptype == "swor" && (sampsize > subj.unique.count)) { sampsize.function <- function(x) { x } sampsize <- subj.unique.count } samp <- NULL case.wt <- get.weight(case.wt, subj.unique.count) } else if (bootstrap == "by.user") { if (is.null(samp)) { stop("samp must not be NULL when bootstrapping by user") } ntree <- ncol(samp) sampsize <- colSums(samp) if (sum(sampsize == sampsize[1]) != ntree) { stop("sampsize must be identical for each tree") } sampsize <- sampsize[1] sampsize.function <- make.samplesize.function(sampsize[1]/subj.unique.count) case.wt <- get.weight(NULL, subj.unique.count) } else { sampsize <- subj.unique.count sampsize.function <- function(x) { x } case.wt <- get.weight(case.wt, sampsize) } split.wt <- get.weight(split.wt, n.xvar) forest.wt <- match.arg(as.character(forest.wt), c(FALSE, TRUE, "inbag", "oob", "all")) if (family == "unspv") { yvar.wt <- NULL } else { yvar.wt <- get.weight(yvar.wt, length(yvar.types)) } xvar.wt <- get.weight(xvar.wt, n.xvar) yvar <- as.matrix(data[, yvar.names, drop = FALSE]) if (dim(yvar)[2] == 0) { yvar <- yvar.nlevels <- yvar.numeric.levels <- yfactor <- NULL } else { yfactor$numeric.levels <- yvar.numeric.levels <- get.numeric.levels(family, yfactor$nlevels, yvar) } if (miss.flag) { n.miss <- get.nmiss(xvar, yvar) } else { n.miss <- 0 } if (impute.only && n.miss == 0) { return(data) } remove(data) big.data <- FALSE event.info <- get.grow.event.info(yvar, family, ntime = ntime) splitinfo <- get.grow.splitinfo(formulaDetail, splitrule, hdim, nsplit, event.info) if (family == "surv" || family == "surv-CR") { if (length(event.info$event.type) > 1) { if (missing(cause) || is.null(cause)) { cause <- NULL cause.wt <- rep(1, length(event.info$event.type)) } else { if (length(cause) == 1) { if (cause >= 1 && cause <= length(event.info$event.type)) { cause.wt <- rep(0, length(event.info$event.type)) cause.wt[cause] <- 1 } else { cause.wt <- rep(1, length(event.info$event.type)) } } else { if (length(cause) == length(event.info$event.type) && all(cause >= 0) && !all(cause == 0)) { cause.wt <- cause/sum(cause) } else { cause.wt <- rep(1, length(event.info$event.type)) } } } } else { cause <- NULL cause.wt = 1 } family <- get.coerced.survival.fmly(family, subj, event.info$event.type, splitinfo$name) } else { cause <- cause.wt <- NULL } nodesize <- get.grow.nodesize(family, nodesize) if ((bootstrap != "by.root") && (bootstrap != "by.user")) { importance <- "none" perf.type <- "none" } if (family == "unsupv") { importance <- "none" perf.type <- "none" } if (impute.only) { forest <- FALSE proximity <- FALSE distance <- FALSE var.used <- FALSE split.depth <- FALSE membership <- FALSE perf.type <- "none" importance <- "none" terminal.qualts <- FALSE terminal.quants <- FALSE cse <- FALSE csv <- FALSE } if (!is.null(holdout.array)) { if (nrow(holdout.array) != n.xvar | ncol(holdout.array) != ntree) { stop("dimension of holdout.array does not conform to p x ntree") } vtry <- 1 } gk.quantile <- get.gk.quantile(gk.quantile) prob.assign <- global.prob.assign(prob, prob.epsilon, gk.quantile, quantile.regr, splitinfo$name, n) prob <- prob.assign$prob prob.epsilon <- prob.assign$prob.epsilon if (terminal.qualts | terminal.quants) { forest <- TRUE } ensemble.bits <- get.ensemble(ensemble) impute.only.bits <- get.impute.only(impute.only, n.miss) var.used.bits <- get.var.used(var.used) split.depth.bits <- get.split.depth(split.depth) importance.bits <- get.importance(importance) bootstrap.bits <- get.bootstrap(bootstrap) forest.bits <- get.forest(forest) proximity.bits <- get.proximity(TRUE, proximity) distance.bits <- get.distance(TRUE, distance) membership.bits <- get.membership(membership) statistics.bits <- get.statistics(statistics) split.cust.bits <- get.split.cust(splitinfo$cust) perf.type <- get.perf(perf.type, impute.only, family) perf.bits <- get.perf.bits(perf.type) rfq <- get.rfq(rfq) rfq.bits <- get.rfq.bits(rfq, family) gk.quantile.bits <- get.gk.quantile.bits(gk.quantile) empirical.risk.bits <- get.empirical.risk.bits(empirical.risk) tdc.rule.bits <- get.tdc.rule.bits(tdc.rule) samptype.bits <- get.samptype(samptype) forest.wt.bits <- get.forest.wt(TRUE, bootstrap, forest.wt) na.action.bits <- get.na.action(na.action) block.size <- get.block.size(block.size, ntree) terminal.qualts.bits <- get.terminal.qualts(terminal.qualts, FALSE) terminal.quants.bits <- get.terminal.quants(terminal.quants, FALSE) cse.bits = get.cse(cse) csv.bits = get.csv(csv) do.trace <- get.trace(do.trace) nativeOutput <- tryCatch({ .Call("rfsrcGrow", as.integer(do.trace), as.integer(seed), as.integer(ensemble.bits + impute.only.bits + var.used.bits + split.depth.bits + importance.bits + bootstrap.bits + forest.bits + proximity.bits + perf.bits + rfq.bits + gk.quantile.bits + statistics.bits + empirical.risk.bits), as.integer(samptype.bits + forest.wt.bits + distance.bits + na.action.bits + split.cust.bits + membership.bits + terminal.qualts.bits + terminal.quants.bits + tdc.rule.bits + cse.bits + csv.bits), as.integer(splitinfo$index), as.integer(splitinfo$nsplit), as.integer(mtry), lot, base.learner, as.integer(vtry), as.integer(holdout.array), holdout.specs, as.integer(formulaDetail$ytry), as.integer(nodesize), as.integer(nodedepth), as.integer(length(cause.wt)), as.double(cause.wt), as.integer(ntree), as.integer(n), list(as.integer(length(yvar.types)), if (is.null(yvar.types)) NULL else as.character(yvar.types), if (is.null(yvar.types)) NULL else as.integer(yvar.nlevels), if (is.null(yvar.numeric.levels)) NULL else sapply(1:length(yvar.numeric.levels), function(nn) { as.integer(length(yvar.numeric.levels[[nn]])) }), if (is.null(subj)) NULL else as.integer(subj), if (is.null(event.info)) NULL else as.integer(length(event.info$event.type)), if (is.null(event.info)) NULL else as.integer(event.info$event.type), if (is.null(yvar)) NULL else as.double(as.vector(yvar))), if (is.null(yvar.numeric.levels)) { NULL } else { lapply(1:length(yvar.numeric.levels), function(nn) { as.integer(yvar.numeric.levels[[nn]]) }) }, list(as.integer(n.xvar), as.character(xvar.types), if (is.null(xvar.types)) NULL else as.integer(xvar.nlevels), if (is.null(xvar.numeric.levels)) NULL else sapply(1:length(xvar.numeric.levels), function(nn) { as.integer(length(xvar.numeric.levels[[nn]])) }), if (is.null(xvar.time)) NULL else as.integer(xvar.time), if (is.null(subj.time)) NULL else as.integer(subj.time), as.double(as.vector(xvar))), if (is.null(xvar.numeric.levels)) { NULL } else { lapply(1:length(xvar.numeric.levels), function(nn) { as.integer(xvar.numeric.levels[[nn]]) }) }, list(as.integer(length(case.wt)), if (is.null(case.wt)) NULL else as.double(case.wt), as.integer(sampsize), if (is.null(samp)) NULL else as.integer(samp)), as.double(split.wt), as.double(yvar.wt), as.double(xvar.wt), as.integer(length(event.info$time.interest)), as.double(event.info$time.interest), as.integer(nimpute), as.integer(block.size), as.integer(length(prob)), as.double(prob), as.double(prob.epsilon), as.integer(get.rf.cores())) }, error = function(e) { print(e) NULL }) if (is.null(nativeOutput)) { if (impute.only) { return(NULL) } else { stop("An error has occurred in the grow algorithm. Please turn trace on for further analysis.") } } if (n.miss > 0) { imputed.data <- matrix(nativeOutput$imputation, nrow = n.miss, byrow = FALSE) imputed.indv <- imputed.data[, 1] imputed.data <- as.matrix(imputed.data[, -1, drop = FALSE]) nativeOutput$imputation <- NULL if (nimpute > 1) { if (grepl("surv", family)) { yvar[imputed.indv, 1] <- imputed.data[, 1] yvar[imputed.indv, 2] <- imputed.data[, 2] xvar[imputed.indv, ] <- imputed.data[, -c(1:2), drop = FALSE] } else { if (!is.null(yvar.types)) { yvar[imputed.indv, ] <- imputed.data[, 1:length(yvar.types), drop = FALSE] xvar[imputed.indv, ] <- imputed.data[, -c(1:length(yvar.types)), drop = FALSE] } else { xvar[imputed.indv, ] <- imputed.data } } imputed.indv <- NULL imputed.data <- NULL imputedOOBData <- NULL na.action = "na.omit" } else { colnames(imputed.data) <- c(yvar.names, xvar.names) imputed.data <- as.data.frame(imputed.data) } } xvar <- as.data.frame(xvar) rownames(xvar) <- data.row.names colnames(xvar) <- xvar.names xvar <- map.factor(xvar, xfactor) if (family != "unsupv") { yvar <- as.data.frame(yvar) colnames(yvar) <- yvar.names } else { yvar <- NULL } if (family != "unsupv") { if (family == "regr+" | family == "class+" | family == "mix+") { yvar <- map.factor(yvar, yfactor) } else { yvar <- amatrix.remove.names(map.factor(yvar, yfactor)) } } pi.hat <- NULL if (family == "class" && rfq) { pi.hat <- table(yvar)/length(yvar) } if ((n.miss > 0) & (nimpute < 2)) { imputed.data <- map.factor(imputed.data, xfactor) if (family != "unsupv") { imputed.data <- map.factor(imputed.data, yfactor) } } if (forest) { nativeArraySize = 0 if (hdim == 0) { mwcpCountSummary <- rep(0, 1) nativeFactorArray <- vector("list", 1) } else { mwcpCountSummary = rep(0, hdim) nativeFactorArray <- vector("list", hdim) } pivot <- which(names(nativeOutput) == "treeID") if (hdim == 0) { offset = 0 } else { offset = 7 if (!is.null(base.learner)) { if (base.learner$interact.depth > 1) { offset = offset + 3 } } if (!is.null(base.learner)) { if (base.learner$synthetic.depth > 1) { offset = offset + 2 } } } if (!is.null(base.learner)) { if (base.learner$synthetic.depth > 1) { mwcpCountSummarySyth <- rep(0, 1) nullO <- lapply(1:ntree, function(b) { mwcpCountSummarySyth[1] <<- mwcpCountSummarySyth[1] + nativeOutput$mwcpCTsyth[b] NULL }) } } nullO <- lapply(1:ntree, function(b) { if (nativeOutput$leafCount[b] > 0) { nativeArraySize <<- nativeArraySize + (2 * nativeOutput$leafCount[b]) - 1 mwcpCountSummary[1] <<- mwcpCountSummary[1] + nativeOutput$mwcpCT[b] if (hdim > 1) { for (i in 2:hdim) { mwcpCountSummary[i] <<- mwcpCountSummary[i] + nativeOutput[[pivot + (offset + 2) + (5 * (hdim - 1)) + (i - 2)]][b] } } } else { nativeArraySize <<- nativeArraySize + 1 } NULL }) rm(nullO) nativeArray <- as.data.frame(cbind(nativeOutput$treeID[1:nativeArraySize], nativeOutput$nodeID[1:nativeArraySize])) nativeArrayHeader <- c("treeID", "nodeID") nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput$parmID[1:nativeArraySize], nativeOutput$contPT[1:nativeArraySize], nativeOutput$mwcpSZ[1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, "parmID", "contPT", "mwcpSZ") if (mwcpCountSummary[1] > 0) { nativeFactorArray[[1]] <- nativeOutput$mwcpPT[1:mwcpCountSummary[1]] } nativeFactorArrayHeader <- "mwcpPT" if (hdim > 0) { if (!is.null(base.learner)) { if (base.learner$interact.depth > 1) { nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput$pairCT[1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, "pairCT") } if (base.learner$synthetic.depth > 1) { nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput$sythSZ[1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, "sythSZ") } if (base.learner$interact.depth > 1) { nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput$augmXone[1:nativeArraySize], nativeOutput$augmXtwo[1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, "augmXone", "augmXtwo") } if (base.learner$synthetic.depth > 1) { nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput$augmXS[1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, "augmXS") } } nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, "hcDim") nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset + 1]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, "contPTR") offset = offset + 2 } if (hdim > 1) { for (i in 2:hdim) { nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset + (0 * (hdim - 1)) + i - 2]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, paste("parmID", i, sep = "")) nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset + (1 * (hdim - 1)) + i - 2]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, paste("contPT", i, sep = "")) nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset + (2 * (hdim - 1)) + i - 2]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, paste("contPTR", i, sep = "")) nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset + (3 * (hdim - 1)) + i - 2]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, paste("mwcpSZ", i, sep = "")) if (mwcpCountSummary[i] > 0) { nativeFactorArray[[i]] <- nativeOutput[[pivot + offset + (4 * (hdim - 1)) + i - 2]][1:mwcpCountSummary[i]] } nativeFactorArrayHeader <- c(nativeFactorArrayHeader, paste("mwcpPT", i, sep = "")) if (!is.null(base.learner)) { hdim.multiplier <- 6 if (base.learner$interact.depth > 1) { nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset + (hdim.multiplier * (hdim - 1)) + i - 2]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, paste("augmXone", i, sep = "")) hdim.multiplier <- hdim.multiplier + 1 nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset + (hdim.multiplier * (hdim - 1)) + i - 2]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, paste("augmXtwo", i, sep = "")) hdim.multiplier <- hdim.multiplier + 1 } if (base.learner$synthetic.depth > 1) { nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset + (hdim.multiplier * (hdim - 1)) + i - 2]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, paste("augmXS", i, sep = "")) } } } } nativeArraySyth <- nativeFactorArraySyth <- NULL nodeCountSyth <- NULL totalNodeCountSyth = 0 if (!is.null(base.learner)) { if (base.learner$synthetic.depth > 1) { if (!is.null(nativeOutput$treeIDsyth)) { nativeArraySyth <- as.data.frame(cbind(nativeOutput$treeIDsyth, nativeOutput$nodeIDsyth, nativeOutput$hcDimsyth, nativeOutput$parmIDsyth, nativeOutput$contPTsyth, nativeOutput$contPTRsyth, nativeOutput$mwcpSZsyth)) nativeArrayHeaderSyth <- c("treeID", "nodeID", "hcDim", "parmID", "contPT", "contPTR", "mwcpSZ") names(nativeArraySyth) = nativeArrayHeaderSyth totalNodeCountSyth <- length(nativeOutput$treeIDsyth) nodeCountSyth <- nativeOutput$nodeCountSyth if (mwcpCountSummarySyth[1] > 0) { nativeFactorArraySyth <- nativeOutput$mwcpPTsyth[1:mwcpCountSummarySyth[1]] nativeFactorArrayHeaderSyth <- "mwcpPT" names(nativeFactorArraySyth) = nativeFactorArrayHeaderSyth } } } } names(nativeArray) <- nativeArrayHeader names(nativeFactorArray) <- nativeFactorArrayHeader if (terminal.qualts | terminal.quants) { totalLeafCount <- sum(nativeOutput$leafCount) valid.mcnt.indices <- 1:totalLeafCount if (terminal.quants) { if (grepl("surv", family)) { valid.2D.surv.indices <- 1:(totalLeafCount * length(event.info$event.type) * length(event.info$time.interest)) valid.1D.surv.indices <- 1:(totalLeafCount * length(event.info$time.interest)) valid.mort.indices <- 1:(totalLeafCount * length(event.info$event.type)) } else { class.index <- which(yvar.types != "R") class.count <- length(class.index) regr.index <- which(yvar.types == "R") regr.count <- length(regr.index) if (class.count > 0) { levels.count <- array(0, class.count) counter <- 0 for (i in class.index) { counter <- counter + 1 levels.count[counter] <- yvar.nlevels[i] } valid.clas.indices <- 1:(totalLeafCount * sum(levels.count)) } if (regr.count > 0) { valid.regr.indices <- 1:(totalLeafCount * regr.count) } } } nativeArrayTNDS <- list(if (!is.null(nativeOutput$tnSURV)) nativeOutput$tnSURV[valid.1D.surv.indices] else NULL, if (!is.null(nativeOutput$tnMORT)) nativeOutput$tnMORT[valid.mort.indices] else NULL, if (!is.null(nativeOutput$tnNLSN)) nativeOutput$tnNLSN[valid.1D.surv.indices] else NULL, if (!is.null(nativeOutput$tnCSHZ)) nativeOutput$tnCSHZ[valid.2D.surv.indices] else NULL, if (!is.null(nativeOutput$tnCIFN)) nativeOutput$tnCIFN[valid.2D.surv.indices] else NULL, if (!is.null(nativeOutput$tnREGR)) nativeOutput$tnREGR[valid.regr.indices] else NULL, if (!is.null(nativeOutput$tnCLAS)) nativeOutput$tnCLAS[valid.clas.indices] else NULL, nativeOutput$rmbrMembership, nativeOutput$ambrMembership, nativeOutput$tnRCNT[valid.mcnt.indices], nativeOutput$tnACNT[valid.mcnt.indices]) names(nativeArrayTNDS) <- c("tnSURV", "tnMORT", "tnNLSN", "tnCSHZ", "tnCIFN", "tnREGR", "tnCLAS", "tnRMBR", "tnAMBR", "tnRCNT", "tnACNT") } else { nativeArrayTNDS <- NULL } if (statistics) { node.stats <- as.data.frame(cbind(nativeOutput$spltST[1:nativeArraySize], nativeOutput$dpthST[1:nativeArraySize])) names(node.stats) <- c("spltST", "dpthST") } else { node.stats <- NULL } forest.out <- list(forest = TRUE, hdim = hdim, base.learner = base.learner, nativeArray = nativeArray, nativeFactorArray = nativeFactorArray, totalNodeCount = dim(nativeArray)[1], nativeArraySyth = nativeArraySyth, nativeFactorArraySyth = nativeFactorArraySyth, nodeCountSyth = nodeCountSyth, nodesize = nodesize, nodedepth = nodedepth, ntree = ntree, family = family, n = n, splitrule = splitinfo$name, yvar = yvar, yvar.names = yvar.names, yvar.factor = yfactor, xvar = xvar, xvar.names = xvar.names, xvar.factor = xfactor, event.info = event.info, subj = subj, subj.names = subj.names, seed = nativeOutput$seed, bootstrap = bootstrap, sampsize = sampsize.function, samptype = samptype, samp = samp, case.wt = case.wt, terminal.qualts = terminal.qualts, terminal.quants = terminal.quants, nativeArrayTNDS = nativeArrayTNDS, version = "2.11.0", na.action = na.action, perf.type = perf.type, rfq = rfq, gk.quantile = gk.quantile, quantile.regr = quantile.regr, prob = prob, prob.epsilon = prob.epsilon, block.size = block.size) if (grepl("surv", family)) { forest.out$time.interest <- event.info$time.interest } class(forest.out) <- c("rfsrc", "forest", family) if (big.data) { class(forest.out) <- c(class(forest.out), "bigdata") } } else { node.stats <- NULL forest.out <- list(forest = FALSE, hdim = hdim, base.learner = base.learner, nodesize = nodesize, nodedepth = nodedepth, ntree = ntree, family = family, n = n, splitrule = splitinfo$name, yvar = yvar, yvar.names = yvar.names, xvar = xvar, xvar.names = xvar.names, subj = subj, subj.names = subj.names, seed = nativeOutput$seed, bootstrap = bootstrap, sampsize = sampsize.function, samptype = samptype, samp = samp, case.wt = case.wt, version = "2.11.0", na.action = na.action, perf.type = perf.type, rfq = rfq, gk.quantile = gk.quantile, quantile.regr = quantile.regr, prob = prob, prob.epsilon = prob.epsilon, block.size = block.size) } if (proximity != FALSE) { proximity.out <- matrix(0, n, n) count <- 0 for (k in 1:n) { proximity.out[k, 1:k] <- nativeOutput$proximity[(count + 1):(count + k)] proximity.out[1:k, k] <- proximity.out[k, 1:k] count <- count + k } nativeOutput$proximity <- NULL } else { proximity.out <- NULL } if (distance != FALSE) { distance.out <- matrix(0, n, n) count <- 0 for (k in 1:n) { distance.out[k, 1:k] <- nativeOutput$distance[(count + 1):(count + k)] distance.out[1:k, k] <- distance.out[k, 1:k] count <- count + k } nativeOutput$distance <- NULL } else { distance.out <- NULL } if (forest.wt != FALSE) { forest.wt.out <- matrix(nativeOutput$weight, c(n, n), byrow = TRUE) nativeOutput$weight <- NULL } else { forest.wt.out <- NULL } if (membership) { membership.out <- matrix(nativeOutput$nodeMembership, c(n, ntree)) inbag.out <- matrix(nativeOutput$bootMembership, c(n, ntree)) nativeOutput$nodeMembership <- NULL nativeOutput$bootMembership <- NULL if (!is.null(subj)) { tdc.membership.cnt <- matrix(nativeOutput$nodeMembershipTDC[[1]], c(n, ntree)) tdc.membership.out <- vector("list", ntree) begin.indx <- 0 end.indx <- 0 for (i in 1:ntree) { temp <- vector("list", n) for (j in 1:n) { begin.indx <- end.indx + 1 end.indx <- end.indx + tdc.membership.cnt[j, i] temp[[j]] <- nativeOutput$nodeMembershipTDC[[2]][begin.indx:end.indx] } tdc.membership.out[[i]] <- temp } } else { tdc.membership.out <- NULL } } else { membership.out <- NULL inbag.out <- NULL tdc.membership.out <- NULL } if (var.used != FALSE) { if (var.used == "all.trees") { var.used.out <- nativeOutput$varUsed names(var.used.out) <- xvar.names } else { var.used.out <- matrix(nativeOutput$varUsed, nrow = ntree, byrow = TRUE) colnames(var.used.out) <- xvar.names } nativeOutput$varUsed <- NULL } else { var.used.out <- NULL } if (split.depth != FALSE) { if (split.depth == "all.trees") { split.depth.out <- array(nativeOutput$splitDepth, c(n, n.xvar)) } else { split.depth.out <- array(nativeOutput$splitDepth, c(n, n.xvar, ntree)) } nativeOutput$splitDepth <- NULL } else { split.depth.out <- NULL } empr.risk <- NULL oob.empr.risk <- NULL if (empirical.risk) { if (!is.null(nativeOutput$emprRisk)) { empr.risk <- array(nativeOutput$emprRisk, c(lot$treesize, ntree)) nativeOutput$emprRisk <- NULL } if (!is.null(nativeOutput$oobEmprRisk)) { oob.empr.risk <- array(nativeOutput$oobEmprRisk, c(lot$treesize, ntree)) nativeOutput$oobEmprRisk <- NULL } } if (!is.null(holdout.specs)) { holdout.blk <- nativeOutput$holdoutBlk nativeOutput$holdoutBlk <- NULL } else { holdout.blk = NULL } rfsrcOutput <- list(call = my.call, family = family, n = n, ntree = ntree, nimpute = nimpute, mtry = mtry, nodesize = nodesize, nodedepth = nodedepth, nsplit = splitinfo$nsplit, yvar = yvar, yvar.names = yvar.names, xvar = xvar, xvar.names = xvar.names, event.info = event.info, subj = subj, subj.names = subj.names, xvar.wt = xvar.wt, split.wt = split.wt, cause.wt = cause.wt, leaf.count = nativeOutput$leafCount, proximity = proximity.out, forest = forest.out, forest.wt = forest.wt.out, distance = distance.out, membership = membership.out, tdc.membership = tdc.membership.out, splitrule = splitinfo$name, inbag = inbag.out, var.used = var.used.out, imputed.indv = (if (n.miss > 0) imputed.indv else NULL), imputed.data = (if (n.miss > 0) imputed.data else NULL), split.depth = split.depth.out, node.stats = node.stats, ensemble = ensemble, holdout.array = holdout.array, block.size = block.size, holdout.blk = holdout.blk, empr.risk = empr.risk, oob.empr.risk = oob.empr.risk) remove(yvar) remove(xvar) nativeOutput$leafCount <- NULL remove(proximity.out) remove(forest.out) remove(forest.wt.out) remove(distance.out) remove(membership.out) remove(inbag.out) remove(var.used.out) if (n.miss > 0) remove(imputed.indv) if (n.miss > 0) remove(imputed.data) remove(split.depth.out) remove(holdout.array) remove(empr.risk) remove(oob.empr.risk) survOutput <- NULL classOutput <- NULL regrOutput <- NULL if (!impute.only) { if (grepl("surv", family)) { if ((length(event.info$event.type) > 1) && (splitinfo$name != "l2.impute") && (splitinfo$name != "logrankscore")) { coerced.event.count <- length(event.info$event.type) } else { coerced.event.count <- 1 } if (family == "surv") { ens.names <- list(NULL, NULL) mortality.names <- list(NULL, NULL) err.names <- list(NULL, NULL) vimp.names <- list(NULL, xvar.names) } else if (family == "surv-CR") { ens.names <- list(NULL, NULL, c(paste("condCHF.", 1:length(event.info$event.type), sep = ""))) mortality.names <- list(NULL, paste("event.", 1:length(event.info$event.type), sep = "")) cif.names <- list(NULL, NULL, c(paste("CIF.", 1:length(event.info$event.type), sep = ""))) err.names <- list(c(paste("event.", 1:length(event.info$event.type), sep = "")), NULL) vimp.names <- list(paste("event.", 1:length(event.info$event.type), sep = ""), xvar.names) } else { ens.names <- list(NULL, NULL) } chf <- (if (!is.null(nativeOutput$allEnsbCHF)) adrop3d.last(array(nativeOutput$allEnsbCHF, c(n, length(event.info$time.interest), length(event.info$event.type)), dimnames = ens.names), coerced.event.count) else NULL) nativeOutput$allEnsbCHF <- NULL survOutput <- list(chf = chf) remove(chf) chf.oob <- (if (!is.null(nativeOutput$oobEnsbCHF)) adrop3d.last(array(nativeOutput$oobEnsbCHF, c(n, length(event.info$time.interest), length(event.info$event.type)), dimnames = ens.names), coerced.event.count) else NULL) nativeOutput$oobEnsbCHF <- NULL survOutput = c(survOutput, chf.oob = list(chf.oob)) remove(chf.oob) predicted <- (if (!is.null(nativeOutput$allEnsbMRT)) adrop2d.last(array(nativeOutput$allEnsbMRT, c(n, length(event.info$event.type)), dimnames = mortality.names), coerced.event.count) else NULL) nativeOutput$allEnsbMRT <- NULL survOutput = c(survOutput, predicted = list(predicted)) remove(predicted) predicted.oob <- (if (!is.null(nativeOutput$oobEnsbMRT)) adrop2d.last(array(nativeOutput$oobEnsbMRT, c(n, length(event.info$event.type)), dimnames = mortality.names), coerced.event.count) else NULL) nativeOutput$oobEnsbMRT <- NULL survOutput <- c(survOutput, predicted.oob = list(predicted.oob)) remove(predicted.oob) hazard <- (if (!is.null(nativeOutput$allEnsbKHZ)) matrix(nativeOutput$allEnsbKHZ, c(subj.unique.count, length(event.info$time.interest))) else NULL) nativeOutput$allEnsbKHZ <- NULL survOutput <- c(survOutput, hazard = list(hazard)) remove(hazard) hazard.oob <- (if (!is.null(nativeOutput$oobEnsbKHZ)) matrix(nativeOutput$oobEnsbKHZ, c(subj.unique.count, length(event.info$time.interest))) else NULL) nativeOutput$oobEnsbKHZ <- NULL survOutput <- c(survOutput, hazard.oob = list(hazard.oob)) remove(hazard.oob) survival <- (if (!is.null(nativeOutput$allEnsbSRV)) matrix(nativeOutput$allEnsbSRV, c(n, length(event.info$time.interest))) else NULL) nativeOutput$allEnsbSRV <- NULL survOutput <- c(survOutput, survival = list(survival)) remove(survival) survival.oob <- (if (!is.null(nativeOutput$oobEnsbSRV)) matrix(nativeOutput$oobEnsbSRV, c(n, length(event.info$time.interest))) else NULL) nativeOutput$oobEnsbSRV <- NULL survOutput <- c(survOutput, survival.oob = list(survival.oob)) remove(survival.oob) cif <- (if (!is.null(nativeOutput$allEnsbCIF)) array(nativeOutput$allEnsbCIF, c(n, length(event.info$time.interest), length(event.info$event.type)), dimnames = cif.names) else NULL) nativeOutput$allEnsbCIF <- NULL survOutput <- c(survOutput, cif = list(cif)) remove(cif) cif.oob <- (if (!is.null(nativeOutput$oobEnsbCIF)) array(nativeOutput$oobEnsbCIF, c(n, length(event.info$time.interest), length(event.info$event.type)), dimnames = cif.names) else NULL) nativeOutput$oobEnsbCIF <- NULL survOutput = c(survOutput, cif.oob = list(cif.oob)) remove(cif.oob) if (!is.null(nativeOutput$perfSurv)) { err.rate <- adrop2d.first(array(nativeOutput$perfSurv, c(length(event.info$event.type), ntree), dimnames = err.names), coerced.event.count) nativeOutput$perfSurv <- NULL if (family == "surv-CR") { survOutput = c(survOutput, err.rate = list(t(err.rate))) } else { survOutput = c(survOutput, err.rate = list(err.rate)) } remove(err.rate) } if (!is.null(nativeOutput$blockSurv)) { err.block.rate <- adrop2d.first(array(nativeOutput$blockSurv, c(length(event.info$event.type), floor(ntree/block.size)), dimnames = err.names), coerced.event.count) nativeOutput$blockSurv <- NULL if (family == "surv-CR") { survOutput = c(survOutput, err.block.rate = list(t(err.block.rate))) } else { survOutput = c(survOutput, err.block.rate = list(err.block.rate)) } remove(err.block.rate) } if (!is.null(nativeOutput$vimpSurv)) { importance <- adrop2d.first(array(nativeOutput$vimpSurv, c(length(event.info$event.type), n.xvar), dimnames = vimp.names), coerced.event.count) nativeOutput$vimpSurv <- NULL if (family == "surv-CR") { survOutput = c(survOutput, importance = list(t(importance))) } else { survOutput = c(survOutput, importance = list(importance)) } remove(importance) } survOutput = c(survOutput, list(time.interest = event.info$time.interest, ndead = sum(na.omit(event.info$cens) != 0))) if (!is.null(nativeOutput$holdoutSurv)) { holdout.vimp <- vector("list", length(rfsrcOutput$holdout.blk)) names(holdout.vimp) <- xvar.names holdout.offset <- rfsrcOutput$holdout.blk * length(event.info$event.type) holdout.offset.sum <- c(0, cumsum(holdout.offset)) for (i in 1:length(holdout.vimp)) { if (rfsrcOutput$holdout.blk[i] > 0) { if (length(event.info$event.type) > 1) { holdout.vimp[[i]] <- array(nativeOutput$holdoutSurv[(holdout.offset.sum[i] + 1):holdout.offset.sum[i + 1]], c(length(event.info$event.type), rfsrcOutput$holdout.blk[i])) } else { holdout.vimp[[i]] <- nativeOutput$holdoutSurv[(holdout.offset.sum[i] + 1):holdout.offset.sum[i + 1]] } } else { holdout.vimp[[i]] = NA } } survOutput = c(survOutput, holdout.vimp = list(holdout.vimp)) remove(holdout.vimp) } if (univariate.nomenclature) { rfsrcOutput <- c(rfsrcOutput, survOutput) } else { rfsrcOutput <- c(rfsrcOutput, survOutput = list(survOutput)) } } else { class.index <- which(yvar.types != "R") resp.clas.count <- length(class.index) regr.index <- which(yvar.types == "R") resp.regr.count <- length(regr.index) if (resp.clas.count > 0) { classOutput <- vector("list", resp.clas.count) names(classOutput) <- yvar.names[class.index] levels.count <- array(0, resp.clas.count) levels.names <- vector("list", resp.clas.count) counter <- 0 for (i in class.index) { counter <- counter + 1 levels.count[counter] <- yvar.nlevels[i] if (yvar.types[i] == "C") { levels.names[[counter]] <- yfactor$levels[[which(yfactor$factor == yvar.names[i])]] } else { levels.names[[counter]] <- yfactor$order.levels[[which(yfactor$order == yvar.names[i])]] } } tree.offset <- array(1, ntree) if (ntree > 1) { tree.offset[2:ntree] <- sum(1 + levels.count) } tree.offset <- cumsum(tree.offset) block.offset <- array(1, floor(ntree/block.size)) if (floor(ntree/block.size) > 1) { block.offset[2:floor(ntree/block.size)] <- sum(1 + levels.count) } block.offset <- cumsum(block.offset) vimp.offset <- array(1, n.xvar) if (n.xvar > 1) { vimp.offset[2:n.xvar] <- sum(1 + levels.count) } vimp.offset <- cumsum(vimp.offset) iter.ensb.start <- 0 iter.ensb.end <- 0 if (!is.null(nativeOutput$holdoutClas)) { holdout.offset.x <- rfsrcOutput$holdout.blk * (sum(1 + levels.count)) holdout.offset.sum.x <- c(0, cumsum(holdout.offset.x)) holdout.offset.r <- 0 } for (i in 1:resp.clas.count) { iter.ensb.start <- iter.ensb.end iter.ensb.end <- iter.ensb.end + (levels.count[i] * n) ens.names <- list(NULL, levels.names[[i]]) err.names <- c("all", levels.names[[i]]) vimp.names <- list(c("all", levels.names[[i]]), xvar.names) predicted <- (if (!is.null(nativeOutput$allEnsbCLS)) array(nativeOutput$allEnsbCLS[(iter.ensb.start + 1):iter.ensb.end], c(n, levels.count[i]), dimnames = ens.names) else NULL) classOutput[[i]] <- list(predicted = predicted) response <- (if (!is.null(predicted)) get.bayes.rule(predicted, pi.hat) else NULL) classOutput[[i]] <- c(classOutput[[i]], class = list(response)) remove(predicted) remove(response) predicted.oob <- (if (!is.null(nativeOutput$oobEnsbCLS)) array(nativeOutput$oobEnsbCLS[(iter.ensb.start + 1):iter.ensb.end], c(n, levels.count[i]), dimnames = ens.names) else NULL) classOutput[[i]] <- c(classOutput[[i]], predicted.oob = list(predicted.oob)) response.oob <- (if (!is.null(predicted.oob)) get.bayes.rule(predicted.oob, pi.hat) else NULL) classOutput[[i]] <- c(classOutput[[i]], class.oob = list(response.oob)) remove(predicted.oob) remove(response.oob) cse.num <- (if (!is.null(nativeOutput$cseClas)) array(nativeOutput$cseClas[(iter.ensb.start + 1):iter.ensb.end], n) else NULL) classOutput[[i]] <- c(classOutput[[i]], cse.num = list(cse.num)) remove(cse.num) cse.den <- (if (!is.null(nativeOutput$cseDen)) array(nativeOutput$cseDen[1:n], n) else NULL) classOutput[[i]] <- c(classOutput[[i]], cse.den = list(cse.den)) if (!is.null(nativeOutput$perfClas)) { err.rate <- array(0, c(1 + levels.count[i], ntree)) for (j in 1:(1 + levels.count[i])) { err.rate[j, ] <- nativeOutput$perfClas[tree.offset] tree.offset <- tree.offset + 1 } row.names(err.rate) <- err.names classOutput[[i]] <- c(classOutput[[i]], err.rate = list(t(err.rate))) remove(err.rate) } if (!is.null(nativeOutput$blockClas)) { err.block.rate <- array(0, c(1 + levels.count[i], floor(ntree/block.size))) for (j in 1:(1 + levels.count[i])) { err.block.rate[j, ] <- nativeOutput$blockClas[block.offset] block.offset <- block.offset + 1 } row.names(err.block.rate) <- err.names classOutput[[i]] <- c(classOutput[[i]], err.block.rate = list(t(err.block.rate))) remove(err.block.rate) } csv.idx <- array(0, n * n.xvar) for (j in 1:n.xvar) { csv.idx[(((j - 1) * n) + 1):(((j - 1) * n) + n)] <- (((i - 1) * n) + ((j - 1) * n * resp.clas.count) + 1):(((i - 1) * n) + ((j - 1) * n * resp.clas.count) + n) } csv.num <- (if (!is.null(nativeOutput$csvClas)) array(nativeOutput$csvClas[csv.idx], c(n, n.xvar)) else NULL) classOutput[[i]] <- c(classOutput[[i]], csv.num = list(csv.num)) remove(csv.num) csv.den <- (if (!is.null(nativeOutput$csvDen)) array(nativeOutput$csvDen, c(n, n.xvar)) else NULL) classOutput[[i]] <- c(classOutput[[i]], csv.den = list(csv.den)) remove(csv.den) if (!is.null(nativeOutput$vimpClas)) { importance <- array(0, c(1 + levels.count[i], n.xvar), dimnames = vimp.names) for (j in 1:(1 + levels.count[i])) { importance[j, ] <- nativeOutput$vimpClas[vimp.offset] vimp.offset <- vimp.offset + 1 } classOutput[[i]] <- c(classOutput[[i]], importance = list(t(importance))) remove(importance) } if (!is.null(nativeOutput$holdoutClas)) { holdout.vimp <- vector("list", length(rfsrcOutput$holdout.blk)) names(holdout.vimp) <- xvar.names if (i > 1) { holdout.offset.r <- holdout.offset.r + (1 + levels.count[i - 1]) } for (k in 1:length(holdout.vimp)) { if (rfsrcOutput$holdout.blk[k] > 0) { offset.x <- holdout.offset.sum.x[k] offset.b <- 0 index.m <- NULL for (m in 1:rfsrcOutput$holdout.blk[k]) { if (m > 1) { offset.b <- offset.b + (sum(1 + levels.count)) } index.m <- c(index.m, seq(from = offset.x + offset.b + holdout.offset.r + 1, by = 1, length.out = levels.count[i] + 1)) } holdout.vimp[[k]] = array(nativeOutput$holdoutClas[index.m], c(levels.count[i] + 1, rfsrcOutput$holdout.blk[k])) } else { holdout.vimp[[k]] = NA } } classOutput[[i]] = c(classOutput[[i]], holdout.vimp = list(holdout.vimp)) remove(holdout.vimp) } } nativeOutput$allEnsbCLS <- NULL nativeOutput$oobEnsbCLS <- NULL nativeOutput$perfClas <- NULL nativeOutput$blockClas <- NULL nativeOutput$vimpClas <- NULL nativeOutput$holdoutClas <- NULL if (univariate.nomenclature) { if ((resp.clas.count == 1) & (resp.regr.count == 0)) { names(classOutput) <- NULL rfsrcOutput <- c(rfsrcOutput, unlist(classOutput, recursive = FALSE)) } else { rfsrcOutput <- c(rfsrcOutput, classOutput = list(classOutput)) } } else { rfsrcOutput <- c(rfsrcOutput, classOutput = list(classOutput)) } } if (resp.regr.count > 0) { regrOutput <- vector("list", resp.regr.count) names(regrOutput) <- yvar.names[regr.index] tree.offset <- array(1, ntree) if (ntree > 1) { tree.offset[2:ntree] <- length(regr.index) } tree.offset <- cumsum(tree.offset) block.offset <- array(1, floor(ntree/block.size)) if (floor(ntree/block.size) > 1) { block.offset[2:floor(ntree/block.size)] <- length(regr.index) } block.offset <- cumsum(block.offset) vimp.offset <- array(1, n.xvar) if (n.xvar > 1) { vimp.offset[2:n.xvar] <- length(regr.index) } vimp.offset <- cumsum(vimp.offset) iter.ensb.start <- 0 iter.ensb.end <- 0 iter.qntl.start <- 0 iter.qntl.end <- 0 if (!is.null(nativeOutput$holdoutRegr)) { holdout.offset.x <- rfsrcOutput$holdout.blk * resp.regr.count holdout.offset.sum.x <- c(0, cumsum(holdout.offset.x)) holdout.offset.r <- 0 } for (i in 1:resp.regr.count) { iter.ensb.start <- iter.ensb.end iter.ensb.end <- iter.ensb.end + n iter.qntl.start <- iter.qntl.end iter.qntl.end <- iter.qntl.end + (length(prob) * n) vimp.names <- xvar.names predicted <- (if (!is.null(nativeOutput$allEnsbRGR)) array(nativeOutput$allEnsbRGR[(iter.ensb.start + 1):iter.ensb.end], n) else NULL) regrOutput[[i]] <- list(predicted = predicted) remove(predicted) predicted.oob <- (if (!is.null(nativeOutput$oobEnsbRGR)) array(nativeOutput$oobEnsbRGR[(iter.ensb.start + 1):iter.ensb.end], n) else NULL) regrOutput[[i]] <- c(regrOutput[[i]], predicted.oob = list(predicted.oob)) remove(predicted.oob) cse.num <- (if (!is.null(nativeOutput$cseRegr)) array(nativeOutput$cseRegr[(iter.ensb.start + 1):iter.ensb.end], n) else NULL) regrOutput[[i]] <- c(regrOutput[[i]], cse.num = list(cse.num)) remove(cse.num) cse.den <- (if (!is.null(nativeOutput$cseDen)) array(nativeOutput$cseDen[1:n], n) else NULL) regrOutput[[i]] <- c(regrOutput[[i]], cse.den = list(cse.den)) quantile <- (if (!is.null(nativeOutput$allEnsbQNT)) array(nativeOutput$allEnsbQNT[(iter.qntl.start + 1):iter.qntl.end], c(n, length(prob))) else NULL) regrOutput[[i]] <- c(regrOutput[[i]], quantile = list(quantile)) remove(quantile) quantile.oob <- (if (!is.null(nativeOutput$oobEnsbQNT)) array(nativeOutput$oobEnsbQNT[(iter.qntl.start + 1):iter.qntl.end], c(n, length(prob))) else NULL) regrOutput[[i]] <- c(regrOutput[[i]], quantile.oob = list(quantile.oob)) remove(quantile.oob) if (!is.null(nativeOutput$perfRegr)) { err.rate <- nativeOutput$perfRegr[tree.offset] tree.offset <- tree.offset + 1 regrOutput[[i]] <- c(regrOutput[[i]], err.rate = list(err.rate)) remove(err.rate) } if (!is.null(nativeOutput$blockRegr)) { err.block.rate <- nativeOutput$blockRegr[block.offset] block.offset <- block.offset + 1 regrOutput[[i]] <- c(regrOutput[[i]], err.block.rate = list(err.block.rate)) remove(err.block.rate) } if (!is.null(nativeOutput$vimpRegr)) { importance <- nativeOutput$vimpRegr[vimp.offset] names(importance) <- xvar.names vimp.offset <- vimp.offset + 1 regrOutput[[i]] <- c(regrOutput[[i]], importance = list(importance)) remove(importance) } csv.idx <- array(0, n * n.xvar) for (j in 1:n.xvar) { csv.idx[(((j - 1) * n) + 1):(((j - 1) * n) + n)] <- (((i - 1) * n) + ((j - 1) * n * resp.regr.count) + 1):(((i - 1) * n) + ((j - 1) * n * resp.regr.count) + n) } csv.num <- (if (!is.null(nativeOutput$csvRegr)) array(nativeOutput$csvRegr[csv.idx], c(n, n.xvar)) else NULL) regrOutput[[i]] <- c(regrOutput[[i]], csv.num = list(csv.num)) remove(csv.num) csv.den <- (if (!is.null(nativeOutput$csvDen)) array(nativeOutput$csvDen, c(n, n.xvar)) else NULL) regrOutput[[i]] <- c(regrOutput[[i]], csv.den = list(csv.den)) remove(csv.den) if (!is.null(nativeOutput$holdoutRegr)) { holdout.vimp <- vector("list", length(rfsrcOutput$holdout.blk)) names(holdout.vimp) <- xvar.names if (i > 1) { holdout.offset.r <- holdout.offset.r + 1 } for (k in 1:length(holdout.vimp)) { if (rfsrcOutput$holdout.blk[k] > 0) { offset.x <- holdout.offset.sum.x[k] offset.b <- 0 index.m <- NULL for (m in 1:rfsrcOutput$holdout.blk[k]) { if (m > 1) { offset.b <- offset.b + resp.regr.count } index.m <- c(index.m, offset.x + offset.b + holdout.offset.r + 1) } holdout.vimp[[k]] <- nativeOutput$holdoutRegr[index.m] } else { holdout.vimp[[k]] <- NA } } regrOutput[[i]] <- c(regrOutput[[i]], holdout.vimp = list(holdout.vimp)) } } nativeOutput$allEnsbRGR <- NULL nativeOutput$oobEnsbRGR <- NULL nativeOutput$allEnsbQNT <- NULL nativeOutput$oobEnsbQNT <- NULL nativeOutput$perfRegr <- NULL nativeOutput$blockRegr <- NULL nativeOutput$vimpRegr <- NULL nativeOutput$holdoutRegr <- NULL if (univariate.nomenclature) { if ((resp.clas.count == 0) & (resp.regr.count == 1)) { names(regrOutput) <- NULL rfsrcOutput <- c(rfsrcOutput, unlist(regrOutput, recursive = FALSE)) } else { rfsrcOutput <- c(rfsrcOutput, regrOutput = list(regrOutput)) } } else { rfsrcOutput <- c(rfsrcOutput, regrOutput = list(regrOutput)) } } } } class(rfsrcOutput) <- c("rfsrc", "grow", family) if (big.data) { class(rfsrcOutput) <- c(class(rfsrcOutput), "bigdata") } return(rfsrcOutput)})(ntree = 50, mtry = 5, nodesize = 5, samptype = "swr", formula = medv ~ ., data = list(crim = c(2.81838, 0.27957, 4.26131, 0.37578, 73.5341, 0.03961, 0.02009, 6.39312, 0.05789, 0.04379, 0.03445, 14.4208, 0.02187, 0.08187, 0.07978, 2.73397, 0.05479, 0.14103, 0.35809, 0.05735, 0.46296, 2.24236, 41.5292, 0.44178, 9.96654, 0.32264, 0.21124, 0.12269, 0.1146, 0.84054, 0.25356, 0.02729, 0.12204, 5.66637, 0.01538, 0.15936, 0.02055, 0.01501, 18.4982, 0.05023, 0.03584, 0.22188, 2.63548, 0.22489, 0.07886, 0.04684, 0.12083, 0.10084, 0.06417, 11.9511), zn = c(0, 0, 0, 0, 0, 0, 95, 0, 12.5, 80, 82.5, 0, 60, 0, 40, 0, 33, 0, 0, 0, 0, 0, 0, 0, 0, 0, 12.5, 0, 20, 0, 0, 0, 0, 0, 90, 0, 85, 90, 0, 35, 80, 20, 0, 12.5, 80, 0, 0, 0, 0, 0), indus = c(18.1, 9.69, 18.1, 10.59, 18.1, 5.19, 2.68, 18.1, 6.07, 3.37, 2.03, 18.1, 2.93, 2.89, 6.41, 19.58, 2.18, 13.92, 6.2, 4.49, 6.2, 19.58, 18.1, 6.2, 18.1, 21.89, 7.87, 6.91, 6.96, 8.14, 9.9, 7.07, 2.89, 18.1, 3.75, 6.91, 0.74, 1.21, 18.1, 6.06, 3.37, 6.96, 9.9, 7.87, 4.95, 3.41, 2.89, 10.01, 5.96, 18.1), chas = c(1L, 1L, 1L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 1L, 1L, 1L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L), nox = c(0.532, 0.585, 0.77, 0.489, 0.679, 0.515, 0.4161, 0.584, 0.409, 0.398, 0.415, 0.74, 0.401, 0.445, 0.447, 0.871, 0.472, 0.437, 0.507, 0.449, 0.504, 0.605, 0.693, 0.504, 0.74, 0.624, 0.524, 0.448, 0.464, 0.538, 0.544, 0.469, 0.445, 0.74, 0.394, 0.448, 0.41, 0.401, 0.668, 0.4379, 0.398, 0.464, 0.544, 0.524, 0.411, 0.489, 0.445, 0.547, 0.499, 0.659), rm = c(5.762, 5.926, 6.112, 5.404, 5.957, 6.037, 8.034, 6.162, 5.878, 5.787, 6.162, 6.461, 6.8, 7.82, 6.482, 5.597, 6.616, 5.79, 6.951, 6.63, 7.412, 5.854, 5.531, 6.552, 6.485, 5.942, 5.631, 6.069, 6.538, 5.599, 5.705, 7.185, 6.625, 6.219, 7.454, 6.211, 6.383, 7.923, 4.138, 5.706, 6.29, 7.691, 4.973, 6.377, 7.148, 6.417, 8.069, 6.715, 5.933, 5.608), age = c(40.3, 42.6, 81.3, 88.6, 100, 34.5, 31.9, 97.4, 21.4, 31.1, 38.4, 93.3, 9.9, 36.9, 32.1, 94.9, 58.1, 58, 88.5, 56.1, 76.9, 91.8, 85.4, 21.4, 100, 93.5, 100, 40, 58.7, 85.7, 77.7, 61.1, 57.8, 100, 34.2, 6.5, 35.7, 24.8, 100, 28.4, 17.8, 51.8, 37.8, 94.3, 27.7, 66.1, 76, 81.6, 68.2, 100), dis = c(4.0983, 2.3817, 2.5091, 3.665, 1.8026, 5.9853, 5.118, 2.206, 6.498, 6.6115, 6.27, 2.0026, 6.2196, 3.4952, 4.1403, 1.5257, 3.37, 6.32, 2.8617, 4.4377, 3.6715, 2.422, 1.6074, 3.3751, 1.9784, 1.9669, 6.0821, 5.7209, 3.9175, 4.4546, 3.945, 4.9671, 3.4952, 2.0048, 6.3361, 5.7209, 9.1876, 5.885, 1.137, 6.6407, 6.6115, 4.3665, 2.5194, 6.3467, 5.1167, 3.0923, 3.4952, 2.6775, 3.3603, 1.2852), rad = c(24, 6, 24, 4, 24, 5, 4, 24, 4, 4, 2, 24, 1, 2, 4, 5, 7, 4, 8, 3, 8, 5, 24, 8, 24, 4, 5, 3, 3, 4, 4, 2, 2, 24, 3, 3, 2, 1, 24, 1, 4, 3, 4, 5, 4, 2, 2, 6, 5, 24), tax = c(666, 391, 666, 277, 666, 224, 224, 666, 345, 337, 348, 666, 265, 276, 254, 403, 222, 289, 307, 247, 307, 403, 666, 307, 666, 437, 311, 233, 223, 307, 304, 242, 276, 666, 244, 233, 313, 198, 666, 304, 337, 223, 304, 311, 245, 270, 276, 432, 279, 666), ptratio = c(20.2, 19.2, 20.2, 18.6, 20.2, 20.2, 14.7, 20.2, 18.9, 16.1, 14.7, 20.2, 15.6, 18, 17.6, 14.7, 18.4, 16, 17.4, 18.5, 17.4, 14.7, 20.2, 17.4, 20.2, 21.2, 15.2, 17.9, 18.6, 21, 18.4, 17.8, 18, 20.2, 15.9, 17.9, 17.3, 13.6, 20.2, 16.9, 16.1, 18.6, 18.4, 15.2, 19.2, 17.8, 18, 17.8, 19.2, 20.2), b = c(392.92, 396.9, 390.74, 395.24, 16.45, 396.9, 390.55, 302.76, 396.21, 396.9, 393.77, 27.49, 393.37, 393.53, 396.9, 351.85, 393.36, 396.9, 391.7, 392.3, 376.14, 395.11, 329.46, 380.34, 386.73, 378.25, 386.63, 389.39, 394.96, 303.42, 396.42, 392.83, 357.98, 395.69, 386.34, 394.46, 396.9, 395.52, 396.9, 394.02, 396.9, 390.77, 350.45, 392.52, 396.9, 392.18, 396.9, 395.59, 396.9, 332.09), lstat = c(10.42, 13.59, 12.67, 23.98, 20.62, 8.01, 2.88, 24.1, 8.1, 10.24, 7.43, 18.05, 5.03, 3.57, 7.19, 21.45, 8.93, 15.84, 9.71, 6.53, 5.25, 11.64, 27.38, 3.76, 18.85, 16.9, 29.93, 9.55, 7.73, 16.51, 11.5, 4.03, 6.65, 16.59, 3.11, 7.44, 5.77, 3.16, 37.97, 12.43, 4.67, 6.58, 12.64, 20.45, 3.56, 8.81, 4.21, 10.16, 9.68, 12.13), medv = c(21.8, 24.5, 22.6, 19.3, 8.8, 21.1, 50, 13.3, 22, 19.4, 24.1, 9.6, 31.1, 43.8, 29.1, 15.4, 28.4, 20.3, 26.7, 26.6, 31.7, 22.7, 8.5, 31.5, 15.4, 17.4, 16.5, 21.2, 24.4, 13.9, 16.2, 34.7, 28.4, 18.4, 44, 24.7, 24.7, 50, 13.8, 17.1, 23.5, 35.2, 16.1, 15, 37.3, 22.6, 38.7, 22.8, 18.9, 27.9)), membership = TRUE, split_rule = "custom2")
6: do.call(rfsrc, params_rfsrc)
7: rfpi(formula, traindata, testdata, alpha, split_rule = "l1", pi_method = pi_method, rf_package = "rfsrc", params_rfsrc = params_rfsrc)
8: piall(formula, traindata = traindata2, testdata = testdata2[, xvar.names], num.trees = 50)
9: eval(code, test_env)
10: eval(code, test_env)
11: withCallingHandlers({ eval(code, test_env) if (!handled && !is.null(test)) { skip_empty() }}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning, message = handle_message, error = handle_error)
12: doTryCatch(return(expr), name, parentenv, handler)
13: tryCatchOne(expr, names, parentenv, handlers[[1L]])
14: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
15: doTryCatch(return(expr), name, parentenv, handler)
16: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), names[nh], parentenv, handlers[[nh]])
17: tryCatchList(expr, classes, parentenv, handlers)
18: tryCatch(withCallingHandlers({ eval(code, test_env) if (!handled && !is.null(test)) { skip_empty() }}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning, message = handle_message, error = handle_error), error = handle_fatal, skip = function(e) { })
19: test_code(test = NULL, code = exprs, env = env, reporter = get_reporter() %||% StopReporter$new())
20: source_file(path, env = env(env), desc = desc, error_call = error_call)
21: FUN(X[[i]], ...)
22: lapply(test_paths, test_one_file, env = env, desc = desc, error_call = error_call)
23: doTryCatch(return(expr), name, parentenv, handler)
24: tryCatchOne(expr, names, parentenv, handlers[[1L]])
25: tryCatchList(expr, classes, parentenv, handlers)
26: tryCatch(code, testthat_abort_reporter = function(cnd) { cat(conditionMessage(cnd), "\n") NULL})
27: with_reporter(reporters$multi, lapply(test_paths, test_one_file, env = env, desc = desc, error_call = error_call))
28: test_files_serial(test_dir = test_dir, test_package = test_package, test_paths = test_paths, load_helpers = load_helpers, reporter = reporter, env = env, stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning, desc = desc, load_package = load_package, error_call = error_call)
29: test_files(test_dir = path, test_paths = test_paths, test_package = package, reporter = reporter, load_helpers = load_helpers, env = env, stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning, load_package = load_package, parallel = parallel)
30: test_dir("testthat", package = package, reporter = reporter, ..., load_package = "installed")
31: test_check("RFpredInterval")
An irrecoverable exception occurred. R is aborting now ...
Flavor: r-devel-linux-x86_64-fedora-clang
Version: 1.0.8
Check: tests
Result: ERROR
Running ‘testthat.R’ [19s/30s]
Running the tests in ‘tests/testthat.R’ failed.
Complete output:
> library(testthat)
> library(RFpredInterval)
RFpredInterval 1.0.8
>
> test_check("RFpredInterval")
*** caught segfault ***
address 0x1, cause 'memory not mapped'
Traceback:
1: doTryCatch(return(expr), name, parentenv, handler)
2: tryCatchOne(expr, names, parentenv, handlers[[1L]])
3: tryCatchList(expr, classes, parentenv, handlers)
4: tryCatch({ .Call("rfsrcGrow", as.integer(do.trace), as.integer(seed), as.integer(ensemble.bits + impute.only.bits + var.used.bits + split.depth.bits + importance.bits + bootstrap.bits + forest.bits + proximity.bits + perf.bits + rfq.bits + gk.quantile.bits + statistics.bits + empirical.risk.bits), as.integer(samptype.bits + forest.wt.bits + distance.bits + na.action.bits + split.cust.bits + membership.bits + terminal.qualts.bits + terminal.quants.bits + tdc.rule.bits + cse.bits + csv.bits), as.integer(splitinfo$index), as.integer(splitinfo$nsplit), as.integer(mtry), lot, base.learner, as.integer(vtry), as.integer(holdout.array), holdout.specs, as.integer(formulaDetail$ytry), as.integer(nodesize), as.integer(nodedepth), as.integer(length(cause.wt)), as.double(cause.wt), as.integer(ntree), as.integer(n), list(as.integer(length(yvar.types)), if (is.null(yvar.types)) NULL else as.character(yvar.types), if (is.null(yvar.types)) NULL else as.integer(yvar.nlevels), if (is.null(yvar.numeric.levels)) NULL else sapply(1:length(yvar.numeric.levels), function(nn) { as.integer(length(yvar.numeric.levels[[nn]])) }), if (is.null(subj)) NULL else as.integer(subj), if (is.null(event.info)) NULL else as.integer(length(event.info$event.type)), if (is.null(event.info)) NULL else as.integer(event.info$event.type), if (is.null(yvar)) NULL else as.double(as.vector(yvar))), if (is.null(yvar.numeric.levels)) { NULL } else { lapply(1:length(yvar.numeric.levels), function(nn) { as.integer(yvar.numeric.levels[[nn]]) }) }, list(as.integer(n.xvar), as.character(xvar.types), if (is.null(xvar.types)) NULL else as.integer(xvar.nlevels), if (is.null(xvar.numeric.levels)) NULL else sapply(1:length(xvar.numeric.levels), function(nn) { as.integer(length(xvar.numeric.levels[[nn]])) }), if (is.null(xvar.time)) NULL else as.integer(xvar.time), if (is.null(subj.time)) NULL else as.integer(subj.time), as.double(as.vector(xvar))), if (is.null(xvar.numeric.levels)) { NULL } else { lapply(1:length(xvar.numeric.levels), function(nn) { as.integer(xvar.numeric.levels[[nn]]) }) }, list(as.integer(length(case.wt)), if (is.null(case.wt)) NULL else as.double(case.wt), as.integer(sampsize), if (is.null(samp)) NULL else as.integer(samp)), as.double(split.wt), as.double(yvar.wt), as.double(xvar.wt), as.integer(length(event.info$time.interest)), as.double(event.info$time.interest), as.integer(nimpute), as.integer(block.size), as.integer(length(prob)), as.double(prob), as.double(prob.epsilon), as.integer(get.rf.cores()))}, error = function(e) { print(e) NULL})
5: (function (formula, data, ntree = 1000, mtry = NULL, ytry = NULL, nodesize = NULL, nodedepth = NULL, splitrule = NULL, nsplit = 10, importance = c(FALSE, TRUE, "none", "permute", "random", "anti"), block.size = if (any(is.element(as.character(importance), c("none", "FALSE")))) NULL else 10, ensemble = c("all", "oob", "inbag"), bootstrap = c("by.root", "none", "by.user"), samptype = c("swor", "swr"), samp = NULL, membership = FALSE, sampsize = if (samptype == "swor") function(x) { x * 0.632 } else function(x) { x }, na.action = c("na.omit", "na.impute"), nimpute = 1, ntime, cause, proximity = FALSE, distance = FALSE, forest.wt = FALSE, xvar.wt = NULL, yvar.wt = NULL, split.wt = NULL, case.wt = NULL, forest = TRUE, var.used = c(FALSE, "all.trees", "by.tree"), split.depth = c(FALSE, "all.trees", "by.tree"), seed = NULL, do.trace = FALSE, statistics = FALSE, ...) { univariate.nomenclature = TRUE user.option <- list(...) impute.only <- is.hidden.impute.only(user.option) terminal.qualts <- is.hidden.terminal.qualts(user.option) terminal.quants <- is.hidden.terminal.quants(user.option) cse <- is.hidden.cse(user.option) csv <- is.hidden.csv(user.option) perf.type <- is.hidden.perf.type(user.option) rfq <- is.hidden.rfq(user.option) gk.quantile <- is.hidden.gk.quantile(user.option) quantile.regr <- is.hidden.quantile.regr(user.option) prob <- is.hidden.prob(user.option) prob.epsilon <- is.hidden.prob.epsilon(user.option) lot <- is.hidden.lot(user.option) hdim <- lot$hdim base.learner <- is.hidden.base.learner(user.option) vtry <- is.hidden.vtry(user.option) holdout.array <- is.hidden.holdout.array(user.option) holdout.specs <- is.hidden.holdout.specs(user.option) empirical.risk <- is.hidden.empirical.risk(user.option) tdc.rule <- is.hidden.tdc.rule(user.option) ensemble <- match.arg(ensemble, c("all", "oob", "inbag")) bootstrap <- match.arg(bootstrap, c("by.root", "none", "by.user")) if (bootstrap == "none") { ensemble <- "inbag" } importance <- match.arg(as.character(importance), c(FALSE, TRUE, "none", "permute", "random", "anti")) na.action <- match.arg(na.action, c("na.omit", "na.impute")) proximity <- match.arg(as.character(proximity), c(FALSE, TRUE, "inbag", "oob", "all")) distance <- match.arg(as.character(distance), c(FALSE, TRUE, "inbag", "oob", "all")) var.used <- match.arg(as.character(var.used), c("FALSE", "all.trees", "by.tree")) split.depth <- match.arg(as.character(split.depth), c("FALSE", "all.trees", "by.tree")) if (var.used == "FALSE") var.used <- FALSE if (split.depth == "FALSE") split.depth <- FALSE if (missing(data)) stop("data is missing") if (any(is.infinite(unlist(data)))) stop("data contains Inf or -Inf values") if (missing(formula) | (!missing(formula) && is.null(formula))) { if (is.null(ytry)) { formula <- as.formula("Unsupervised() ~ .") } else { formula <- as.formula(paste("Unsupervised(", ytry, ")~.")) } } formulaPrelim <- parseFormula(formula, data, ytry) my.call <- match.call() my.call$formula <- eval(formula) if (any(is.na(data))) { data <- parseMissingData(formulaPrelim, data) miss.flag <- TRUE } else { miss.flag <- FALSE } formulaDetail <- finalizeFormula(formulaPrelim, data) ntree <- round(ntree) if (ntree < 1) stop("Invalid choice of 'ntree'. Cannot be less than 1.") if (!is.null(nodesize) && nodesize < 1) stop("Invalid choice of 'nodesize'. Cannot be less than 1.") if (!is.null(nodedepth)) nodedepth = round(nodedepth) else nodedepth = -1 nimpute <- round(nimpute) if (nimpute < 1) stop("Invalid choice of 'nimpute'. Cannot be less than 1.") seed <- get.seed(seed) family <- formulaDetail$family xvar.names <- formulaDetail$xvar.names yvar.names <- formulaDetail$yvar.names subj.names <- formulaDetail$subj.names if (length(xvar.names) == 0) { stop("something seems wrong: your formula did not define any x-variables") } if (family != "unsupv" && length(yvar.names) == 0) { stop("something seems wrong: your formula did not define any y-variables") } if (family == "class") { if (length(setdiff(levels(data[, yvar.names]), unique(data[, yvar.names]))) > 0) { warning("empty classes found when implementing classification\n") } } data <- rm.na.levels(data, xvar.names) data <- rm.na.levels(data, yvar.names) yfactor <- extract.factor(data, yvar.names) yfactor$types <- yvar.types <- get.yvar.type(family, yfactor$generic.types, yvar.names) yfactor$nlevels <- yvar.nlevels <- get.yvar.nlevels(family, yfactor$nlevels, yvar.names, data) xfactor <- extract.factor(data, xvar.names) xfactor$types <- xvar.types <- xfactor$generic.types xvar.nlevels <- xfactor$nlevels data <- finalizeData(c(subj.names, yvar.names, xvar.names), data, na.action, miss.flag) data.row.names <- rownames(data) xvar <- as.matrix(data[, xvar.names, drop = FALSE]) rownames(xvar) <- colnames(xvar) <- NULL xfactor$numeric.levels <- xvar.numeric.levels <- get.numeric.levels(family, xfactor$nlevels, xvar) n <- nrow(xvar) n.xvar <- length(xvar.names) mtry <- get.grow.mtry(mtry, n.xvar, family) samptype <- match.arg(samptype, c("swor", "swr")) subj.unique.count <- n subj <- NULL xvar.time <- NULL subj.time <- NULL if (bootstrap == "by.root") { if (!is.function(sampsize) && !is.numeric(sampsize)) { stop("sampsize must be a function or number specifying size of subsampled data") } if (is.function(sampsize)) { sampsize.function <- sampsize } else { sampsize.function <- make.samplesize.function(sampsize/subj.unique.count) } sampsize <- round(sampsize.function(subj.unique.count)) if (sampsize < 1) { stop("sampsize must be greater than zero") } if (samptype == "swor" && (sampsize > subj.unique.count)) { sampsize.function <- function(x) { x } sampsize <- subj.unique.count } samp <- NULL case.wt <- get.weight(case.wt, subj.unique.count) } else if (bootstrap == "by.user") { if (is.null(samp)) { stop("samp must not be NULL when bootstrapping by user") } ntree <- ncol(samp) sampsize <- colSums(samp) if (sum(sampsize == sampsize[1]) != ntree) { stop("sampsize must be identical for each tree") } sampsize <- sampsize[1] sampsize.function <- make.samplesize.function(sampsize[1]/subj.unique.count) case.wt <- get.weight(NULL, subj.unique.count) } else { sampsize <- subj.unique.count sampsize.function <- function(x) { x } case.wt <- get.weight(case.wt, sampsize) } split.wt <- get.weight(split.wt, n.xvar) forest.wt <- match.arg(as.character(forest.wt), c(FALSE, TRUE, "inbag", "oob", "all")) if (family == "unspv") { yvar.wt <- NULL } else { yvar.wt <- get.weight(yvar.wt, length(yvar.types)) } xvar.wt <- get.weight(xvar.wt, n.xvar) yvar <- as.matrix(data[, yvar.names, drop = FALSE]) if (dim(yvar)[2] == 0) { yvar <- yvar.nlevels <- yvar.numeric.levels <- yfactor <- NULL } else { yfactor$numeric.levels <- yvar.numeric.levels <- get.numeric.levels(family, yfactor$nlevels, yvar) } if (miss.flag) { n.miss <- get.nmiss(xvar, yvar) } else { n.miss <- 0 } if (impute.only && n.miss == 0) { return(data) } remove(data) big.data <- FALSE event.info <- get.grow.event.info(yvar, family, ntime = ntime) splitinfo <- get.grow.splitinfo(formulaDetail, splitrule, hdim, nsplit, event.info) if (family == "surv" || family == "surv-CR") { if (length(event.info$event.type) > 1) { if (missing(cause) || is.null(cause)) { cause <- NULL cause.wt <- rep(1, length(event.info$event.type)) } else { if (length(cause) == 1) { if (cause >= 1 && cause <= length(event.info$event.type)) { cause.wt <- rep(0, length(event.info$event.type)) cause.wt[cause] <- 1 } else { cause.wt <- rep(1, length(event.info$event.type)) } } else { if (length(cause) == length(event.info$event.type) && all(cause >= 0) && !all(cause == 0)) { cause.wt <- cause/sum(cause) } else { cause.wt <- rep(1, length(event.info$event.type)) } } } } else { cause <- NULL cause.wt = 1 } family <- get.coerced.survival.fmly(family, subj, event.info$event.type, splitinfo$name) } else { cause <- cause.wt <- NULL } nodesize <- get.grow.nodesize(family, nodesize) if ((bootstrap != "by.root") && (bootstrap != "by.user")) { importance <- "none" perf.type <- "none" } if (family == "unsupv") { importance <- "none" perf.type <- "none" } if (impute.only) { forest <- FALSE proximity <- FALSE distance <- FALSE var.used <- FALSE split.depth <- FALSE membership <- FALSE perf.type <- "none" importance <- "none" terminal.qualts <- FALSE terminal.quants <- FALSE cse <- FALSE csv <- FALSE } if (!is.null(holdout.array)) { if (nrow(holdout.array) != n.xvar | ncol(holdout.array) != ntree) { stop("dimension of holdout.array does not conform to p x ntree") } vtry <- 1 } gk.quantile <- get.gk.quantile(gk.quantile) prob.assign <- global.prob.assign(prob, prob.epsilon, gk.quantile, quantile.regr, splitinfo$name, n) prob <- prob.assign$prob prob.epsilon <- prob.assign$prob.epsilon if (terminal.qualts | terminal.quants) { forest <- TRUE } ensemble.bits <- get.ensemble(ensemble) impute.only.bits <- get.impute.only(impute.only, n.miss) var.used.bits <- get.var.used(var.used) split.depth.bits <- get.split.depth(split.depth) importance.bits <- get.importance(importance) bootstrap.bits <- get.bootstrap(bootstrap) forest.bits <- get.forest(forest) proximity.bits <- get.proximity(TRUE, proximity) distance.bits <- get.distance(TRUE, distance) membership.bits <- get.membership(membership) statistics.bits <- get.statistics(statistics) split.cust.bits <- get.split.cust(splitinfo$cust) perf.type <- get.perf(perf.type, impute.only, family) perf.bits <- get.perf.bits(perf.type) rfq <- get.rfq(rfq) rfq.bits <- get.rfq.bits(rfq, family) gk.quantile.bits <- get.gk.quantile.bits(gk.quantile) empirical.risk.bits <- get.empirical.risk.bits(empirical.risk) tdc.rule.bits <- get.tdc.rule.bits(tdc.rule) samptype.bits <- get.samptype(samptype) forest.wt.bits <- get.forest.wt(TRUE, bootstrap, forest.wt) na.action.bits <- get.na.action(na.action) block.size <- get.block.size(block.size, ntree) terminal.qualts.bits <- get.terminal.qualts(terminal.qualts, FALSE) terminal.quants.bits <- get.terminal.quants(terminal.quants, FALSE) cse.bits = get.cse(cse) csv.bits = get.csv(csv) do.trace <- get.trace(do.trace) nativeOutput <- tryCatch({ .Call("rfsrcGrow", as.integer(do.trace), as.integer(seed), as.integer(ensemble.bits + impute.only.bits + var.used.bits + split.depth.bits + importance.bits + bootstrap.bits + forest.bits + proximity.bits + perf.bits + rfq.bits + gk.quantile.bits + statistics.bits + empirical.risk.bits), as.integer(samptype.bits + forest.wt.bits + distance.bits + na.action.bits + split.cust.bits + membership.bits + terminal.qualts.bits + terminal.quants.bits + tdc.rule.bits + cse.bits + csv.bits), as.integer(splitinfo$index), as.integer(splitinfo$nsplit), as.integer(mtry), lot, base.learner, as.integer(vtry), as.integer(holdout.array), holdout.specs, as.integer(formulaDetail$ytry), as.integer(nodesize), as.integer(nodedepth), as.integer(length(cause.wt)), as.double(cause.wt), as.integer(ntree), as.integer(n), list(as.integer(length(yvar.types)), if (is.null(yvar.types)) NULL else as.character(yvar.types), if (is.null(yvar.types)) NULL else as.integer(yvar.nlevels), if (is.null(yvar.numeric.levels)) NULL else sapply(1:length(yvar.numeric.levels), function(nn) { as.integer(length(yvar.numeric.levels[[nn]])) }), if (is.null(subj)) NULL else as.integer(subj), if (is.null(event.info)) NULL else as.integer(length(event.info$event.type)), if (is.null(event.info)) NULL else as.integer(event.info$event.type), if (is.null(yvar)) NULL else as.double(as.vector(yvar))), if (is.null(yvar.numeric.levels)) { NULL } else { lapply(1:length(yvar.numeric.levels), function(nn) { as.integer(yvar.numeric.levels[[nn]]) }) }, list(as.integer(n.xvar), as.character(xvar.types), if (is.null(xvar.types)) NULL else as.integer(xvar.nlevels), if (is.null(xvar.numeric.levels)) NULL else sapply(1:length(xvar.numeric.levels), function(nn) { as.integer(length(xvar.numeric.levels[[nn]])) }), if (is.null(xvar.time)) NULL else as.integer(xvar.time), if (is.null(subj.time)) NULL else as.integer(subj.time), as.double(as.vector(xvar))), if (is.null(xvar.numeric.levels)) { NULL } else { lapply(1:length(xvar.numeric.levels), function(nn) { as.integer(xvar.numeric.levels[[nn]]) }) }, list(as.integer(length(case.wt)), if (is.null(case.wt)) NULL else as.double(case.wt), as.integer(sampsize), if (is.null(samp)) NULL else as.integer(samp)), as.double(split.wt), as.double(yvar.wt), as.double(xvar.wt), as.integer(length(event.info$time.interest)), as.double(event.info$time.interest), as.integer(nimpute), as.integer(block.size), as.integer(length(prob)), as.double(prob), as.double(prob.epsilon), as.integer(get.rf.cores())) }, error = function(e) { print(e) NULL }) if (is.null(nativeOutput)) { if (impute.only) { return(NULL) } else { stop("An error has occurred in the grow algorithm. Please turn trace on for further analysis.") } } if (n.miss > 0) { imputed.data <- matrix(nativeOutput$imputation, nrow = n.miss, byrow = FALSE) imputed.indv <- imputed.data[, 1] imputed.data <- as.matrix(imputed.data[, -1, drop = FALSE]) nativeOutput$imputation <- NULL if (nimpute > 1) { if (grepl("surv", family)) { yvar[imputed.indv, 1] <- imputed.data[, 1] yvar[imputed.indv, 2] <- imputed.data[, 2] xvar[imputed.indv, ] <- imputed.data[, -c(1:2), drop = FALSE] } else { if (!is.null(yvar.types)) { yvar[imputed.indv, ] <- imputed.data[, 1:length(yvar.types), drop = FALSE] xvar[imputed.indv, ] <- imputed.data[, -c(1:length(yvar.types)), drop = FALSE] } else { xvar[imputed.indv, ] <- imputed.data } } imputed.indv <- NULL imputed.data <- NULL imputedOOBData <- NULL na.action = "na.omit" } else { colnames(imputed.data) <- c(yvar.names, xvar.names) imputed.data <- as.data.frame(imputed.data) } } xvar <- as.data.frame(xvar) rownames(xvar) <- data.row.names colnames(xvar) <- xvar.names xvar <- map.factor(xvar, xfactor) if (family != "unsupv") { yvar <- as.data.frame(yvar) colnames(yvar) <- yvar.names } else { yvar <- NULL } if (family != "unsupv") { if (family == "regr+" | family == "class+" | family == "mix+") { yvar <- map.factor(yvar, yfactor) } else { yvar <- amatrix.remove.names(map.factor(yvar, yfactor)) } } pi.hat <- NULL if (family == "class" && rfq) { pi.hat <- table(yvar)/length(yvar) } if ((n.miss > 0) & (nimpute < 2)) { imputed.data <- map.factor(imputed.data, xfactor) if (family != "unsupv") { imputed.data <- map.factor(imputed.data, yfactor) } } if (forest) { nativeArraySize = 0 if (hdim == 0) { mwcpCountSummary <- rep(0, 1) nativeFactorArray <- vector("list", 1) } else { mwcpCountSummary = rep(0, hdim) nativeFactorArray <- vector("list", hdim) } pivot <- which(names(nativeOutput) == "treeID") if (hdim == 0) { offset = 0 } else { offset = 7 if (!is.null(base.learner)) { if (base.learner$interact.depth > 1) { offset = offset + 3 } } if (!is.null(base.learner)) { if (base.learner$synthetic.depth > 1) { offset = offset + 2 } } } if (!is.null(base.learner)) { if (base.learner$synthetic.depth > 1) { mwcpCountSummarySyth <- rep(0, 1) nullO <- lapply(1:ntree, function(b) { mwcpCountSummarySyth[1] <<- mwcpCountSummarySyth[1] + nativeOutput$mwcpCTsyth[b] NULL }) } } nullO <- lapply(1:ntree, function(b) { if (nativeOutput$leafCount[b] > 0) { nativeArraySize <<- nativeArraySize + (2 * nativeOutput$leafCount[b]) - 1 mwcpCountSummary[1] <<- mwcpCountSummary[1] + nativeOutput$mwcpCT[b] if (hdim > 1) { for (i in 2:hdim) { mwcpCountSummary[i] <<- mwcpCountSummary[i] + nativeOutput[[pivot + (offset + 2) + (5 * (hdim - 1)) + (i - 2)]][b] } } } else { nativeArraySize <<- nativeArraySize + 1 } NULL }) rm(nullO) nativeArray <- as.data.frame(cbind(nativeOutput$treeID[1:nativeArraySize], nativeOutput$nodeID[1:nativeArraySize])) nativeArrayHeader <- c("treeID", "nodeID") nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput$parmID[1:nativeArraySize], nativeOutput$contPT[1:nativeArraySize], nativeOutput$mwcpSZ[1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, "parmID", "contPT", "mwcpSZ") if (mwcpCountSummary[1] > 0) { nativeFactorArray[[1]] <- nativeOutput$mwcpPT[1:mwcpCountSummary[1]] } nativeFactorArrayHeader <- "mwcpPT" if (hdim > 0) { if (!is.null(base.learner)) { if (base.learner$interact.depth > 1) { nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput$pairCT[1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, "pairCT") } if (base.learner$synthetic.depth > 1) { nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput$sythSZ[1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, "sythSZ") } if (base.learner$interact.depth > 1) { nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput$augmXone[1:nativeArraySize], nativeOutput$augmXtwo[1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, "augmXone", "augmXtwo") } if (base.learner$synthetic.depth > 1) { nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput$augmXS[1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, "augmXS") } } nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, "hcDim") nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset + 1]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, "contPTR") offset = offset + 2 } if (hdim > 1) { for (i in 2:hdim) { nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset + (0 * (hdim - 1)) + i - 2]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, paste("parmID", i, sep = "")) nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset + (1 * (hdim - 1)) + i - 2]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, paste("contPT", i, sep = "")) nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset + (2 * (hdim - 1)) + i - 2]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, paste("contPTR", i, sep = "")) nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset + (3 * (hdim - 1)) + i - 2]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, paste("mwcpSZ", i, sep = "")) if (mwcpCountSummary[i] > 0) { nativeFactorArray[[i]] <- nativeOutput[[pivot + offset + (4 * (hdim - 1)) + i - 2]][1:mwcpCountSummary[i]] } nativeFactorArrayHeader <- c(nativeFactorArrayHeader, paste("mwcpPT", i, sep = "")) if (!is.null(base.learner)) { hdim.multiplier <- 6 if (base.learner$interact.depth > 1) { nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset + (hdim.multiplier * (hdim - 1)) + i - 2]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, paste("augmXone", i, sep = "")) hdim.multiplier <- hdim.multiplier + 1 nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset + (hdim.multiplier * (hdim - 1)) + i - 2]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, paste("augmXtwo", i, sep = "")) hdim.multiplier <- hdim.multiplier + 1 } if (base.learner$synthetic.depth > 1) { nativeArray <- as.data.frame(cbind(nativeArray, nativeOutput[[pivot + offset + (hdim.multiplier * (hdim - 1)) + i - 2]][1:nativeArraySize])) nativeArrayHeader <- c(nativeArrayHeader, paste("augmXS", i, sep = "")) } } } } nativeArraySyth <- nativeFactorArraySyth <- NULL nodeCountSyth <- NULL totalNodeCountSyth = 0 if (!is.null(base.learner)) { if (base.learner$synthetic.depth > 1) { if (!is.null(nativeOutput$treeIDsyth)) { nativeArraySyth <- as.data.frame(cbind(nativeOutput$treeIDsyth, nativeOutput$nodeIDsyth, nativeOutput$hcDimsyth, nativeOutput$parmIDsyth, nativeOutput$contPTsyth, nativeOutput$contPTRsyth, nativeOutput$mwcpSZsyth)) nativeArrayHeaderSyth <- c("treeID", "nodeID", "hcDim", "parmID", "contPT", "contPTR", "mwcpSZ") names(nativeArraySyth) = nativeArrayHeaderSyth totalNodeCountSyth <- length(nativeOutput$treeIDsyth) nodeCountSyth <- nativeOutput$nodeCountSyth if (mwcpCountSummarySyth[1] > 0) { nativeFactorArraySyth <- nativeOutput$mwcpPTsyth[1:mwcpCountSummarySyth[1]] nativeFactorArrayHeaderSyth <- "mwcpPT" names(nativeFactorArraySyth) = nativeFactorArrayHeaderSyth } } } } names(nativeArray) <- nativeArrayHeader names(nativeFactorArray) <- nativeFactorArrayHeader if (terminal.qualts | terminal.quants) { totalLeafCount <- sum(nativeOutput$leafCount) valid.mcnt.indices <- 1:totalLeafCount if (terminal.quants) { if (grepl("surv", family)) { valid.2D.surv.indices <- 1:(totalLeafCount * length(event.info$event.type) * length(event.info$time.interest)) valid.1D.surv.indices <- 1:(totalLeafCount * length(event.info$time.interest)) valid.mort.indices <- 1:(totalLeafCount * length(event.info$event.type)) } else { class.index <- which(yvar.types != "R") class.count <- length(class.index) regr.index <- which(yvar.types == "R") regr.count <- length(regr.index) if (class.count > 0) { levels.count <- array(0, class.count) counter <- 0 for (i in class.index) { counter <- counter + 1 levels.count[counter] <- yvar.nlevels[i] } valid.clas.indices <- 1:(totalLeafCount * sum(levels.count)) } if (regr.count > 0) { valid.regr.indices <- 1:(totalLeafCount * regr.count) } } } nativeArrayTNDS <- list(if (!is.null(nativeOutput$tnSURV)) nativeOutput$tnSURV[valid.1D.surv.indices] else NULL, if (!is.null(nativeOutput$tnMORT)) nativeOutput$tnMORT[valid.mort.indices] else NULL, if (!is.null(nativeOutput$tnNLSN)) nativeOutput$tnNLSN[valid.1D.surv.indices] else NULL, if (!is.null(nativeOutput$tnCSHZ)) nativeOutput$tnCSHZ[valid.2D.surv.indices] else NULL, if (!is.null(nativeOutput$tnCIFN)) nativeOutput$tnCIFN[valid.2D.surv.indices] else NULL, if (!is.null(nativeOutput$tnREGR)) nativeOutput$tnREGR[valid.regr.indices] else NULL, if (!is.null(nativeOutput$tnCLAS)) nativeOutput$tnCLAS[valid.clas.indices] else NULL, nativeOutput$rmbrMembership, nativeOutput$ambrMembership, nativeOutput$tnRCNT[valid.mcnt.indices], nativeOutput$tnACNT[valid.mcnt.indices]) names(nativeArrayTNDS) <- c("tnSURV", "tnMORT", "tnNLSN", "tnCSHZ", "tnCIFN", "tnREGR", "tnCLAS", "tnRMBR", "tnAMBR", "tnRCNT", "tnACNT") } else { nativeArrayTNDS <- NULL } if (statistics) { node.stats <- as.data.frame(cbind(nativeOutput$spltST[1:nativeArraySize], nativeOutput$dpthST[1:nativeArraySize])) names(node.stats) <- c("spltST", "dpthST") } else { node.stats <- NULL } forest.out <- list(forest = TRUE, hdim = hdim, base.learner = base.learner, nativeArray = nativeArray, nativeFactorArray = nativeFactorArray, totalNodeCount = dim(nativeArray)[1], nativeArraySyth = nativeArraySyth, nativeFactorArraySyth = nativeFactorArraySyth, nodeCountSyth = nodeCountSyth, nodesize = nodesize, nodedepth = nodedepth, ntree = ntree, family = family, n = n, splitrule = splitinfo$name, yvar = yvar, yvar.names = yvar.names, yvar.factor = yfactor, xvar = xvar, xvar.names = xvar.names, xvar.factor = xfactor, event.info = event.info, subj = subj, subj.names = subj.names, seed = nativeOutput$seed, bootstrap = bootstrap, sampsize = sampsize.function, samptype = samptype, samp = samp, case.wt = case.wt, terminal.qualts = terminal.qualts, terminal.quants = terminal.quants, nativeArrayTNDS = nativeArrayTNDS, version = "2.11.0", na.action = na.action, perf.type = perf.type, rfq = rfq, gk.quantile = gk.quantile, quantile.regr = quantile.regr, prob = prob, prob.epsilon = prob.epsilon, block.size = block.size) if (grepl("surv", family)) { forest.out$time.interest <- event.info$time.interest } class(forest.out) <- c("rfsrc", "forest", family) if (big.data) { class(forest.out) <- c(class(forest.out), "bigdata") } } else { node.stats <- NULL forest.out <- list(forest = FALSE, hdim = hdim, base.learner = base.learner, nodesize = nodesize, nodedepth = nodedepth, ntree = ntree, family = family, n = n, splitrule = splitinfo$name, yvar = yvar, yvar.names = yvar.names, xvar = xvar, xvar.names = xvar.names, subj = subj, subj.names = subj.names, seed = nativeOutput$seed, bootstrap = bootstrap, sampsize = sampsize.function, samptype = samptype, samp = samp, case.wt = case.wt, version = "2.11.0", na.action = na.action, perf.type = perf.type, rfq = rfq, gk.quantile = gk.quantile, quantile.regr = quantile.regr, prob = prob, prob.epsilon = prob.epsilon, block.size = block.size) } if (proximity != FALSE) { proximity.out <- matrix(0, n, n) count <- 0 for (k in 1:n) { proximity.out[k, 1:k] <- nativeOutput$proximity[(count + 1):(count + k)] proximity.out[1:k, k] <- proximity.out[k, 1:k] count <- count + k } nativeOutput$proximity <- NULL } else { proximity.out <- NULL } if (distance != FALSE) { distance.out <- matrix(0, n, n) count <- 0 for (k in 1:n) { distance.out[k, 1:k] <- nativeOutput$distance[(count + 1):(count + k)] distance.out[1:k, k] <- distance.out[k, 1:k] count <- count + k } nativeOutput$distance <- NULL } else { distance.out <- NULL } if (forest.wt != FALSE) { forest.wt.out <- matrix(nativeOutput$weight, c(n, n), byrow = TRUE) nativeOutput$weight <- NULL } else { forest.wt.out <- NULL } if (membership) { membership.out <- matrix(nativeOutput$nodeMembership, c(n, ntree)) inbag.out <- matrix(nativeOutput$bootMembership, c(n, ntree)) nativeOutput$nodeMembership <- NULL nativeOutput$bootMembership <- NULL if (!is.null(subj)) { tdc.membership.cnt <- matrix(nativeOutput$nodeMembershipTDC[[1]], c(n, ntree)) tdc.membership.out <- vector("list", ntree) begin.indx <- 0 end.indx <- 0 for (i in 1:ntree) { temp <- vector("list", n) for (j in 1:n) { begin.indx <- end.indx + 1 end.indx <- end.indx + tdc.membership.cnt[j, i] temp[[j]] <- nativeOutput$nodeMembershipTDC[[2]][begin.indx:end.indx] } tdc.membership.out[[i]] <- temp } } else { tdc.membership.out <- NULL } } else { membership.out <- NULL inbag.out <- NULL tdc.membership.out <- NULL } if (var.used != FALSE) { if (var.used == "all.trees") { var.used.out <- nativeOutput$varUsed names(var.used.out) <- xvar.names } else { var.used.out <- matrix(nativeOutput$varUsed, nrow = ntree, byrow = TRUE) colnames(var.used.out) <- xvar.names } nativeOutput$varUsed <- NULL } else { var.used.out <- NULL } if (split.depth != FALSE) { if (split.depth == "all.trees") { split.depth.out <- array(nativeOutput$splitDepth, c(n, n.xvar)) } else { split.depth.out <- array(nativeOutput$splitDepth, c(n, n.xvar, ntree)) } nativeOutput$splitDepth <- NULL } else { split.depth.out <- NULL } empr.risk <- NULL oob.empr.risk <- NULL if (empirical.risk) { if (!is.null(nativeOutput$emprRisk)) { empr.risk <- array(nativeOutput$emprRisk, c(lot$treesize, ntree)) nativeOutput$emprRisk <- NULL } if (!is.null(nativeOutput$oobEmprRisk)) { oob.empr.risk <- array(nativeOutput$oobEmprRisk, c(lot$treesize, ntree)) nativeOutput$oobEmprRisk <- NULL } } if (!is.null(holdout.specs)) { holdout.blk <- nativeOutput$holdoutBlk nativeOutput$holdoutBlk <- NULL } else { holdout.blk = NULL } rfsrcOutput <- list(call = my.call, family = family, n = n, ntree = ntree, nimpute = nimpute, mtry = mtry, nodesize = nodesize, nodedepth = nodedepth, nsplit = splitinfo$nsplit, yvar = yvar, yvar.names = yvar.names, xvar = xvar, xvar.names = xvar.names, event.info = event.info, subj = subj, subj.names = subj.names, xvar.wt = xvar.wt, split.wt = split.wt, cause.wt = cause.wt, leaf.count = nativeOutput$leafCount, proximity = proximity.out, forest = forest.out, forest.wt = forest.wt.out, distance = distance.out, membership = membership.out, tdc.membership = tdc.membership.out, splitrule = splitinfo$name, inbag = inbag.out, var.used = var.used.out, imputed.indv = (if (n.miss > 0) imputed.indv else NULL), imputed.data = (if (n.miss > 0) imputed.data else NULL), split.depth = split.depth.out, node.stats = node.stats, ensemble = ensemble, holdout.array = holdout.array, block.size = block.size, holdout.blk = holdout.blk, empr.risk = empr.risk, oob.empr.risk = oob.empr.risk) remove(yvar) remove(xvar) nativeOutput$leafCount <- NULL remove(proximity.out) remove(forest.out) remove(forest.wt.out) remove(distance.out) remove(membership.out) remove(inbag.out) remove(var.used.out) if (n.miss > 0) remove(imputed.indv) if (n.miss > 0) remove(imputed.data) remove(split.depth.out) remove(holdout.array) remove(empr.risk) remove(oob.empr.risk) survOutput <- NULL classOutput <- NULL regrOutput <- NULL if (!impute.only) { if (grepl("surv", family)) { if ((length(event.info$event.type) > 1) && (splitinfo$name != "l2.impute") && (splitinfo$name != "logrankscore")) { coerced.event.count <- length(event.info$event.type) } else { coerced.event.count <- 1 } if (family == "surv") { ens.names <- list(NULL, NULL) mortality.names <- list(NULL, NULL) err.names <- list(NULL, NULL) vimp.names <- list(NULL, xvar.names) } else if (family == "surv-CR") { ens.names <- list(NULL, NULL, c(paste("condCHF.", 1:length(event.info$event.type), sep = ""))) mortality.names <- list(NULL, paste("event.", 1:length(event.info$event.type), sep = "")) cif.names <- list(NULL, NULL, c(paste("CIF.", 1:length(event.info$event.type), sep = ""))) err.names <- list(c(paste("event.", 1:length(event.info$event.type), sep = "")), NULL) vimp.names <- list(paste("event.", 1:length(event.info$event.type), sep = ""), xvar.names) } else { ens.names <- list(NULL, NULL) } chf <- (if (!is.null(nativeOutput$allEnsbCHF)) adrop3d.last(array(nativeOutput$allEnsbCHF, c(n, length(event.info$time.interest), length(event.info$event.type)), dimnames = ens.names), coerced.event.count) else NULL) nativeOutput$allEnsbCHF <- NULL survOutput <- list(chf = chf) remove(chf) chf.oob <- (if (!is.null(nativeOutput$oobEnsbCHF)) adrop3d.last(array(nativeOutput$oobEnsbCHF, c(n, length(event.info$time.interest), length(event.info$event.type)), dimnames = ens.names), coerced.event.count) else NULL) nativeOutput$oobEnsbCHF <- NULL survOutput = c(survOutput, chf.oob = list(chf.oob)) remove(chf.oob) predicted <- (if (!is.null(nativeOutput$allEnsbMRT)) adrop2d.last(array(nativeOutput$allEnsbMRT, c(n, length(event.info$event.type)), dimnames = mortality.names), coerced.event.count) else NULL) nativeOutput$allEnsbMRT <- NULL survOutput = c(survOutput, predicted = list(predicted)) remove(predicted) predicted.oob <- (if (!is.null(nativeOutput$oobEnsbMRT)) adrop2d.last(array(nativeOutput$oobEnsbMRT, c(n, length(event.info$event.type)), dimnames = mortality.names), coerced.event.count) else NULL) nativeOutput$oobEnsbMRT <- NULL survOutput <- c(survOutput, predicted.oob = list(predicted.oob)) remove(predicted.oob) hazard <- (if (!is.null(nativeOutput$allEnsbKHZ)) matrix(nativeOutput$allEnsbKHZ, c(subj.unique.count, length(event.info$time.interest))) else NULL) nativeOutput$allEnsbKHZ <- NULL survOutput <- c(survOutput, hazard = list(hazard)) remove(hazard) hazard.oob <- (if (!is.null(nativeOutput$oobEnsbKHZ)) matrix(nativeOutput$oobEnsbKHZ, c(subj.unique.count, length(event.info$time.interest))) else NULL) nativeOutput$oobEnsbKHZ <- NULL survOutput <- c(survOutput, hazard.oob = list(hazard.oob)) remove(hazard.oob) survival <- (if (!is.null(nativeOutput$allEnsbSRV)) matrix(nativeOutput$allEnsbSRV, c(n, length(event.info$time.interest))) else NULL) nativeOutput$allEnsbSRV <- NULL survOutput <- c(survOutput, survival = list(survival)) remove(survival) survival.oob <- (if (!is.null(nativeOutput$oobEnsbSRV)) matrix(nativeOutput$oobEnsbSRV, c(n, length(event.info$time.interest))) else NULL) nativeOutput$oobEnsbSRV <- NULL survOutput <- c(survOutput, survival.oob = list(survival.oob)) remove(survival.oob) cif <- (if (!is.null(nativeOutput$allEnsbCIF)) array(nativeOutput$allEnsbCIF, c(n, length(event.info$time.interest), length(event.info$event.type)), dimnames = cif.names) else NULL) nativeOutput$allEnsbCIF <- NULL survOutput <- c(survOutput, cif = list(cif)) remove(cif) cif.oob <- (if (!is.null(nativeOutput$oobEnsbCIF)) array(nativeOutput$oobEnsbCIF, c(n, length(event.info$time.interest), length(event.info$event.type)), dimnames = cif.names) else NULL) nativeOutput$oobEnsbCIF <- NULL survOutput = c(survOutput, cif.oob = list(cif.oob)) remove(cif.oob) if (!is.null(nativeOutput$perfSurv)) { err.rate <- adrop2d.first(array(nativeOutput$perfSurv, c(length(event.info$event.type), ntree), dimnames = err.names), coerced.event.count) nativeOutput$perfSurv <- NULL if (family == "surv-CR") { survOutput = c(survOutput, err.rate = list(t(err.rate))) } else { survOutput = c(survOutput, err.rate = list(err.rate)) } remove(err.rate) } if (!is.null(nativeOutput$blockSurv)) { err.block.rate <- adrop2d.first(array(nativeOutput$blockSurv, c(length(event.info$event.type), floor(ntree/block.size)), dimnames = err.names), coerced.event.count) nativeOutput$blockSurv <- NULL if (family == "surv-CR") { survOutput = c(survOutput, err.block.rate = list(t(err.block.rate))) } else { survOutput = c(survOutput, err.block.rate = list(err.block.rate)) } remove(err.block.rate) } if (!is.null(nativeOutput$vimpSurv)) { importance <- adrop2d.first(array(nativeOutput$vimpSurv, c(length(event.info$event.type), n.xvar), dimnames = vimp.names), coerced.event.count) nativeOutput$vimpSurv <- NULL if (family == "surv-CR") { survOutput = c(survOutput, importance = list(t(importance))) } else { survOutput = c(survOutput, importance = list(importance)) } remove(importance) } survOutput = c(survOutput, list(time.interest = event.info$time.interest, ndead = sum(na.omit(event.info$cens) != 0))) if (!is.null(nativeOutput$holdoutSurv)) { holdout.vimp <- vector("list", length(rfsrcOutput$holdout.blk)) names(holdout.vimp) <- xvar.names holdout.offset <- rfsrcOutput$holdout.blk * length(event.info$event.type) holdout.offset.sum <- c(0, cumsum(holdout.offset)) for (i in 1:length(holdout.vimp)) { if (rfsrcOutput$holdout.blk[i] > 0) { if (length(event.info$event.type) > 1) { holdout.vimp[[i]] <- array(nativeOutput$holdoutSurv[(holdout.offset.sum[i] + 1):holdout.offset.sum[i + 1]], c(length(event.info$event.type), rfsrcOutput$holdout.blk[i])) } else { holdout.vimp[[i]] <- nativeOutput$holdoutSurv[(holdout.offset.sum[i] + 1):holdout.offset.sum[i + 1]] } } else { holdout.vimp[[i]] = NA } } survOutput = c(survOutput, holdout.vimp = list(holdout.vimp)) remove(holdout.vimp) } if (univariate.nomenclature) { rfsrcOutput <- c(rfsrcOutput, survOutput) } else { rfsrcOutput <- c(rfsrcOutput, survOutput = list(survOutput)) } } else { class.index <- which(yvar.types != "R") resp.clas.count <- length(class.index) regr.index <- which(yvar.types == "R") resp.regr.count <- length(regr.index) if (resp.clas.count > 0) { classOutput <- vector("list", resp.clas.count) names(classOutput) <- yvar.names[class.index] levels.count <- array(0, resp.clas.count) levels.names <- vector("list", resp.clas.count) counter <- 0 for (i in class.index) { counter <- counter + 1 levels.count[counter] <- yvar.nlevels[i] if (yvar.types[i] == "C") { levels.names[[counter]] <- yfactor$levels[[which(yfactor$factor == yvar.names[i])]] } else { levels.names[[counter]] <- yfactor$order.levels[[which(yfactor$order == yvar.names[i])]] } } tree.offset <- array(1, ntree) if (ntree > 1) { tree.offset[2:ntree] <- sum(1 + levels.count) } tree.offset <- cumsum(tree.offset) block.offset <- array(1, floor(ntree/block.size)) if (floor(ntree/block.size) > 1) { block.offset[2:floor(ntree/block.size)] <- sum(1 + levels.count) } block.offset <- cumsum(block.offset) vimp.offset <- array(1, n.xvar) if (n.xvar > 1) { vimp.offset[2:n.xvar] <- sum(1 + levels.count) } vimp.offset <- cumsum(vimp.offset) iter.ensb.start <- 0 iter.ensb.end <- 0 if (!is.null(nativeOutput$holdoutClas)) { holdout.offset.x <- rfsrcOutput$holdout.blk * (sum(1 + levels.count)) holdout.offset.sum.x <- c(0, cumsum(holdout.offset.x)) holdout.offset.r <- 0 } for (i in 1:resp.clas.count) { iter.ensb.start <- iter.ensb.end iter.ensb.end <- iter.ensb.end + (levels.count[i] * n) ens.names <- list(NULL, levels.names[[i]]) err.names <- c("all", levels.names[[i]]) vimp.names <- list(c("all", levels.names[[i]]), xvar.names) predicted <- (if (!is.null(nativeOutput$allEnsbCLS)) array(nativeOutput$allEnsbCLS[(iter.ensb.start + 1):iter.ensb.end], c(n, levels.count[i]), dimnames = ens.names) else NULL) classOutput[[i]] <- list(predicted = predicted) response <- (if (!is.null(predicted)) get.bayes.rule(predicted, pi.hat) else NULL) classOutput[[i]] <- c(classOutput[[i]], class = list(response)) remove(predicted) remove(response) predicted.oob <- (if (!is.null(nativeOutput$oobEnsbCLS)) array(nativeOutput$oobEnsbCLS[(iter.ensb.start + 1):iter.ensb.end], c(n, levels.count[i]), dimnames = ens.names) else NULL) classOutput[[i]] <- c(classOutput[[i]], predicted.oob = list(predicted.oob)) response.oob <- (if (!is.null(predicted.oob)) get.bayes.rule(predicted.oob, pi.hat) else NULL) classOutput[[i]] <- c(classOutput[[i]], class.oob = list(response.oob)) remove(predicted.oob) remove(response.oob) cse.num <- (if (!is.null(nativeOutput$cseClas)) array(nativeOutput$cseClas[(iter.ensb.start + 1):iter.ensb.end], n) else NULL) classOutput[[i]] <- c(classOutput[[i]], cse.num = list(cse.num)) remove(cse.num) cse.den <- (if (!is.null(nativeOutput$cseDen)) array(nativeOutput$cseDen[1:n], n) else NULL) classOutput[[i]] <- c(classOutput[[i]], cse.den = list(cse.den)) if (!is.null(nativeOutput$perfClas)) { err.rate <- array(0, c(1 + levels.count[i], ntree)) for (j in 1:(1 + levels.count[i])) { err.rate[j, ] <- nativeOutput$perfClas[tree.offset] tree.offset <- tree.offset + 1 } row.names(err.rate) <- err.names classOutput[[i]] <- c(classOutput[[i]], err.rate = list(t(err.rate))) remove(err.rate) } if (!is.null(nativeOutput$blockClas)) { err.block.rate <- array(0, c(1 + levels.count[i], floor(ntree/block.size))) for (j in 1:(1 + levels.count[i])) { err.block.rate[j, ] <- nativeOutput$blockClas[block.offset] block.offset <- block.offset + 1 } row.names(err.block.rate) <- err.names classOutput[[i]] <- c(classOutput[[i]], err.block.rate = list(t(err.block.rate))) remove(err.block.rate) } csv.idx <- array(0, n * n.xvar) for (j in 1:n.xvar) { csv.idx[(((j - 1) * n) + 1):(((j - 1) * n) + n)] <- (((i - 1) * n) + ((j - 1) * n * resp.clas.count) + 1):(((i - 1) * n) + ((j - 1) * n * resp.clas.count) + n) } csv.num <- (if (!is.null(nativeOutput$csvClas)) array(nativeOutput$csvClas[csv.idx], c(n, n.xvar)) else NULL) classOutput[[i]] <- c(classOutput[[i]], csv.num = list(csv.num)) remove(csv.num) csv.den <- (if (!is.null(nativeOutput$csvDen)) array(nativeOutput$csvDen, c(n, n.xvar)) else NULL) classOutput[[i]] <- c(classOutput[[i]], csv.den = list(csv.den)) remove(csv.den) if (!is.null(nativeOutput$vimpClas)) { importance <- array(0, c(1 + levels.count[i], n.xvar), dimnames = vimp.names) for (j in 1:(1 + levels.count[i])) { importance[j, ] <- nativeOutput$vimpClas[vimp.offset] vimp.offset <- vimp.offset + 1 } classOutput[[i]] <- c(classOutput[[i]], importance = list(t(importance))) remove(importance) } if (!is.null(nativeOutput$holdoutClas)) { holdout.vimp <- vector("list", length(rfsrcOutput$holdout.blk)) names(holdout.vimp) <- xvar.names if (i > 1) { holdout.offset.r <- holdout.offset.r + (1 + levels.count[i - 1]) } for (k in 1:length(holdout.vimp)) { if (rfsrcOutput$holdout.blk[k] > 0) { offset.x <- holdout.offset.sum.x[k] offset.b <- 0 index.m <- NULL for (m in 1:rfsrcOutput$holdout.blk[k]) { if (m > 1) { offset.b <- offset.b + (sum(1 + levels.count)) } index.m <- c(index.m, seq(from = offset.x + offset.b + holdout.offset.r + 1, by = 1, length.out = levels.count[i] + 1)) } holdout.vimp[[k]] = array(nativeOutput$holdoutClas[index.m], c(levels.count[i] + 1, rfsrcOutput$holdout.blk[k])) } else { holdout.vimp[[k]] = NA } } classOutput[[i]] = c(classOutput[[i]], holdout.vimp = list(holdout.vimp)) remove(holdout.vimp) } } nativeOutput$allEnsbCLS <- NULL nativeOutput$oobEnsbCLS <- NULL nativeOutput$perfClas <- NULL nativeOutput$blockClas <- NULL nativeOutput$vimpClas <- NULL nativeOutput$holdoutClas <- NULL if (univariate.nomenclature) { if ((resp.clas.count == 1) & (resp.regr.count == 0)) { names(classOutput) <- NULL rfsrcOutput <- c(rfsrcOutput, unlist(classOutput, recursive = FALSE)) } else { rfsrcOutput <- c(rfsrcOutput, classOutput = list(classOutput)) } } else { rfsrcOutput <- c(rfsrcOutput, classOutput = list(classOutput)) } } if (resp.regr.count > 0) { regrOutput <- vector("list", resp.regr.count) names(regrOutput) <- yvar.names[regr.index] tree.offset <- array(1, ntree) if (ntree > 1) { tree.offset[2:ntree] <- length(regr.index) } tree.offset <- cumsum(tree.offset) block.offset <- array(1, floor(ntree/block.size)) if (floor(ntree/block.size) > 1) { block.offset[2:floor(ntree/block.size)] <- length(regr.index) } block.offset <- cumsum(block.offset) vimp.offset <- array(1, n.xvar) if (n.xvar > 1) { vimp.offset[2:n.xvar] <- length(regr.index) } vimp.offset <- cumsum(vimp.offset) iter.ensb.start <- 0 iter.ensb.end <- 0 iter.qntl.start <- 0 iter.qntl.end <- 0 if (!is.null(nativeOutput$holdoutRegr)) { holdout.offset.x <- rfsrcOutput$holdout.blk * resp.regr.count holdout.offset.sum.x <- c(0, cumsum(holdout.offset.x)) holdout.offset.r <- 0 } for (i in 1:resp.regr.count) { iter.ensb.start <- iter.ensb.end iter.ensb.end <- iter.ensb.end + n iter.qntl.start <- iter.qntl.end iter.qntl.end <- iter.qntl.end + (length(prob) * n) vimp.names <- xvar.names predicted <- (if (!is.null(nativeOutput$allEnsbRGR)) array(nativeOutput$allEnsbRGR[(iter.ensb.start + 1):iter.ensb.end], n) else NULL) regrOutput[[i]] <- list(predicted = predicted) remove(predicted) predicted.oob <- (if (!is.null(nativeOutput$oobEnsbRGR)) array(nativeOutput$oobEnsbRGR[(iter.ensb.start + 1):iter.ensb.end], n) else NULL) regrOutput[[i]] <- c(regrOutput[[i]], predicted.oob = list(predicted.oob)) remove(predicted.oob) cse.num <- (if (!is.null(nativeOutput$cseRegr)) array(nativeOutput$cseRegr[(iter.ensb.start + 1):iter.ensb.end], n) else NULL) regrOutput[[i]] <- c(regrOutput[[i]], cse.num = list(cse.num)) remove(cse.num) cse.den <- (if (!is.null(nativeOutput$cseDen)) array(nativeOutput$cseDen[1:n], n) else NULL) regrOutput[[i]] <- c(regrOutput[[i]], cse.den = list(cse.den)) quantile <- (if (!is.null(nativeOutput$allEnsbQNT)) array(nativeOutput$allEnsbQNT[(iter.qntl.start + 1):iter.qntl.end], c(n, length(prob))) else NULL) regrOutput[[i]] <- c(regrOutput[[i]], quantile = list(quantile)) remove(quantile) quantile.oob <- (if (!is.null(nativeOutput$oobEnsbQNT)) array(nativeOutput$oobEnsbQNT[(iter.qntl.start + 1):iter.qntl.end], c(n, length(prob))) else NULL) regrOutput[[i]] <- c(regrOutput[[i]], quantile.oob = list(quantile.oob)) remove(quantile.oob) if (!is.null(nativeOutput$perfRegr)) { err.rate <- nativeOutput$perfRegr[tree.offset] tree.offset <- tree.offset + 1 regrOutput[[i]] <- c(regrOutput[[i]], err.rate = list(err.rate)) remove(err.rate) } if (!is.null(nativeOutput$blockRegr)) { err.block.rate <- nativeOutput$blockRegr[block.offset] block.offset <- block.offset + 1 regrOutput[[i]] <- c(regrOutput[[i]], err.block.rate = list(err.block.rate)) remove(err.block.rate) } if (!is.null(nativeOutput$vimpRegr)) { importance <- nativeOutput$vimpRegr[vimp.offset] names(importance) <- xvar.names vimp.offset <- vimp.offset + 1 regrOutput[[i]] <- c(regrOutput[[i]], importance = list(importance)) remove(importance) } csv.idx <- array(0, n * n.xvar) for (j in 1:n.xvar) { csv.idx[(((j - 1) * n) + 1):(((j - 1) * n) + n)] <- (((i - 1) * n) + ((j - 1) * n * resp.regr.count) + 1):(((i - 1) * n) + ((j - 1) * n * resp.regr.count) + n) } csv.num <- (if (!is.null(nativeOutput$csvRegr)) array(nativeOutput$csvRegr[csv.idx], c(n, n.xvar)) else NULL) regrOutput[[i]] <- c(regrOutput[[i]], csv.num = list(csv.num)) remove(csv.num) csv.den <- (if (!is.null(nativeOutput$csvDen)) array(nativeOutput$csvDen, c(n, n.xvar)) else NULL) regrOutput[[i]] <- c(regrOutput[[i]], csv.den = list(csv.den)) remove(csv.den) if (!is.null(nativeOutput$holdoutRegr)) { holdout.vimp <- vector("list", length(rfsrcOutput$holdout.blk)) names(holdout.vimp) <- xvar.names if (i > 1) { holdout.offset.r <- holdout.offset.r + 1 } for (k in 1:length(holdout.vimp)) { if (rfsrcOutput$holdout.blk[k] > 0) { offset.x <- holdout.offset.sum.x[k] offset.b <- 0 index.m <- NULL for (m in 1:rfsrcOutput$holdout.blk[k]) { if (m > 1) { offset.b <- offset.b + resp.regr.count } index.m <- c(index.m, offset.x + offset.b + holdout.offset.r + 1) } holdout.vimp[[k]] <- nativeOutput$holdoutRegr[index.m] } else { holdout.vimp[[k]] <- NA } } regrOutput[[i]] <- c(regrOutput[[i]], holdout.vimp = list(holdout.vimp)) } } nativeOutput$allEnsbRGR <- NULL nativeOutput$oobEnsbRGR <- NULL nativeOutput$allEnsbQNT <- NULL nativeOutput$oobEnsbQNT <- NULL nativeOutput$perfRegr <- NULL nativeOutput$blockRegr <- NULL nativeOutput$vimpRegr <- NULL nativeOutput$holdoutRegr <- NULL if (univariate.nomenclature) { if ((resp.clas.count == 0) & (resp.regr.count == 1)) { names(regrOutput) <- NULL rfsrcOutput <- c(rfsrcOutput, unlist(regrOutput, recursive = FALSE)) } else { rfsrcOutput <- c(rfsrcOutput, regrOutput = list(regrOutput)) } } else { rfsrcOutput <- c(rfsrcOutput, regrOutput = list(regrOutput)) } } } } class(rfsrcOutput) <- c("rfsrc", "grow", family) if (big.data) { class(rfsrcOutput) <- c(class(rfsrcOutput), "bigdata") } return(rfsrcOutput)})(ntree = 50, mtry = 5, nodesize = 5, samptype = "swr", formula = medv ~ ., data = list(crim = c(2.81838, 0.27957, 4.26131, 0.37578, 73.5341, 0.03961, 0.02009, 6.39312, 0.05789, 0.04379, 0.03445, 14.4208, 0.02187, 0.08187, 0.07978, 2.73397, 0.05479, 0.14103, 0.35809, 0.05735, 0.46296, 2.24236, 41.5292, 0.44178, 9.96654, 0.32264, 0.21124, 0.12269, 0.1146, 0.84054, 0.25356, 0.02729, 0.12204, 5.66637, 0.01538, 0.15936, 0.02055, 0.01501, 18.4982, 0.05023, 0.03584, 0.22188, 2.63548, 0.22489, 0.07886, 0.04684, 0.12083, 0.10084, 0.06417, 11.9511), zn = c(0, 0, 0, 0, 0, 0, 95, 0, 12.5, 80, 82.5, 0, 60, 0, 40, 0, 33, 0, 0, 0, 0, 0, 0, 0, 0, 0, 12.5, 0, 20, 0, 0, 0, 0, 0, 90, 0, 85, 90, 0, 35, 80, 20, 0, 12.5, 80, 0, 0, 0, 0, 0), indus = c(18.1, 9.69, 18.1, 10.59, 18.1, 5.19, 2.68, 18.1, 6.07, 3.37, 2.03, 18.1, 2.93, 2.89, 6.41, 19.58, 2.18, 13.92, 6.2, 4.49, 6.2, 19.58, 18.1, 6.2, 18.1, 21.89, 7.87, 6.91, 6.96, 8.14, 9.9, 7.07, 2.89, 18.1, 3.75, 6.91, 0.74, 1.21, 18.1, 6.06, 3.37, 6.96, 9.9, 7.87, 4.95, 3.41, 2.89, 10.01, 5.96, 18.1), chas = c(1L, 1L, 1L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 1L, 1L, 1L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L), nox = c(0.532, 0.585, 0.77, 0.489, 0.679, 0.515, 0.4161, 0.584, 0.409, 0.398, 0.415, 0.74, 0.401, 0.445, 0.447, 0.871, 0.472, 0.437, 0.507, 0.449, 0.504, 0.605, 0.693, 0.504, 0.74, 0.624, 0.524, 0.448, 0.464, 0.538, 0.544, 0.469, 0.445, 0.74, 0.394, 0.448, 0.41, 0.401, 0.668, 0.4379, 0.398, 0.464, 0.544, 0.524, 0.411, 0.489, 0.445, 0.547, 0.499, 0.659), rm = c(5.762, 5.926, 6.112, 5.404, 5.957, 6.037, 8.034, 6.162, 5.878, 5.787, 6.162, 6.461, 6.8, 7.82, 6.482, 5.597, 6.616, 5.79, 6.951, 6.63, 7.412, 5.854, 5.531, 6.552, 6.485, 5.942, 5.631, 6.069, 6.538, 5.599, 5.705, 7.185, 6.625, 6.219, 7.454, 6.211, 6.383, 7.923, 4.138, 5.706, 6.29, 7.691, 4.973, 6.377, 7.148, 6.417, 8.069, 6.715, 5.933, 5.608), age = c(40.3, 42.6, 81.3, 88.6, 100, 34.5, 31.9, 97.4, 21.4, 31.1, 38.4, 93.3, 9.9, 36.9, 32.1, 94.9, 58.1, 58, 88.5, 56.1, 76.9, 91.8, 85.4, 21.4, 100, 93.5, 100, 40, 58.7, 85.7, 77.7, 61.1, 57.8, 100, 34.2, 6.5, 35.7, 24.8, 100, 28.4, 17.8, 51.8, 37.8, 94.3, 27.7, 66.1, 76, 81.6, 68.2, 100), dis = c(4.0983, 2.3817, 2.5091, 3.665, 1.8026, 5.9853, 5.118, 2.206, 6.498, 6.6115, 6.27, 2.0026, 6.2196, 3.4952, 4.1403, 1.5257, 3.37, 6.32, 2.8617, 4.4377, 3.6715, 2.422, 1.6074, 3.3751, 1.9784, 1.9669, 6.0821, 5.7209, 3.9175, 4.4546, 3.945, 4.9671, 3.4952, 2.0048, 6.3361, 5.7209, 9.1876, 5.885, 1.137, 6.6407, 6.6115, 4.3665, 2.5194, 6.3467, 5.1167, 3.0923, 3.4952, 2.6775, 3.3603, 1.2852), rad = c(24, 6, 24, 4, 24, 5, 4, 24, 4, 4, 2, 24, 1, 2, 4, 5, 7, 4, 8, 3, 8, 5, 24, 8, 24, 4, 5, 3, 3, 4, 4, 2, 2, 24, 3, 3, 2, 1, 24, 1, 4, 3, 4, 5, 4, 2, 2, 6, 5, 24), tax = c(666, 391, 666, 277, 666, 224, 224, 666, 345, 337, 348, 666, 265, 276, 254, 403, 222, 289, 307, 247, 307, 403, 666, 307, 666, 437, 311, 233, 223, 307, 304, 242, 276, 666, 244, 233, 313, 198, 666, 304, 337, 223, 304, 311, 245, 270, 276, 432, 279, 666), ptratio = c(20.2, 19.2, 20.2, 18.6, 20.2, 20.2, 14.7, 20.2, 18.9, 16.1, 14.7, 20.2, 15.6, 18, 17.6, 14.7, 18.4, 16, 17.4, 18.5, 17.4, 14.7, 20.2, 17.4, 20.2, 21.2, 15.2, 17.9, 18.6, 21, 18.4, 17.8, 18, 20.2, 15.9, 17.9, 17.3, 13.6, 20.2, 16.9, 16.1, 18.6, 18.4, 15.2, 19.2, 17.8, 18, 17.8, 19.2, 20.2), b = c(392.92, 396.9, 390.74, 395.24, 16.45, 396.9, 390.55, 302.76, 396.21, 396.9, 393.77, 27.49, 393.37, 393.53, 396.9, 351.85, 393.36, 396.9, 391.7, 392.3, 376.14, 395.11, 329.46, 380.34, 386.73, 378.25, 386.63, 389.39, 394.96, 303.42, 396.42, 392.83, 357.98, 395.69, 386.34, 394.46, 396.9, 395.52, 396.9, 394.02, 396.9, 390.77, 350.45, 392.52, 396.9, 392.18, 396.9, 395.59, 396.9, 332.09), lstat = c(10.42, 13.59, 12.67, 23.98, 20.62, 8.01, 2.88, 24.1, 8.1, 10.24, 7.43, 18.05, 5.03, 3.57, 7.19, 21.45, 8.93, 15.84, 9.71, 6.53, 5.25, 11.64, 27.38, 3.76, 18.85, 16.9, 29.93, 9.55, 7.73, 16.51, 11.5, 4.03, 6.65, 16.59, 3.11, 7.44, 5.77, 3.16, 37.97, 12.43, 4.67, 6.58, 12.64, 20.45, 3.56, 8.81, 4.21, 10.16, 9.68, 12.13), medv = c(21.8, 24.5, 22.6, 19.3, 8.8, 21.1, 50, 13.3, 22, 19.4, 24.1, 9.6, 31.1, 43.8, 29.1, 15.4, 28.4, 20.3, 26.7, 26.6, 31.7, 22.7, 8.5, 31.5, 15.4, 17.4, 16.5, 21.2, 24.4, 13.9, 16.2, 34.7, 28.4, 18.4, 44, 24.7, 24.7, 50, 13.8, 17.1, 23.5, 35.2, 16.1, 15, 37.3, 22.6, 38.7, 22.8, 18.9, 27.9)), membership = TRUE, split_rule = "custom2")
6: do.call(rfsrc, params_rfsrc)
7: rfpi(formula, traindata, testdata, alpha, split_rule = "l1", pi_method = pi_method, rf_package = "rfsrc", params_rfsrc = params_rfsrc)
8: piall(formula, traindata = traindata2, testdata = testdata2[, xvar.names], num.trees = 50)
9: eval(code, test_env)
10: eval(code, test_env)
11: withCallingHandlers({ eval(code, test_env) if (!handled && !is.null(test)) { skip_empty() }}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning, message = handle_message, error = handle_error)
12: doTryCatch(return(expr), name, parentenv, handler)
13: tryCatchOne(expr, names, parentenv, handlers[[1L]])
14: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
15: doTryCatch(return(expr), name, parentenv, handler)
16: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), names[nh], parentenv, handlers[[nh]])
17: tryCatchList(expr, classes, parentenv, handlers)
18: tryCatch(withCallingHandlers({ eval(code, test_env) if (!handled && !is.null(test)) { skip_empty() }}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning, message = handle_message, error = handle_error), error = handle_fatal, skip = function(e) { })
19: test_code(test = NULL, code = exprs, env = env, reporter = get_reporter() %||% StopReporter$new())
20: source_file(path, env = env(env), desc = desc, error_call = error_call)
21: FUN(X[[i]], ...)
22: lapply(test_paths, test_one_file, env = env, desc = desc, error_call = error_call)
23: doTryCatch(return(expr), name, parentenv, handler)
24: tryCatchOne(expr, names, parentenv, handlers[[1L]])
25: tryCatchList(expr, classes, parentenv, handlers)
26: tryCatch(code, testthat_abort_reporter = function(cnd) { cat(conditionMessage(cnd), "\n") NULL})
27: with_reporter(reporters$multi, lapply(test_paths, test_one_file, env = env, desc = desc, error_call = error_call))
28: test_files_serial(test_dir = test_dir, test_package = test_package, test_paths = test_paths, load_helpers = load_helpers, reporter = reporter, env = env, stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning, desc = desc, load_package = load_package, error_call = error_call)
29: test_files(test_dir = path, test_paths = test_paths, test_package = package, reporter = reporter, load_helpers = load_helpers, env = env, stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning, load_package = load_package, parallel = parallel)
30: test_dir("testthat", package = package, reporter = reporter, ..., load_package = "installed")
31: test_check("RFpredInterval")
An irrecoverable exception occurred. R is aborting now ...
Flavor: r-devel-linux-x86_64-fedora-gcc
Version: 1.0.8
Check: compiled code
Result: NOTE
File 'RFpredInterval/libs/x64/RFpredInterval.dll':
Found non-API call to R: 'STRING_PTR'
Compiled code should not call non-API entry points in R.
See 'Writing portable packages' in the 'Writing R Extensions' manual,
and section 'Moving into C API compliance' for issues with the use of
non-API entry points.
Flavor: r-devel-windows-x86_64
Version: 1.0.8
Check: tests
Result: ERROR
Running 'testthat.R' [12s]
Running the tests in 'tests/testthat.R' failed.
Complete output:
> library(testthat)
> library(RFpredInterval)
RFpredInterval 1.0.8
>
> test_check("RFpredInterval")
Flavor: r-devel-windows-x86_64