2015-05-31 21:09:04 +02:00
|
|
|
# VT.OBJECT ---------------------------------------------------------------
|
|
|
|
|
2015-07-25 02:10:28 +02:00
|
|
|
#' VT.object
|
2015-06-02 23:33:14 +02:00
|
|
|
#'
|
2015-06-01 23:22:49 +02:00
|
|
|
#' A Reference Class to deal with RCT dataset
|
|
|
|
#'
|
2015-06-11 13:34:55 +02:00
|
|
|
#' Currently working with binary response only. Continous will come, one day.
|
2015-06-02 23:33:14 +02:00
|
|
|
#' Two-levels treatment only as well.
|
|
|
|
#'
|
|
|
|
#' \code{data} field should be as described, however if virtual twins won't used
|
2015-06-11 13:34:55 +02:00
|
|
|
#' interactions, there is no need to transform factors. See
|
|
|
|
#' \link{formatRCTDataset} for more details.
|
2015-06-02 23:33:14 +02:00
|
|
|
#'
|
2015-06-01 23:22:49 +02:00
|
|
|
#'
|
2015-06-02 23:33:14 +02:00
|
|
|
#' @field data Data.frame with format: \eqn{Y,T,X_{1}, \ldots, X_{p}}. Y must be
|
|
|
|
#' two levels factor if type is binary. T must be numeric or integer.
|
2015-06-11 13:34:55 +02:00
|
|
|
#' @field screening Logical, set to \code{FALSE} Set to \code{TRUE} to use
|
|
|
|
#' \code{varimp} in trees computation.
|
2015-06-02 23:33:14 +02:00
|
|
|
#' @field varimp Character vector of important variables to use in trees
|
|
|
|
#' computation.
|
|
|
|
#' @field delta Numeric representing the difference of incidence between
|
|
|
|
#' treatments.
|
|
|
|
#' @field type Character : binary or continous. Only binary is currently
|
|
|
|
#' available.
|
|
|
|
#'
|
2015-06-01 23:22:49 +02:00
|
|
|
#' @import methods
|
2015-06-02 23:33:14 +02:00
|
|
|
#'
|
|
|
|
#' @name VT.object
|
|
|
|
#'
|
2015-06-11 13:34:55 +02:00
|
|
|
#' @export VT.object
|
|
|
|
#'
|
2015-06-02 23:33:14 +02:00
|
|
|
#' @examples
|
2015-06-10 14:36:00 +02:00
|
|
|
#' \dontrun{
|
2015-06-02 23:33:14 +02:00
|
|
|
#' # Default use :
|
|
|
|
#' vt.o <- VT.object$new(data = my.rct.dataset)
|
|
|
|
#'
|
|
|
|
#' # Getting data
|
2015-06-10 14:36:00 +02:00
|
|
|
#' head(vt.o$data)
|
2015-06-02 23:33:14 +02:00
|
|
|
#'
|
|
|
|
#' # or getting predictor with interactions
|
|
|
|
#' vt.o$getX(interactions = T)
|
|
|
|
#'
|
|
|
|
#' # or getting X|T = 1
|
|
|
|
#' vt.o$getX(trt = 1)
|
|
|
|
#'
|
|
|
|
#' # or getting Y|T = 0
|
|
|
|
#' vt.o$getY(0)
|
|
|
|
#'
|
|
|
|
#' # Print incidences
|
|
|
|
#' vt.o$getIncidences()
|
2015-06-10 14:36:00 +02:00
|
|
|
#' }
|
2015-06-02 23:33:14 +02:00
|
|
|
#'
|
2015-06-11 13:34:55 +02:00
|
|
|
#' @seealso \code{\link{VT.difft}}
|
2015-06-02 23:33:14 +02:00
|
|
|
#'
|
2015-05-31 21:09:04 +02:00
|
|
|
VT.object <- setRefClass(
|
|
|
|
Class = "VT.object",
|
|
|
|
|
|
|
|
fields = list(
|
|
|
|
data = "data.frame",
|
|
|
|
screening = "logical",
|
|
|
|
varimp = "character",
|
|
|
|
delta = "numeric",
|
|
|
|
type = "character"
|
|
|
|
),
|
|
|
|
|
|
|
|
methods = list(
|
2015-06-11 13:34:55 +02:00
|
|
|
initialize = function(screening = F, type = "binary", ...){
|
2015-05-31 21:09:04 +02:00
|
|
|
|
|
|
|
.self$screening <- screening
|
|
|
|
|
|
|
|
.self$type <- type
|
2015-06-11 13:34:55 +02:00
|
|
|
|
2015-05-31 21:09:04 +02:00
|
|
|
.self$initFields(...)
|
|
|
|
},
|
|
|
|
|
|
|
|
getFormula = function(){
|
2015-06-01 23:22:49 +02:00
|
|
|
"Return formula : Y~T+X1+...+Xp. Usefull for cforest function."
|
2015-05-31 21:09:04 +02:00
|
|
|
return(as.formula(paste(colnames(.self$data)[1], ".", sep = "~")))
|
|
|
|
},
|
|
|
|
|
|
|
|
getX = function(interactions = T, trt = NULL){
|
2015-06-02 23:33:14 +02:00
|
|
|
"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"
|
2016-10-09 02:44:17 +02:00
|
|
|
# predictors if trt is not null
|
2015-05-31 21:09:04 +02:00
|
|
|
if(!is.null(trt)) return(.self$data[.self$data[,2] == trt, -c(1,2)])
|
2016-10-09 02:44:17 +02:00
|
|
|
# predictor*treatment no matter trt if interactions is TRUE
|
2015-05-31 21:09:04 +02:00
|
|
|
if(interactions == T) return(.self$getXwithInt())
|
2016-10-09 02:44:17 +02:00
|
|
|
# predictors
|
2015-05-31 21:09:04 +02:00
|
|
|
return(.self$data[, -1])
|
|
|
|
},
|
|
|
|
|
|
|
|
getY = function(trt = NULL){
|
2015-06-02 23:33:14 +02:00
|
|
|
"Return outcome. If trt is not NULL, return outcome for T = trt."
|
2015-05-31 21:09:04 +02:00
|
|
|
if(is.null(trt)) return(.self$data[, 1])
|
|
|
|
return(.self$data[.self$data[,2] == trt, 1])
|
|
|
|
},
|
|
|
|
|
|
|
|
getXwithInt = function(){
|
2015-06-01 23:22:49 +02:00
|
|
|
"Return predictors with interactions. Use VT.object::getX(interactions = T) instead."
|
2015-05-31 21:09:04 +02:00
|
|
|
tmp <- .self$data[, -c(1,2)]
|
|
|
|
return(data.frame(cbind(.self$data[,-1], tmp*.self$data[, 2], tmp*(1 - .self$data[, 2]))))
|
|
|
|
},
|
|
|
|
|
2015-06-21 02:30:21 +02:00
|
|
|
getData = function(interactions = F){
|
|
|
|
"Return dataset. If interactions is set to T, return data with treatement interactions"
|
|
|
|
if(!isTRUE(interactions))
|
|
|
|
return(.self$data)
|
|
|
|
else{
|
|
|
|
data.int <- cbind(.self$data[, 1], .self$getX(T))
|
|
|
|
colnames(data.int)[1] <- colnames(.self$data)[1]
|
|
|
|
return(data.int)
|
|
|
|
}
|
|
|
|
},
|
|
|
|
|
2015-05-31 21:09:04 +02:00
|
|
|
switchTreatment = function(){
|
2015-06-01 23:22:49 +02:00
|
|
|
"Switch treatment value."
|
2015-05-31 21:09:04 +02:00
|
|
|
cl <- class(.self$data[, 2])
|
|
|
|
# Treatments must be numeric or integer and binary
|
|
|
|
.self$data[, 2] <- 1 - .self$data[, 2]
|
|
|
|
# keep original class for treatment
|
|
|
|
if(cl == "integer"){
|
|
|
|
.self$data[, 2] <- as.integer(.self$data[, 2])
|
|
|
|
}else{
|
|
|
|
.self$data[, 2] <- as.numeric(.self$data[, 2])
|
|
|
|
}
|
|
|
|
return(TRUE)
|
|
|
|
},
|
|
|
|
|
|
|
|
computeDelta = function(){
|
2015-06-01 23:22:49 +02:00
|
|
|
"Compute delta value."
|
2015-05-31 21:09:04 +02:00
|
|
|
if(.self$type == "binary"){
|
|
|
|
.self$delta <- sum((as.numeric(.self$data[, 1]) - 1)*(.self$data[, 2])) / sum(.self$data[, 2]) -
|
|
|
|
sum((as.numeric(.self$data[, 1]) - 1)*(1 - .self$data[, 2])) / sum(1 - .self$data[, 2])
|
|
|
|
|
|
|
|
return(.self$delta)
|
|
|
|
}else{
|
|
|
|
stop("Error : type is not Binary")
|
|
|
|
}
|
|
|
|
},
|
|
|
|
|
2015-06-21 02:30:21 +02:00
|
|
|
# Hack of VT.incidences
|
|
|
|
getIncidences = function(rule = NULL){
|
|
|
|
"Return incidence table of data if rule set to NULL. Otherwise return incidence for the rule."
|
|
|
|
hack.difft <- VT.difft$new(.self)
|
|
|
|
if(is.null(rule))
|
|
|
|
return(vt.getIncidence(.self$data))
|
|
|
|
else
|
|
|
|
return(VT.incidences(hack.difft, rule, F))
|
2015-05-31 21:09:04 +02:00
|
|
|
}
|
|
|
|
)
|
|
|
|
)
|