finished implementing 'selection' option for plot

R/SFCB.R

@@ -272,11 +272,13 @@ print.SFCB <- function(x, ...) {
 plot.SFCB <- function(x, 
                       plot.type = c("dendrogram", "selection", "importance"),
                       shape.imp = c("boxplot", "histogram"),
-                      sel.type = c("importance", "selection")) {
+                      sel.type = c("importance", "selection"),
+                      threshold = "none") {
   args <- list("x" = x)
   args$"plot.type" <- match.arg(plot.type)
   args$"shape.imp" <- match.arg(shape.imp)
   args$"sel.type" <- match.arg(sel.type)
+  args$"threshold" <- threshold
   
   plot_function <- sprintf("plot_%s", plot.type)
   plot_function <- eval(as.name(plot_function))

R/plot_functions.R

@@ -35,9 +35,25 @@ plot_importance <- function(x, shape.imp) {
   return(p)
 }
 
-plot_selection <- function(x, sel.type) {
+plot_selection <- function(x, sel.type, threshold) {
   is_selected <- "selected" %in% names(x)
-  if (sel.type == "selection" && !is_selected)
+  
+  if (threshold != "none") {
+    if (!is.numeric(threshold)) stop("'threshold' must be numeric.")
+    
+    if (is_selected) 
+      stop(paste("A selection method has already been used: 'threshold' must",
+                 "be 'none'."))
+           
+    if (sel.type != "selection") {
+      warning(paste("A 'threshold' has passed to the plot function while",
+                    "'sel.type' is not 'selection'. Automatically switching it",
+                    "to 'selection'."))
+      sel.type <- "selection"
+    }
+  }
+  
+  if (sel.type == "selection" && !is_selected && threshold == "none")
     stop(paste("Variable selection was not used on this result. Choose",
                "sel.type = 'importance'"))
   
@@ -46,6 +62,29 @@ plot_selection <- function(x, sel.type) {
   basics <- ncol(x$importances[[1]]) != nrepeats
   var_names <- names(x$groups[[1]])
   
+  if (threshold != "none") {
+    if (!basics) { # not basics, 'at'
+      best <- tapply(x$mse$mse, x$mse$clust, which.min)
+      x$selected <- mapply(function(a, b) { rownames(a)[a[, b] > threshold] }, 
+                           x$importances, best, SIMPLIFY = FALSE)
+    } else {
+      best <- tapply(x$mse$mse, x$mse$clust, which.min)
+      x$selected <- mapply(function(a, b) {
+        bmean <- paste0("mean", b)
+        bmean <- rownames(a)[a[, bmean] > threshold]
+        bsd <- paste0("sd", b)
+        bsd <- rownames(a)[a[, bsd] > threshold]
+        bsd <- na.omit(bsd)
+        variables <- unique(c(bmean, bsd))
+        variables <- var_names[var_names %in% variables]
+        out <- data.frame("variable" = variables,
+                          "in.mean" = variables %in% bmean,
+                          "in.sd" = variables %in% bsd)
+        return(out)
+      }, x$importances, best, SIMPLIFY = FALSE)
+    }
+  }
+  
   if (sel.type == "selection") { # not basics, 'at'
     if (lobj == 1 & !basics) {
       dfline <- make_line_df(x$selected[[1]], var_names)
@@ -247,22 +286,30 @@ fill_na <- function(dataset, var) {
 
 make_line_df <- function(selected, var_names, level = 1) {
   which_sel <- match(selected, var_names)
-  diff_which <- diff(which_sel)
-  starts <- which(diff_which > 1) + 1
-  starts <- c(which_sel[1], which_sel[starts])
-  ends <- which(diff_which > 1)
-  ends <- c(which_sel[ends], which_sel[length(which_sel)])
-  df <- data.frame("xstart" = starts, "ystart" = rep(level, length(starts)),
-                   "xend" = ends, "yend" = rep(level, length(starts)))
-  which_sel <- setdiff(seq_along(var_names), which_sel)
-  diff_which <- diff(which_sel)
-  starts <- which(diff_which > 1) + 1
-  starts <- c(which_sel[1], which_sel[starts])
-  ends <- which(diff_which > 1)
-  ends <- c(which_sel[ends], which_sel[length(which_sel)])
-  df2 <- data.frame("xstart" = starts, "ystart" = rep(0, length(starts)),
-                    "xend" = ends, "yend" = rep(0, length(starts)))
-  df <- rbind(df, df2)
+  if (length(which_sel) > 0 & length(which_sel) < length(var_names)) {
+    diff_which <- diff(which_sel)
+    starts <- which(diff_which > 1) + 1
+    starts <- c(which_sel[1], which_sel[starts])
+    ends <- which(diff_which > 1)
+    ends <- c(which_sel[ends], which_sel[length(which_sel)])
+    df <- data.frame("xstart" = starts, "ystart" = rep(level, length(starts)),
+                     "xend" = ends, "yend" = rep(level, length(starts)))
+    which_sel <- setdiff(seq_along(var_names), which_sel)
+    diff_which <- diff(which_sel)
+    starts <- which(diff_which > 1) + 1
+    starts <- c(which_sel[1], which_sel[starts])
+    ends <- which(diff_which > 1)
+    ends <- c(which_sel[ends], which_sel[length(which_sel)])
+    df2 <- data.frame("xstart" = starts, "ystart" = rep(0, length(starts)),
+                      "xend" = ends, "yend" = rep(0, length(starts)))
+    df <- rbind(df, df2)
+  } else if (length(which_sel) == 0) {
+    df <- data.frame("xstart" = 1, "ystart" = 0, "xend" = length(var_names),
+                     "yend" = 0)
+  } else {
+    df <- data.frame("xstart" = 1, "ystart" = level, "xend" = length(var_names),
+                     "yend" = level)
+  }
   return(df)
 }
 

man/SFCB.Rd

@@ -15,7 +15,9 @@
 \method{plot}{SFCB}(
   x,
   plot.type = c("dendrogram", "selection", "importance"),
-  shape.imp = c("boxplot", "histogram")
+  shape.imp = c("boxplot", "histogram"),
+  sel.type = c("importance", "selection"),
+  threshold = "none"
 )
 }
 \arguments{