mirror of
https://github.com/prise6/aVirtualTwins.git
synced 2024-06-07 01:32:12 +02:00
Add competitors rules
This commit is contained in:
parent
1096887e15
commit
88494d0472
106
R/tree.R
106
R/tree.R
|
@ -23,6 +23,7 @@ VT.tree <- setRefClass(
|
||||||
sens = "character",
|
sens = "character",
|
||||||
name = "character",
|
name = "character",
|
||||||
tree = "rpart",
|
tree = "rpart",
|
||||||
|
competitors = "data.frame",
|
||||||
Ahat = "vector"
|
Ahat = "vector"
|
||||||
),
|
),
|
||||||
|
|
||||||
|
@ -83,7 +84,11 @@ VT.tree <- setRefClass(
|
||||||
return(invisible(NULL))
|
return(invisible(NULL))
|
||||||
},
|
},
|
||||||
|
|
||||||
getRules = function(only.leaf = F, only.fav = F, tables = T, verbose = T){
|
getRules = function(only.leaf = F, only.fav = F, tables = T, verbose = T, compete = F){
|
||||||
|
|
||||||
|
# On crée le tableau des competitors
|
||||||
|
if(isTRUE(compete))
|
||||||
|
comp.df <- .self$createCompetitors()
|
||||||
|
|
||||||
# On supprime le root node, inutile pour les stats d'incidences et autres...
|
# On supprime le root node, inutile pour les stats d'incidences et autres...
|
||||||
full.frame <- .self$tree$frame[-1, ]
|
full.frame <- .self$tree$frame[-1, ]
|
||||||
|
@ -120,18 +125,44 @@ VT.tree <- setRefClass(
|
||||||
if (length(frm) == 0) stop("VT.tree : no tree");
|
if (length(frm) == 0) stop("VT.tree : no tree");
|
||||||
if (ncol(frm)==0) stop("VT.tree : no rules");
|
if (ncol(frm)==0) stop("VT.tree : no rules");
|
||||||
|
|
||||||
pth <- rpart::path.rpart(.self$tree, nodes = row.names(frm), print.it = F)
|
pth <- path.rpart(.self$tree, nodes = row.names(frm), print.it = F)
|
||||||
# Delete 'root' node from rules
|
# Delete 'root' node des règles
|
||||||
pth <- lapply(pth, FUN = function(d) return(d[-1]))
|
pth <- lapply(pth, FUN = function(d) return(d[-1]))
|
||||||
|
|
||||||
depth <- 0
|
nodes <- c()
|
||||||
nodes <- names(pth)
|
if(isTRUE(compete)){
|
||||||
|
comp <- comp.df$path
|
||||||
|
for(i in names(pth)){
|
||||||
|
tmp <- length(comp[comp == i][-1])
|
||||||
|
if(tmp>0){
|
||||||
|
tmp <- 1:tmp
|
||||||
|
tmp <- paste(i, tmp, sep = ".")
|
||||||
|
nodes <- c(nodes, i, tmp)
|
||||||
|
}else
|
||||||
|
nodes <- c(nodes, i)
|
||||||
|
}
|
||||||
|
}else
|
||||||
|
nodes <- names(pth)
|
||||||
|
|
||||||
rules <- data.frame(replicate(6, character(0), simplify = T), replicate(2, numeric(0), simplify = T), stringsAsFactors = F)
|
rules <- data.frame(replicate(6, character(0), simplify = T), replicate(2, numeric(0), simplify = T), stringsAsFactors = F)
|
||||||
|
|
||||||
colnames(rules) <- c("Subgroup", "Subgroup size", "Treatement event rate", "Control event rate",
|
colnames(rules) <- c("Subgroup", "Subgroup size", "Treatement event rate", "Control event rate",
|
||||||
"Treatment sample size", "Control sample size", "RR (resub)", "RR (snd)")
|
"Treatment sample size", "Control sample size", "RR (resub)", "RR (snd)")
|
||||||
for(i in nodes){
|
for(i in nodes){
|
||||||
pth.text <- paste(pth[[i]], collapse = " & ")
|
is.comp <- FALSE
|
||||||
|
if (isTRUE(length(grep("^\\d+\\.\\d+$", i)) > 0)){
|
||||||
|
tmp.str <- strsplit(x = i, split = ".", fixed = T)[[1]]
|
||||||
|
tmp.path <- as.numeric(tmp.str[1])
|
||||||
|
tmp.path.str <- tmp.str[1]
|
||||||
|
tmp.comp <- as.numeric(tmp.str[2])
|
||||||
|
l <- length(pth[[tmp.path.str]])
|
||||||
|
pth.text.c <- c(pth[[tmp.path.str]][-l], comp.df[comp.df$path == tmp.path, ][(tmp.comp+1), "string"])
|
||||||
|
pth.text <- paste(pth.text.c, collapse = " & ")
|
||||||
|
is.comp <- TRUE
|
||||||
|
}else{
|
||||||
|
pth.text <- paste(pth[[i]], collapse = " & ")
|
||||||
|
}
|
||||||
|
|
||||||
incid <- .self$getIncidences(pth.text)
|
incid <- .self$getIncidences(pth.text)
|
||||||
|
|
||||||
rules[i, 1] <- pth.text
|
rules[i, 1] <- pth.text
|
||||||
|
@ -147,24 +178,30 @@ VT.tree <- setRefClass(
|
||||||
cat("----------------------------\n")
|
cat("----------------------------\n")
|
||||||
cat(sprintf("| Rule number %s : ", i))
|
cat(sprintf("| Rule number %s : ", i))
|
||||||
|
|
||||||
|
if(isTRUE(!is.comp)){
|
||||||
|
if(inherits(.self, "VT.tree.reg")){
|
||||||
|
cat(sprintf("Y val = %0.3f \n", frm[i, ]$yval))
|
||||||
|
}else{
|
||||||
|
cat(sprintf("Y val = %i \n", frm[i, ]$yval))
|
||||||
|
}
|
||||||
|
|
||||||
if(inherits(.self, "VT.tree.reg")){
|
cat("----------------------------\n")
|
||||||
cat(sprintf("Y val = %0.3f \n", frm[i, ]$yval))
|
|
||||||
}else{
|
cat(sprintf("[n = %i", frm[i, ]$n))
|
||||||
cat(sprintf("Y val = %i \n", frm[i, ]$yval))
|
cat(sprintf(", loss = %s, prob = %0.2f",
|
||||||
|
frm[i, ]$dev,
|
||||||
|
frm[i, ]$yval2[, 5]))
|
||||||
|
|
||||||
|
cat("] \n")
|
||||||
|
cat("\t\t")
|
||||||
|
cat(pth[[i]], sep="\n\t\t")
|
||||||
|
|
||||||
|
} else {
|
||||||
|
cat("\n----------------------------\n")
|
||||||
|
cat("\t\t")
|
||||||
|
cat(pth.text.c, sep="\n\t\t")
|
||||||
}
|
}
|
||||||
|
|
||||||
cat("----------------------------\n")
|
|
||||||
|
|
||||||
cat(sprintf("[n = %i", frm[i, ]$n))
|
|
||||||
cat(sprintf(", loss = %s, prob = %0.2f",
|
|
||||||
frm[i, ]$dev,
|
|
||||||
frm[i, ]$yval2[, 5]))
|
|
||||||
|
|
||||||
cat("] \n")
|
|
||||||
cat("\t\t")
|
|
||||||
cat(pth[[i]], sep="\n\t\t")
|
|
||||||
|
|
||||||
if(isTRUE(tables)){
|
if(isTRUE(tables)){
|
||||||
cat("\n")
|
cat("\n")
|
||||||
cat(sprintf("Incidence dans la selection \n"))
|
cat(sprintf("Incidence dans la selection \n"))
|
||||||
|
@ -187,6 +224,33 @@ VT.tree <- setRefClass(
|
||||||
return(invisible(rules))
|
return(invisible(rules))
|
||||||
},
|
},
|
||||||
|
|
||||||
|
createCompetitors = function(){
|
||||||
|
|
||||||
|
fr <- .self$tree$frame
|
||||||
|
fr <- fr[fr$var != "<leaf>",]
|
||||||
|
sp <- .self$tree$splits
|
||||||
|
sp <- as.data.frame(sp)
|
||||||
|
sp$var <- row.names(sp)
|
||||||
|
row.names(sp) <- NULL
|
||||||
|
|
||||||
|
sp$path <- rep(as.numeric(row.names(fr)), (fr$ncompete+fr$nsurrogate+1))
|
||||||
|
sp$string <- paste(sp$var, ifelse(sp$ncat == -1L, "<", ">="), round(sp$index, digits = 3))
|
||||||
|
|
||||||
|
sp <- with(sp, sp[adj==0, ])
|
||||||
|
sp <- with(sp, sp[, -5])
|
||||||
|
|
||||||
|
sp.2 <- sp.3 <- sp
|
||||||
|
sp.2$path <- sp$path*2
|
||||||
|
sp.2$string <- paste(sp.2$var, ifelse(sp.2$ncat == -1L, "<", ">="), round(sp.2$index, digits = 3))
|
||||||
|
|
||||||
|
sp.3$path <- sp$path*2+1
|
||||||
|
sp.3$string <- paste(sp.3$var, ifelse(sp.3$ncat == -1L, ">=", "<"), round(sp.3$index, digits = 3))
|
||||||
|
|
||||||
|
.self$competitors <- rbind(sp.2, sp.3)
|
||||||
|
|
||||||
|
return(invisible(.self$competitors))
|
||||||
|
},
|
||||||
|
|
||||||
getIncidences = function(rule, rr.snd = T){
|
getIncidences = function(rule, rr.snd = T){
|
||||||
return(VT.incidences(.self$vt.difft, rule, rr.snd))
|
return(VT.incidences(.self$vt.difft, rule, rr.snd))
|
||||||
},
|
},
|
||||||
|
|
Loading…
Reference in a new issue