Update R files
This commit is contained in:
parent
5942b328e7
commit
7cfbd2755c
|
@ -5,9 +5,9 @@
|
|||
#' \itemize{
|
||||
#' \item \code{\link{VT.object}} class to represent RCT dataset used by aVirtualTwins. To format correctly RCT dataset, use \code{\link{formatRCTDataset}}.
|
||||
#' \item \code{\link{VT.difft}} class to compute difference between twins. Family \code{\link{VT.forest}} extends it to compute twins by random forest.
|
||||
#' \code{\link{vt.forest()}} is users function.
|
||||
#' \code{\link{vt.forest}} is users function.
|
||||
#' \item \code{\link{VT.tree}} class to find subgroups from \code{difft} by CART trees. \code{\link{VT.tree.class}} and \code{\link{VT.tree.reg}} extend it.
|
||||
#' \code{\link{vt.tree()}} is users function.
|
||||
#' \code{\link{vt.tree}} is users function.
|
||||
#' }
|
||||
#'
|
||||
#' @section TODO LIST:
|
||||
|
|
4
R/data.R
4
R/data.R
|
@ -4,7 +4,7 @@
|
|||
#' details.
|
||||
#'
|
||||
#' This dataset is taken from
|
||||
#' \href{http://biopharmnet.com/wiki/Software_for_subgroup_identification_and_analysis}{SIDES
|
||||
#' \href{http://biopharmnet.com/subgroup-analysis-software/}{SIDES
|
||||
#' method}.
|
||||
#'
|
||||
#' \code{Sepsis} contains simulated data on 470 subjects with a binary outcome
|
||||
|
@ -35,7 +35,7 @@
|
|||
#' @usage data(sepsis)
|
||||
#' @docType data
|
||||
#' @source
|
||||
#' \url{http://biopharmnet.com/wiki/Software_for_subgroup_identification_and_analysis}
|
||||
#' \url{http://biopharmnet.com/subgroup-analysis-software/}
|
||||
#'
|
||||
#' @name sepsis
|
||||
NULL
|
||||
|
|
|
@ -15,6 +15,8 @@
|
|||
#' @seealso \code{\link{VT.difft}}, \code{\link{VT.forest.one}}, \code{\link{VT.forest.double}}
|
||||
#'
|
||||
#' @import methods
|
||||
#'
|
||||
#' @rdname VT.forest-abstract
|
||||
VT.forest <- setRefClass(
|
||||
Class = "VT.forest",
|
||||
|
||||
|
|
|
@ -21,7 +21,7 @@
|
|||
#' forest.type = "double". If NULL, a randomForest model is grown inside the
|
||||
#' function. NULL is default. See \code{\link{VT.forest.double}} for details.
|
||||
#' @param model_trt1 see model_trt0 explanation and
|
||||
#' \code{\link{VT.double.forest}} details.
|
||||
#' \code{\link{VT.forest.double}} details.
|
||||
#' @param fold number of fold you want to construct forest with k-fold method.
|
||||
#' Is only used with forest.type = "fold". Default to 5. See
|
||||
#' \code{\link{VT.forest.fold}}
|
||||
|
@ -55,7 +55,6 @@
|
|||
#' @name vt.forest
|
||||
#'
|
||||
#' @export vt.forest
|
||||
|
||||
vt.forest <- function(forest.type = "one", vt.data, interactions = T, method = "absolute",
|
||||
model = NULL, model_trt1 = NULL, model_trt0 = NULL, ratio = 1, fold = 10, ...){
|
||||
if(!inherits(vt.data, "VT.object"))
|
||||
|
@ -64,7 +63,7 @@ vt.forest <- function(forest.type = "one", vt.data, interactions = T, method = "
|
|||
params <- list(...)
|
||||
if (forest.type == "one"){
|
||||
if(is.null(model)){
|
||||
model <- randomForest(x = vt.data$getX(interactions = interactions, trt = NULL),
|
||||
model <- randomForest::randomForest(x = vt.data$getX(interactions = interactions, trt = NULL),
|
||||
y = vt.data$getY(),
|
||||
...)
|
||||
}
|
||||
|
@ -73,14 +72,14 @@ vt.forest <- function(forest.type = "one", vt.data, interactions = T, method = "
|
|||
vt.difft <- VT.forest.one(vt.object = vt.data, model = rf, interactions = interactions, method = method)
|
||||
} else if (forest.type == "double"){
|
||||
if(is.null(model_trt1)){
|
||||
model_trt1 <- randomForest(x = vt.data$getX(trt = 1),
|
||||
model_trt1 <- randomForest::randomForest(x = vt.data$getX(trt = 1),
|
||||
y = vt.data$getY(1),
|
||||
...)
|
||||
}
|
||||
rf_trt1 <- model_trt1
|
||||
|
||||
if(is.null(model_trt0)){
|
||||
model_trt0 <- randomForest(x = vt.data$getX(trt = 0),
|
||||
model_trt0 <- randomForest::randomForest(x = vt.data$getX(trt = 0),
|
||||
y = vt.data$getY(0),
|
||||
...)
|
||||
}
|
||||
|
@ -88,7 +87,7 @@ vt.forest <- function(forest.type = "one", vt.data, interactions = T, method = "
|
|||
|
||||
vt.difft <- VT.forest.double(vt.object = vt.data, model_trt1 = rf_trt1, model_trt0 = rf_trt0, method = method)
|
||||
} else if (forest.type == "fold"){
|
||||
vt.difft <- aVirtualTwins:::VT.forest.fold(vt.object = vt.data, fold = fold, ratio = ratio,
|
||||
vt.difft <- VT.forest.fold(vt.object = vt.data, fold = fold, ratio = ratio,
|
||||
interactions = interactions, method = method)
|
||||
|
||||
} else
|
||||
|
|
|
@ -81,11 +81,11 @@ VT.object <- setRefClass(
|
|||
getX = function(interactions = T, trt = NULL){
|
||||
"Return predictors (T,X,X*T,X*(1-T)). Or (T,X) if interactions is FALSE.
|
||||
If trt is not NULL, return predictors for T = trt"
|
||||
# retour les prédicteurs si trt n'est pas null
|
||||
# predictors if trt is not null
|
||||
if(!is.null(trt)) return(.self$data[.self$data[,2] == trt, -c(1,2)])
|
||||
# retourne les predicteurs*traitement peut importe le traitement si interactions est à TRUE
|
||||
# predictor*treatment no matter trt if interactions is TRUE
|
||||
if(interactions == T) return(.self$getXwithInt())
|
||||
# retourne les predicteurs
|
||||
# predictors
|
||||
return(.self$data[, -1])
|
||||
},
|
||||
|
||||
|
|
20
R/predict.R
20
R/predict.R
|
@ -25,7 +25,7 @@ setGeneric("VT.predict",
|
|||
function(rfor, newdata, type){standardGeneric("VT.predict")}
|
||||
)
|
||||
|
||||
#' @describeIn VT.predict
|
||||
#' @describeIn VT.predict rfor(RandomForest) newdata (missing) type (character)
|
||||
setMethod(
|
||||
f = "VT.predict",
|
||||
signature = c(rfor = "RandomForest", newdata = "missing", type = "character"),
|
||||
|
@ -33,7 +33,7 @@ setMethod(
|
|||
if(! type %in% c("binary", "continous")) stop("Type must be Binary or continous")
|
||||
if(type == "binary"){
|
||||
if(!requireNamespace("party", quietly = TRUE)) stop("Party package must be loaded.")
|
||||
tmp <- party:::predict.RandomForest(rfor, OOB = T, type = "prob")
|
||||
tmp <- stats::predict(rfor, OOB = T, type = "prob")
|
||||
tmp <- unlist(tmp)
|
||||
tmp <- tmp[seq(2, length(tmp), 2)]
|
||||
}else{
|
||||
|
@ -45,7 +45,7 @@ setMethod(
|
|||
}
|
||||
)
|
||||
|
||||
#' @describeIn VT.predict
|
||||
#' @describeIn VT.predict rfor(RandomForest) newdata (data.frame) type (character)
|
||||
setMethod(
|
||||
f = "VT.predict",
|
||||
signature = c(rfor = "RandomForest", newdata = "data.frame", type = "character"),
|
||||
|
@ -53,7 +53,7 @@ setMethod(
|
|||
if(! type %in% c("binary", "continous")) stop("Type must be Binary or continous")
|
||||
if(type == "binary"){
|
||||
if(!requireNamespace("party", quietly = TRUE)) stop("Party package must be loaded.")
|
||||
tmp <- party:::predict.RandomForest(rfor, newdata = newdata, type = "prob")
|
||||
tmp <- stats::predict(rfor, newdata = newdata, type = "prob")
|
||||
tmp <- unlist(tmp)
|
||||
tmp <- tmp[seq(2, length(tmp), 2)]
|
||||
}else{
|
||||
|
@ -65,7 +65,7 @@ setMethod(
|
|||
}
|
||||
)
|
||||
|
||||
#' @describeIn VT.predict
|
||||
#' @describeIn VT.predict rfor(randomForest) newdata (missing) type (character)
|
||||
setMethod(
|
||||
f = "VT.predict",
|
||||
signature = c(rfor = "randomForest", newdata = "missing", type = "character"),
|
||||
|
@ -75,7 +75,7 @@ setMethod(
|
|||
# no longer available in all version ?!
|
||||
# tmp <- rfor$vote[, 2] # get the "o" prob
|
||||
if(!requireNamespace("randomForest", quietly = TRUE)) stop("randomForest package must be loaded.")
|
||||
tmp <- randomForest:::predict.randomForest(rfor, type = "prob")[, 2] # We want to get the "o" prob
|
||||
tmp <- stats::predict(rfor, type = "prob")[, 2] # We want to get the "o" prob
|
||||
}else{
|
||||
message("continous is not done yet")
|
||||
tmp <- NULL
|
||||
|
@ -84,7 +84,7 @@ setMethod(
|
|||
}
|
||||
)
|
||||
|
||||
#' @describeIn VT.predict
|
||||
#' @describeIn VT.predict rfor(randomForest) newdata (data.frame) type (character)
|
||||
setMethod(
|
||||
f = "VT.predict",
|
||||
signature = c(rfor = "randomForest", newdata = "data.frame", type = "character"),
|
||||
|
@ -92,7 +92,7 @@ setMethod(
|
|||
if(! type %in% c("binary", "continous")) stop("Type must be Binary or continous")
|
||||
if(type == "binary"){
|
||||
if(!requireNamespace("randomForest", quietly = TRUE)) stop("randomForest package must be loaded.")
|
||||
tmp <- randomForest:::predict.randomForest(rfor, newdata = newdata, type = "prob")[, 2] # We want to get the "o" prob
|
||||
tmp <- stats::predict(rfor, newdata = newdata, type = "prob")[, 2] # We want to get the "o" prob
|
||||
}else{
|
||||
message("continous is not done yet")
|
||||
tmp <- NULL
|
||||
|
@ -101,7 +101,7 @@ setMethod(
|
|||
}
|
||||
)
|
||||
|
||||
#' @describeIn VT.predict
|
||||
#' @describeIn VT.predict rfor(train) newdata (ANY) type (character)
|
||||
setMethod(
|
||||
f = "VT.predict",
|
||||
signature = c(rfor = "train", newdata = "ANY", type = "character"),
|
||||
|
@ -111,7 +111,7 @@ setMethod(
|
|||
}
|
||||
)
|
||||
|
||||
#' @describeIn VT.predict
|
||||
#' @describeIn VT.predict rfor(train) newdata (missing) type (character)
|
||||
setMethod(
|
||||
f = "VT.predict",
|
||||
signature = c(rfor = "train", newdata = "missing", type = "character"),
|
||||
|
|
|
@ -36,7 +36,7 @@
|
|||
#' @name vt.subgroups
|
||||
#'
|
||||
|
||||
vt.subgroups <- function(vt.trees, only.leaf = T, only.fav = T, tables = F, verbose = F){
|
||||
vt.subgroups <- function(vt.trees, only.leaf = T, only.fav = T, tables = F, verbose = F, compete = F){
|
||||
|
||||
if(is.list(vt.trees)){
|
||||
subgroups <- lapply(vt.trees, function(x)x$getRules(only.leaf = only.leaf, only.fav = only.fav, tables = tables, verbose = verbose, compete = F))
|
||||
|
@ -64,8 +64,8 @@ vt.getQAOriginal <- function(response, trt, ahat){
|
|||
vt.getTable <- function(table){
|
||||
if(is.list(table)) table <- table[[1]]
|
||||
Incidence <- function(X) as.character(round(X[2] / X[3], digits = 3))
|
||||
t <- addmargins(table, margin = c(1,2), FUN = sum, quiet = T)
|
||||
t <- addmargins(t, FUN = Incidence, margin = 1, quiet = T)
|
||||
t <- stats::addmargins(table, margin = c(1,2), FUN = sum, quiet = T)
|
||||
t <- stats::addmargins(t, FUN = Incidence, margin = 1, quiet = T)
|
||||
rr <- as.numeric(t["Incidence", "1"]) / as.numeric(t["Incidence", "0"])
|
||||
return(list(table = t, rr = rr))
|
||||
}
|
||||
|
|
12
R/tree.R
12
R/tree.R
|
@ -43,6 +43,8 @@
|
|||
#' @name VT.tree
|
||||
#'
|
||||
#' @import methods
|
||||
#'
|
||||
#' @rdname VT.tree-abstract
|
||||
VT.tree <- setRefClass(
|
||||
Class = "VT.tree",
|
||||
|
||||
|
@ -76,7 +78,7 @@ VT.tree <- setRefClass(
|
|||
|
||||
if(.self$screening == T){
|
||||
d.tmp <- d
|
||||
d <- d.tmp[, colnames(d.tmp) %in% .self$vt.difft$vt.object$varimp] # To see later
|
||||
d <- d.tmp[, colnames(d.tmp) %in% .self$vt.difft$vt.object$varimp]
|
||||
}
|
||||
|
||||
d <- data.frame(.self$outcome, d)
|
||||
|
@ -112,8 +114,6 @@ VT.tree <- setRefClass(
|
|||
cat("\n")
|
||||
cat(sprintf("Sens : %s", .self$sens))
|
||||
cat("\n")
|
||||
# cat(sprintf("Bounds = %0.4f", (.self$vt.difft$vt.object$delta + .self$threshold)))
|
||||
# cat("\n")
|
||||
cat(sprintf("Size of Ahat : %i", (sum(.self$Ahat))))
|
||||
|
||||
return(invisible(NULL))
|
||||
|
@ -132,7 +132,7 @@ VT.tree <- setRefClass(
|
|||
warning("VT.tree : no nodes"); return(invisible(NULL));
|
||||
}
|
||||
|
||||
# On supprime le root node, inutile pour les stats d'incidences et autres...
|
||||
# delete root node
|
||||
full.frame <- .self$tree$frame[-1, ]
|
||||
|
||||
if (only.fav == T){
|
||||
|
@ -163,13 +163,13 @@ VT.tree <- setRefClass(
|
|||
frm <- full.frame
|
||||
}
|
||||
|
||||
# Le cas où l'arbre est vide ou n'existe pas:
|
||||
# in case tree is empty or doesn't exist
|
||||
if (ncol(frm) == 0){
|
||||
warning("VT.tree : no rules"); return(invisible(NULL));
|
||||
}
|
||||
|
||||
pth <- rpart::path.rpart(.self$tree, nodes = row.names(frm), print.it = F)
|
||||
# Delete 'root' node des règles
|
||||
# Delete 'root' node of rule
|
||||
pth <- lapply(pth, FUN = function(d) return(d[-1]))
|
||||
|
||||
nodes <- c()
|
||||
|
|
|
@ -10,7 +10,8 @@
|
|||
#'
|
||||
#' @export VT.tree.class
|
||||
#'
|
||||
#' @import methods
|
||||
#' @import methods
|
||||
#' @importFrom rpart rpart
|
||||
VT.tree.class <- setRefClass(
|
||||
Class = "VT.tree.class",
|
||||
|
||||
|
|
|
@ -9,6 +9,8 @@
|
|||
#' @export VT.tree.reg
|
||||
#'
|
||||
#' @name VT.tree.reg
|
||||
#'
|
||||
#' @importFrom rpart rpart
|
||||
|
||||
VT.tree.reg <- setRefClass(
|
||||
Class = "VT.tree.reg",
|
||||
|
@ -31,9 +33,9 @@ VT.tree.reg <- setRefClass(
|
|||
.self$tree <- rpart::rpart(as.formula(paste(.self$name, ".", sep = "~")), data = data, ...)
|
||||
|
||||
if(.self$sens == ">")
|
||||
res <- ifelse(predict(.self$tree) >= (.self$threshold), 1, 0)
|
||||
res <- ifelse(stats::predict(.self$tree) >= (.self$threshold), 1, 0)
|
||||
else
|
||||
res <- ifelse(predict(.self$tree) <= (.self$threshold), 1, 0)
|
||||
res <- ifelse(stats::predict(.self$tree) <= (.self$threshold), 1, 0)
|
||||
|
||||
.self$Ahat <- res
|
||||
# if(sum(res) != 0) .self$vt.forest$addAhatColumn(name, res)
|
||||
|
|
|
@ -57,9 +57,9 @@ vt.tree <- function(tree.type = "class", vt.difft, sens = ">", threshold = seq(.
|
|||
return(res.list)
|
||||
}else{
|
||||
if(tree.type == "class")
|
||||
tree <- aVirtualTwins:::VT.tree.class(vt.difft = vt.difft, sens = sens, threshold = threshold, screening = screening)
|
||||
tree <- VT.tree.class(vt.difft = vt.difft, sens = sens, threshold = threshold, screening = screening)
|
||||
else
|
||||
tree <- aVirtualTwins:::VT.tree.reg(vt.difft = vt.difft, sens = sens, threshold = threshold, screening = screening)
|
||||
tree <- VT.tree.reg(vt.difft = vt.difft, sens = sens, threshold = threshold, screening = screening)
|
||||
|
||||
tree$run(...)
|
||||
|
||||
|
|
Loading…
Reference in New Issue