Update R files

This commit is contained in:
François Vieille 2016-10-09 02:44:17 +02:00
parent 5942b328e7
commit 7cfbd2755c
11 changed files with 41 additions and 37 deletions

View File

@ -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:

View File

@ -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

View File

@ -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",

View File

@ -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

View File

@ -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])
},

View File

@ -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"),

View File

@ -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))
}

View File

@ -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()

View File

@ -10,7 +10,8 @@
#'
#' @export VT.tree.class
#'
#' @import methods
#' @import methods
#' @importFrom rpart rpart
VT.tree.class <- setRefClass(
Class = "VT.tree.class",

View File

@ -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)

View File

@ -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(...)