added option 'selection' in plot.selection

R/plot_functions.R

@@ -46,7 +46,72 @@ plot_selection <- function(x, sel.type) {
   basics <- ncol(x$importances[[1]]) != nrepeats
   var_names <- names(x$groups[[1]])
   
-  if (sel.type == "selection") {
+  if (sel.type == "selection") { # not basics, 'at'
+    if (lobj == 1 & !basics) {
+      dfline <- make_line_df(x$selected[[1]], var_names)
+      dfrect <- make_rect_df(x$selected[[1]], var_names)
+      
+      p <- ggplot() +
+        geom_rect(data = dfrect, 
+                  aes(xmin = xstart, ymin = ystart, xmax = xend, ymax = yend), 
+                  alpha = 0.2)
+    } else if (!basics) { # not basics, 'range_at'
+      all_levels <- seq(0.7, 1, length.out = length(x$selected))
+      dfline <- mapply(function(a, b) {
+        make_line_df(a, var_names = var_names, level = b)
+      }, x$selected, all_levels, SIMPLIFY = FALSE)
+      
+      all_at <- sapply(dfline, nrow)
+      all_at <- rep(names(dfline), all_at)
+      dfline <- data.frame(Reduce(rbind, dfline), "at" = all_at)
+      
+      p <- ggplot(data = dfline, aes(group = at, colour = at))
+    } else if (lobj == 1) { # basics, 'at'
+      sel_mean <- x$selected[[1]]$variable[x$selected[[1]]$"in.mean"]
+      dfline_mean <- make_line_df(sel_mean, var_names)
+      sel_sd <- x$selected[[1]]$variable[x$selected[[1]]$"in.sd"]
+      dfline_sd <- make_line_df(sel_sd, var_names, level = 0.8)
+      dfline <- rbind(dfline_mean, dfline_sd)
+      dfline$type <- c(rep("mean", nrow(dfline_mean)),
+                       rep("sd", nrow(dfline_sd)))
+      
+      p <- ggplot(data = dfline, aes(group = type, colour = type))
+    } else { # basics, 'range_at'
+      dfmean <- lapply(x$selected, 
+                       function(alist) alist$variable[alist$"in.mean"])
+      names(dfmean) <- paste0("mean", names(dfmean))
+      dfsd <- lapply(x$selected, function(alist) alist$variable[alist$"in.sd"])
+      names(dfsd) <- paste0("sd", names(dfmean))
+      df <- c(dfmean, dfsd)
+      
+      all_levels <- seq(0.7, 1, length.out = length(df))
+      dfline <- mapply(function(a, b) {
+        make_line_df(a, var_names = var_names, level = b)
+      }, df, all_levels, SIMPLIFY = FALSE)
+      
+      all_at <- sapply(dfline, nrow)
+      all_at <- rep(names(dfline), all_at)
+      dfline <- data.frame(Reduce(rbind, dfline), "at" = all_at)
+      
+      p <- ggplot(data = dfline, aes(group = at, colour = at))
+    }
+    
+     p <- p +
+      geom_segment(data = dfline, 
+                   aes(x = xstart, y = ystart, xend = xend, yend = yend), 
+                   size = 1) +
+      theme_bw() + xlim(1, length(var_names)) + 
+      scale_y_continuous(breaks = c(0, 1), minor_breaks = c(0, 1), 
+                         labels = c("not selected", "selected"),
+                         limits = c(0, 1.23)) +
+      theme(axis.title.y = element_blank(), axis.title.x = element_blank())
+     if (lobj == 1 & basics) { # basics, 'at'
+       p <- p + guides(colour = guide_legend(title = "for summary..."))
+     } else if (!basics & lobj > 1) { # not basics, 'range_at'
+       p <- p + guides(colour = guide_legend(title = "# intervals"))
+     } else if (lobj > 1) { # basics, 'range_at'
+       p <- p + guides(colour = guide_legend(title = "summary + # interv."))
+     }
     
   } else { # sel.type == "importance"
     if (lobj == 1 & !basics) {
@@ -89,15 +154,13 @@ plot_selection <- function(x, sel.type) {
       p <- ggplot(df, aes(x = x, group = at, colour = at, fill = at))
     }
     
-    # if (!is_selected) 
-    #   p <- p + geom_ribbon(aes(ymin = min, ymax = max), alpha = 0.1)
-    
-    p <- p + geom_ribbon(aes(ymin = min, ymax = max), alpha = 0.1) + geom_line(aes(y = mean)) + theme_bw() + 
+    p <- p + geom_ribbon(aes(ymin = min, ymax = max), alpha = 0.1) + 
+      geom_line(aes(y = mean)) + theme_bw() + 
       ylab("variable importance") +
       theme(axis.title.x = element_blank(), axis.text.x = element_blank(),
             axis.ticks.x = element_blank())
-
   }
+  
   return(p)
 }
 
@@ -181,3 +244,37 @@ fill_na <- function(dataset, var) {
   dataset[, var] <- out
   return(dataset)
 }
+
+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)
+  return(df)
+}
+
+make_rect_df <- function(selected, var_names) {
+  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_rect <- data.frame("xstart" = starts, "ystart" = rep(0, length(starts)), 
+                        "xend" = ends, "yend" = rep(1, length(starts)))
+
+  return(df_rect)
+}