diff --git a/R/tree.R b/R/tree.R index 971d368..0d2ce99 100644 --- a/R/tree.R +++ b/R/tree.R @@ -23,6 +23,7 @@ VT.tree <- setRefClass( sens = "character", name = "character", tree = "rpart", + competitors = "data.frame", Ahat = "vector" ), @@ -83,12 +84,16 @@ VT.tree <- setRefClass( 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... full.frame <- .self$tree$frame[-1, ] - if (only.fav == T){ + if (only.fav == T){ if(inherits(.self, "VT.tree.reg")){ if(.self$sens == ">"){ frm.only.fav <- full.frame[full.frame$yval >= (.self$threshold), ] @@ -120,18 +125,44 @@ VT.tree <- setRefClass( if (length(frm) == 0) stop("VT.tree : no tree"); if (ncol(frm)==0) stop("VT.tree : no rules"); - pth <- rpart::path.rpart(.self$tree, nodes = row.names(frm), print.it = F) - # Delete 'root' node from rules + pth <- path.rpart(.self$tree, nodes = row.names(frm), print.it = F) + # Delete 'root' node des règles pth <- lapply(pth, FUN = function(d) return(d[-1])) - depth <- 0 - nodes <- names(pth) + nodes <- c() + 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) colnames(rules) <- c("Subgroup", "Subgroup size", "Treatement event rate", "Control event rate", "Treatment sample size", "Control sample size", "RR (resub)", "RR (snd)") 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) rules[i, 1] <- pth.text @@ -147,24 +178,30 @@ VT.tree <- setRefClass( cat("----------------------------\n") cat(sprintf("| Rule number %s : ", i)) - - 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(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)) + } + + 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") + + } 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)){ cat("\n") cat(sprintf("Incidence dans la selection \n")) @@ -187,6 +224,33 @@ VT.tree <- setRefClass( return(invisible(rules)) }, + createCompetitors = function(){ + + fr <- .self$tree$frame + fr <- fr[fr$var != "",] + 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){ return(VT.incidences(.self$vt.difft, rule, rr.snd)) },