diff --git a/R/plot_functions.R b/R/plot_functions.R index 694d667759360f6664117b483e6bfa4de9358803..a083779264f62908bb572563e436ffd22ec08244 100644 --- a/R/plot_functions.R +++ b/R/plot_functions.R @@ -17,7 +17,7 @@ plot_dendrogram <- function(x) { basics <- ncol(x$importances[[1]]) != (nrow(x$mse) / length(all_at)) if (basics) { all_groups <- rep(names(x$groups), 2) - all_types <- rep(c("mean", "sd"), each = length(x$groups)) + all_types <- rep(c("mean", "sd"), each = nrange) } all_h <- rev(x$dendro$height) @@ -37,44 +37,66 @@ plot_dendrogram <- function(x) { } } + if (!basics) { + if (nrange > 3) { + cutb <- 3 + message(paste("Only the first 3 selections are represented below. If ", + "you want to display others, please use `extract_at`", + "before plotting.")) + } else cutb <- nrange + } else { + if (nrange > 2) { + cutb <- 2 + message(paste("Only the first 2 selections are represented below. If", + "you want to display others, please use `extract_at`", + "before plotting.")) + } else cutb <- nrange + all_types_c <- rep(c("mean", "sd"), each = cutb) + all_groups_c <- rep(names(x$groups)[1:cutb], 2) + } + + # bars if ("selected" %in% names(x)) { # case 'selected' - values <- replicate(nrange, rep("grey", length(labs)), simplify = FALSE) + values <- replicate(cutb, rep("grey", length(labs)), simplify = FALSE) if (!basics) { values <- mapply(function(a, b) { names(a) <- labs; a[b] <- "darkred"; return(a) - }, values, x$selected) - bar_labs <- paste("#int.:", names(x$groups), "- sel:") + }, values, x$selected[1:cutb]) + bar_labs <- paste("#int.:", names(x$groups)[1:cutb], "- sel:") } else { values_mean <- mapply(function(a, b) { names(a) <- labs; a[b$variable[b$"in.mean"]] <- "darkred"; return(a) - }, values, x$selected) + }, values, x$selected[1:cutb]) values_sd <- mapply(function(a, b) { names(a) <- labs; a[b$variable[b$"in.sd"]] <- "darkred"; return(a) - }, values, x$selected) + }, values, x$selected[1:cutb]) values <- cbind(values_mean, values_sd) - bar_labs <- paste(all_groups, "/", all_types, "sel.") + bar_labs <- paste(all_groups_c, "/", all_types_c, "sel.") } } else { best <- tapply(x$mse$mse, x$mse$clust, which.min) if (!basics) { - values <- mapply(function(a, b) return(a[, b]), x$importances, best) + values <- mapply(function(a, b) return(a[, b]), + x$importances[1:cutb], best[1:cutb]) values <- apply(values, 2, cut, breaks = 9, labels = FALSE) values <- apply(values, 2, function(acol) brewer.pal(9, "YlOrRd")[acol]) - bar_labs <- paste("#int.:", names(x$groups), "- imp.") + bar_labs <- paste("#int.:", names(x$groups)[1:cutb], "- imp.") } else { bestm <- paste0("mean", best) bestsd <- paste0("sd", best) - values_m <- mapply(function(a, b) return(a[, b]), x$importances, bestm) + values_m <- mapply(function(a, b) return(a[, b]), + x$importances[1:cutb], bestm[1:cutb]) values_m <- apply(values_m, 2, cut, breaks = 9, labels = FALSE) values_m <- apply(values_m, 2, function(acol) brewer.pal(9, "YlOrRd")[acol]) - values_sd <- mapply(function(a, b) return(a[, b]), x$importances, bestsd) + values_sd <- mapply(function(a, b) return(a[, b]), + x$importances[1:cutb], bestsd[1:cutb]) values_sd <- apply(values_sd, 2, cut, breaks = 9, labels = FALSE) values_sd <- apply(values_sd, 2, function(acol) brewer.pal(9, "YlOrRd")[acol]) values_sd[is.na(values_sd)] <- "black" values <- cbind(values_m, values_sd) - bar_labs <- paste(all_groups, "/", all_types, "- imp.") + bar_labs <- paste(all_groups_c, "/", all_types_c, "- imp.") } } # bars