From e3dc38b95d42d6e238839a23d4bfda59fef5939a Mon Sep 17 00:00:00 2001 From: Nathaniel Phillips Date: Thu, 23 May 2024 09:28:11 -0400 Subject: [PATCH 01/12] ran styler on plotfftrees --- R/plotFFTrees_function.R | 2463 ++++++++++++++++++-------------------- 1 file changed, 1186 insertions(+), 1277 deletions(-) diff --git a/R/plotFFTrees_function.R b/R/plotFFTrees_function.R index 8fe72957..732e3825 100644 --- a/R/plotFFTrees_function.R +++ b/R/plotFFTrees_function.R @@ -98,36 +98,43 @@ #' #' @examples #' # Create FFTs (for heartdisease data): -#' heart_fft <- FFTrees(formula = diagnosis ~ ., -#' data = heart.train) +#' heart_fft <- FFTrees( +#' formula = diagnosis ~ ., +#' data = heart.train +#' ) #' #' # Visualize the default FFT (Tree #1, what = 'all'): -#' plot(heart_fft, main = "Heart disease", -#' decision.labels = c("Absent", "Present")) +#' plot(heart_fft, +#' main = "Heart disease", +#' decision.labels = c("Absent", "Present") +#' ) #' #' # Visualize cue accuracies (in ROC space): -#' plot(heart_fft, what = "cues", main = "Cue accuracies for heart disease data") +#' plot(heart_fft, what = "cues", main = "Cue accuracies for heart disease data") #' #' # Visualize tree diagram with icon arrays on exit nodes: -#' plot(heart_fft, what = "icontree", n.per.icon = 2, -#' main = "Diagnosing heart disease") +#' plot(heart_fft, +#' what = "icontree", n.per.icon = 2, +#' main = "Diagnosing heart disease" +#' ) #' #' # Visualize performance comparison in ROC space: #' plot(heart_fft, what = "roc", main = "Performance comparison for heart disease data") #' #' # Visualize predictions of FFT #2 (for new test data) with custom options: -#' plot(heart_fft, tree = 2, data = heart.test, -#' main = "Predicting heart disease", -#' cue.labels = c("1. thal?", "2. cp?", "3. ca?", "4. exang"), -#' decision.labels = c("ok", "treat"), truth.labels = c("Healthy", "Sick"), -#' n.per.icon = 2, -#' show.header = TRUE, show.confusion = TRUE, show.levels = TRUE, show.roc = TRUE, -#' hlines = FALSE, font = 3, col = "steelblue") +#' plot(heart_fft, +#' tree = 2, data = heart.test, +#' main = "Predicting heart disease", +#' cue.labels = c("1. thal?", "2. cp?", "3. ca?", "4. exang"), +#' decision.labels = c("ok", "treat"), truth.labels = c("Healthy", "Sick"), +#' n.per.icon = 2, +#' show.header = TRUE, show.confusion = TRUE, show.levels = TRUE, show.roc = TRUE, +#' hlines = FALSE, font = 3, col = "steelblue" +#' ) #' #' # # For details, see #' # vignette("FFTrees_plot", package = "FFTrees") #' -#' #' @family plot functions #' #' @seealso @@ -145,7 +152,7 @@ plot.FFTrees <- function(x = NULL, # data = "train", - what = "all", # valid_what <- c("all", "default", "cues", "tree", "icontree", "roc") + what = "all", # valid_what <- c("all", "default", "cues", "tree", "icontree", "roc") tree = 1, # main = NULL, @@ -173,13 +180,12 @@ plot.FFTrees <- function(x = NULL, n.per.icon = NULL, level.type = "bar", # deprecated arguments: - which.tree = NULL, # deprecated: Use tree instead. - decision.names = NULL, # deprecated: Use decision.labels instead. - stats = NULL, # deprecated: Use what = "all" or what = "tree" instead. + which.tree = NULL, # deprecated: Use tree instead. + decision.names = NULL, # deprecated: Use decision.labels instead. + stats = NULL, # deprecated: Use what = "all" or what = "tree" instead. grayscale = FALSE, # graphical parameters: ...) { - # Prepare: ------ par0 <- par(no.readonly = TRUE) @@ -189,38 +195,40 @@ plot.FFTrees <- function(x = NULL, # Deprecated arguments: ---- if (is.null(which.tree) == FALSE) { - warning("plot.FFTrees: 'which.tree' is deprecated. Use 'tree' instead.") tree <- which.tree } if (is.null(decision.names) == FALSE) { - warning("plot.FFTrees: 'decision.names' is deprecated, use 'decision.labels' instead.") decision.labels <- decision.names } - if (is.null(stats) == FALSE){ - + if (is.null(stats) == FALSE) { warning("plot.FFTrees: 'stats' is deprecated, use either what = 'all' or what = 'tree' instead.") - if (stats) { what <- "all" } else { what <- "tree" } + if (stats) { + what <- "all" + } else { + what <- "tree" + } } # Verify what: ---- - valid_what <- c("all", "default", - "cues", "tree", "icontree", "roc") # as (local) constant + valid_what <- c( + "all", "default", + "cues", "tree", "icontree", "roc" + ) # as (local) constant - what <- tolower(substr(what, 1, 3)) # 4robustness + what <- tolower(substr(what, 1, 3)) # 4robustness if (what %in% substr(valid_what, 1, 3) == FALSE) { - valid_string <- paste(valid_what, collapse = ", ") - valid_string_q <- sapply(strsplit(valid_string, ', '), FUN = add_quotes) + valid_string_q <- sapply(strsplit(valid_string, ", "), FUN = add_quotes) stop(paste0("what must be a string in c(", valid_string_q, ").", sep = "")) } @@ -230,11 +238,10 @@ plot.FFTrees <- function(x = NULL, if (what == "cue") { # handle special case: - showcues(x = x, main = main, ...) # pass key inputs + graphical parameters + showcues(x = x, main = main, ...) # pass key inputs + graphical parameters # Note: The argument data = data was removed from showcues(), # as currently no cue accuracy statistics exist in x. - } @@ -265,7 +272,6 @@ plot.FFTrees <- function(x = NULL, if (is.null(show.iconguide)) { show.iconguide <- TRUE } - } # if (what == "all" | "def"). @@ -292,7 +298,6 @@ plot.FFTrees <- function(x = NULL, if (is.null(show.iconguide)) { show.iconguide <- FALSE } - } # if (what == "tre"). @@ -319,7 +324,6 @@ plot.FFTrees <- function(x = NULL, if (is.null(show.iconguide)) { show.iconguide <- FALSE } - } # if (what == "ico"). @@ -334,7 +338,6 @@ plot.FFTrees <- function(x = NULL, show.top <- FALSE hlines <- FALSE - } # if (what == "roc"). @@ -345,58 +348,54 @@ plot.FFTrees <- function(x = NULL, # Top, middle, and bottom: if (show.header & show.tree & (show.confusion | show.levels | show.roc)) { - - show.top <- TRUE + show.top <- TRUE show.middle <- TRUE show.bottom <- TRUE layout(matrix(1:3, nrow = 3, ncol = 1), - widths = c(6), - heights = c(1.2, 3, 1.8) + widths = c(6), + heights = c(1.2, 3, 1.8) ) } # Top and middle only: if (show.header & show.tree & (show.confusion == FALSE & show.levels == FALSE & show.roc == FALSE)) { - show.top <- TRUE show.middle <- TRUE show.bottom <- FALSE layout(matrix(1:2, nrow = 2, ncol = 1), - widths = c(6), - heights = c(1.2, 3)) + widths = c(6), + heights = c(1.2, 3) + ) } # Middle and bottom only: if (show.header == FALSE & show.tree & (show.confusion | show.levels | show.roc)) { - show.top <- FALSE show.middle <- TRUE show.bottom <- TRUE layout(matrix(1:2, nrow = 2, ncol = 1), - widths = c(6), - heights = c(3, 1.8) + widths = c(6), + heights = c(3, 1.8) ) } # Middle only: if (show.header == FALSE & show.tree & (show.confusion == FALSE & show.levels == FALSE & show.roc == FALSE)) { - show.top <- FALSE show.middle <- TRUE show.bottom <- FALSE layout(matrix(1:1, nrow = 1, ncol = 1), - widths = c(6), - heights = c(3) + widths = c(6), + heights = c(3) ) } # Bottom only: if (show.header == FALSE & show.tree == FALSE) { - show.top <- FALSE show.middle <- FALSE show.bottom <- TRUE @@ -404,8 +403,8 @@ plot.FFTrees <- function(x = NULL, nplots <- show.confusion + show.levels + show.roc layout(matrix(1:nplots, nrow = 1, ncol = nplots), - widths = c(3 * nplots), - heights = c(3) + widths = c(3 * nplots), + heights = c(3) ) } @@ -416,18 +415,16 @@ plot.FFTrees <- function(x = NULL, # OR an entire data frame (of new test data): if (inherits(data, "character")) { - - data <- tolower(data) # 4robustness + data <- tolower(data) # 4robustness # testthat::expect_true(data %in% c("train", "test")) - if (!data %in% c("test", "train")){ + if (!data %in% c("test", "train")) { stop("The data to plot must be 'test' or 'train'.") } } if (inherits(data, "data.frame")) { - message("Applying FFTrees object x to new test data...") x <- fftrees_apply(x, mydata = "test", newdata = data) @@ -435,7 +432,6 @@ plot.FFTrees <- function(x = NULL, message("Success, but re-assign output to x or use fftrees_apply() to globally change x") data <- "test" # in rest of this function - } @@ -447,46 +443,35 @@ plot.FFTrees <- function(x = NULL, # decision.labels: if (is.null(decision.labels)) { - if (("decision.labels" %in% names(x$params))) { decision.labels <- x$params$decision.labels } else { decision.labels <- c(0, 1) } - } # truth.labels: if (is.null(truth.labels)) { - truth.labels <- decision.labels # ToDo: Check for 2 cases, else use a default of c(0, 1). - } # main: ---- if (is.null(main)) { - if (("main" %in% names(x$params))) { - if (is.null(x$params$main)) { - if (show.header) { main <- "Data" } else { main <- "" } - } else { main <- x$params$main } - } else { - if (inherits(data, "character")) { - if (data == "train") { main <- "Data (Training)" } @@ -499,9 +484,7 @@ plot.FFTrees <- function(x = NULL, if (inherits(data, "data.frame")) { main <- "Test Data" } - } # if (("main" %in% names(x$params))). - } # if (is.null(main)). @@ -509,50 +492,52 @@ plot.FFTrees <- function(x = NULL, # Verify tree input: ---- - tree <- verify_tree_arg(x = x, data = data, tree = tree) # use helper (for plotting AND printing) + tree <- verify_tree_arg(x = x, data = data, tree = tree) # use helper (for plotting AND printing) # Get "best" tree: ---- if (tree == "best.train") { - - if (data == "test"){ + if (data == "test") { warning("You asked for the 'best.train' tree, but data was set to 'test'. Used the best tree for 'train' data instead...") data <- "train" - if (is.null(main)) { main <- "Data (Training)" } + if (is.null(main)) { + main <- "Data (Training)" + } } # tree <- x$trees$best$train # using current x - tree <- get_best_tree(x, data = "train", goal = x$params$goal) # using helper + tree <- get_best_tree(x, data = "train", goal = x$params$goal) # using helper } if (tree == "best.test") { - - if (data == "train"){ + if (data == "train") { warning("You asked for the 'best.test' tree, but data was set to 'train'. Used the best tree for 'test' data instead...") data <- "test" - if (is.null(main)) { main <- "Data (Testing)" } + if (is.null(main)) { + main <- "Data (Testing)" + } } # tree <- x$trees$best$test # using current x - tree <- get_best_tree(x, data = "test", goal = x$params$goal) # using helper + tree <- get_best_tree(x, data = "test", goal = x$params$goal) # using helper } # Define critical objects: ------ # decision_v <- x$trees$decisions[[data]][[tree]]$decision - tree_stats <- x$trees$stats[[data]] + tree_stats <- x$trees$stats[[data]] level_stats <- x$trees$level_stats[[data]][x$trees$level_stats[[data]]$tree == tree, ] # Get criterion (from object x): - criterion_name <- x$criterion_name # (only ONCE) + criterion_name <- x$criterion_name # (only ONCE) # Compute criterion baseline/base rate: - if (allow_NA_crit){ + if (allow_NA_crit) { crit_br <- mean(x$data[[data]][[criterion_name]], na.rm = TRUE) } else { # default: - crit_br <- mean(x$data[[data]][[criterion_name]]) # (from logical, i.e., proportion of TRUE values) + crit_br <- mean(x$data[[data]][[criterion_name]]) # (from logical, i.e., proportion of TRUE values) } n_exemplars <- nrow(x$data[[data]]) @@ -569,13 +554,12 @@ plot.FFTrees <- function(x = NULL, # Add marginal classification statistics to level_stats / Frequencies per level: - level_stats$hi_m <- NA # initialize marginal freqs + level_stats$hi_m <- NA # initialize marginal freqs level_stats$fa_m <- NA level_stats$mi_m <- NA level_stats$cr_m <- NA for (i in 1:n_levels) { - if (i == 1) { level_stats$hi_m[1] <- level_stats$hi[1] level_stats$fa_m[1] <- level_stats$fa[1] @@ -589,7 +573,6 @@ plot.FFTrees <- function(x = NULL, level_stats$mi_m[i] <- level_stats$mi[i] - level_stats$mi[i - 1] level_stats$cr_m[i] <- level_stats$cr[i] - level_stats$cr[i - 1] } - } # for n_levels. # print(level_stats) # tree with marginal frequency values (for each level) @@ -602,11 +585,11 @@ plot.FFTrees <- function(x = NULL, # print(paste0("par('cex') = ", par("cex"))) # Note: Value varies from .66 to 1 # Sizes not set by user: - f_cex <- 1 # cex scaling factor + f_cex <- 1 # cex scaling factor decision_node_cex <- 4 * f_cex - exit_node_cex <- 4 * f_cex - panel_title_cex <- 2 * f_cex + exit_node_cex <- 4 * f_cex + panel_title_cex <- 2 * f_cex # Set by user arguments: @@ -636,8 +619,8 @@ plot.FFTrees <- function(x = NULL, panel_line_lty <- 1 # Ball parameters: - ball_col <- c(gray(0), gray(0)) # = black - ball_bg <- c(gray(1), gray(1)) # = white + ball_col <- c(gray(0), gray(0)) # = black + ball_bg <- c(gray(1), gray(1)) # = white ball_pch <- c(21, 24) ball_cex <- c(1, 1) @@ -647,9 +630,9 @@ plot.FFTrees <- function(x = NULL, max_label_length <- 100 # def_par <- par(no.readonly = TRUE) # is NOT used anywhere? - ball_box_width <- 10 - label_box_height <- 2 - label_box_width <- 5 + ball_box_width <- 10 + label_box_height <- 2 + label_box_width <- 5 # Cue labels: if (is.null(cue.labels)) { @@ -675,28 +658,26 @@ plot.FFTrees <- function(x = NULL, plotting_parameters_df <- data.frame( n_levels = 1:6, - plot_height = c(10, 12, 15, 19, 23, 27), # Note: use default, +2 for n_levels == 6 - plot_width = c(14, 16, 20, 24, 28, 34) * 1.0, # Note: use default, +2 for n_levels == 6 + plot_height = c(10, 12, 15, 19, 23, 27), # Note: use default, +2 for n_levels == 6 + plot_width = c(14, 16, 20, 24, 28, 34) * 1.0, # Note: use default, +2 for n_levels == 6 label_box_text_cex = cue.cex, break_label_cex = threshold.cex ) - - } else if ((show.top == FALSE) & show.middle & (show.bottom == FALSE)) { # only "ico" or "tree": + } else if ((show.top == FALSE) & show.middle & (show.bottom == FALSE)) { # only "ico" or "tree": plotting_parameters_df <- data.frame( n_levels = 1:6, plot_height = c(10, 12, 15, 19, 23, 25), - plot_width = c(14, 16, 20, 24, 28, 32) * 0.80, # stretch wider (but not too wide for n.per.icon = 1) + plot_width = c(14, 16, 20, 24, 28, 32) * 0.80, # stretch wider (but not too wide for n.per.icon = 1) label_box_text_cex = cue.cex, break_label_cex = threshold.cex ) - } else { # default: plotting_parameters_df <- data.frame( n_levels = 1:6, plot_height = c(10, 12, 15, 19, 23, 25), - plot_width = c(14, 16, 20, 24, 28, 32) * 1, # stretch to default width + plot_width = c(14, 16, 20, 24, 28, 32) * 1, # stretch to default width label_box_text_cex = cue.cex, break_label_cex = threshold.cex ) @@ -704,19 +685,16 @@ plot.FFTrees <- function(x = NULL, # local variables: if (n_levels < 6) { - label_box_text_cex <- plotting_parameters_df$label_box_text_cex[n_levels] break_label_cex <- plotting_parameters_df$break_label_cex[n_levels] plot_height <- plotting_parameters_df$plot_height[n_levels] plot_width <- plotting_parameters_df$plot_width[n_levels] - } else { # n_levels >= 6: label_box_text_cex <- plotting_parameters_df$label_box_text_cex[6] break_label_cex <- plotting_parameters_df$break_label_cex[6] plot_height <- plotting_parameters_df$plot_height[6] plot_width <- plotting_parameters_df$plot_width[6] - } @@ -736,1418 +714,1350 @@ plot.FFTrees <- function(x = NULL, # col_correct_border <- scales::alpha(correct.colfun(65), .9) if (!grayscale) { - col_error_bg <- "#FF7352CC" col_error_border <- "#AD1A0AE6" col_correct_bg <- "#89FF6FCC" col_correct_border <- "#24AB18E6" - } else { - # Grayscale colors col_error_bg <- gray(.1) col_error_border <- gray(0) col_correct_bg <- gray(1) col_correct_border <- gray(0) - } - # max_cex <- 6 # is NOT used anywhere? - # min_cex <- 1 # is NOT used anywhere? - - exit_node_pch <- 21 - - decision_node_pch <- NA_integer_ - - - # Balls: ---- - - ball_loc <- "variable" - - if (n_levels == 3) { - ball_box_width <- 14 - } - - if (n_levels == 4) { - ball_box_width <- 18 - } - - ball_box_height <- 2.5 - ball_box_horiz_shift <- 10 - ball_box_vert_shift <- -1 - ball_box_max_shift_p <- .9 - ball_box_min_shift_p <- .4 - - ball_box_fixed_x_shift <- c(ball_box_min_shift_p * plot_width, ball_box_max_shift_p * plot_width) - - # Determine N per ball: - if (is.null(n.per.icon)) { - - max_n_side <- max(c(n_pos_cases, n_neg_cases)) - - i <- max_n_side / c(1, 5, 10^(1:10)) - i[i > 50] <- 0 - - n.per.icon <- c(1, 5, 10^(1:10))[which(i == max(i))] - - } - - noise_ball_pch <- ball_pch[1] - signal_ball_pch <- ball_pch[2] - noise_ball_col <- ball_col[1] - signal_ball_col <- ball_col[2] - noise_ball_bg <- ball_bg[1] - signal_ball_bg <- ball_bg[2] - - - # Arrows: ---- - - arrow_lty <- 1 - arrow_lwd <- 1 - arrow_length <- 2.50 - arrow_head_length <- .08 - arrow_col <- gray(0) # = black - - - # Final stats: ---- - - # spec_circle_x <- .40 # is NOT used anywhere? - # dprime_circle_x <- .50 # is NOT used anywhere? - # sens_circle_x <- .60 # is NOT used anywhere? - - # stat_circle_y <- .30 # is NOT used anywhere? - - # sens_circle_col <- "green" # is NOT used anywhere? - # spec_circle_col <- "red" # is NOT used anywhere? - # dprime_circle_col <- "blue" # is NOT used anywhere? - # stat_outer_circle_col <- gray(.50) # is NOT used anywhere? - - - # 1: Initial Frequencies: ------ - - # Parameters: - - if (show.top) { - - par(mar = c(0, 0, 1, 0)) - - # Prepare plot: - plot(1, - xlim = c(0, 1), ylim = c(0, 1), bty = "n", type = "n", - xlab = "", ylab = "", yaxt = "n", xaxt = "n" - ) - - # 1. Title: ---- - - par(xpd = TRUE) - - # (a) lines: - if (hlines) { - - segments(0, .95, 1, .95, col = col_panel_line, lwd = panel_line_lwd, lty = panel_line_lty) # top hline - - x_dev <- get_x_dev(main) - y_dev <- .20 - rect((.50 - x_dev), (1 - y_dev), (.50 + x_dev), (1 + y_dev), col = "white", border = NA) # title background - - } - - # (b) label: - text(x = .50, y = .96, main, cex = panel_title_cex, ...) # title 1 (top): main - - - # 2. Data info: ---- - - # (a) N and labels: - text(x = .50, y = .78, paste("N = ", prettyNum(n_exemplars, big.mark = ","), "", sep = ""), cex = 1.25) # N - text(.50, .63, paste(truth.labels[1], sep = ""), pos = 2, cex = 1.2, adj = 1) # 1: False - text(.50, .63, paste(truth.labels[2], sep = ""), pos = 4, cex = 1.2, adj = 0) # 2: True - - # (b) Show balls: - n_true_pos <- with(final_stats, hi + mi) - n_true_neg <- with(final_stats, fa + cr) - - add_balls( - x_lim = c(.33, .67), - y_lim = c(.12, .52), - n_vec = c(n_true_neg, n_true_pos), - pch_vec = c(noise_ball_pch, signal_ball_pch), - bg_vec = c(noise_ball_bg, signal_ball_bg), - col_vec = c(noise_ball_col, signal_ball_col), - ball_cex = ball_cex, - upper_text_adj = 2, - n_per_icon = n.per.icon - ) - - # (c) n.per.icon legend 1 (top): - - # show_icon_guide_legend <- TRUE # 4debugging - - if (show_icon_guide_legend){ - - text(.98, 0, labels = paste("Showing ", n.per.icon, " cases per icon:", sep = ""), pos = 2) - points(.98, 0, pch = noise_ball_pch, cex = ball_cex) - points(.99, 0, pch = signal_ball_pch, cex = ball_cex) - - } # if (show_icon_guide_legend). - - - par(xpd = FALSE) - - - # 3. Add p_signal and p_noise levels: ----- - - signal_p <- crit_br # criterion baseline/base rate (from above) - noise_p <- (1 - signal_p) - - p_rect_ylim <- c(.10, .60) - - - # (a) p_signal level (on right): ---- - - text( - x = .80, y = p_rect_ylim[2], - labels = paste("p(", truth.labels[2], ")", sep = ""), - pos = 3, cex = 1.2 - ) - - # Filling: - rect(.775, p_rect_ylim[1], - .825, p_rect_ylim[1] + signal_p * diff(p_rect_ylim), - col = gray(.50, .25), border = NA - ) - - # Filltop: - segments(.775, p_rect_ylim[1] + signal_p * diff(p_rect_ylim), - .825, p_rect_ylim[1] + signal_p * diff(p_rect_ylim), - lwd = 1 - ) - - # Outline: - rect(.775, p_rect_ylim[1], - .825, p_rect_ylim[2], - lwd = 1 - ) - - if (signal_p < .0001) { - signal_p_text <- "<1%" - } else { - signal_p_text <- paste(round(signal_p * 100, 0), "%", sep = "") - } - - text(.825, p_rect_ylim[1] + signal_p * diff(p_rect_ylim), - labels = signal_p_text, - pos = 4, cex = 1.2 - ) - - - # (b) p_noise level (on left): ---- - - text( - x = .20, y = p_rect_ylim[2], - labels = paste("p(", truth.labels[1], ")", sep = ""), - pos = 3, cex = 1.2 - ) - - - rect(.175, p_rect_ylim[1], .225, p_rect_ylim[1] + noise_p * diff(p_rect_ylim), - col = gray(.50, .25), border = NA - ) - - # Filltop: - segments(.175, p_rect_ylim[1] + noise_p * diff(p_rect_ylim), - .225, p_rect_ylim[1] + noise_p * diff(p_rect_ylim), - lwd = 1 - ) - - # Outline: - rect(.175, p_rect_ylim[1], .225, p_rect_ylim[2], - lwd = 1 - ) - - if (noise_p < .0001) { - noise_p_text <- "<0.01%" - } else { - noise_p_text <- paste(round(noise_p * 100, 0), "%", sep = "") - } - - text(.175, p_rect_ylim[1] + noise_p * diff(p_rect_ylim), - labels = noise_p_text, - pos = 2, cex = 1.2 - ) - - } # if (show.top). - - - # 2. Main TREE: ------ - - if (show.middle) { - - if ((show.top == FALSE) & (show.bottom == FALSE)) { - par(mar = c(3, 3, 3, 3) + .1) - } else { - par(mar = c(0, 0, 0, 0)) - } - - par(xpd = TRUE) - - # Prepare plot: - plot(1, - xlim = c(-plot_width, plot_width), - ylim = c(-plot_height, 0), - type = "n", bty = "n", - xaxt = "n", yaxt = "n", - ylab = "", xlab = "" - ) - - - # Middle title: ---- - - if (show.top | show.bottom) { - - if (hlines) { - x_dev <- .28 # scaling factor, rather than difference - segments(-plot_width, 0, -plot_width * x_dev, 0, col = col_panel_line, lwd = panel_line_lwd, lty = panel_line_lty) - segments( plot_width, 0, plot_width * x_dev, 0, col = col_panel_line, lwd = panel_line_lwd, lty = panel_line_lty) - } - - if (is.null(label.tree)) { - label.tree <- paste("FFT #", tree, " (of ", x$trees$n, ")", sep = "") - } - - text(x = 0, y = 0, label.tree, cex = panel_title_cex, ...) # title 2 (middle): (a) tree label - - } # if (show.top | show.bottom). + # max_cex <- 6 # is NOT used anywhere? + # min_cex <- 1 # is NOT used anywhere? - if (show.top == FALSE & show.bottom == FALSE) { + exit_node_pch <- 21 - if (is.null(main) & is.null(x$params$main)) { - main <- "" - } + decision_node_pch <- NA_integer_ - mtext(text = main, side = 3, cex = panel_title_cex, ...) # title 2 (middle): (b) main label - } # if (show.top == FALSE & show.bottom == FALSE). + # Balls: ---- + ball_loc <- "variable" - # Icon guide: ------ - - if (show.iconguide) { - - # Parameters: - if (what == "ico") { - - f_x <- 1.2 # scaling factor (to stretch in x-dim) - f_y <- 0.8 # scaling factor (to shift up) - - } else { # default scaling factors: - - f_x <- 1 - f_y <- 1 - - } - - get_exit_word <- get_exit_word(data) # either 'train':'decide' or 'test':'predict' - - - # (a) Noise panel (on left): ---- - - # Parameters: - - if (what == "ico"){ - leg_head_y <- .02 - leg_ball_y <- .14 - } else { - leg_head_y <- .05 - leg_ball_y <- .15 - } - - - # Heading: - text(-plot_width * .60 * f_x, - -plot_height * leg_head_y * f_y, - paste(get_exit_word, decision.labels[1], sep = " "), - cex = 1.2, font = 3 - ) - - # Noise balls: - points(c(-plot_width * .70, -plot_width * .50) * f_x, - c(-plot_height * leg_ball_y, -plot_height * leg_ball_y) * f_y, - pch = c(noise_ball_pch, signal_ball_pch), - bg = c(col_correct_bg, col_error_bg), - col = c(col_correct_border, col_error_border), - cex = ball_cex * 1.5 - ) - - # Labels: - text(c(-plot_width * .70, -plot_width * .50) * f_x, - c(-plot_height * leg_ball_y, -plot_height * leg_ball_y) * f_y, - labels = c("Correct\nRejection", "Miss"), - pos = c(2, 4), offset = .80, cex = 1 - ) - + if (n_levels == 3) { + ball_box_width <- 14 + } + if (n_levels == 4) { + ball_box_width <- 18 + } - # (b) Signal panel (on right): ---- + ball_box_height <- 2.5 + ball_box_horiz_shift <- 10 + ball_box_vert_shift <- -1 + ball_box_max_shift_p <- .9 + ball_box_min_shift_p <- .4 - # Heading: - text( plot_width * .60 * f_x, - -plot_height * leg_head_y * f_y, - paste(get_exit_word, decision.labels[2], sep = " "), - cex = 1.2, font = 3 - ) + ball_box_fixed_x_shift <- c(ball_box_min_shift_p * plot_width, ball_box_max_shift_p * plot_width) - # Signal balls: - points(c(plot_width * .50, plot_width * .70 ) * f_x, - c(-plot_height * leg_ball_y, -plot_height * leg_ball_y) * f_y, - pch = c(noise_ball_pch, signal_ball_pch), - bg = c(col_error_bg, col_correct_bg), - col = c(col_error_border, col_correct_border), - cex = ball_cex * 1.5 - ) + # Determine N per ball: + if (is.null(n.per.icon)) { + max_n_side <- max(c(n_pos_cases, n_neg_cases)) - # Labels: - text(c( plot_width * .50, plot_width * .70) * f_x, - c(-plot_height * leg_ball_y, -plot_height * leg_ball_y) * f_y, - labels = c("False\nAlarm", "Hit"), - pos = c(2, 4), offset = .80, cex = 1 - ) + i <- max_n_side / c(1, 5, 10^(1:10)) + i[i > 50] <- 0 + n.per.icon <- c(1, 5, 10^(1:10))[which(i == max(i))] + } - # (c) Additional lines (below icon guide): ---- - if (what == "ico" & hlines) { + noise_ball_pch <- ball_pch[1] + signal_ball_pch <- ball_pch[2] + noise_ball_col <- ball_col[1] + signal_ball_col <- ball_col[2] + noise_ball_bg <- ball_bg[1] + signal_ball_bg <- ball_bg[2] - x_hline <- plot_width * 1.0 * f_x - y_hline <- -plot_height * .22 * f_y - segments(-x_hline, y_hline, x_hline, y_hline, col = col_panel_line, lwd = panel_line_lwd, lty = panel_line_lty) - rect(-x_hline * .33, (y_hline - .5), x_hline * .33, (y_hline + .5), col = "white", border = NA) - } + # Arrows: ---- + arrow_lty <- 1 + arrow_lwd <- 1 + arrow_length <- 2.50 + arrow_head_length <- .08 + arrow_col <- gray(0) # = black - # (d) n.per.icon legend 2 (middle): ---- - if (what == "ico") { show_icon_guide_legend <- TRUE } # special case + # Final stats: ---- - if (show_icon_guide_legend){ + # spec_circle_x <- .40 # is NOT used anywhere? + # dprime_circle_x <- .50 # is NOT used anywhere? + # sens_circle_x <- .60 # is NOT used anywhere? - if (what == "ico") { # special case: + # stat_circle_y <- .30 # is NOT used anywhere? - x_s2 <- plot_width - x_s1 <- plot_width - .80 # left of default - y_s1 <- plot_height * -1.10 # lower than default + # sens_circle_col <- "green" # is NOT used anywhere? + # spec_circle_col <- "red" # is NOT used anywhere? + # dprime_circle_col <- "blue" # is NOT used anywhere? + # stat_outer_circle_col <- gray(.50) # is NOT used anywhere? - } else { # defaults: - x_s2 <- plot_width - x_s1 <- plot_width - .40 - y_s1 <- plot_height * -1 + # 1: Initial Frequencies: ------ - } + # Parameters: - text(x_s1, y_s1, labels = paste("Showing ", n.per.icon, " cases per icon:", sep = ""), pos = 2, cex = ball_cex) - points(x_s1, y_s1, pch = noise_ball_pch, cex = ball_cex) - points(x_s2, y_s1, pch = signal_ball_pch, cex = ball_cex) + if (show.top) { + par(mar = c(0, 0, 1, 0)) - } # if (show_icon_guide_legend). + # Prepare plot: + plot(1, + xlim = c(0, 1), ylim = c(0, 1), bty = "n", type = "n", + xlab = "", ylab = "", yaxt = "n", xaxt = "n" + ) - } # if (show.iconguide). + # 1. Title: ---- - par(xpd = FALSE) + par(xpd = TRUE) + # (a) lines: + if (hlines) { + segments(0, .95, 1, .95, col = col_panel_line, lwd = panel_line_lwd, lty = panel_line_lty) # top hline - # Plot main TREE: ------ + x_dev <- get_x_dev(main) + y_dev <- .20 + rect((.50 - x_dev), (1 - y_dev), (.50 + x_dev), (1 + y_dev), col = "white", border = NA) # title background + } - # Set initial subplot center: - subplot_center <- c(0, -4) + # (b) label: + text(x = .50, y = .96, main, cex = panel_title_cex, ...) # title 1 (top): main - # Loop over levels: ------ - for (level_i in 1:min(c(n_levels, 6))) { - # Cue label: - cur_cue <- cue.labels[level_i] + # 2. Data info: ---- - # Get stats for current level: - hi_i <- level_stats$hi_m[level_i] - fa_i <- level_stats$fa_m[level_i] - mi_i <- level_stats$mi_m[level_i] - cr_i <- level_stats$cr_m[level_i] + # (a) N and labels: + text(x = .50, y = .78, paste("N = ", prettyNum(n_exemplars, big.mark = ","), "", sep = ""), cex = 1.25) # N + text(.50, .63, paste(truth.labels[1], sep = ""), pos = 2, cex = 1.2, adj = 1) # 1: False + text(.50, .63, paste(truth.labels[2], sep = ""), pos = 4, cex = 1.2, adj = 0) # 2: True + # (b) Show balls: + n_true_pos <- with(final_stats, hi + mi) + n_true_neg <- with(final_stats, fa + cr) - # Top: If level_i == 1, draw top textbox: ---- + add_balls( + x_lim = c(.33, .67), + y_lim = c(.12, .52), + n_vec = c(n_true_neg, n_true_pos), + pch_vec = c(noise_ball_pch, signal_ball_pch), + bg_vec = c(noise_ball_bg, signal_ball_bg), + col_vec = c(noise_ball_col, signal_ball_col), + ball_cex = ball_cex, + upper_text_adj = 2, + n_per_icon = n.per.icon + ) - if (level_i == 1) { + # (c) n.per.icon legend 1 (top): - rect(subplot_center[1] - label_box_width / 2, - subplot_center[2] + 2 - label_box_height / 2, - subplot_center[1] + label_box_width / 2, - subplot_center[2] + 2 + label_box_height / 2, - col = "white", - border = "black" - ) + # show_icon_guide_legend <- TRUE # 4debugging - points( - x = subplot_center[1], - y = subplot_center[2] + 2, - cex = decision_node_cex, - pch = decision_node_pch - ) + if (show_icon_guide_legend) { + text(.98, 0, labels = paste("Showing ", n.per.icon, " cases per icon:", sep = ""), pos = 2) + points(.98, 0, pch = noise_ball_pch, cex = ball_cex) + points(.99, 0, pch = signal_ball_pch, cex = ball_cex) + } # if (show_icon_guide_legend). - text( - x = subplot_center[1], - y = subplot_center[2] + 2, - labels = cur_cue, - cex = label_box_text_cex # WAS: get_label_cex(cur_cue, label_box_text_cex = label_box_text_cex) - ) - } # if (level_i == 1). + par(xpd = FALSE) - # Left (Noise) classification / New level: ---- + # 3. Add p_signal and p_noise levels: ----- - # Exit node on 0 / FALSE / noise / left: ---- + signal_p <- crit_br # criterion baseline/base rate (from above) + noise_p <- (1 - signal_p) - # if (level_stats$exit[level_i] %in% c(0, .5) | paste(level_stats$exit[level_i]) %in% c("0", ".5")) { - if ( (level_stats$exit[level_i] %in% exit_types[c(1, 3)]) | (paste(level_stats$exit[level_i]) %in% paste(exit_types[c(1, 3)], collapse = ", ")) ) { + p_rect_ylim <- c(.10, .60) - segments(subplot_center[1], - subplot_center[2] + 1, - subplot_center[1] - 2, - subplot_center[2] - 2, - lty = segment_lty, - lwd = segment_lwd - ) - arrows( - x0 = subplot_center[1] - 2, - y0 = subplot_center[2] - 2, - x1 = subplot_center[1] - 2 - arrow_length, - y1 = subplot_center[2] - 2, - lty = arrow_lty, - lwd = arrow_lwd, - col = arrow_col, - length = arrow_head_length - ) + # (a) p_signal level (on right): ---- - # Decision text: + text( + x = .80, y = p_rect_ylim[2], + labels = paste("p(", truth.labels[2], ")", sep = ""), + pos = 3, cex = 1.2 + ) - if (decision.cex > 0) { + # Filling: + rect(.775, p_rect_ylim[1], + .825, p_rect_ylim[1] + signal_p * diff(p_rect_ylim), + col = gray(.50, .25), border = NA + ) - text( - x = subplot_center[1] - 2 - arrow_length * .7, - y = subplot_center[2] - 2.2, - labels = decision.labels[1], - pos = 1, font = 3, cex = decision.cex - ) + # Filltop: + segments(.775, p_rect_ylim[1] + signal_p * diff(p_rect_ylim), + .825, p_rect_ylim[1] + signal_p * diff(p_rect_ylim), + lwd = 1 + ) - } + # Outline: + rect(.775, p_rect_ylim[1], + .825, p_rect_ylim[2], + lwd = 1 + ) - if (ball_loc == "fixed") { + if (signal_p < .0001) { + signal_p_text <- "<1%" + } else { + signal_p_text <- paste(round(signal_p * 100, 0), "%", sep = "") + } - ball_x_lim <- c(-max(ball_box_fixed_x_shift), -min(ball_box_fixed_x_shift)) + text(.825, p_rect_ylim[1] + signal_p * diff(p_rect_ylim), + labels = signal_p_text, + pos = 4, cex = 1.2 + ) - ball_y_lim <- c( - subplot_center[2] + ball_box_vert_shift - ball_box_height / 2, - subplot_center[2] + ball_box_vert_shift + ball_box_height / 2 - ) - } + # (b) p_noise level (on left): ---- - if (ball_loc == "variable") { + text( + x = .20, y = p_rect_ylim[2], + labels = paste("p(", truth.labels[1], ")", sep = ""), + pos = 3, cex = 1.2 + ) - ball_x_lim <- c( - subplot_center[1] - ball_box_horiz_shift - ball_box_width / 2, - subplot_center[1] - ball_box_horiz_shift + ball_box_width / 2 - ) - ball_y_lim <- c( - subplot_center[2] + ball_box_vert_shift - ball_box_height / 2, - subplot_center[2] + ball_box_vert_shift + ball_box_height / 2 - ) + rect(.175, p_rect_ylim[1], .225, p_rect_ylim[1] + noise_p * diff(p_rect_ylim), + col = gray(.50, .25), border = NA + ) - } + # Filltop: + segments(.175, p_rect_ylim[1] + noise_p * diff(p_rect_ylim), + .225, p_rect_ylim[1] + noise_p * diff(p_rect_ylim), + lwd = 1 + ) - if ((max(c(cr_i, mi_i), na.rm = TRUE) > 0) & (show.icons == TRUE)) { - - add_balls( - x_lim = ball_x_lim, - y_lim = ball_y_lim, - n_vec = c(cr_i, mi_i), - pch_vec = c(noise_ball_pch, signal_ball_pch), - ball_cex = ball_cex, - # bg_vec = c(noise_ball_bg, signal_ball_bg), - bg_vec = c(col_correct_bg, col_error_bg), - col_vec = c(col_correct_border, col_error_border), - freq_text = TRUE, - n_per_icon = n.per.icon - ) - - } - - # level break label: - pos_dir_symbol <- c("<=", "<", "=", "!=", ">", ">=")[which(level_stats$direction[level_i] == c(">", ">=", "!=", "=", "<=", "<"))] - neg_dir_symbol <- c("<=", "<", "=", "!=", ">", ">=")[which(level_stats$direction[level_i] == c("<=", "<", "=", "!=", ">", ">="))] - - text_outline( - x = subplot_center[1] - 1, - y = subplot_center[2], - labels = paste(pos_dir_symbol, " ", level_stats$threshold[level_i], sep = ""), - pos = 2, cex = break_label_cex, r = .1 - ) - - points( - x = subplot_center[1] - 2, - y = subplot_center[2] - 2, - pch = exit_node_pch, - cex = exit_node_cex, - bg = col_exit_node_bg - ) - - text( - x = subplot_center[1] - 2, - y = subplot_center[2] - 2, - labels = substr(decision.labels[1], 1, 1) - ) - - } # if (exit node on left). - - - # New level on 1 / TRUE / signal / right: ---- - - # if ((level_stats$exit[level_i] %in% c(1)) | (paste(level_stats$exit[level_i]) %in% c("1"))) { - if ( (level_stats$exit[level_i] %in% exit_types[c(2)]) | (paste(level_stats$exit[level_i]) %in% paste(exit_types[c(2)], collapse = ", ")) ) { - - segments(subplot_center[1], - subplot_center[2] + 1, - subplot_center[1] - 2, - subplot_center[2] - 2, - lty = segment_lty, - lwd = segment_lwd - ) - - rect(subplot_center[1] - 2 - label_box_width / 2, - subplot_center[2] - 2 - label_box_height / 2, - subplot_center[1] - 2 + label_box_width / 2, - subplot_center[2] - 2 + label_box_height / 2, - col = "white", - border = "black" - ) - - if (level_i < 6) { - - text( - x = subplot_center[1] - 2, - y = subplot_center[2] - 2, - labels = cue.labels[level_i + 1], - cex = label_box_text_cex - ) - - } else { - - text( - x = subplot_center[1] - 2, - y = subplot_center[2] - 2, - labels = paste0("+ ", n_levels - 6, " More"), - cex = label_box_text_cex, - font = 3 - ) - - } - - } # if (new level on right). - - - # Right (Signal) classification / New level: ---- - - # Exit node on 1 / TRUE / signal / right: ---- - - # if ((level_stats$exit[level_i] %in% c(1, .5)) | (paste(level_stats$exit[level_i]) %in% c("1", ".5"))) { - if ( (level_stats$exit[level_i] %in% exit_types[c(2, 3)]) | (paste(level_stats$exit[level_i]) %in% paste(exit_types[c(2, 3)], collapse = ", ")) ) { - - segments(subplot_center[1], - subplot_center[2] + 1, - subplot_center[1] + 2, - subplot_center[2] - 2, - lty = segment_lty, - lwd = segment_lwd - ) - - arrows( - x0 = subplot_center[1] + 2, - y0 = subplot_center[2] - 2, - x1 = subplot_center[1] + 2 + arrow_length, - y1 = subplot_center[2] - 2, - lty = arrow_lty, - lwd = arrow_lwd, - col = arrow_col, - length = arrow_head_length - ) - - # Decision text: - - if (decision.cex > 0) { - text( - x = subplot_center[1] + 2 + arrow_length * .7, - y = subplot_center[2] - 2.2, - labels = decision.labels[2], - pos = 1, - font = 3, - cex = decision.cex - ) - - } - - if (ball_loc == "fixed") { - - ball_x_lim <- c(min(ball_box_fixed_x_shift), max(ball_box_fixed_x_shift)) - ball_y_lim <- c( - subplot_center[2] + ball_box_vert_shift - ball_box_height / 2, - subplot_center[2] + ball_box_vert_shift + ball_box_height / 2 - ) - - } - - if (ball_loc == "variable") { - - ball_x_lim <- c( - subplot_center[1] + ball_box_horiz_shift - ball_box_width / 2, - subplot_center[1] + ball_box_horiz_shift + ball_box_width / 2 - ) - - ball_y_lim <- c( - subplot_center[2] + ball_box_vert_shift - ball_box_height / 2, - subplot_center[2] + ball_box_vert_shift + ball_box_height / 2 - ) - - } - - if ((max(c(fa_i, hi_i), na.rm = TRUE) > 0) & (show.icons == TRUE)) { - - add_balls( - x_lim = ball_x_lim, - y_lim = ball_y_lim, - n_vec = c(fa_i, hi_i), - pch_vec = c(noise_ball_pch, signal_ball_pch), - ball_cex = ball_cex, - # bg_vec = c(noise_ball_bg, signal_ball_bg), - bg_vec = c(col_error_bg, col_correct_bg), - col_vec = c(col_error_border, col_correct_border), - freq_text = TRUE, - n_per_icon = n.per.icon - ) - - } - - # level break label: - dir_symbol <- c("<=", "<", "=", "!=", ">", ">=") # as (local) constant - - pos_dir_symbol <- dir_symbol[which(level_stats$direction[level_i] == c("<=", "<", "=", "!=", ">", ">="))] - neg_dir_symbol <- dir_symbol[which(level_stats$direction[level_i] == rev(c("<=", "<", "=", "!=", ">", ">=")))] - - - text_outline(subplot_center[1] + 1, - subplot_center[2], - labels = paste(pos_dir_symbol, " ", level_stats$threshold[level_i], sep = ""), - pos = 4, cex = break_label_cex, r = .1 - ) + # Outline: + rect(.175, p_rect_ylim[1], .225, p_rect_ylim[2], + lwd = 1 + ) - points( - x = subplot_center[1] + 2, - y = subplot_center[2] - 2, - pch = exit_node_pch, - cex = exit_node_cex, - bg = col_exit_node_bg - ) + if (noise_p < .0001) { + noise_p_text <- "<0.01%" + } else { + noise_p_text <- paste(round(noise_p * 100, 0), "%", sep = "") + } - text( - x = subplot_center[1] + 2, - y = subplot_center[2] - 2, - labels = substr(decision.labels[2], 1, 1) - ) + text(.175, p_rect_ylim[1] + noise_p * diff(p_rect_ylim), + labels = noise_p_text, + pos = 2, cex = 1.2 + ) + } # if (show.top). - } # if (exit node on right). + # 2. Main TREE: ------ - # New level on 0 / FALSE / noise / left: ---- + if (show.middle) { + if ((show.top == FALSE) & (show.bottom == FALSE)) { + par(mar = c(3, 3, 3, 3) + .1) + } else { + par(mar = c(0, 0, 0, 0)) + } - # if (level_stats$exit[level_i] %in% 0 | paste(level_stats$exit[level_i]) %in% c("0")) { - if ( (level_stats$exit[level_i] %in% exit_types[c(1)]) | (paste(level_stats$exit[level_i]) %in% paste(exit_types[c(1)], collapse = ", ")) ) { + par(xpd = TRUE) - segments(subplot_center[1], - subplot_center[2] + 1, - subplot_center[1] + 2, - subplot_center[2] - 2, - lty = segment_lty, - lwd = segment_lwd - ) + # Prepare plot: + plot(1, + xlim = c(-plot_width, plot_width), + ylim = c(-plot_height, 0), + type = "n", bty = "n", + xaxt = "n", yaxt = "n", + ylab = "", xlab = "" + ) - if (level_i < 6) { - rect(subplot_center[1] + 2 - label_box_width / 2, - subplot_center[2] - 2 - label_box_height / 2, - subplot_center[1] + 2 + label_box_width / 2, - subplot_center[2] - 2 + label_box_height / 2, - col = "white", - border = "black" - ) + # Middle title: ---- - text( - x = subplot_center[1] + 2, - y = subplot_center[2] - 2, - labels = cue.labels[level_i + 1], - cex = label_box_text_cex - ) + if (show.top | show.bottom) { + if (hlines) { + x_dev <- .28 # scaling factor, rather than difference + segments(-plot_width, 0, -plot_width * x_dev, 0, col = col_panel_line, lwd = panel_line_lwd, lty = panel_line_lty) + segments(plot_width, 0, plot_width * x_dev, 0, col = col_panel_line, lwd = panel_line_lwd, lty = panel_line_lty) + } - } else { + if (is.null(label.tree)) { + label.tree <- paste("FFT #", tree, " (of ", x$trees$n, ")", sep = "") + } - rect(subplot_center[1] + 2 - label_box_width / 2, - subplot_center[2] - 2 - label_box_height / 2, - subplot_center[1] + 2 + label_box_width / 2, - subplot_center[2] - 2 + label_box_height / 2, - col = "white", - border = "black", lty = 2 - ) + text(x = 0, y = 0, label.tree, cex = panel_title_cex, ...) # title 2 (middle): (a) tree label + } # if (show.top | show.bottom). - text( - x = subplot_center[1] + 2, - y = subplot_center[2] - 2, - labels = paste0("+ ", n_levels - 6, " More"), - cex = label_box_text_cex, - font = 3 - ) - } + if (show.top == FALSE & show.bottom == FALSE) { + if (is.null(main) & is.null(x$params$main)) { + main <- "" + } - } # if (new level on right). + mtext(text = main, side = 3, cex = panel_title_cex, ...) # title 2 (middle): (b) main label + } # if (show.top == FALSE & show.bottom == FALSE). - # Update plot center: ---- + # Icon guide: ------ - # if (identical(paste(level_stats$exit[level_i]), "0")) { # 0 / FALSE / noise / left: - if (identical(paste(level_stats$exit[level_i]), paste0(exit_types[1]))) { + if (show.iconguide) { + # Parameters: + if (what == "ico") { + f_x <- 1.2 # scaling factor (to stretch in x-dim) + f_y <- 0.8 # scaling factor (to shift up) + } else { # default scaling factors: - subplot_center <- c( - subplot_center[1] + 2, - subplot_center[2] - 4 - ) - } # if (identical exit 0 / left etc. + f_x <- 1 + f_y <- 1 + } - # if (identical(paste(level_stats$exit[level_i]), "1")) { # 1 / TRUE / signal / right: - if (identical(paste(level_stats$exit[level_i]), paste0(exit_types[2]))) { + get_exit_word <- get_exit_word(data) # either 'train':'decide' or 'test':'predict' - subplot_center <- c( - subplot_center[1] - 2, - subplot_center[2] - 4 - ) - } # if (identical exit 1 / right etc. + # (a) Noise panel (on left): ---- - } # for (level_i etc. loop. + # Parameters: - } # if (show.middle). + if (what == "ico") { + leg_head_y <- .02 + leg_ball_y <- .14 + } else { + leg_head_y <- .05 + leg_ball_y <- .15 + } - # 3. Cumulative performance: ---- + # Heading: + text(-plot_width * .60 * f_x, + -plot_height * leg_head_y * f_y, + paste(get_exit_word, decision.labels[1], sep = " "), + cex = 1.2, font = 3 + ) + + # Noise balls: + points(c(-plot_width * .70, -plot_width * .50) * f_x, + c(-plot_height * leg_ball_y, -plot_height * leg_ball_y) * f_y, + pch = c(noise_ball_pch, signal_ball_pch), + bg = c(col_correct_bg, col_error_bg), + col = c(col_correct_border, col_error_border), + cex = ball_cex * 1.5 + ) + + # Labels: + text(c(-plot_width * .70, -plot_width * .50) * f_x, + c(-plot_height * leg_ball_y, -plot_height * leg_ball_y) * f_y, + labels = c("Correct\nRejection", "Miss"), + pos = c(2, 4), offset = .80, cex = 1 + ) + + + + # (b) Signal panel (on right): ---- + + # Heading: + text(plot_width * .60 * f_x, + -plot_height * leg_head_y * f_y, + paste(get_exit_word, decision.labels[2], sep = " "), + cex = 1.2, font = 3 + ) + + # Signal balls: + points(c(plot_width * .50, plot_width * .70) * f_x, + c(-plot_height * leg_ball_y, -plot_height * leg_ball_y) * f_y, + pch = c(noise_ball_pch, signal_ball_pch), + bg = c(col_error_bg, col_correct_bg), + col = c(col_error_border, col_correct_border), + cex = ball_cex * 1.5 + ) + + # Labels: + text(c(plot_width * .50, plot_width * .70) * f_x, + c(-plot_height * leg_ball_y, -plot_height * leg_ball_y) * f_y, + labels = c("False\nAlarm", "Hit"), + pos = c(2, 4), offset = .80, cex = 1 + ) + + + # (c) Additional lines (below icon guide): ---- + if (what == "ico" & hlines) { + x_hline <- plot_width * 1.0 * f_x + y_hline <- -plot_height * .22 * f_y + + segments(-x_hline, y_hline, x_hline, y_hline, col = col_panel_line, lwd = panel_line_lwd, lty = panel_line_lty) + rect(-x_hline * .33, (y_hline - .5), x_hline * .33, (y_hline + .5), col = "white", border = NA) + } - if (show.bottom == TRUE) { # obtain tree statistics: - fft_sens_vec <- tree_stats$sens - fft_spec_vec <- tree_stats$spec + # (d) n.per.icon legend 2 (middle): ---- - # General plotting space: ---- + if (what == "ico") { + show_icon_guide_legend <- TRUE + } # special case - # Parameters: - header_y <- 1.0 - subheader_y <- .925 + if (show_icon_guide_legend) { + if (what == "ico") { # special case: - header_cex <- 1.10 - subheader_cex <- .90 + x_s2 <- plot_width + x_s1 <- plot_width - .80 # left of default + y_s1 <- plot_height * -1.10 # lower than default + } else { # defaults: - par(mar = c(0, 0, 2, 0)) + x_s2 <- plot_width + x_s1 <- plot_width - .40 + y_s1 <- plot_height * -1 + } - plot(1, - xlim = c(0, 1), ylim = c(0, 1), - bty = "n", type = "n", - xlab = "", ylab = "", - yaxt = "n", xaxt = "n" + text(x_s1, y_s1, labels = paste("Showing ", n.per.icon, " cases per icon:", sep = ""), pos = 2, cex = ball_cex) + points(x_s1, y_s1, pch = noise_ball_pch, cex = ball_cex) + points(x_s2, y_s1, pch = signal_ball_pch, cex = ball_cex) + } # if (show_icon_guide_legend). + } # if (show.iconguide). + + par(xpd = FALSE) + + + # Plot main TREE: ------ + + # Set initial subplot center: + subplot_center <- c(0, -4) + + # Loop over levels: ------ + for (level_i in 1:min(c(n_levels, 6))) { + # Cue label: + cur_cue <- cue.labels[level_i] + + # Get stats for current level: + hi_i <- level_stats$hi_m[level_i] + fa_i <- level_stats$fa_m[level_i] + mi_i <- level_stats$mi_m[level_i] + cr_i <- level_stats$cr_m[level_i] + + + # Top: If level_i == 1, draw top textbox: ---- + + if (level_i == 1) { + rect(subplot_center[1] - label_box_width / 2, + subplot_center[2] + 2 - label_box_height / 2, + subplot_center[1] + label_box_width / 2, + subplot_center[2] + 2 + label_box_height / 2, + col = "white", + border = "black" + ) + + points( + x = subplot_center[1], + y = subplot_center[2] + 2, + cex = decision_node_cex, + pch = decision_node_pch + ) + + text( + x = subplot_center[1], + y = subplot_center[2] + 2, + labels = cur_cue, + cex = label_box_text_cex # WAS: get_label_cex(cur_cue, label_box_text_cex = label_box_text_cex) + ) + } # if (level_i == 1). + + + # Left (Noise) classification / New level: ---- + + # Exit node on 0 / FALSE / noise / left: ---- + + # if (level_stats$exit[level_i] %in% c(0, .5) | paste(level_stats$exit[level_i]) %in% c("0", ".5")) { + if ((level_stats$exit[level_i] %in% exit_types[c(1, 3)]) | (paste(level_stats$exit[level_i]) %in% paste(exit_types[c(1, 3)], collapse = ", "))) { + segments(subplot_center[1], + subplot_center[2] + 1, + subplot_center[1] - 2, + subplot_center[2] - 2, + lty = segment_lty, + lwd = segment_lwd + ) + + arrows( + x0 = subplot_center[1] - 2, + y0 = subplot_center[2] - 2, + x1 = subplot_center[1] - 2 - arrow_length, + y1 = subplot_center[2] - 2, + lty = arrow_lty, + lwd = arrow_lwd, + col = arrow_col, + length = arrow_head_length + ) + + # Decision text: + + if (decision.cex > 0) { + text( + x = subplot_center[1] - 2 - arrow_length * .7, + y = subplot_center[2] - 2.2, + labels = decision.labels[1], + pos = 1, font = 3, cex = decision.cex ) + } + if (ball_loc == "fixed") { + ball_x_lim <- c(-max(ball_box_fixed_x_shift), -min(ball_box_fixed_x_shift)) - if (what != "roc"){ - - # Set par: - par(xpd = TRUE) - - # Bottom title: ---- - - if (hlines) { - - segments(0, 1.1, 1, 1.1, col = col_panel_line, lwd = panel_line_lwd, lty = panel_line_lty) - - x_dev <- .20 - rect((.50 - x_dev), 1, (.50 + x_dev), 1.2, col = "white", border = NA) # label background - } - - # Bottom label: - if (is.null(label.performance)) { # user argument not set: - - if (data == "train") { - label.performance <- "Accuracy (Training)" - } - if (data == "test") { - label.performance <- "Accuracy (Testing)" - } - - } - - text(x = .50, y = 1.1, labels = label.performance, cex = panel_title_cex, ...) # title 3 (bottom): Performance - - par(xpd = FALSE) - - } # if (what != "roc"). - - - # Level parameters: - level_height_max <- .65 - level_width <- .05 - level_center_y <- .45 - # level_bottom <- .1 - level_bottom <- level_center_y - (level_height_max / 2) - level_top <- level_center_y + (level_height_max / 2) - - # Get either bacc OR wacc (based on sens.w): - sens.w <- x$params$sens.w - bacc_wacc <- get_bacc_wacc(sens = final_stats$sens, spec = final_stats$spec, sens.w = sens.w) - bacc_wacc_name <- names(bacc_wacc) + ball_y_lim <- c( + subplot_center[2] + ball_box_vert_shift - ball_box_height / 2, + subplot_center[2] + ball_box_vert_shift + ball_box_height / 2 + ) + } - # Set labels, values, and locations (as df): - lloc <- data.frame( - element = c("classtable", "mcu", "pci", "sens", "spec", "acc", bacc_wacc_name, "roc"), - long_name = c("Classification Table", "mcu", "pci", "sens", "spec", "acc", bacc_wacc_name, "ROC"), # used by add_level() helper function - center_x = c(.18, seq(.35, .65, length.out = 6), .85), - center_y = rep(level_center_y, 8), - width = c(.20, rep(level_width, 6), .20), - height = c(.65, rep(level_height_max, 6), .65), - value = c(NA, - abs(final_stats$mcu - 5) / (abs(1 - 5)), final_stats$pci, - final_stats$sens, final_stats$spec, - with(final_stats, (cr + hi) / n), bacc_wacc, NA), - value_name = c(NA, - round(final_stats$mcu, 1), pretty_dec(final_stats$pci), # used by add_level() helper function - pretty_dec(final_stats$sens), pretty_dec(final_stats$spec), - pretty_dec(final_stats$acc), pretty_dec(bacc_wacc), NA) + if (ball_loc == "variable") { + ball_x_lim <- c( + subplot_center[1] - ball_box_horiz_shift - ball_box_width / 2, + subplot_center[1] - ball_box_horiz_shift + ball_box_width / 2 ) - # print(lloc) # 4debugging + ball_y_lim <- c( + subplot_center[2] + ball_box_vert_shift - ball_box_height / 2, + subplot_center[2] + ball_box_vert_shift + ball_box_height / 2 + ) + } - # Classification table: ---- + if ((max(c(cr_i, mi_i), na.rm = TRUE) > 0) & (show.icons == TRUE)) { + add_balls( + x_lim = ball_x_lim, + y_lim = ball_y_lim, + n_vec = c(cr_i, mi_i), + pch_vec = c(noise_ball_pch, signal_ball_pch), + ball_cex = ball_cex, + # bg_vec = c(noise_ball_bg, signal_ball_bg), + bg_vec = c(col_correct_bg, col_error_bg), + col_vec = c(col_correct_border, col_error_border), + freq_text = TRUE, + n_per_icon = n.per.icon + ) + } - if (show.confusion) { + # level break label: + pos_dir_symbol <- c("<=", "<", "=", "!=", ">", ">=")[which(level_stats$direction[level_i] == c(">", ">=", "!=", "=", "<=", "<"))] + neg_dir_symbol <- c("<=", "<", "=", "!=", ">", ">=")[which(level_stats$direction[level_i] == c("<=", "<", "=", "!=", ">", ">="))] + + text_outline( + x = subplot_center[1] - 1, + y = subplot_center[2], + labels = paste(pos_dir_symbol, " ", level_stats$threshold[level_i], sep = ""), + pos = 2, cex = break_label_cex, r = .1 + ) + + points( + x = subplot_center[1] - 2, + y = subplot_center[2] - 2, + pch = exit_node_pch, + cex = exit_node_cex, + bg = col_exit_node_bg + ) + + text( + x = subplot_center[1] - 2, + y = subplot_center[2] - 2, + labels = substr(decision.labels[1], 1, 1) + ) + } # if (exit node on left). + + + # New level on 1 / TRUE / signal / right: ---- + + # if ((level_stats$exit[level_i] %in% c(1)) | (paste(level_stats$exit[level_i]) %in% c("1"))) { + if ((level_stats$exit[level_i] %in% exit_types[c(2)]) | (paste(level_stats$exit[level_i]) %in% paste(exit_types[c(2)], collapse = ", "))) { + segments(subplot_center[1], + subplot_center[2] + 1, + subplot_center[1] - 2, + subplot_center[2] - 2, + lty = segment_lty, + lwd = segment_lwd + ) + + rect(subplot_center[1] - 2 - label_box_width / 2, + subplot_center[2] - 2 - label_box_height / 2, + subplot_center[1] - 2 + label_box_width / 2, + subplot_center[2] - 2 + label_box_height / 2, + col = "white", + border = "black" + ) + + if (level_i < 6) { + text( + x = subplot_center[1] - 2, + y = subplot_center[2] - 2, + labels = cue.labels[level_i + 1], + cex = label_box_text_cex + ) + } else { + text( + x = subplot_center[1] - 2, + y = subplot_center[2] - 2, + labels = paste0("+ ", n_levels - 6, " More"), + cex = label_box_text_cex, + font = 3 + ) + } + } # if (new level on right). - # Parameters: - classtable_lwd <- 1 - # x/y coordinates: - final_classtable_x <- c(lloc$center_x[lloc$element == "classtable"] - lloc$width[lloc$element == "classtable"] / 2, lloc$center_x[lloc$element == "classtable"] + lloc$width[lloc$element == "classtable"] / 2) - final_classtable_y <- c(lloc$center_y[lloc$element == "classtable"] - lloc$height[lloc$element == "classtable"] / 2, lloc$center_y[lloc$element == "classtable"] + lloc$height[lloc$element == "classtable"] / 2) + # Right (Signal) classification / New level: ---- - rect(final_classtable_x[1], final_classtable_y[1], - final_classtable_x[2], final_classtable_y[2], - lwd = classtable_lwd - ) + # Exit node on 1 / TRUE / signal / right: ---- - segments(mean(final_classtable_x), final_classtable_y[1], mean(final_classtable_x), final_classtable_y[2], col = gray(0), lwd = classtable_lwd) - segments(final_classtable_x[1], mean(final_classtable_y), final_classtable_x[2], mean(final_classtable_y), col = gray(0), lwd = classtable_lwd) + # if ((level_stats$exit[level_i] %in% c(1, .5)) | (paste(level_stats$exit[level_i]) %in% c("1", ".5"))) { + if ((level_stats$exit[level_i] %in% exit_types[c(2, 3)]) | (paste(level_stats$exit[level_i]) %in% paste(exit_types[c(2, 3)], collapse = ", "))) { + segments(subplot_center[1], + subplot_center[2] + 1, + subplot_center[1] + 2, + subplot_center[2] - 2, + lty = segment_lty, + lwd = segment_lwd + ) + arrows( + x0 = subplot_center[1] + 2, + y0 = subplot_center[2] - 2, + x1 = subplot_center[1] + 2 + arrow_length, + y1 = subplot_center[2] - 2, + lty = arrow_lty, + lwd = arrow_lwd, + col = arrow_col, + length = arrow_head_length + ) - # Column titles: ---- + # Decision text: - text( - x = mean(mean(final_classtable_x)), - y = header_y, - "Truth", pos = 1, cex = header_cex - ) + if (decision.cex > 0) { + text( + x = subplot_center[1] + 2 + arrow_length * .7, + y = subplot_center[2] - 2.2, + labels = decision.labels[2], + pos = 1, + font = 3, + cex = decision.cex + ) + } - text( - x = final_classtable_x[1] + .25 * diff(final_classtable_x), - y = subheader_y, pos = 1, cex = subheader_cex, - truth.labels[2] - ) + if (ball_loc == "fixed") { + ball_x_lim <- c(min(ball_box_fixed_x_shift), max(ball_box_fixed_x_shift)) + ball_y_lim <- c( + subplot_center[2] + ball_box_vert_shift - ball_box_height / 2, + subplot_center[2] + ball_box_vert_shift + ball_box_height / 2 + ) + } - text( - x = final_classtable_x[1] + .75 * diff(final_classtable_x), - y = subheader_y, pos = 1, cex = subheader_cex, - truth.labels[1] - ) + if (ball_loc == "variable") { + ball_x_lim <- c( + subplot_center[1] + ball_box_horiz_shift - ball_box_width / 2, + subplot_center[1] + ball_box_horiz_shift + ball_box_width / 2 + ) + ball_y_lim <- c( + subplot_center[2] + ball_box_vert_shift - ball_box_height / 2, + subplot_center[2] + ball_box_vert_shift + ball_box_height / 2 + ) + } - # Row titles: ---- + if ((max(c(fa_i, hi_i), na.rm = TRUE) > 0) & (show.icons == TRUE)) { + add_balls( + x_lim = ball_x_lim, + y_lim = ball_y_lim, + n_vec = c(fa_i, hi_i), + pch_vec = c(noise_ball_pch, signal_ball_pch), + ball_cex = ball_cex, + # bg_vec = c(noise_ball_bg, signal_ball_bg), + bg_vec = c(col_error_bg, col_correct_bg), + col_vec = c(col_error_border, col_correct_border), + freq_text = TRUE, + n_per_icon = n.per.icon + ) + } - text( - x = final_classtable_x[1] - .01, - y = final_classtable_y[1] + .75 * diff(final_classtable_y), cex = subheader_cex, - decision.labels[2], adj = 1 - ) + # level break label: + dir_symbol <- c("<=", "<", "=", "!=", ">", ">=") # as (local) constant + + pos_dir_symbol <- dir_symbol[which(level_stats$direction[level_i] == c("<=", "<", "=", "!=", ">", ">="))] + neg_dir_symbol <- dir_symbol[which(level_stats$direction[level_i] == rev(c("<=", "<", "=", "!=", ">", ">=")))] + + + text_outline(subplot_center[1] + 1, + subplot_center[2], + labels = paste(pos_dir_symbol, " ", level_stats$threshold[level_i], sep = ""), + pos = 4, cex = break_label_cex, r = .1 + ) + + points( + x = subplot_center[1] + 2, + y = subplot_center[2] - 2, + pch = exit_node_pch, + cex = exit_node_cex, + bg = col_exit_node_bg + ) + + text( + x = subplot_center[1] + 2, + y = subplot_center[2] - 2, + labels = substr(decision.labels[2], 1, 1) + ) + } # if (exit node on right). + + + # New level on 0 / FALSE / noise / left: ---- + + # if (level_stats$exit[level_i] %in% 0 | paste(level_stats$exit[level_i]) %in% c("0")) { + if ((level_stats$exit[level_i] %in% exit_types[c(1)]) | (paste(level_stats$exit[level_i]) %in% paste(exit_types[c(1)], collapse = ", "))) { + segments(subplot_center[1], + subplot_center[2] + 1, + subplot_center[1] + 2, + subplot_center[2] - 2, + lty = segment_lty, + lwd = segment_lwd + ) + + if (level_i < 6) { + rect(subplot_center[1] + 2 - label_box_width / 2, + subplot_center[2] - 2 - label_box_height / 2, + subplot_center[1] + 2 + label_box_width / 2, + subplot_center[2] - 2 + label_box_height / 2, + col = "white", + border = "black" + ) - text( - x = final_classtable_x[1] - .01, - y = final_classtable_y[1] + .25 * diff(final_classtable_y), cex = subheader_cex, - decision.labels[1], adj = 1 - ) + text( + x = subplot_center[1] + 2, + y = subplot_center[2] - 2, + labels = cue.labels[level_i + 1], + cex = label_box_text_cex + ) + } else { + rect(subplot_center[1] + 2 - label_box_width / 2, + subplot_center[2] - 2 - label_box_height / 2, + subplot_center[1] + 2 + label_box_width / 2, + subplot_center[2] - 2 + label_box_height / 2, + col = "white", + border = "black", lty = 2 + ) - text( - x = final_classtable_x[1] - .065, - y = mean(final_classtable_y), cex = header_cex, - "Decision" - ) + text( + x = subplot_center[1] + 2, + y = subplot_center[2] - 2, + labels = paste0("+ ", n_levels - 6, " More"), + cex = label_box_text_cex, + font = 3 + ) + } + } # if (new level on right). - # text(x = final_classtable_x[1] - .05, - # y = mean(final_classtable_y), cex = header_cex, - # "Decision", srt = 90, pos = 3) + # Update plot center: ---- - # Add final frequencies: ---- + # if (identical(paste(level_stats$exit[level_i]), "0")) { # 0 / FALSE / noise / left: + if (identical(paste(level_stats$exit[level_i]), paste0(exit_types[1]))) { + subplot_center <- c( + subplot_center[1] + 2, + subplot_center[2] - 4 + ) + } # if (identical exit 0 / left etc. - text(final_classtable_x[1] + .75 * diff(final_classtable_x), - final_classtable_y[1] + .25 * diff(final_classtable_y), - prettyNum(final_stats$cr, big.mark = ","), - cex = 1.5 - ) + # if (identical(paste(level_stats$exit[level_i]), "1")) { # 1 / TRUE / signal / right: + if (identical(paste(level_stats$exit[level_i]), paste0(exit_types[2]))) { + subplot_center <- c( + subplot_center[1] - 2, + subplot_center[2] - 4 + ) + } # if (identical exit 1 / right etc. + } # for (level_i etc. loop. + } # if (show.middle). - text(final_classtable_x[1] + .25 * diff(final_classtable_x), - final_classtable_y[1] + .25 * diff(final_classtable_y), - prettyNum(final_stats$mi, big.mark = ","), - cex = 1.5 - ) - text(final_classtable_x[1] + .75 * diff(final_classtable_x), - final_classtable_y[1] + .75 * diff(final_classtable_y), - prettyNum(final_stats$fa, big.mark = ","), - cex = 1.5 - ) + # 3. Cumulative performance: ---- - text(final_classtable_x[1] + .25 * diff(final_classtable_x), - final_classtable_y[1] + .75 * diff(final_classtable_y), - prettyNum(final_stats$hi, big.mark = ","), - cex = 1.5 - ) + if (show.bottom == TRUE) { # obtain tree statistics: + fft_sens_vec <- tree_stats$sens + fft_spec_vec <- tree_stats$spec - # Add symbols: ---- + # General plotting space: ---- - points(final_classtable_x[1] + .55 * diff(final_classtable_x), - final_classtable_y[1] + .05 * diff(final_classtable_y), - pch = noise_ball_pch, bg = col_correct_bg, col = col_correct_border, cex = ball_cex - ) + # Parameters: + header_y <- 1.0 + subheader_y <- .925 - points(final_classtable_x[1] + .05 * diff(final_classtable_x), - final_classtable_y[1] + .55 * diff(final_classtable_y), - pch = signal_ball_pch, bg = col_correct_bg, cex = ball_cex, col = col_correct_border - ) + header_cex <- 1.10 + subheader_cex <- .90 - points(final_classtable_x[1] + .55 * diff(final_classtable_x), - final_classtable_y[1] + .55 * diff(final_classtable_y), - pch = noise_ball_pch, bg = col_error_bg, col = col_error_border, cex = ball_cex - ) + par(mar = c(0, 0, 2, 0)) - points(final_classtable_x[1] + .05 * diff(final_classtable_x), - final_classtable_y[1] + .05 * diff(final_classtable_y), - pch = signal_ball_pch, bg = col_error_bg, col = col_error_border, cex = ball_cex - ) + plot(1, + xlim = c(0, 1), ylim = c(0, 1), + bty = "n", type = "n", + xlab = "", ylab = "", + yaxt = "n", xaxt = "n" + ) - # Add labels: ---- + if (what != "roc") { + # Set par: + par(xpd = TRUE) - text(final_classtable_x[1] + .62 * diff(final_classtable_x), - final_classtable_y[1] + .07 * diff(final_classtable_y), - "cr", - cex = 1, font = 3, adj = 0 - ) + # Bottom title: ---- - text(final_classtable_x[1] + .12 * diff(final_classtable_x), - final_classtable_y[1] + .07 * diff(final_classtable_y), - "mi", - cex = 1, font = 3, adj = 0 - ) + if (hlines) { + segments(0, 1.1, 1, 1.1, col = col_panel_line, lwd = panel_line_lwd, lty = panel_line_lty) - text(final_classtable_x[1] + .62 * diff(final_classtable_x), - final_classtable_y[1] + .57 * diff(final_classtable_y), - "fa", - cex = 1, font = 3, adj = 0 - ) + x_dev <- .20 + rect((.50 - x_dev), 1, (.50 + x_dev), 1.2, col = "white", border = NA) # label background + } - text(final_classtable_x[1] + .12 * diff(final_classtable_x), - final_classtable_y[1] + .57 * diff(final_classtable_y), - "hi", - cex = 1, font = 3, adj = 0 - ) + # Bottom label: + if (is.null(label.performance)) { # user argument not set: - } # if (show.confusion). + if (data == "train") { + label.performance <- "Accuracy (Training)" + } + if (data == "test") { + label.performance <- "Accuracy (Testing)" + } + } + text(x = .50, y = 1.1, labels = label.performance, cex = panel_title_cex, ...) # title 3 (bottom): Performance + + par(xpd = FALSE) + } # if (what != "roc"). + + + # Level parameters: + level_height_max <- .65 + level_width <- .05 + level_center_y <- .45 + # level_bottom <- .1 + level_bottom <- level_center_y - (level_height_max / 2) + level_top <- level_center_y + (level_height_max / 2) + + # Get either bacc OR wacc (based on sens.w): + sens.w <- x$params$sens.w + bacc_wacc <- get_bacc_wacc(sens = final_stats$sens, spec = final_stats$spec, sens.w = sens.w) + bacc_wacc_name <- names(bacc_wacc) + + # Set labels, values, and locations (as df): + lloc <- data.frame( + element = c("classtable", "mcu", "pci", "sens", "spec", "acc", bacc_wacc_name, "roc"), + long_name = c("Classification Table", "mcu", "pci", "sens", "spec", "acc", bacc_wacc_name, "ROC"), # used by add_level() helper function + center_x = c(.18, seq(.35, .65, length.out = 6), .85), + center_y = rep(level_center_y, 8), + width = c(.20, rep(level_width, 6), .20), + height = c(.65, rep(level_height_max, 6), .65), + value = c( + NA, + abs(final_stats$mcu - 5) / (abs(1 - 5)), final_stats$pci, + final_stats$sens, final_stats$spec, + with(final_stats, (cr + hi) / n), bacc_wacc, NA + ), + value_name = c( + NA, + round(final_stats$mcu, 1), pretty_dec(final_stats$pci), # used by add_level() helper function + pretty_dec(final_stats$sens), pretty_dec(final_stats$spec), + pretty_dec(final_stats$acc), pretty_dec(bacc_wacc), NA + ) + ) + # print(lloc) # 4debugging - # Levels: ---- - if (show.levels) { + # Classification table: ---- - if (level.type %in% c("line", "bar")) { + if (show.confusion) { + # Parameters: + classtable_lwd <- 1 - # Color function (taken from colorRamp2 function in circlize package) - # col.fun <- circlize::colorRamp2(c(0, .75, 1), - # c("red", "yellow", "green"), - # transparency = .5) + # x/y coordinates: + final_classtable_x <- c(lloc$center_x[lloc$element == "classtable"] - lloc$width[lloc$element == "classtable"] / 2, lloc$center_x[lloc$element == "classtable"] + lloc$width[lloc$element == "classtable"] / 2) + final_classtable_y <- c(lloc$center_y[lloc$element == "classtable"] - lloc$height[lloc$element == "classtable"] / 2, lloc$center_y[lloc$element == "classtable"] + lloc$height[lloc$element == "classtable"] / 2) - paste(final_stats$cr, "/", 1, collapse = "") + rect(final_classtable_x[1], final_classtable_y[1], + final_classtable_x[2], final_classtable_y[2], + lwd = classtable_lwd + ) - # Add 100% reference line: ---- + segments(mean(final_classtable_x), final_classtable_y[1], mean(final_classtable_x), final_classtable_y[2], col = gray(0), lwd = classtable_lwd) + segments(final_classtable_x[1], mean(final_classtable_y), final_classtable_x[2], mean(final_classtable_y), col = gray(0), lwd = classtable_lwd) - # segments(x0 = lloc$center_x[lloc$element == "mcu"] - lloc$width[lloc$element == "mcu"] * .8, - # y0 = level_top, - # x1 = lloc$center_x[lloc$element == "bacc"] + lloc$width[lloc$element == "bacc"] * .8, - # y1 = level_top, - # lty = 3, lwd = .75) + # Column titles: ---- - # mcu level: ---- + text( + x = mean(mean(final_classtable_x)), + y = header_y, + "Truth", pos = 1, cex = header_cex + ) - add_level("mcu", ok_val = .75, min_val = 0, max_val = 1, - level_type = level.type, lloc_row = lloc[lloc$element == "mcu", ], - header_y = header_y, header_cex = header_cex) # , sub = paste(c(final_stats$cr, "/", final_stats$cr + final_stats$fa), collapse = "")) + text( + x = final_classtable_x[1] + .25 * diff(final_classtable_x), + y = subheader_y, pos = 1, cex = subheader_cex, + truth.labels[2] + ) + text( + x = final_classtable_x[1] + .75 * diff(final_classtable_x), + y = subheader_y, pos = 1, cex = subheader_cex, + truth.labels[1] + ) - # pci level: ---- - add_level("pci", ok_val = .75, min_val = 0, max_val = 1, - level_type = level.type, lloc_row = lloc[lloc$element == "pci", ], - header_y = header_y, header_cex = header_cex) # , sub = paste(c(final_stats$cr, "/", final_stats$cr + final_stats$fa), collapse = "")) + # Row titles: ---- - # text(lloc$center_x[lloc$element == "pci"], - # lloc$center_y[lloc$element == "pci"], - # labels = paste0("mcu\n", round(mcu, 2))) + text( + x = final_classtable_x[1] - .01, + y = final_classtable_y[1] + .75 * diff(final_classtable_y), cex = subheader_cex, + decision.labels[2], adj = 1 + ) + text( + x = final_classtable_x[1] - .01, + y = final_classtable_y[1] + .25 * diff(final_classtable_y), cex = subheader_cex, + decision.labels[1], adj = 1 + ) - # spec level: ---- + text( + x = final_classtable_x[1] - .065, + y = mean(final_classtable_y), cex = header_cex, + "Decision" + ) - add_level("spec", ok_val = .75, min_val = 0, max_val = 1, - level_type = level.type, lloc_row = lloc[lloc$element == "spec", ], - header_y = header_y, header_cex = header_cex) # , sub = paste(c(final_stats$cr, "/", final_stats$cr + final_stats$fa), collapse = "")) + # text(x = final_classtable_x[1] - .05, + # y = mean(final_classtable_y), cex = header_cex, + # "Decision", srt = 90, pos = 3) - # sens level: ---- + # Add final frequencies: ---- - add_level("sens", ok_val = .75, min_val = 0, max_val = 1, - level_type = level.type, lloc_row = lloc[lloc$element == "sens", ], - header_y = header_y, header_cex = header_cex) # , sub = paste(c(final_stats$hi, "/", final_stats$hi + final_stats$mi), collapse = "")) + text(final_classtable_x[1] + .75 * diff(final_classtable_x), + final_classtable_y[1] + .25 * diff(final_classtable_y), + prettyNum(final_stats$cr, big.mark = ","), + cex = 1.5 + ) + text(final_classtable_x[1] + .25 * diff(final_classtable_x), + final_classtable_y[1] + .25 * diff(final_classtable_y), + prettyNum(final_stats$mi, big.mark = ","), + cex = 1.5 + ) - # acc level: ---- + text(final_classtable_x[1] + .75 * diff(final_classtable_x), + final_classtable_y[1] + .75 * diff(final_classtable_y), + prettyNum(final_stats$fa, big.mark = ","), + cex = 1.5 + ) - min_acc <- max(crit_br, 1 - crit_br) # accuracy baseline + text(final_classtable_x[1] + .25 * diff(final_classtable_x), + final_classtable_y[1] + .75 * diff(final_classtable_y), + prettyNum(final_stats$hi, big.mark = ","), + cex = 1.5 + ) - add_level("acc", ok_val = .50, min_val = 0, max_val = 1, - level_type = level.type, lloc_row = lloc[lloc$element == "acc", ], - header_y = header_y, header_cex = header_cex) # , sub = paste(c(final_stats$hi + final_stats$cr, "/", final_stats$n), collapse = "")) - # Add baseline to acc level: - segments( - x0 = (lloc$center_x[lloc$element == "acc"] - lloc$width[lloc$element == "acc"] / 2), - y0 = (lloc$center_y[lloc$element == "acc"] - lloc$height[lloc$element == "acc"] / 2) + (lloc$height[lloc$element == "acc"] * min_acc), - x1 = (lloc$center_x[lloc$element == "acc"] + lloc$width[lloc$element == "acc"] / 2), - y1 = (lloc$center_y[lloc$element == "acc"] - lloc$height[lloc$element == "acc"] / 2) + (lloc$height[lloc$element == "acc"] * min_acc), - lty = 3 - ) + # Add symbols: ---- - text( - x = lloc$center_x[lloc$element == "acc"], - y = (lloc$center_y[lloc$element == "acc"] - lloc$height[lloc$element == "acc"] / 2) + lloc$height[lloc$element == "acc"] * min_acc, - labels = "BL", pos = 1 - ) + points(final_classtable_x[1] + .55 * diff(final_classtable_x), + final_classtable_y[1] + .05 * diff(final_classtable_y), + pch = noise_ball_pch, bg = col_correct_bg, col = col_correct_border, cex = ball_cex + ) - # paste("BL = ", pretty_dec(min_acc), sep = ""), pos = 1) + points(final_classtable_x[1] + .05 * diff(final_classtable_x), + final_classtable_y[1] + .55 * diff(final_classtable_y), + pch = signal_ball_pch, bg = col_correct_bg, cex = ball_cex, col = col_correct_border + ) + points(final_classtable_x[1] + .55 * diff(final_classtable_x), + final_classtable_y[1] + .55 * diff(final_classtable_y), + pch = noise_ball_pch, bg = col_error_bg, col = col_error_border, cex = ball_cex + ) - # bacc OR wacc level: ---- + points(final_classtable_x[1] + .05 * diff(final_classtable_x), + final_classtable_y[1] + .05 * diff(final_classtable_y), + pch = signal_ball_pch, bg = col_error_bg, col = col_error_border, cex = ball_cex + ) - if (names(bacc_wacc) == "bacc"){ # show bacc level: - add_level("bacc", ok_val = .50, min_val = 0, max_val = 1, - level_type = level.type, lloc_row = lloc[lloc$element == "bacc", ], - header_y = header_y, header_cex = header_cex) + # Add labels: ---- - } else { # show wacc level (and sens.w value): + text(final_classtable_x[1] + .62 * diff(final_classtable_x), + final_classtable_y[1] + .07 * diff(final_classtable_y), + "cr", + cex = 1, font = 3, adj = 0 + ) - sens.w_lbl <- paste0("sens.w = .", pretty_dec(sens.w)) + text(final_classtable_x[1] + .12 * diff(final_classtable_x), + final_classtable_y[1] + .07 * diff(final_classtable_y), + "mi", + cex = 1, font = 3, adj = 0 + ) - add_level("wacc", ok_val = .50, min_val = 0, max_val = 1, - level_type = level.type, lloc_row = lloc[lloc$element == "wacc", ], - header_y = header_y, - bottom_text = sens.w_lbl, # (only here) - header_cex = header_cex) + text(final_classtable_x[1] + .62 * diff(final_classtable_x), + final_classtable_y[1] + .57 * diff(final_classtable_y), + "fa", + cex = 1, font = 3, adj = 0 + ) - } # if (bacc_wacc). + text(final_classtable_x[1] + .12 * diff(final_classtable_x), + final_classtable_y[1] + .57 * diff(final_classtable_y), + "hi", + cex = 1, font = 3, adj = 0 + ) + } # if (show.confusion). - # Add baseline (at bottom?): - # - # segments(x0 = mean(lloc$center_x[2]), - # y0 = lloc$center_y[1] - lloc$height[1] / 2, - # x1 = mean(lloc$center_x[7]), - # y1 = lloc$center_y[1] - lloc$height[1] / 2, lend = 1, - # lwd = .5, - # col = gray(0)) + # Levels: ---- + if (show.levels) { + if (level.type %in% c("line", "bar")) { + # Color function (taken from colorRamp2 function in circlize package) + # col.fun <- circlize::colorRamp2(c(0, .75, 1), + # c("red", "yellow", "green"), + # transparency = .5) - } # if (level.type %in% c("line", "bar")). + paste(final_stats$cr, "/", 1, collapse = "") - } # if (show.levels). + # Add 100% reference line: ---- + # segments(x0 = lloc$center_x[lloc$element == "mcu"] - lloc$width[lloc$element == "mcu"] * .8, + # y0 = level_top, + # x1 = lloc$center_x[lloc$element == "bacc"] + lloc$width[lloc$element == "bacc"] * .8, + # y1 = level_top, + # lty = 3, lwd = .75) - # ROC curve: ----- - if (show.roc) { + # mcu level: ---- - # Parameters: - roc_border_lwd <- 1 - roc_border_col <- gray(0) + add_level("mcu", + ok_val = .75, min_val = 0, max_val = 1, + level_type = level.type, lloc_row = lloc[lloc$element == "mcu", ], + header_y = header_y, header_cex = header_cex + ) # , sub = paste(c(final_stats$cr, "/", final_stats$cr + final_stats$fa), collapse = "")) - roc_title <- "ROC" - roc_title_font <- 1 - roc_curve_col <- gray(.01) # ~black - roc_curve_lwd <- 1.1 + # pci level: ---- - diag_col <- gray(.01) # ~black - diag_lty <- 3 + add_level("pci", + ok_val = .75, min_val = 0, max_val = 1, + level_type = level.type, lloc_row = lloc[lloc$element == "pci", ], + header_y = header_y, header_cex = header_cex + ) # , sub = paste(c(final_stats$cr, "/", final_stats$cr + final_stats$fa), collapse = "")) - x_lbl <- expression(1 - Specificity~(FAR)) # to plot minus, rather than dash - y_lbl <- expression(Sensitivity~(HR)) + # text(lloc$center_x[lloc$element == "pci"], + # lloc$center_y[lloc$element == "pci"], + # labels = paste0("mcu\n", round(mcu, 2))) - x_d <- .015 # distance of x-axis labels (on left) to x-axis - # y-locations of legend labels (default: using full height): - roc_lbl_y <- seq(.10, .90, length.out = 5) # SVM, RF, LR, CART, FFT + # spec level: ---- + add_level("spec", + ok_val = .75, min_val = 0, max_val = 1, + level_type = level.type, lloc_row = lloc[lloc$element == "spec", ], + header_y = header_y, header_cex = header_cex + ) # , sub = paste(c(final_stats$cr, "/", final_stats$cr + final_stats$fa), collapse = "")) - if (what == "roc"){ # ROC as main plot: - # Rescale key coordinates: - lloc$center_x[lloc$element == "roc"] <- .50 - lloc$center_y[lloc$element == "roc"] <- .55 + # sens level: ---- - lloc$width[lloc$element == "roc"] <- .70 - lloc$height[lloc$element == "roc"] <- .80 + add_level("sens", + ok_val = .75, min_val = 0, max_val = 1, + level_type = level.type, lloc_row = lloc[lloc$element == "sens", ], + header_y = header_y, header_cex = header_cex + ) # , sub = paste(c(final_stats$hi, "/", final_stats$hi + final_stats$mi), collapse = "")) - # Reset some parameters: - if (is.null(main) == FALSE) { roc_title <- main } - roc_border_lwd <- .80 - roc_border_col <- gray(.25) + # acc level: ---- - roc_curve_col <- gray(.10) # "green2" - roc_curve_lwd <- 1.5 + min_acc <- max(crit_br, 1 - crit_br) # accuracy baseline - diag_col <- gray(.60) # as in showcues() - diag_lty <- 1 # as in showcues() + add_level("acc", + ok_val = .50, min_val = 0, max_val = 1, + level_type = level.type, lloc_row = lloc[lloc$element == "acc", ], + header_y = header_y, header_cex = header_cex + ) # , sub = paste(c(final_stats$hi + final_stats$cr, "/", final_stats$n), collapse = "")) - x_d <- .035 + # Add baseline to acc level: + segments( + x0 = (lloc$center_x[lloc$element == "acc"] - lloc$width[lloc$element == "acc"] / 2), + y0 = (lloc$center_y[lloc$element == "acc"] - lloc$height[lloc$element == "acc"] / 2) + (lloc$height[lloc$element == "acc"] * min_acc), + x1 = (lloc$center_x[lloc$element == "acc"] + lloc$width[lloc$element == "acc"] / 2), + y1 = (lloc$center_y[lloc$element == "acc"] - lloc$height[lloc$element == "acc"] / 2) + (lloc$height[lloc$element == "acc"] * min_acc), + lty = 3 + ) - # y-locations of legend labels (cluster labels on top right): - roc_lbl_y <- seq(.55, .95, length.out = 5) # SVM, RF, LR, CART, FFT + text( + x = lloc$center_x[lloc$element == "acc"], + y = (lloc$center_y[lloc$element == "acc"] - lloc$height[lloc$element == "acc"] / 2) + lloc$height[lloc$element == "acc"] * min_acc, + labels = "BL", pos = 1 + ) - } # if (what == "roc"). + # paste("BL = ", pretty_dec(min_acc), sep = ""), pos = 1) - # ROC plot coordinates: - final_roc_x <- c(lloc$center_x[lloc$element == "roc"] - lloc$width[lloc$element == "roc"] / 2, lloc$center_x[lloc$element == "roc"] + lloc$width[lloc$element == "roc"] / 2) - final_roc_y <- c(lloc$center_y[lloc$element == "roc"] - lloc$height[lloc$element == "roc"] / 2, lloc$center_y[lloc$element == "roc"] + lloc$height[lloc$element == "roc"] / 2) + # bacc OR wacc level: ---- + if (names(bacc_wacc) == "bacc") { # show bacc level: - if (what == "roc"){ # ROC as main plot: + add_level("bacc", + ok_val = .50, min_val = 0, max_val = 1, + level_type = level.type, lloc_row = lloc[lloc$element == "bacc", ], + header_y = header_y, header_cex = header_cex + ) + } else { # show wacc level (and sens.w value): - # Title: - title(main = roc_title, ...) # + graphical parameters + sens.w_lbl <- paste0("sens.w = .", pretty_dec(sens.w)) - # Background: - rect(final_roc_x[1], final_roc_y[1], final_roc_x[2], final_roc_y[2], - col = gray(.96)) # as in showcues() + add_level("wacc", + ok_val = .50, min_val = 0, max_val = 1, + level_type = level.type, lloc_row = lloc[lloc$element == "wacc", ], + header_y = header_y, + bottom_text = sens.w_lbl, # (only here) + header_cex = header_cex + ) + } # if (bacc_wacc). - # Grid: - x_ax_seq <- seq(final_roc_x[1], final_roc_x[2], length.out = 11) - y_ax_seq <- seq(final_roc_y[1], final_roc_y[2], length.out = 11) - abline(v = x_ax_seq, lwd = c(2, rep(1, 4)), col = gray(1)) # x-grid - abline(h = y_ax_seq, lwd = c(2, rep(1, 4)), col = gray(1)) # y-grid - # Axis ticks: - segments(x_ax_seq, final_roc_y[1], x_ax_seq, (final_roc_y[1] - .025), lty = 1, lwd = 1, col = gray(.10)) # x-axis - segments(final_roc_x[1], y_ax_seq, (final_roc_x[1] - .015), y_ax_seq, lty = 1, lwd = 1, col = gray(.10)) # y-axis + # Add baseline (at bottom?): + # + # segments(x0 = mean(lloc$center_x[2]), + # y0 = lloc$center_y[1] - lloc$height[1] / 2, + # x1 = mean(lloc$center_x[7]), + # y1 = lloc$center_y[1] - lloc$height[1] / 2, lend = 1, + # lwd = .5, + # col = gray(0)) + } # if (level.type %in% c("line", "bar")). + } # if (show.levels). - # Tick labels: - text(x_ax_seq, (final_roc_y[1] - .025), labels = scales::comma(seq(0, 1, by = .1), accuracy = .1), pos = 1, cex = .9) # x-lbl - text((final_roc_x[1] - .015), y_ax_seq, labels = scales::comma(seq(0, 1, by = .1), accuracy = .1), pos = 2, cex = .9) # y-llb - # Axis labels: - text(mean(final_roc_x), final_roc_y[1] - .125, labels = x_lbl, cex = 1) # x-lab - text(final_roc_x[1] - (3.5 * x_d), mean(final_roc_y), labels = y_lbl, cex = 1, srt = 90) # y-lab + # ROC curve: ----- - # Subtitle: Note data used - subnote <- paste0("ROC for '", data, "' data:") - text(x = (final_roc_x[1] - .015), y = (final_roc_y[2] + .03), - labels = subnote, pos = 4, cex = subheader_cex) + if (show.roc) { + # Parameters: + roc_border_lwd <- 1 + roc_border_col <- gray(0) + roc_title <- "ROC" + roc_title_font <- 1 - } else { # ROC as miniature plot: + roc_curve_col <- gray(.01) # ~black + roc_curve_lwd <- 1.1 - # Title: - text(lloc$center_x[lloc$element == "roc"], header_y, labels = roc_title, - font = roc_title_font, pos = 1, cex = header_cex) + diag_col <- gray(.01) # ~black + diag_lty <- 3 - # x-axis: - text(c(final_roc_x[1], final_roc_x[2]), - c(final_roc_y[1], final_roc_y[1]) - .04, - labels = c(0, 1) - ) + x_lbl <- expression(1 - Specificity ~ (FAR)) # to plot minus, rather than dash + y_lbl <- expression(Sensitivity ~ (HR)) - text(mean(final_roc_x), final_roc_y[1] - .08, labels = x_lbl) # x-lab + x_d <- .015 # distance of x-axis labels (on left) to x-axis - # y-axis: - text(c(final_roc_x[1], final_roc_x[1], final_roc_x[1]) - x_d, - c(final_roc_y[1], mean(final_roc_y[1:2]), final_roc_y[2]), - labels = c(0, .5, 1) - ) + # y-locations of legend labels (default: using full height): + roc_lbl_y <- seq(.10, .90, length.out = 5) # SVM, RF, LR, CART, FFT - text(final_roc_x[1] - (2.5 * x_d), mean(final_roc_y), labels = y_lbl, srt = 90) # y-lab - # AUC label: - # text(final.roc.center[1], subheader_y, paste("AUC =", round(final.auc, 2)), pos = 1) + if (what == "roc") { # ROC as main plot: - # Plot bg: - # - # rect(final_roc_x[1], - # final_roc_y[1], - # final_roc_x[2], - # final_roc_y[2], - # col = gray(1), lwd = .5) + # Rescale key coordinates: + lloc$center_x[lloc$element == "roc"] <- .50 + lloc$center_y[lloc$element == "roc"] <- .55 - # Gridlines: - # # Horizontal: - # segments(x0 = rep(final_roc_x[1], 9), - # y0 = seq(final_roc_y[1], final_roc_y[2], length.out = 5)[2:10], - # x1 = rep(final_roc_x[2], 9), - # y1 = seq(final_roc_y[1], final_roc_y[2], length.out = 5)[2:10], - # lty = 1, col = gray(.8), lwd = c(.5), lend = 3 - # ) - # - # # Vertical: - # segments(y0 = rep(final_roc_y[1], 9), - # x0 = seq(final_roc_x[1], final_roc_x[2], length.out = 5)[2:10], - # y1 = rep(final_roc_y[2], 9), - # x1 = seq(final_roc_x[1], final_roc_x[2], length.out = 5)[2:10], - # lty = 1, col = gray(.8), lwd = c(.5), lend = 3 - # ) + lloc$width[lloc$element == "roc"] <- .70 + lloc$height[lloc$element == "roc"] <- .80 - } + # Reset some parameters: + if (is.null(main) == FALSE) { + roc_title <- main + } - # Plot border: - rect(final_roc_x[1], - final_roc_y[1], - final_roc_x[2], - final_roc_y[2], - border = roc_border_col, - lwd = roc_border_lwd - ) + roc_border_lwd <- .80 + roc_border_col <- gray(.25) + + roc_curve_col <- gray(.10) # "green2" + roc_curve_lwd <- 1.5 + + diag_col <- gray(.60) # as in showcues() + diag_lty <- 1 # as in showcues() + + x_d <- .035 + + # y-locations of legend labels (cluster labels on top right): + roc_lbl_y <- seq(.55, .95, length.out = 5) # SVM, RF, LR, CART, FFT + } # if (what == "roc"). + + + # ROC plot coordinates: + final_roc_x <- c(lloc$center_x[lloc$element == "roc"] - lloc$width[lloc$element == "roc"] / 2, lloc$center_x[lloc$element == "roc"] + lloc$width[lloc$element == "roc"] / 2) + final_roc_y <- c(lloc$center_y[lloc$element == "roc"] - lloc$height[lloc$element == "roc"] / 2, lloc$center_y[lloc$element == "roc"] + lloc$height[lloc$element == "roc"] / 2) + + + if (what == "roc") { # ROC as main plot: + + # Title: + title(main = roc_title, ...) # + graphical parameters + + # Background: + rect(final_roc_x[1], final_roc_y[1], final_roc_x[2], final_roc_y[2], + col = gray(.96) + ) # as in showcues() + + # Grid: + x_ax_seq <- seq(final_roc_x[1], final_roc_x[2], length.out = 11) + y_ax_seq <- seq(final_roc_y[1], final_roc_y[2], length.out = 11) + abline(v = x_ax_seq, lwd = c(2, rep(1, 4)), col = gray(1)) # x-grid + abline(h = y_ax_seq, lwd = c(2, rep(1, 4)), col = gray(1)) # y-grid + + # Axis ticks: + segments(x_ax_seq, final_roc_y[1], x_ax_seq, (final_roc_y[1] - .025), lty = 1, lwd = 1, col = gray(.10)) # x-axis + segments(final_roc_x[1], y_ax_seq, (final_roc_x[1] - .015), y_ax_seq, lty = 1, lwd = 1, col = gray(.10)) # y-axis + + # Tick labels: + text(x_ax_seq, (final_roc_y[1] - .025), labels = scales::comma(seq(0, 1, by = .1), accuracy = .1), pos = 1, cex = .9) # x-lbl + text((final_roc_x[1] - .015), y_ax_seq, labels = scales::comma(seq(0, 1, by = .1), accuracy = .1), pos = 2, cex = .9) # y-llb + + # Axis labels: + text(mean(final_roc_x), final_roc_y[1] - .125, labels = x_lbl, cex = 1) # x-lab + text(final_roc_x[1] - (3.5 * x_d), mean(final_roc_y), labels = y_lbl, cex = 1, srt = 90) # y-lab + + # Subtitle: Note data used + subnote <- paste0("ROC for '", data, "' data:") + text( + x = (final_roc_x[1] - .015), y = (final_roc_y[2] + .03), + labels = subnote, pos = 4, cex = subheader_cex + ) + } else { # ROC as miniature plot: + + # Title: + text(lloc$center_x[lloc$element == "roc"], header_y, + labels = roc_title, + font = roc_title_font, pos = 1, cex = header_cex + ) + + # x-axis: + text(c(final_roc_x[1], final_roc_x[2]), + c(final_roc_y[1], final_roc_y[1]) - .04, + labels = c(0, 1) + ) + + text(mean(final_roc_x), final_roc_y[1] - .08, labels = x_lbl) # x-lab + + # y-axis: + text(c(final_roc_x[1], final_roc_x[1], final_roc_x[1]) - x_d, + c(final_roc_y[1], mean(final_roc_y[1:2]), final_roc_y[2]), + labels = c(0, .5, 1) + ) + + text(final_roc_x[1] - (2.5 * x_d), mean(final_roc_y), labels = y_lbl, srt = 90) # y-lab + + # AUC label: + # text(final.roc.center[1], subheader_y, paste("AUC =", round(final.auc, 2)), pos = 1) + + # Plot bg: + # + # rect(final_roc_x[1], + # final_roc_y[1], + # final_roc_x[2], + # final_roc_y[2], + # col = gray(1), lwd = .5) + + # Gridlines: + # # Horizontal: + # segments(x0 = rep(final_roc_x[1], 9), + # y0 = seq(final_roc_y[1], final_roc_y[2], length.out = 5)[2:10], + # x1 = rep(final_roc_x[2], 9), + # y1 = seq(final_roc_y[1], final_roc_y[2], length.out = 5)[2:10], + # lty = 1, col = gray(.8), lwd = c(.5), lend = 3 + # ) + # + # # Vertical: + # segments(y0 = rep(final_roc_y[1], 9), + # x0 = seq(final_roc_x[1], final_roc_x[2], length.out = 5)[2:10], + # y1 = rep(final_roc_y[2], 9), + # x1 = seq(final_roc_x[1], final_roc_x[2], length.out = 5)[2:10], + # lty = 1, col = gray(.8), lwd = c(.5), lend = 3 + # ) + } - # Diagonal: - segments(final_roc_x[1], - final_roc_y[1], - final_roc_x[2], - final_roc_y[2], - col = diag_col, - lwd = 1, - lty = diag_lty - ) - - # FFTs: ---- - - { - - if (!grayscale) { - - col_fft_point_col <- scales::alpha("green", .1) - col_fft_point_bg <- scales::alpha("white", .9) - col_fft_point_bg_2 <- scales::alpha("green", .2) - col_fft_point_col_2 <- scales::alpha("green", .6) - - } else { - - col_fft_point_col <- gray(0) - col_fft_point_bg <- gray(1) - col_fft_point_bg_2 <- gray(1) - col_fft_point_col_2 <- gray(0) - } - - roc_order <- order(fft_spec_vec, decreasing = TRUE) # from highest to lowest spec - # roc_order <- 1:x$trees$n - - fft_sens_vec_ord <- fft_sens_vec[roc_order] - fft_spec_vec_ord <- fft_spec_vec[roc_order] - - # Add segments and points for all trees but tree: - - if (length(roc_order) > 1) { - - segments(final_roc_x[1] + c(0, 1 - fft_spec_vec_ord) * lloc$width[lloc$element == "roc"], - final_roc_y[1] + c(0, fft_sens_vec_ord) * lloc$height[lloc$element == "roc"], - final_roc_x[1] + c(1 - fft_spec_vec_ord, 1) * lloc$width[lloc$element == "roc"], - final_roc_y[1] + c(fft_sens_vec_ord, 1) * lloc$height[lloc$element == "roc"], - lwd = roc_curve_lwd, - col = roc_curve_col - ) - - points(final_roc_x[1] + ((1 - fft_spec_vec_ord[-(which(roc_order == tree))]) * lloc$width[lloc$element == "roc"]), - final_roc_y[1] + (fft_sens_vec_ord[-(which(roc_order == tree))] * lloc$height[lloc$element == "roc"]), - pch = 21, cex = 2.5, col = col_fft_point_col_2, - bg = col_fft_point_bg - ) - - text(final_roc_x[1] + ((1 - fft_spec_vec_ord[-(which(roc_order == tree))]) * lloc$width[lloc$element == "roc"]), - final_roc_y[1] + (fft_sens_vec_ord[-(which(roc_order == tree))] * lloc$height[lloc$element == "roc"]), - labels = roc_order[which(roc_order != tree)], cex = 1, col = gray(.50) - ) - - } - - # Add larger point for plotted tree: - - # white point (to hide point from above): - points(final_roc_x[1] + ((1 - fft_spec_vec[tree]) * lloc$width[lloc$element == "roc"]), - final_roc_y[1] + (fft_sens_vec[tree] * lloc$height[lloc$element == "roc"]), - pch = 21, cex = 3, col = col_fft_point_col_2, # col = scales::alpha("green", .30), - bg = scales::alpha("white", 1), lwd = 1 - ) - - # green point: - points(final_roc_x[1] + ((1 - fft_spec_vec[tree]) * lloc$width[lloc$element == "roc"]), - final_roc_y[1] + (fft_sens_vec[tree] * lloc$height[lloc$element == "roc"]), - pch = 21, cex = 3, col = col_fft_point_col_2, # col = scales::alpha("green", .30), - bg = col_fft_point_bg_2, lwd = 1 - ) - - text(final_roc_x[1] + ((1 - fft_spec_vec[tree]) * lloc$width[lloc$element == "roc"]), - final_roc_y[1] + (fft_sens_vec[tree] * lloc$height[lloc$element == "roc"]), - labels = tree, cex = 1.25, col = gray(.20), font = 2 - ) + # Plot border: + rect(final_roc_x[1], + final_roc_y[1], + final_roc_x[2], + final_roc_y[2], + border = roc_border_col, + lwd = roc_border_lwd + ) + + # Diagonal: + segments(final_roc_x[1], + final_roc_y[1], + final_roc_x[2], + final_roc_y[2], + col = diag_col, + lwd = 1, + lty = diag_lty + ) + + # FFTs: ---- + + { + if (!grayscale) { + col_fft_point_col <- scales::alpha("green", .1) + col_fft_point_bg <- scales::alpha("white", .9) + col_fft_point_bg_2 <- scales::alpha("green", .2) + col_fft_point_col_2 <- scales::alpha("green", .6) + } else { + col_fft_point_col <- gray(0) + col_fft_point_bg <- gray(1) + col_fft_point_bg_2 <- gray(1) + col_fft_point_col_2 <- gray(0) + } + roc_order <- order(fft_spec_vec, decreasing = TRUE) # from highest to lowest spec + # roc_order <- 1:x$trees$n - } # FFTs. + fft_sens_vec_ord <- fft_sens_vec[roc_order] + fft_spec_vec_ord <- fft_spec_vec[roc_order] - } # if (show.roc). + # Add segments and points for all trees but tree: - } # if (show.bottom). + if (length(roc_order) > 1) { + segments(final_roc_x[1] + c(0, 1 - fft_spec_vec_ord) * lloc$width[lloc$element == "roc"], + final_roc_y[1] + c(0, fft_sens_vec_ord) * lloc$height[lloc$element == "roc"], + final_roc_x[1] + c(1 - fft_spec_vec_ord, 1) * lloc$width[lloc$element == "roc"], + final_roc_y[1] + c(fft_sens_vec_ord, 1) * lloc$height[lloc$element == "roc"], + lwd = roc_curve_lwd, + col = roc_curve_col + ) - # # Reset plotting space: - # par(mfrow = c(1, 1)) - # par(mar = c(5, 4, 4, 1) + .1) + points(final_roc_x[1] + ((1 - fft_spec_vec_ord[-(which(roc_order == tree))]) * lloc$width[lloc$element == "roc"]), + final_roc_y[1] + (fft_sens_vec_ord[-(which(roc_order == tree))] * lloc$height[lloc$element == "roc"]), + pch = 21, cex = 2.5, col = col_fft_point_col_2, + bg = col_fft_point_bg + ) + text(final_roc_x[1] + ((1 - fft_spec_vec_ord[-(which(roc_order == tree))]) * lloc$width[lloc$element == "roc"]), + final_roc_y[1] + (fft_sens_vec_ord[-(which(roc_order == tree))] * lloc$height[lloc$element == "roc"]), + labels = roc_order[which(roc_order != tree)], cex = 1, col = gray(.50) + ) + } + # Add larger point for plotted tree: + + # white point (to hide point from above): + points(final_roc_x[1] + ((1 - fft_spec_vec[tree]) * lloc$width[lloc$element == "roc"]), + final_roc_y[1] + (fft_sens_vec[tree] * lloc$height[lloc$element == "roc"]), + pch = 21, cex = 3, col = col_fft_point_col_2, # col = scales::alpha("green", .30), + bg = scales::alpha("white", 1), lwd = 1 + ) + + # green point: + points(final_roc_x[1] + ((1 - fft_spec_vec[tree]) * lloc$width[lloc$element == "roc"]), + final_roc_y[1] + (fft_sens_vec[tree] * lloc$height[lloc$element == "roc"]), + pch = 21, cex = 3, col = col_fft_point_col_2, # col = scales::alpha("green", .30), + bg = col_fft_point_bg_2, lwd = 1 + ) + + text(final_roc_x[1] + ((1 - fft_spec_vec[tree]) * lloc$width[lloc$element == "roc"]), + final_roc_y[1] + (fft_sens_vec[tree] * lloc$height[lloc$element == "roc"]), + labels = tree, cex = 1.25, col = gray(.20), font = 2 + ) + } # FFTs. + } # if (show.roc). + } # if (show.bottom). + + # # Reset plotting space: + # par(mfrow = c(1, 1)) + # par(mar = c(5, 4, 4, 1) + .1) } # if (what != "cues"). @@ -2155,7 +2065,6 @@ plot.FFTrees <- function(x = NULL, # Output x may differ from input x when applying new 'test' data (as df): return(invisible(x)) - } # plot.FFTrees(). From eb5c3560d4b47a9984082c9a027494c8141472bf Mon Sep 17 00:00:00 2001 From: Nathaniel Phillips Date: Thu, 23 May 2024 17:48:59 -0400 Subject: [PATCH 02/12] created plot_level_bar() helper fun and used in plotFFTrees for signal and noise levels --- R/plotFFTrees_function.R | 263 ++++++++++++++++----------------------- 1 file changed, 109 insertions(+), 154 deletions(-) diff --git a/R/plotFFTrees_function.R b/R/plotFFTrees_function.R index 732e3825..0f620c17 100644 --- a/R/plotFFTrees_function.R +++ b/R/plotFFTrees_function.R @@ -191,9 +191,6 @@ plot.FFTrees <- function(x = NULL, par0 <- par(no.readonly = TRUE) on.exit(par(par0), add = TRUE) - - # Deprecated arguments: ---- - if (is.null(which.tree) == FALSE) { warning("plot.FFTrees: 'which.tree' is deprecated. Use 'tree' instead.") @@ -217,7 +214,6 @@ plot.FFTrees <- function(x = NULL, } - # Verify what: ---- valid_what <- c( "all", "default", @@ -233,9 +229,6 @@ plot.FFTrees <- function(x = NULL, stop(paste0("what must be a string in c(", valid_string_q, ").", sep = "")) } - - # Handle what: ---- - if (what == "cue") { # handle special case: showcues(x = x, main = main, ...) # pass key inputs + graphical parameters @@ -244,11 +237,8 @@ plot.FFTrees <- function(x = NULL, # as currently no cue accuracy statistics exist in x. } - if (what != "cue") { # ALL else in function: what in c("all", "tree", "roc") - # Set show.parts parameters: ---- - if (what == "all" | what == "def") { # default: if (is.null(show.header)) { @@ -340,13 +330,8 @@ plot.FFTrees <- function(x = NULL, hlines <- FALSE } # if (what == "roc"). - - # Determine layout: ---- - - # Constants (currently fixed parameters): show_icon_guide_legend <- FALSE - # Top, middle, and bottom: if (show.header & show.tree & (show.confusion | show.levels | show.roc)) { show.top <- TRUE show.middle <- TRUE @@ -408,9 +393,6 @@ plot.FFTrees <- function(x = NULL, ) } - - # data: ---- - # Note: data can be either a string "train"/"test" # OR an entire data frame (of new test data): @@ -434,14 +416,8 @@ plot.FFTrees <- function(x = NULL, data <- "test" # in rest of this function } - - # Extract key parameters from x: ------ - - # goal: ---- - goal <- x$params$goal - # decision.labels: if (is.null(decision.labels)) { if (("decision.labels" %in% names(x$params))) { decision.labels <- x$params$decision.labels @@ -450,15 +426,10 @@ plot.FFTrees <- function(x = NULL, } } - # truth.labels: if (is.null(truth.labels)) { truth.labels <- decision.labels - - # ToDo: Check for 2 cases, else use a default of c(0, 1). } - # main: ---- - if (is.null(main)) { if (("main" %in% names(x$params))) { if (is.null(x$params$main)) { @@ -487,16 +458,9 @@ plot.FFTrees <- function(x = NULL, } # if (("main" %in% names(x$params))). } # if (is.null(main)). - - # tree: ---- - - # Verify tree input: ---- - tree <- verify_tree_arg(x = x, data = data, tree = tree) # use helper (for plotting AND printing) - # Get "best" tree: ---- - if (tree == "best.train") { if (data == "test") { warning("You asked for the 'best.train' tree, but data was set to 'test'. Used the best tree for 'train' data instead...") @@ -523,9 +487,6 @@ plot.FFTrees <- function(x = NULL, tree <- get_best_tree(x, data = "test", goal = x$params$goal) # using helper } - - # Define critical objects: ------ - # decision_v <- x$trees$decisions[[data]][[tree]]$decision tree_stats <- x$trees$stats[[data]] level_stats <- x$trees$level_stats[[data]][x$trees$level_stats[[data]]$tree == tree, ] @@ -547,9 +508,6 @@ plot.FFTrees <- function(x = NULL, final_stats <- tree_stats[tree, ] - - # Add level statistics: ---- - n_levels <- nrow(level_stats) # Add marginal classification statistics to level_stats / Frequencies per level: @@ -578,22 +536,14 @@ plot.FFTrees <- function(x = NULL, # print(level_stats) # tree with marginal frequency values (for each level) - # Set plotting parameters: ---- - - # Label sizes: - - # print(paste0("par('cex') = ", par("cex"))) # Note: Value varies from .66 to 1 + ## Set plotting parameters: ---- - # Sizes not set by user: f_cex <- 1 # cex scaling factor decision_node_cex <- 4 * f_cex exit_node_cex <- 4 * f_cex panel_title_cex <- 2 * f_cex - # Set by user arguments: - - # Cue label size: if (is.null(cue.cex)) { cue.cex <- c(1.50, 1.50, 1.25, 1, 1, 1) } else { @@ -601,9 +551,7 @@ plot.FFTrees <- function(x = NULL, cue.cex <- rep(cue.cex, length.out = 6) } } - # print(cue.cex) # 4debugging - # Break label size: if (is.null(threshold.cex)) { threshold.cex <- c(1.50, 1.50, 1.25, 1, 1, 1) } else { @@ -697,9 +645,6 @@ plot.FFTrees <- function(x = NULL, plot_width <- plotting_parameters_df$plot_width[6] } - - # Colors: ---- - col_exit_node_bg <- "white" # error.colfun <- circlize::colorRamp2(c(0, 50, 100), @@ -734,9 +679,6 @@ plot.FFTrees <- function(x = NULL, decision_node_pch <- NA_integer_ - - # Balls: ---- - ball_loc <- "variable" if (n_levels == 3) { @@ -772,18 +714,12 @@ plot.FFTrees <- function(x = NULL, noise_ball_bg <- ball_bg[1] signal_ball_bg <- ball_bg[2] - - # Arrows: ---- - arrow_lty <- 1 arrow_lwd <- 1 arrow_length <- 2.50 arrow_head_length <- .08 arrow_col <- gray(0) # = black - - # Final stats: ---- - # spec_circle_x <- .40 # is NOT used anywhere? # dprime_circle_x <- .50 # is NOT used anywhere? # sens_circle_x <- .60 # is NOT used anywhere? @@ -795,11 +731,6 @@ plot.FFTrees <- function(x = NULL, # dprime_circle_col <- "blue" # is NOT used anywhere? # stat_outer_circle_col <- gray(.50) # is NOT used anywhere? - - # 1: Initial Frequencies: ------ - - # Parameters: - if (show.top) { par(mar = c(0, 0, 1, 0)) @@ -826,7 +757,6 @@ plot.FFTrees <- function(x = NULL, text(x = .50, y = .96, main, cex = panel_title_cex, ...) # title 1 (top): main - # 2. Data info: ---- # (a) N and labels: text(x = .50, y = .78, paste("N = ", prettyNum(n_exemplars, big.mark = ","), "", sep = ""), cex = 1.25) # N @@ -862,89 +792,31 @@ plot.FFTrees <- function(x = NULL, par(xpd = FALSE) - - # 3. Add p_signal and p_noise levels: ----- - - signal_p <- crit_br # criterion baseline/base rate (from above) - noise_p <- (1 - signal_p) - - p_rect_ylim <- c(.10, .60) - - # (a) p_signal level (on right): ---- - text( - x = .80, y = p_rect_ylim[2], - labels = paste("p(", truth.labels[2], ")", sep = ""), - pos = 3, cex = 1.2 - ) - - # Filling: - rect(.775, p_rect_ylim[1], - .825, p_rect_ylim[1] + signal_p * diff(p_rect_ylim), - col = gray(.50, .25), border = NA - ) - - # Filltop: - segments(.775, p_rect_ylim[1] + signal_p * diff(p_rect_ylim), - .825, p_rect_ylim[1] + signal_p * diff(p_rect_ylim), - lwd = 1 - ) - - # Outline: - rect(.775, p_rect_ylim[1], - .825, p_rect_ylim[2], - lwd = 1 - ) - - if (signal_p < .0001) { - signal_p_text <- "<1%" - } else { - signal_p_text <- paste(round(signal_p * 100, 0), "%", sep = "") - } - - text(.825, p_rect_ylim[1] + signal_p * diff(p_rect_ylim), - labels = signal_p_text, - pos = 4, cex = 1.2 - ) - + plot_level_bar(title = paste("p(", truth.labels[2], ")", sep = ""), + value = crit_br, + value_label = scales::percent(crit_br), + max_value = 1, + rect_max_y = .6, + rect_min_y = .1, + rect_min_x = .775, + rect_max_x = .825, + label_pos = "right") # (b) p_noise level (on left): ---- - text( - x = .20, y = p_rect_ylim[2], - labels = paste("p(", truth.labels[1], ")", sep = ""), - pos = 3, cex = 1.2 - ) - - - rect(.175, p_rect_ylim[1], .225, p_rect_ylim[1] + noise_p * diff(p_rect_ylim), - col = gray(.50, .25), border = NA - ) - - # Filltop: - segments(.175, p_rect_ylim[1] + noise_p * diff(p_rect_ylim), - .225, p_rect_ylim[1] + noise_p * diff(p_rect_ylim), - lwd = 1 - ) - - # Outline: - rect(.175, p_rect_ylim[1], .225, p_rect_ylim[2], - lwd = 1 - ) - - if (noise_p < .0001) { - noise_p_text <- "<0.01%" - } else { - noise_p_text <- paste(round(noise_p * 100, 0), "%", sep = "") - } - - text(.175, p_rect_ylim[1] + noise_p * diff(p_rect_ylim), - labels = noise_p_text, - pos = 2, cex = 1.2 - ) - } # if (show.top). + plot_level_bar(title = paste("p(", truth.labels[1], ")", sep = ""), + value = 1 - crit_br, + value_label = scales::percent(1 - crit_br), + max_value = 1, + rect_max_y = .6, + rect_min_y = .1, + rect_min_x = .175, + rect_max_x = .225, + label_pos = "left") + } # 2. Main TREE: ------ @@ -966,9 +838,6 @@ plot.FFTrees <- function(x = NULL, ylab = "", xlab = "" ) - - # Middle title: ---- - if (show.top | show.bottom) { if (hlines) { x_dev <- .28 # scaling factor, rather than difference @@ -992,8 +861,6 @@ plot.FFTrees <- function(x = NULL, } # if (show.top == FALSE & show.bottom == FALSE). - # Icon guide: ------ - if (show.iconguide) { # Parameters: if (what == "ico") { @@ -1462,7 +1329,6 @@ plot.FFTrees <- function(x = NULL, } # if (show.middle). - # 3. Cumulative performance: ---- if (show.bottom == TRUE) { # obtain tree statistics: @@ -2067,6 +1933,95 @@ plot.FFTrees <- function(x = NULL, return(invisible(x)) } # plot.FFTrees(). +plot_level_bar <- function(title = "", + value = NULL, + value_label = value, + max_value = 1, + rect_max_y = 1, + rect_min_y = 0, + rect_min_x = 0, + rect_max_x = 1, + title_cex = 1.2, + cex_label = 1.2, + col_outline = "black", + fill = "gray", + label_pos = "top", + reference_val = NULL, + reference_label = NULL, + outline = TRUE) { + rect_x_center <- (rect_max_x + rect_min_x) / 2 + rect_y_center <- (rect_max_y + rect_min_y) / 2 + + ## Title ================================================================ + + text( + x = rect_x_center, + y = rect_max_y, + labels = title, + pos = 3, + cex = title_cex + ) + + ## Filling ============================================================== + + rect( + xleft = rect_min_x, + xright = rect_max_x, + ybottom = rect_min_y, + ytop = rect_min_y + value / max_value * (rect_max_y - rect_min_y), + col = fill, + border = NA + ) + + ## Top of filling ======================================================= + + segments( + x0 = rect_min_x, + x1 = rect_max_x, + y0 = rect_min_y + value / max_value * (rect_max_y - rect_min_y), + y1 = rect_min_y + value / max_value * (rect_max_y - rect_min_y), + lwd = 1 + ) + + ## Outline ============================================================== + + if (outline) { + rect( + xleft = rect_min_x, + xright = rect_max_x, + ybottom = rect_min_y, + ytop = rect_max_y, + lwd = 1, + border = col_outline, + col = NULL + ) + } + + ## Value Text =========================================================== + + if (label_pos == "top") { + x_text <- rect_x_center + y_text <- rect_max_y + pos_label <- 3 + } else if (label_pos == "left") { + x_text <- rect_min_x + y_text <- rect_min_y + value / max_value * (rect_max_y - rect_min_y) + pos_label <- 2 + } else if (label_pos == "right") { + x_text <- rect_max_x + y_text <- rect_min_y + value / max_value * (rect_max_y - rect_min_y) + pos_label <- 4 + } + + text( + x = x_text, + y = y_text, + labels = value_label, + pos = pos_label, + cex = cex_label + ) +} + # ToDo: ------ From ddd5103e041425adb3cd2a914c781a27f26d99bc Mon Sep 17 00:00:00 2001 From: Nathaniel Phillips Date: Fri, 24 May 2024 07:59:22 -0400 Subject: [PATCH 03/12] replaced all level bars in plot.FFTrees() with new helper function --- R/plotFFTrees_function.R | 234 ++++++++++++++------------------------- R/util_plot.R | 154 -------------------------- 2 files changed, 86 insertions(+), 302 deletions(-) diff --git a/R/plotFFTrees_function.R b/R/plotFFTrees_function.R index 0f620c17..75ea425f 100644 --- a/R/plotFFTrees_function.R +++ b/R/plotFFTrees_function.R @@ -794,28 +794,31 @@ plot.FFTrees <- function(x = NULL, # (a) p_signal level (on right): ---- - plot_level_bar(title = paste("p(", truth.labels[2], ")", sep = ""), - value = crit_br, - value_label = scales::percent(crit_br), - max_value = 1, - rect_max_y = .6, - rect_min_y = .1, - rect_min_x = .775, - rect_max_x = .825, - label_pos = "right") + plot_level_bar( + title = paste("p(", truth.labels[2], ")", sep = ""), + value = crit_br, + value_label = scales::percent(crit_br), + max_value = 1, + rect_min_y = .1, + rect_max_y = .6, + rect_min_x = .775, + rect_max_x = .825, + label_pos = "right" + ) # (b) p_noise level (on left): ---- - plot_level_bar(title = paste("p(", truth.labels[1], ")", sep = ""), - value = 1 - crit_br, - value_label = scales::percent(1 - crit_br), - max_value = 1, - rect_max_y = .6, - rect_min_y = .1, - rect_min_x = .175, - rect_max_x = .225, - label_pos = "left") - + plot_level_bar( + title = paste("p(", truth.labels[1], ")", sep = ""), + value = 1 - crit_br, + value_label = scales::percent(1 - crit_br), + max_value = 1, + rect_min_y = .1, + rect_max_y = .6, + rect_min_x = .175, + rect_max_x = .225, + label_pos = "left" + ) } # 2. Main TREE: ------ @@ -1418,8 +1421,11 @@ plot.FFTrees <- function(x = NULL, pretty_dec(final_stats$acc), pretty_dec(bacc_wacc), NA ) ) - # print(lloc) # 4debugging + lloc$reference_val[lloc$element == "acc"] <- max(crit_br, 1 - crit_br) + lloc$reference_label[lloc$element == "acc"] <- "BL" + + # print(lloc) # 4debugging # Classification table: ---- @@ -1567,125 +1573,26 @@ plot.FFTrees <- function(x = NULL, # Levels: ---- if (show.levels) { - if (level.type %in% c("line", "bar")) { - # Color function (taken from colorRamp2 function in circlize package) - # col.fun <- circlize::colorRamp2(c(0, .75, 1), - # c("red", "yellow", "green"), - # transparency = .5) - - paste(final_stats$cr, "/", 1, collapse = "") - - # Add 100% reference line: ---- - - # segments(x0 = lloc$center_x[lloc$element == "mcu"] - lloc$width[lloc$element == "mcu"] * .8, - # y0 = level_top, - # x1 = lloc$center_x[lloc$element == "bacc"] + lloc$width[lloc$element == "bacc"] * .8, - # y1 = level_top, - # lty = 3, lwd = .75) - - - # mcu level: ---- - - add_level("mcu", - ok_val = .75, min_val = 0, max_val = 1, - level_type = level.type, lloc_row = lloc[lloc$element == "mcu", ], - header_y = header_y, header_cex = header_cex - ) # , sub = paste(c(final_stats$cr, "/", final_stats$cr + final_stats$fa), collapse = "")) - - - # pci level: ---- - - add_level("pci", - ok_val = .75, min_val = 0, max_val = 1, - level_type = level.type, lloc_row = lloc[lloc$element == "pci", ], - header_y = header_y, header_cex = header_cex - ) # , sub = paste(c(final_stats$cr, "/", final_stats$cr + final_stats$fa), collapse = "")) - - # text(lloc$center_x[lloc$element == "pci"], - # lloc$center_y[lloc$element == "pci"], - # labels = paste0("mcu\n", round(mcu, 2))) - - - # spec level: ---- - - add_level("spec", - ok_val = .75, min_val = 0, max_val = 1, - level_type = level.type, lloc_row = lloc[lloc$element == "spec", ], - header_y = header_y, header_cex = header_cex - ) # , sub = paste(c(final_stats$cr, "/", final_stats$cr + final_stats$fa), collapse = "")) - - - # sens level: ---- - - add_level("sens", - ok_val = .75, min_val = 0, max_val = 1, - level_type = level.type, lloc_row = lloc[lloc$element == "sens", ], - header_y = header_y, header_cex = header_cex - ) # , sub = paste(c(final_stats$hi, "/", final_stats$hi + final_stats$mi), collapse = "")) - - - # acc level: ---- - - min_acc <- max(crit_br, 1 - crit_br) # accuracy baseline - - add_level("acc", - ok_val = .50, min_val = 0, max_val = 1, - level_type = level.type, lloc_row = lloc[lloc$element == "acc", ], - header_y = header_y, header_cex = header_cex - ) # , sub = paste(c(final_stats$hi + final_stats$cr, "/", final_stats$n), collapse = "")) - - # Add baseline to acc level: - segments( - x0 = (lloc$center_x[lloc$element == "acc"] - lloc$width[lloc$element == "acc"] / 2), - y0 = (lloc$center_y[lloc$element == "acc"] - lloc$height[lloc$element == "acc"] / 2) + (lloc$height[lloc$element == "acc"] * min_acc), - x1 = (lloc$center_x[lloc$element == "acc"] + lloc$width[lloc$element == "acc"] / 2), - y1 = (lloc$center_y[lloc$element == "acc"] - lloc$height[lloc$element == "acc"] / 2) + (lloc$height[lloc$element == "acc"] * min_acc), - lty = 3 + for (element_i in c("mcu", "pci", "sens", "spec", "acc", "bacc")) { + plot_level_bar( + title = element_i, + value = lloc$value[lloc$element == element_i], + value_label = lloc$value_name[lloc$element == element_i], + max_value = 1, + y_title = .88, + cex_label = 1.5, + rect_min_y = .12, + rect_max_y = .78, + fill = "white", + y_reference = lloc$reference_val[lloc$element == element_i], + y_reference_label = lloc$reference_label[lloc$element == element_i], + rect_min_x = lloc$center_x[lloc$element == element_i] - lloc$width[lloc$element == element_i] / 2, + rect_max_x = lloc$center_x[lloc$element == element_i] + lloc$width[lloc$element == element_i] / 2, + label_pos = "top", + outline = FALSE ) - - text( - x = lloc$center_x[lloc$element == "acc"], - y = (lloc$center_y[lloc$element == "acc"] - lloc$height[lloc$element == "acc"] / 2) + lloc$height[lloc$element == "acc"] * min_acc, - labels = "BL", pos = 1 - ) - - # paste("BL = ", pretty_dec(min_acc), sep = ""), pos = 1) - - - # bacc OR wacc level: ---- - - if (names(bacc_wacc) == "bacc") { # show bacc level: - - add_level("bacc", - ok_val = .50, min_val = 0, max_val = 1, - level_type = level.type, lloc_row = lloc[lloc$element == "bacc", ], - header_y = header_y, header_cex = header_cex - ) - } else { # show wacc level (and sens.w value): - - sens.w_lbl <- paste0("sens.w = .", pretty_dec(sens.w)) - - add_level("wacc", - ok_val = .50, min_val = 0, max_val = 1, - level_type = level.type, lloc_row = lloc[lloc$element == "wacc", ], - header_y = header_y, - bottom_text = sens.w_lbl, # (only here) - header_cex = header_cex - ) - } # if (bacc_wacc). - - - # Add baseline (at bottom?): - # - # segments(x0 = mean(lloc$center_x[2]), - # y0 = lloc$center_y[1] - lloc$height[1] / 2, - # x1 = mean(lloc$center_x[7]), - # y1 = lloc$center_y[1] - lloc$height[1] / 2, lend = 1, - # lwd = .5, - # col = gray(0)) - } # if (level.type %in% c("line", "bar")). - } # if (show.levels). - + } + } # ROC curve: ----- @@ -1937,12 +1844,16 @@ plot_level_bar <- function(title = "", value = NULL, value_label = value, max_value = 1, + y_reference = NA, + y_reference_label = NULL, + cex_reference_label = 1, rect_max_y = 1, rect_min_y = 0, rect_min_x = 0, rect_max_x = 1, - title_cex = 1.2, + cex_title = 1.2, cex_label = 1.2, + y_title = rect_max_y, col_outline = "black", fill = "gray", label_pos = "top", @@ -1952,14 +1863,16 @@ plot_level_bar <- function(title = "", rect_x_center <- (rect_max_x + rect_min_x) / 2 rect_y_center <- (rect_max_y + rect_min_y) / 2 + y_scaled <- rect_min_y + value / max_value * (rect_max_y - rect_min_y) + ## Title ================================================================ text( x = rect_x_center, - y = rect_max_y, + y = y_title, labels = title, pos = 3, - cex = title_cex + cex = cex_title ) ## Filling ============================================================== @@ -1968,9 +1881,9 @@ plot_level_bar <- function(title = "", xleft = rect_min_x, xright = rect_max_x, ybottom = rect_min_y, - ytop = rect_min_y + value / max_value * (rect_max_y - rect_min_y), + ytop = y_scaled, col = fill, - border = NA + border = "black" ) ## Top of filling ======================================================= @@ -1978,8 +1891,8 @@ plot_level_bar <- function(title = "", segments( x0 = rect_min_x, x1 = rect_max_x, - y0 = rect_min_y + value / max_value * (rect_max_y - rect_min_y), - y1 = rect_min_y + value / max_value * (rect_max_y - rect_min_y), + y0 = y_scaled, + y1 = y_scaled, lwd = 1 ) @@ -1997,19 +1910,44 @@ plot_level_bar <- function(title = "", ) } + ## Reference Line ======================================================= + + if (!is.na(y_reference)) { + y_reference_scaled <- rect_min_y + y_reference / max_value * (rect_max_y - rect_min_y) + + segments( + x0 = rect_min_x, + x1 = rect_max_x, + y0 = y_reference_scaled, + y1 = y_reference_scaled, + lwd = 1, + lty = 3 + ) + + if (!is.null(y_reference_label)) { + text( + x = rect_x_center, + y = y_reference_scaled, + labels = y_reference_label, + pos = 1, + cex = cex_reference_label + ) + } + } + ## Value Text =========================================================== if (label_pos == "top") { x_text <- rect_x_center - y_text <- rect_max_y + y_text <- y_scaled pos_label <- 3 } else if (label_pos == "left") { x_text <- rect_min_x - y_text <- rect_min_y + value / max_value * (rect_max_y - rect_min_y) + y_text <- y_scaled pos_label <- 2 } else if (label_pos == "right") { x_text <- rect_max_x - y_text <- rect_min_y + value / max_value * (rect_max_y - rect_min_y) + y_text <- y_scaled pos_label <- 4 } diff --git a/R/util_plot.R b/R/util_plot.R index e4722fbe..6eae0534 100644 --- a/R/util_plot.R +++ b/R/util_plot.R @@ -450,160 +450,6 @@ get_x_dev <- function(string, csf = .80){ -# add_level: Add level display to a plot ---- - -# lloc_row: Data frame with labels, size values, and locations. - -add_level <- function(name, - sub = "", - ok_val = .5, - min_val = 0, - max_val = 1, - bottom_text = "", - level_type = "line", # user argument "level.type" set in plot() to default "bar". - # needed from plot: - lloc_row = NULL, # element == name row (of df) - header_y = NULL, - header_cex = NULL) { - - # Parameters: - rect_center_x <- lloc_row$center_x - rect_center_y <- lloc_row$center_y - - rect_height <- lloc_row$height - rect_width <- lloc_row$width - - rect_bottom_y <- rect_center_y - rect_height / 2 - rect_top_y <- rect_center_y + rect_height / 2 - - rect_left_x <- rect_center_x - rect_width / 2 - rect_right_x <- rect_center_x + rect_width / 2 - - long_name <- lloc_row$long_name - value <- lloc_row$value - value_name <- lloc_row$value_name - - # # Color gradient: - # level_col_fun <- circlize::colorRamp2(c(min_val, ok_val, max_val), - # colors = c("firebrick2", "yellow", "green4"), - # transparency = .1) - - - text(x = rect_center_x, y = header_y, - labels = long_name, pos = 1, cex = header_cex - ) - - # text_outline(x = rect_center_x, - # y = header.y.loc, - # labels = long_name, - # pos = 1, cex = header_cex, r = .02 - # ) - - value_height <- rect_bottom_y + min(c(1, ((value - min_val) / (max_val - min_val)))) * rect_height - - - # Add filling: ---- - - value_s <- min(value / max_val, 1) - - delta <- 1 - gamma <- .50 - - value_col_scale <- delta * value_s^gamma / (delta * value_s^gamma + (1 - value_s)^gamma) - # value_col <- gray(1 - value_col_scale * .5) - - value_col <- gray(1, .25) - - # plot(seq(0, 1, .01), delta * seq(0, 1, .01) ^ gamma / (delta * seq(0, 1, .01) ^ gamma + (1 - seq(0, 1, .01)) ^ gamma)) - - if (level_type == "bar") { - - rect(rect_left_x, - rect_bottom_y, - rect_right_x, - value_height, - # col = level_col_fun(value_s), - col = value_col, - # col = spec.level.fun(lloc_row$value), - border = "black" - ) - - text_outline( - x = rect_center_x, - y = value_height, - labels = lloc_row$value_name, - cex = 1.5, r = .008, pos = 3 - ) - - # Add level border: - - # rect(rect_left_x, - # rect_bottom_y, - # rect_right_x, - # rect_top_y, - # border = gray(.5, .5)) - } - - - if (level_type == "line") { - - # stem: - segments(rect_center_x, - rect_bottom_y, - rect_center_x, - value_height, - lty = 3 - ) - - # horizontal platform: - platform.width <- .02 - - segments( - rect_center_x - platform.width, - value_height, - rect_center_x + platform.width, - value_height - ) - - # text label: - text_outline( - x = rect_center_x, - y = value_height, - labels = lloc_row$value_name, - cex = 1.5, r = 0, pos = 3 - ) - - # points(rect_center_x, - # value_height, - # cex = 5.5, - # pch = 21, - # bg = "white", - # col = "black", lwd = .5) - } - - # Add subtext: ---- - - text( - x = rect_center_x, - y = rect_center_y - .05, - labels = sub, - cex = .8, - font = 1, - pos = 1 - ) - - # Add bottom text: ---- - - text( - x = rect_center_x, - y = rect_bottom_y, - labels = bottom_text, - pos = 1 - ) - -} # add_level(). - - # pretty_dec: Print pretty decimal values ---- pretty_dec <- function(x) { From a076e7175d67ebfe889b7d2d40fabfca094095ee Mon Sep 17 00:00:00 2001 From: Nathaniel Phillips Date: Fri, 24 May 2024 10:17:36 -0400 Subject: [PATCH 04/12] created plot_icon_arrays() function and replaced legacy code --- R/plotFFTrees_function.R | 175 ++++++++++++++++++++++++++++++++------- R/util_plot.R | 151 --------------------------------- 2 files changed, 146 insertions(+), 180 deletions(-) diff --git a/R/plotFFTrees_function.R b/R/plotFFTrees_function.R index 75ea425f..9158c736 100644 --- a/R/plotFFTrees_function.R +++ b/R/plotFFTrees_function.R @@ -756,18 +756,11 @@ plot.FFTrees <- function(x = NULL, # (b) label: text(x = .50, y = .96, main, cex = panel_title_cex, ...) # title 1 (top): main - - - # (a) N and labels: - text(x = .50, y = .78, paste("N = ", prettyNum(n_exemplars, big.mark = ","), "", sep = ""), cex = 1.25) # N - text(.50, .63, paste(truth.labels[1], sep = ""), pos = 2, cex = 1.2, adj = 1) # 1: False - text(.50, .63, paste(truth.labels[2], sep = ""), pos = 4, cex = 1.2, adj = 0) # 2: True - # (b) Show balls: n_true_pos <- with(final_stats, hi + mi) n_true_neg <- with(final_stats, fa + cr) - add_balls( + plot_icon_array( x_lim = c(.33, .67), y_lim = c(.12, .52), n_vec = c(n_true_neg, n_true_pos), @@ -775,21 +768,12 @@ plot.FFTrees <- function(x = NULL, bg_vec = c(noise_ball_bg, signal_ball_bg), col_vec = c(noise_ball_col, signal_ball_col), ball_cex = ball_cex, - upper_text_adj = 2, - n_per_icon = n.per.icon + n_per_icon = n.per.icon, + truth.labels = truth.labels, + show_truth_labels = TRUE, + show_exemplar_total = TRUE ) - # (c) n.per.icon legend 1 (top): - - # show_icon_guide_legend <- TRUE # 4debugging - - if (show_icon_guide_legend) { - text(.98, 0, labels = paste("Showing ", n.per.icon, " cases per icon:", sep = ""), pos = 2) - points(.98, 0, pch = noise_ball_pch, cex = ball_cex) - points(.99, 0, pch = signal_ball_pch, cex = ball_cex) - } # if (show_icon_guide_legend). - - par(xpd = FALSE) # (a) p_signal level (on right): ---- @@ -1023,7 +1007,6 @@ plot.FFTrees <- function(x = NULL, ) } # if (level_i == 1). - # Left (Noise) classification / New level: ---- # Exit node on 0 / FALSE / noise / left: ---- @@ -1081,8 +1064,9 @@ plot.FFTrees <- function(x = NULL, ) } + if ((max(c(cr_i, mi_i), na.rm = TRUE) > 0) & (show.icons == TRUE)) { - add_balls( + plot_icon_array( x_lim = ball_x_lim, y_lim = ball_y_lim, n_vec = c(cr_i, mi_i), @@ -1092,7 +1076,9 @@ plot.FFTrees <- function(x = NULL, bg_vec = c(col_correct_bg, col_error_bg), col_vec = c(col_correct_border, col_error_border), freq_text = TRUE, - n_per_icon = n.per.icon + n_per_icon = n.per.icon, + show_truth_labels = FALSE, + show_exemplar_total = FALSE ) } @@ -1221,7 +1207,7 @@ plot.FFTrees <- function(x = NULL, } if ((max(c(fa_i, hi_i), na.rm = TRUE) > 0) & (show.icons == TRUE)) { - add_balls( + plot_icon_array( x_lim = ball_x_lim, y_lim = ball_y_lim, n_vec = c(fa_i, hi_i), @@ -1231,7 +1217,8 @@ plot.FFTrees <- function(x = NULL, bg_vec = c(col_error_bg, col_correct_bg), col_vec = c(col_error_border, col_correct_border), freq_text = TRUE, - n_per_icon = n.per.icon + n_per_icon = n.per.icon, + show_truth_labels = FALSE, show_exemplar_total = FALSE ) } @@ -1263,7 +1250,6 @@ plot.FFTrees <- function(x = NULL, ) } # if (exit node on right). - # New level on 0 / FALSE / noise / left: ---- # if (level_stats$exit[level_i] %in% 0 | paste(level_stats$exit[level_i]) %in% c("0")) { @@ -1331,8 +1317,6 @@ plot.FFTrees <- function(x = NULL, } # for (level_i etc. loop. } # if (show.middle). - - if (show.bottom == TRUE) { # obtain tree statistics: fft_sens_vec <- tree_stats$sens @@ -1960,6 +1944,139 @@ plot_level_bar <- function(title = "", ) } +plot_icon_array <- function(x_lim = c(-10, 0), + y_lim = c(-2, 0), + n_vec = c(20, 10), + pch_vec = c(21, 21), + ball_cex = 1, + bg_vec = "white", + col_vec = "black", + ball_lwd = .70, + freq_text = TRUE, + freq_text_cex = 1.2, + # rev_order = FALSE, # is NOT used anywhere? + box_col = NULL, + box_bg = NULL, + n_per_icon = NULL, + show_legend = FALSE, + truth.labels = c("FALSE", "TRUE"), + show_truth_labels = TRUE, + show_exemplar_total = TRUE) { + par(xpd = TRUE) + + if (show_exemplar_total) { + text( + x = .50, y = .78, + paste("N = ", prettyNum(sum(n_vec), big.mark = ","), "", sep = ""), + cex = 1.25 + ) # N + } + + if (show_truth_labels) { + text(.50, .63, paste(truth.labels[1], sep = ""), pos = 2, cex = 1.2, adj = 1) # 1: False + text(.50, .63, paste(truth.labels[2], sep = ""), pos = 4, cex = 1.2, adj = 0) # 2: True + } + + # Add box: + if (is.null(box_col) == FALSE | is.null(box_bg) == FALSE) { + rect(x_lim[1], + y_lim[1], + x_lim[2], + y_lim[2], + col = box_bg, + border = box_col + ) + } + + a_n <- n_vec[1] + b_n <- n_vec[2] + + # a_p <- n_vec[1] / sum(n_vec) # is NOT used anywhere? + + box_x_center <- sum(x_lim) / 2 + # box_y_center <- sum(y_lim) / 2 # is NOT used anywhere? + # box_x_width <- x_lim[2] - x_lim[1] # is NOT used anywhere? + + + if (is.null(n_per_icon)) { # determine cases per ball/icon: + + max_n_side <- max(c(a_n, b_n)) + + i <- max_n_side / c(1, 5, 10, 50, 100, 1000, 10000) + i[i > 50] <- 0 + + n_per_icon <- c(1, 5, 10, 50, 100, 1000, 10000)[which(i == max(i))] + } + + # Determine general ball/icon locations: + + a_balls <- ceiling(a_n / n_per_icon) + b_balls <- ceiling(b_n / n_per_icon) + # n_balls <- a_balls + b_balls # is NOT used anywhere? + + a_ball_x <- 0 + a_ball_y <- 0 + b_ball_x <- 0 + b_ball_y <- 0 + + if (a_balls > 0) { + a_ball_x <- rep(-1:-10, each = 5, length.out = 50)[1:a_balls] + a_ball_y <- rep(1:5, times = 10, length.out = 50)[1:a_balls] + a_ball_x <- a_ball_x * (x_lim[2] - box_x_center) / 10 + box_x_center + a_ball_y <- a_ball_y * (y_lim[2] - y_lim[1]) / 5 + y_lim[1] + } + + if (b_balls > 0) { + b_ball_x <- rep(1:10, each = 5, length.out = 50)[1:b_balls] + b_ball_y <- rep(1:5, times = 10, length.out = 50)[1:b_balls] + b_ball_x <- b_ball_x * (x_lim[2] - box_x_center) / 10 + box_x_center + b_ball_y <- b_ball_y * (y_lim[2] - y_lim[1]) / 5 + y_lim[1] + } + + # Add frequency text: ---- + + if (freq_text) { + text(box_x_center, y_lim[1] - 1 * (y_lim[2] - y_lim[1]) / 5, prettyNum(b_n, big.mark = ","), pos = 4, cex = freq_text_cex) + text(box_x_center, y_lim[1] - 1 * (y_lim[2] - y_lim[1]) / 5, prettyNum(a_n, big.mark = ","), pos = 2, cex = freq_text_cex) + } + + # Draw balls: ---- + + # Noise: + suppressWarnings(if (a_balls > 0) { + points( + x = a_ball_x, + y = a_ball_y, + pch = pch_vec[1], + bg = bg_vec[1], + col = col_vec[1], + cex = ball_cex, + lwd = ball_lwd + ) + }) + + # Signal: + suppressWarnings(if (b_balls > 0) { + points( + x = b_ball_x, + y = b_ball_y, + pch = pch_vec[2], + bg = bg_vec[2], + col = col_vec[2], + cex = ball_cex, + lwd = ball_lwd + ) + }) + + if (show_legend) { + text(.98, 0, labels = paste("Showing ", n.per.icon, " cases per icon:", sep = ""), pos = 2) + points(.98, 0, pch = noise_ball_pch, cex = ball_cex) + points(.99, 0, pch = signal_ball_pch, cex = ball_cex) + } + + par(xpd = FALSE) +} # plot_icon_array(). + # ToDo: ------ diff --git a/R/util_plot.R b/R/util_plot.R index 6eae0534..fe3d8674 100644 --- a/R/util_plot.R +++ b/R/util_plot.R @@ -263,157 +263,6 @@ transparent <- function(col_orig = "red", - - -# (2) Specific functions for plot.FFTrees(): ------ - - - -# add_balls: Add balls/icon arrays to a plot ---- - -add_balls <- function(x_lim = c(-10, 0), - y_lim = c( -2, 0), - n_vec = c(20, 10), - pch_vec = c(21, 21), - ball_cex = 1, - bg_vec = "white", - col_vec = "black", - ball_lwd = .70, - freq_text = TRUE, - freq_text_cex = 1.2, - upper_text = "", - upper_text_cex = 1, - upper_text_adj = 0, - # rev_order = FALSE, # is NOT used anywhere? - box_col = NULL, - box_bg = NULL, - n_per_icon = NULL) { - - - par(xpd = TRUE) - - # Add box: - if (is.null(box_col) == FALSE | is.null(box_bg) == FALSE) { - - rect(x_lim[1], - y_lim[1], - x_lim[2], - y_lim[2], - col = box_bg, - border = box_col - ) - - } - - # Add upper text: - text(mean(x_lim), y_lim[2] + upper_text_adj, - label = upper_text, cex = upper_text_cex - ) - - a_n <- n_vec[1] - b_n <- n_vec[2] - - # a_p <- n_vec[1] / sum(n_vec) # is NOT used anywhere? - - box_x_center <- sum(x_lim) / 2 - # box_y_center <- sum(y_lim) / 2 # is NOT used anywhere? - # box_x_width <- x_lim[2] - x_lim[1] # is NOT used anywhere? - - - if (is.null(n_per_icon)) { # determine cases per ball/icon: - - max_n_side <- max(c(a_n, b_n)) - - i <- max_n_side / c(1, 5, 10, 50, 100, 1000, 10000) - i[i > 50] <- 0 - - n_per_icon <- c(1, 5, 10, 50, 100, 1000, 10000)[which(i == max(i))] - - } - - # Determine general ball/icon locations: - - a_balls <- ceiling(a_n / n_per_icon) - b_balls <- ceiling(b_n / n_per_icon) - # n_balls <- a_balls + b_balls # is NOT used anywhere? - - a_ball_x <- 0 - a_ball_y <- 0 - b_ball_x <- 0 - b_ball_y <- 0 - - if (a_balls > 0) { - - a_ball_x <- rep(-1:-10, each = 5, length.out = 50)[1:a_balls] - a_ball_y <- rep(1:5, times = 10, length.out = 50)[1:a_balls] - a_ball_x <- a_ball_x * (x_lim[2] - box_x_center) / 10 + box_x_center - a_ball_y <- a_ball_y * (y_lim[2] - y_lim[1]) / 5 + y_lim[1] - - } - - if (b_balls > 0) { - - b_ball_x <- rep(1:10, each = 5, length.out = 50)[1:b_balls] - b_ball_y <- rep(1:5, times = 10, length.out = 50)[1:b_balls] - b_ball_x <- b_ball_x * (x_lim[2] - box_x_center) / 10 + box_x_center - b_ball_y <- b_ball_y * (y_lim[2] - y_lim[1]) / 5 + y_lim[1] - - } - - # if(rev_order) { - # - # x <- b_ball_x - # y <- b_ball_y - # - # b_ball_x <- a.x.loc - # b_ball_y <- a.y.loc - # - # a_ball_x <- x - # a_ball_y <- y - # - # } - - - # Add frequency text: ---- - - if (freq_text) { - text(box_x_center, y_lim[1] - 1 * (y_lim[2] - y_lim[1]) / 5, prettyNum(b_n, big.mark = ","), pos = 4, cex = freq_text_cex) - text(box_x_center, y_lim[1] - 1 * (y_lim[2] - y_lim[1]) / 5, prettyNum(a_n, big.mark = ","), pos = 2, cex = freq_text_cex) - } - - # Draw balls: ---- - - # Noise: - suppressWarnings(if (a_balls > 0) { - points( - x = a_ball_x, - y = a_ball_y, - pch = pch_vec[1], - bg = bg_vec[1], - col = col_vec[1], - cex = ball_cex, - lwd = ball_lwd - ) - }) - - # Signal: - suppressWarnings(if (b_balls > 0) { - points( - x = b_ball_x, - y = b_ball_y, - pch = pch_vec[2], - bg = bg_vec[2], - col = col_vec[2], - cex = ball_cex, - lwd = ball_lwd - ) - }) - - par(xpd = FALSE) - -} # add_balls(). - - # get_x_dev: Adjust rectangle width of main title(s) ---- get_x_dev <- function(string, csf = .80){ From a340509220c8dc7c3d3af63b9953721bfbf2120f Mon Sep 17 00:00:00 2001 From: Nathaniel Phillips Date: Fri, 24 May 2024 12:21:42 -0400 Subject: [PATCH 05/12] created plot_fft() and used in plot.FFTrees() --- R/plotFFTrees_function.R | 766 +++++++++++++++++++++------------------ 1 file changed, 405 insertions(+), 361 deletions(-) diff --git a/R/plotFFTrees_function.R b/R/plotFFTrees_function.R index 9158c736..8b164ce6 100644 --- a/R/plotFFTrees_function.R +++ b/R/plotFFTrees_function.R @@ -579,8 +579,6 @@ plot.FFTrees <- function(x = NULL, # def_par <- par(no.readonly = TRUE) # is NOT used anywhere? ball_box_width <- 10 - label_box_height <- 2 - label_box_width <- 5 # Cue labels: if (is.null(cue.labels)) { @@ -963,358 +961,19 @@ plot.FFTrees <- function(x = NULL, par(xpd = FALSE) - # Plot main TREE: ------ - # Set initial subplot center: - subplot_center <- c(0, -4) - - # Loop over levels: ------ - for (level_i in 1:min(c(n_levels, 6))) { - # Cue label: - cur_cue <- cue.labels[level_i] - - # Get stats for current level: - hi_i <- level_stats$hi_m[level_i] - fa_i <- level_stats$fa_m[level_i] - mi_i <- level_stats$mi_m[level_i] - cr_i <- level_stats$cr_m[level_i] - - - # Top: If level_i == 1, draw top textbox: ---- - - if (level_i == 1) { - rect(subplot_center[1] - label_box_width / 2, - subplot_center[2] + 2 - label_box_height / 2, - subplot_center[1] + label_box_width / 2, - subplot_center[2] + 2 + label_box_height / 2, - col = "white", - border = "black" - ) - - points( - x = subplot_center[1], - y = subplot_center[2] + 2, - cex = decision_node_cex, - pch = decision_node_pch - ) - - text( - x = subplot_center[1], - y = subplot_center[2] + 2, - labels = cur_cue, - cex = label_box_text_cex # WAS: get_label_cex(cur_cue, label_box_text_cex = label_box_text_cex) - ) - } # if (level_i == 1). - - # Left (Noise) classification / New level: ---- - - # Exit node on 0 / FALSE / noise / left: ---- - - # if (level_stats$exit[level_i] %in% c(0, .5) | paste(level_stats$exit[level_i]) %in% c("0", ".5")) { - if ((level_stats$exit[level_i] %in% exit_types[c(1, 3)]) | (paste(level_stats$exit[level_i]) %in% paste(exit_types[c(1, 3)], collapse = ", "))) { - segments(subplot_center[1], - subplot_center[2] + 1, - subplot_center[1] - 2, - subplot_center[2] - 2, - lty = segment_lty, - lwd = segment_lwd - ) - - arrows( - x0 = subplot_center[1] - 2, - y0 = subplot_center[2] - 2, - x1 = subplot_center[1] - 2 - arrow_length, - y1 = subplot_center[2] - 2, - lty = arrow_lty, - lwd = arrow_lwd, - col = arrow_col, - length = arrow_head_length - ) - - # Decision text: - - if (decision.cex > 0) { - text( - x = subplot_center[1] - 2 - arrow_length * .7, - y = subplot_center[2] - 2.2, - labels = decision.labels[1], - pos = 1, font = 3, cex = decision.cex - ) - } - - if (ball_loc == "fixed") { - ball_x_lim <- c(-max(ball_box_fixed_x_shift), -min(ball_box_fixed_x_shift)) - - ball_y_lim <- c( - subplot_center[2] + ball_box_vert_shift - ball_box_height / 2, - subplot_center[2] + ball_box_vert_shift + ball_box_height / 2 - ) - } - - if (ball_loc == "variable") { - ball_x_lim <- c( - subplot_center[1] - ball_box_horiz_shift - ball_box_width / 2, - subplot_center[1] - ball_box_horiz_shift + ball_box_width / 2 - ) - - ball_y_lim <- c( - subplot_center[2] + ball_box_vert_shift - ball_box_height / 2, - subplot_center[2] + ball_box_vert_shift + ball_box_height / 2 - ) - } - - - if ((max(c(cr_i, mi_i), na.rm = TRUE) > 0) & (show.icons == TRUE)) { - plot_icon_array( - x_lim = ball_x_lim, - y_lim = ball_y_lim, - n_vec = c(cr_i, mi_i), - pch_vec = c(noise_ball_pch, signal_ball_pch), - ball_cex = ball_cex, - # bg_vec = c(noise_ball_bg, signal_ball_bg), - bg_vec = c(col_correct_bg, col_error_bg), - col_vec = c(col_correct_border, col_error_border), - freq_text = TRUE, - n_per_icon = n.per.icon, - show_truth_labels = FALSE, - show_exemplar_total = FALSE - ) - } - - # level break label: - pos_dir_symbol <- c("<=", "<", "=", "!=", ">", ">=")[which(level_stats$direction[level_i] == c(">", ">=", "!=", "=", "<=", "<"))] - neg_dir_symbol <- c("<=", "<", "=", "!=", ">", ">=")[which(level_stats$direction[level_i] == c("<=", "<", "=", "!=", ">", ">="))] - - text_outline( - x = subplot_center[1] - 1, - y = subplot_center[2], - labels = paste(pos_dir_symbol, " ", level_stats$threshold[level_i], sep = ""), - pos = 2, cex = break_label_cex, r = .1 - ) - - points( - x = subplot_center[1] - 2, - y = subplot_center[2] - 2, - pch = exit_node_pch, - cex = exit_node_cex, - bg = col_exit_node_bg - ) - - text( - x = subplot_center[1] - 2, - y = subplot_center[2] - 2, - labels = substr(decision.labels[1], 1, 1) - ) - } # if (exit node on left). - - - # New level on 1 / TRUE / signal / right: ---- - - # if ((level_stats$exit[level_i] %in% c(1)) | (paste(level_stats$exit[level_i]) %in% c("1"))) { - if ((level_stats$exit[level_i] %in% exit_types[c(2)]) | (paste(level_stats$exit[level_i]) %in% paste(exit_types[c(2)], collapse = ", "))) { - segments(subplot_center[1], - subplot_center[2] + 1, - subplot_center[1] - 2, - subplot_center[2] - 2, - lty = segment_lty, - lwd = segment_lwd - ) - - rect(subplot_center[1] - 2 - label_box_width / 2, - subplot_center[2] - 2 - label_box_height / 2, - subplot_center[1] - 2 + label_box_width / 2, - subplot_center[2] - 2 + label_box_height / 2, - col = "white", - border = "black" - ) - - if (level_i < 6) { - text( - x = subplot_center[1] - 2, - y = subplot_center[2] - 2, - labels = cue.labels[level_i + 1], - cex = label_box_text_cex - ) - } else { - text( - x = subplot_center[1] - 2, - y = subplot_center[2] - 2, - labels = paste0("+ ", n_levels - 6, " More"), - cex = label_box_text_cex, - font = 3 - ) - } - } # if (new level on right). - - - # Right (Signal) classification / New level: ---- - - # Exit node on 1 / TRUE / signal / right: ---- - - # if ((level_stats$exit[level_i] %in% c(1, .5)) | (paste(level_stats$exit[level_i]) %in% c("1", ".5"))) { - if ((level_stats$exit[level_i] %in% exit_types[c(2, 3)]) | (paste(level_stats$exit[level_i]) %in% paste(exit_types[c(2, 3)], collapse = ", "))) { - segments(subplot_center[1], - subplot_center[2] + 1, - subplot_center[1] + 2, - subplot_center[2] - 2, - lty = segment_lty, - lwd = segment_lwd - ) - - arrows( - x0 = subplot_center[1] + 2, - y0 = subplot_center[2] - 2, - x1 = subplot_center[1] + 2 + arrow_length, - y1 = subplot_center[2] - 2, - lty = arrow_lty, - lwd = arrow_lwd, - col = arrow_col, - length = arrow_head_length - ) - - # Decision text: - - if (decision.cex > 0) { - text( - x = subplot_center[1] + 2 + arrow_length * .7, - y = subplot_center[2] - 2.2, - labels = decision.labels[2], - pos = 1, - font = 3, - cex = decision.cex - ) - } - - if (ball_loc == "fixed") { - ball_x_lim <- c(min(ball_box_fixed_x_shift), max(ball_box_fixed_x_shift)) - ball_y_lim <- c( - subplot_center[2] + ball_box_vert_shift - ball_box_height / 2, - subplot_center[2] + ball_box_vert_shift + ball_box_height / 2 - ) - } - - if (ball_loc == "variable") { - ball_x_lim <- c( - subplot_center[1] + ball_box_horiz_shift - ball_box_width / 2, - subplot_center[1] + ball_box_horiz_shift + ball_box_width / 2 - ) - - ball_y_lim <- c( - subplot_center[2] + ball_box_vert_shift - ball_box_height / 2, - subplot_center[2] + ball_box_vert_shift + ball_box_height / 2 - ) - } - - if ((max(c(fa_i, hi_i), na.rm = TRUE) > 0) & (show.icons == TRUE)) { - plot_icon_array( - x_lim = ball_x_lim, - y_lim = ball_y_lim, - n_vec = c(fa_i, hi_i), - pch_vec = c(noise_ball_pch, signal_ball_pch), - ball_cex = ball_cex, - # bg_vec = c(noise_ball_bg, signal_ball_bg), - bg_vec = c(col_error_bg, col_correct_bg), - col_vec = c(col_error_border, col_correct_border), - freq_text = TRUE, - n_per_icon = n.per.icon, - show_truth_labels = FALSE, show_exemplar_total = FALSE - ) - } - - # level break label: - dir_symbol <- c("<=", "<", "=", "!=", ">", ">=") # as (local) constant - - pos_dir_symbol <- dir_symbol[which(level_stats$direction[level_i] == c("<=", "<", "=", "!=", ">", ">="))] - neg_dir_symbol <- dir_symbol[which(level_stats$direction[level_i] == rev(c("<=", "<", "=", "!=", ">", ">=")))] - - - text_outline(subplot_center[1] + 1, - subplot_center[2], - labels = paste(pos_dir_symbol, " ", level_stats$threshold[level_i], sep = ""), - pos = 4, cex = break_label_cex, r = .1 - ) - - points( - x = subplot_center[1] + 2, - y = subplot_center[2] - 2, - pch = exit_node_pch, - cex = exit_node_cex, - bg = col_exit_node_bg - ) - - text( - x = subplot_center[1] + 2, - y = subplot_center[2] - 2, - labels = substr(decision.labels[2], 1, 1) - ) - } # if (exit node on right). - - # New level on 0 / FALSE / noise / left: ---- - - # if (level_stats$exit[level_i] %in% 0 | paste(level_stats$exit[level_i]) %in% c("0")) { - if ((level_stats$exit[level_i] %in% exit_types[c(1)]) | (paste(level_stats$exit[level_i]) %in% paste(exit_types[c(1)], collapse = ", "))) { - segments(subplot_center[1], - subplot_center[2] + 1, - subplot_center[1] + 2, - subplot_center[2] - 2, - lty = segment_lty, - lwd = segment_lwd - ) - - if (level_i < 6) { - rect(subplot_center[1] + 2 - label_box_width / 2, - subplot_center[2] - 2 - label_box_height / 2, - subplot_center[1] + 2 + label_box_width / 2, - subplot_center[2] - 2 + label_box_height / 2, - col = "white", - border = "black" - ) - - text( - x = subplot_center[1] + 2, - y = subplot_center[2] - 2, - labels = cue.labels[level_i + 1], - cex = label_box_text_cex - ) - } else { - rect(subplot_center[1] + 2 - label_box_width / 2, - subplot_center[2] - 2 - label_box_height / 2, - subplot_center[1] + 2 + label_box_width / 2, - subplot_center[2] - 2 + label_box_height / 2, - col = "white", - border = "black", lty = 2 - ) - - text( - x = subplot_center[1] + 2, - y = subplot_center[2] - 2, - labels = paste0("+ ", n_levels - 6, " More"), - cex = label_box_text_cex, - font = 3 - ) - } - } # if (new level on right). - - - # Update plot center: ---- - - # if (identical(paste(level_stats$exit[level_i]), "0")) { # 0 / FALSE / noise / left: - if (identical(paste(level_stats$exit[level_i]), paste0(exit_types[1]))) { - subplot_center <- c( - subplot_center[1] + 2, - subplot_center[2] - 4 - ) - } # if (identical exit 0 / left etc. - - # if (identical(paste(level_stats$exit[level_i]), "1")) { # 1 / TRUE / signal / right: - if (identical(paste(level_stats$exit[level_i]), paste0(exit_types[2]))) { - subplot_center <- c( - subplot_center[1] - 2, - subplot_center[2] - 4 - ) - } # if (identical exit 1 / right etc. - } # for (level_i etc. loop. + plot_fft( + level_stats = level_stats, + cue.cex = cue.cex, + threshold.cex = threshold.cex, + decision.cex = decision.cex, + decision.labels = decision.labels, + ball_loc = ball_loc, + show.icons = show.icons, + n.per.icon = n.per.icon, + grayscale = grayscale + ) } # if (show.middle). if (show.bottom == TRUE) { # obtain tree statistics: @@ -2075,19 +1734,404 @@ plot_icon_array <- function(x_lim = c(-10, 0), } par(xpd = FALSE) -} # plot_icon_array(). +} + +plot_fft <- function(level_stats, + cue.cex = NULL, + threshold.cex = NULL, + decision.cex = NULL, + decision.labels = NULL, + ball_loc = "variable", + show.icons = TRUE, + n.per.icon = NULL, + grayscale = FALSE) { + subplot_center <- c(0, -4) + label_box_height <- 2 + label_box_width <- 5 + f_cex <- 1 + segment_lty <- 1 + segment_lwd <- 1 + arrow_lty <- 1 + arrow_lwd <- 1 + arrow_length <- 2.50 + arrow_head_length <- .08 + arrow_col <- gray(0) # = black + decision_node_pch <- NA_integer_ + decision_node_cex <- 4 * f_cex + exit_node_cex <- 4 * f_cex + ball_box_height <- 2.5 + ball_box_horiz_shift <- 10 + ball_box_vert_shift <- -1 + ball_box_max_shift_p <- .9 + ball_box_min_shift_p <- .4 + ball_box_width <- 10 + col_exit_node_bg <- "white" + + ball_col <- c(gray(0), gray(0)) # = black + ball_bg <- c(gray(1), gray(1)) # = white + ball_pch <- c(21, 24) + ball_cex <- c(1, 1) + + noise_ball_pch <- ball_pch[1] + signal_ball_pch <- ball_pch[2] + noise_ball_col <- ball_col[1] + signal_ball_col <- ball_col[2] + noise_ball_bg <- ball_bg[1] + signal_ball_bg <- ball_bg[2] + exit_node_pch <- 21 + + if (!grayscale) { + col_error_bg <- "#FF7352CC" + col_error_border <- "#AD1A0AE6" + col_correct_bg <- "#89FF6FCC" + col_correct_border <- "#24AB18E6" + } else { + # Grayscale colors + + col_error_bg <- gray(.1) + col_error_border <- gray(0) + col_correct_bg <- gray(1) + col_correct_border <- gray(0) + } + + plotting_parameters_df <- data.frame( + n_levels = 1:6, + plot_height = c(10, 12, 15, 19, 23, 25), + plot_width = c(14, 16, 20, 24, 28, 32) * 1, # stretch to default width + label_box_text_cex = cue.cex, + break_label_cex = threshold.cex + ) + + n_levels <- nrow(level_stats) + + + # local variables: + if (n_levels < 6) { + label_box_text_cex <- plotting_parameters_df$label_box_text_cex[n_levels] + break_label_cex <- plotting_parameters_df$break_label_cex[n_levels] + plot_height <- plotting_parameters_df$plot_height[n_levels] + plot_width <- plotting_parameters_df$plot_width[n_levels] + } else { # n_levels >= 6: + + label_box_text_cex <- plotting_parameters_df$label_box_text_cex[6] + break_label_cex <- plotting_parameters_df$break_label_cex[6] + plot_height <- plotting_parameters_df$plot_height[6] + plot_width <- plotting_parameters_df$plot_width[6] + } + + cue.labels <- level_stats$cue + + for (level_i in 1:min(c(n_levels, 6))) { + cur_cue <- cue.labels[level_i] + + hi_i <- level_stats$hi_m[level_i] + fa_i <- level_stats$fa_m[level_i] + mi_i <- level_stats$mi_m[level_i] + cr_i <- level_stats$cr_m[level_i] + + + if (level_i == 1) { + rect(subplot_center[1] - label_box_width / 2, + subplot_center[2] + 2 - label_box_height / 2, + subplot_center[1] + label_box_width / 2, + subplot_center[2] + 2 + label_box_height / 2, + col = "white", + border = "black" + ) + + points( + x = subplot_center[1], + y = subplot_center[2] + 2, + cex = decision_node_cex, + pch = decision_node_pch + ) + + text( + x = subplot_center[1], + y = subplot_center[2] + 2, + labels = cur_cue, + cex = label_box_text_cex # WAS: get_label_cex(cur_cue, label_box_text_cex = label_box_text_cex) + ) + } + + if ((level_stats$exit[level_i] %in% exit_types[c(1, 3)]) | (paste(level_stats$exit[level_i]) %in% paste(exit_types[c(1, 3)], collapse = ", "))) { + segments(subplot_center[1], + subplot_center[2] + 1, + subplot_center[1] - 2, + subplot_center[2] - 2, + lty = segment_lty, + lwd = segment_lwd + ) + + arrows( + x0 = subplot_center[1] - 2, + y0 = subplot_center[2] - 2, + x1 = subplot_center[1] - 2 - arrow_length, + y1 = subplot_center[2] - 2, + lty = arrow_lty, + lwd = arrow_lwd, + col = arrow_col, + length = arrow_head_length + ) + + if (decision.cex > 0) { + text( + x = subplot_center[1] - 2 - arrow_length * .7, + y = subplot_center[2] - 2.2, + labels = decision.labels[1], + pos = 1, font = 3, cex = decision.cex + ) + } + + if (ball_loc == "fixed") { + ball_x_lim <- c(-max(ball_box_fixed_x_shift), -min(ball_box_fixed_x_shift)) + + ball_y_lim <- c( + subplot_center[2] + ball_box_vert_shift - ball_box_height / 2, + subplot_center[2] + ball_box_vert_shift + ball_box_height / 2 + ) + } + + if (ball_loc == "variable") { + ball_x_lim <- c( + subplot_center[1] - ball_box_horiz_shift - ball_box_width / 2, + subplot_center[1] - ball_box_horiz_shift + ball_box_width / 2 + ) + + ball_y_lim <- c( + subplot_center[2] + ball_box_vert_shift - ball_box_height / 2, + subplot_center[2] + ball_box_vert_shift + ball_box_height / 2 + ) + } + if ((max(c(cr_i, mi_i), na.rm = TRUE) > 0) & (show.icons == TRUE)) { + plot_icon_array( + x_lim = ball_x_lim, + y_lim = ball_y_lim, + n_vec = c(cr_i, mi_i), + pch_vec = c(noise_ball_pch, signal_ball_pch), + ball_cex = ball_cex, + bg_vec = c(col_correct_bg, col_error_bg), + col_vec = c(col_correct_border, col_error_border), + freq_text = TRUE, + n_per_icon = n.per.icon, + show_truth_labels = FALSE, + show_exemplar_total = FALSE + ) + } -# ToDo: ------ + pos_dir_symbol <- c("<=", "<", "=", "!=", ">", ">=")[which(level_stats$direction[level_i] == c(">", ">=", "!=", "=", "<=", "<"))] + neg_dir_symbol <- c("<=", "<", "=", "!=", ">", ">=")[which(level_stats$direction[level_i] == c("<=", "<", "=", "!=", ">", ">="))] -# - Further cleanup & clutter reduction: -# - Remove ROC curve parts to a separate function, and -# handle what == "roc" as a special case (like what = "cues"). + text_outline( + x = subplot_center[1] - 1, + y = subplot_center[2], + labels = paste(pos_dir_symbol, " ", level_stats$threshold[level_i], sep = ""), + pos = 2, cex = break_label_cex, r = .1 + ) -# - Issue #91: Allow data to accept new test data (as df). -# Suggestion: Use a 'newdata' argument for this purpose, as in predict().) + points( + x = subplot_center[1] - 2, + y = subplot_center[2] - 2, + pch = exit_node_pch, + cex = exit_node_cex, + bg = col_exit_node_bg + ) -# - Offer options for adding/changing color information. + text( + x = subplot_center[1] - 2, + y = subplot_center[2] - 2, + labels = substr(decision.labels[1], 1, 1) + ) + } # if (exit node on left). + + if ((level_stats$exit[level_i] %in% exit_types[c(2)]) | (paste(level_stats$exit[level_i]) %in% paste(exit_types[c(2)], collapse = ", "))) { + segments(subplot_center[1], + subplot_center[2] + 1, + subplot_center[1] - 2, + subplot_center[2] - 2, + lty = segment_lty, + lwd = segment_lwd + ) -# eof. + rect(subplot_center[1] - 2 - label_box_width / 2, + subplot_center[2] - 2 - label_box_height / 2, + subplot_center[1] - 2 + label_box_width / 2, + subplot_center[2] - 2 + label_box_height / 2, + col = "white", + border = "black" + ) + + if (level_i < 6) { + text( + x = subplot_center[1] - 2, + y = subplot_center[2] - 2, + labels = cue.labels[level_i + 1], + cex = label_box_text_cex + ) + } else { + text( + x = subplot_center[1] - 2, + y = subplot_center[2] - 2, + labels = paste0("+ ", n_levels - 6, " More"), + cex = label_box_text_cex, + font = 3 + ) + } + } # if (new level on right). + + + if ((level_stats$exit[level_i] %in% exit_types[c(2, 3)]) | (paste(level_stats$exit[level_i]) %in% paste(exit_types[c(2, 3)], collapse = ", "))) { + segments(subplot_center[1], + subplot_center[2] + 1, + subplot_center[1] + 2, + subplot_center[2] - 2, + lty = segment_lty, + lwd = segment_lwd + ) + + arrows( + x0 = subplot_center[1] + 2, + y0 = subplot_center[2] - 2, + x1 = subplot_center[1] + 2 + arrow_length, + y1 = subplot_center[2] - 2, + lty = arrow_lty, + lwd = arrow_lwd, + col = arrow_col, + length = arrow_head_length + ) + + if (decision.cex > 0) { + text( + x = subplot_center[1] + 2 + arrow_length * .7, + y = subplot_center[2] - 2.2, + labels = decision.labels[2], + pos = 1, + font = 3, + cex = decision.cex + ) + } + + if (ball_loc == "fixed") { + ball_x_lim <- c(min(ball_box_fixed_x_shift), max(ball_box_fixed_x_shift)) + ball_y_lim <- c( + subplot_center[2] + ball_box_vert_shift - ball_box_height / 2, + subplot_center[2] + ball_box_vert_shift + ball_box_height / 2 + ) + } + + if (ball_loc == "variable") { + ball_x_lim <- c( + subplot_center[1] + ball_box_horiz_shift - ball_box_width / 2, + subplot_center[1] + ball_box_horiz_shift + ball_box_width / 2 + ) + + ball_y_lim <- c( + subplot_center[2] + ball_box_vert_shift - ball_box_height / 2, + subplot_center[2] + ball_box_vert_shift + ball_box_height / 2 + ) + } + + if ((max(c(fa_i, hi_i), na.rm = TRUE) > 0) & (show.icons == TRUE)) { + plot_icon_array( + x_lim = ball_x_lim, + y_lim = ball_y_lim, + n_vec = c(fa_i, hi_i), + pch_vec = c(noise_ball_pch, signal_ball_pch), + ball_cex = ball_cex, + # bg_vec = c(noise_ball_bg, signal_ball_bg), + bg_vec = c(col_error_bg, col_correct_bg), + col_vec = c(col_error_border, col_correct_border), + freq_text = TRUE, + n_per_icon = n.per.icon, + show_truth_labels = FALSE, show_exemplar_total = FALSE + ) + } + + dir_symbol <- c("<=", "<", "=", "!=", ">", ">=") # as (local) constant + + pos_dir_symbol <- dir_symbol[which(level_stats$direction[level_i] == c("<=", "<", "=", "!=", ">", ">="))] + neg_dir_symbol <- dir_symbol[which(level_stats$direction[level_i] == rev(c("<=", "<", "=", "!=", ">", ">=")))] + + + text_outline(subplot_center[1] + 1, + subplot_center[2], + labels = paste(pos_dir_symbol, " ", level_stats$threshold[level_i], sep = ""), + pos = 4, cex = break_label_cex, r = .1 + ) + + points( + x = subplot_center[1] + 2, + y = subplot_center[2] - 2, + pch = exit_node_pch, + cex = exit_node_cex, + bg = col_exit_node_bg + ) + + text( + x = subplot_center[1] + 2, + y = subplot_center[2] - 2, + labels = substr(decision.labels[2], 1, 1) + ) + } # if (exit node on right). + + + if ((level_stats$exit[level_i] %in% exit_types[c(1)]) | (paste(level_stats$exit[level_i]) %in% paste(exit_types[c(1)], collapse = ", "))) { + segments(subplot_center[1], + subplot_center[2] + 1, + subplot_center[1] + 2, + subplot_center[2] - 2, + lty = segment_lty, + lwd = segment_lwd + ) + + if (level_i < 6) { + rect(subplot_center[1] + 2 - label_box_width / 2, + subplot_center[2] - 2 - label_box_height / 2, + subplot_center[1] + 2 + label_box_width / 2, + subplot_center[2] - 2 + label_box_height / 2, + col = "white", + border = "black" + ) + + text( + x = subplot_center[1] + 2, + y = subplot_center[2] - 2, + labels = cue.labels[level_i + 1], + cex = label_box_text_cex + ) + } else { + rect(subplot_center[1] + 2 - label_box_width / 2, + subplot_center[2] - 2 - label_box_height / 2, + subplot_center[1] + 2 + label_box_width / 2, + subplot_center[2] - 2 + label_box_height / 2, + col = "white", + border = "black", lty = 2 + ) + + text( + x = subplot_center[1] + 2, + y = subplot_center[2] - 2, + labels = paste0("+ ", n_levels - 6, " More"), + cex = label_box_text_cex, + font = 3 + ) + } + } # if (new level on right). + + if (identical(paste(level_stats$exit[level_i]), paste0(exit_types[1]))) { + subplot_center <- c( + subplot_center[1] + 2, + subplot_center[2] - 4 + ) + } # if (identical exit 0 / left etc. + + if (identical(paste(level_stats$exit[level_i]), paste0(exit_types[2]))) { + subplot_center <- c( + subplot_center[1] - 2, + subplot_center[2] - 4 + ) + } # if (identical exit 1 / right etc. + } # for (level_i etc. loop. +} From 691dcdd32bf39cf3cc56f44830572b0b524b9875 Mon Sep 17 00:00:00 2001 From: Nathaniel Phillips Date: Fri, 24 May 2024 12:35:15 -0400 Subject: [PATCH 06/12] created plot_confusion() --- R/plotFFTrees_function.R | 304 +++++++++++++++++++++------------------ 1 file changed, 164 insertions(+), 140 deletions(-) diff --git a/R/plotFFTrees_function.R b/R/plotFFTrees_function.R index 8b164ce6..05a99325 100644 --- a/R/plotFFTrees_function.R +++ b/R/plotFFTrees_function.R @@ -1072,146 +1072,17 @@ plot.FFTrees <- function(x = NULL, # Classification table: ---- - if (show.confusion) { - # Parameters: - classtable_lwd <- 1 - - # x/y coordinates: - final_classtable_x <- c(lloc$center_x[lloc$element == "classtable"] - lloc$width[lloc$element == "classtable"] / 2, lloc$center_x[lloc$element == "classtable"] + lloc$width[lloc$element == "classtable"] / 2) - final_classtable_y <- c(lloc$center_y[lloc$element == "classtable"] - lloc$height[lloc$element == "classtable"] / 2, lloc$center_y[lloc$element == "classtable"] + lloc$height[lloc$element == "classtable"] / 2) - - rect(final_classtable_x[1], final_classtable_y[1], - final_classtable_x[2], final_classtable_y[2], - lwd = classtable_lwd - ) - - segments(mean(final_classtable_x), final_classtable_y[1], mean(final_classtable_x), final_classtable_y[2], col = gray(0), lwd = classtable_lwd) - segments(final_classtable_x[1], mean(final_classtable_y), final_classtable_x[2], mean(final_classtable_y), col = gray(0), lwd = classtable_lwd) - - - # Column titles: ---- - - text( - x = mean(mean(final_classtable_x)), - y = header_y, - "Truth", pos = 1, cex = header_cex - ) - - text( - x = final_classtable_x[1] + .25 * diff(final_classtable_x), - y = subheader_y, pos = 1, cex = subheader_cex, - truth.labels[2] - ) - - text( - x = final_classtable_x[1] + .75 * diff(final_classtable_x), - y = subheader_y, pos = 1, cex = subheader_cex, - truth.labels[1] - ) - - - # Row titles: ---- - - text( - x = final_classtable_x[1] - .01, - y = final_classtable_y[1] + .75 * diff(final_classtable_y), cex = subheader_cex, - decision.labels[2], adj = 1 - ) - - text( - x = final_classtable_x[1] - .01, - y = final_classtable_y[1] + .25 * diff(final_classtable_y), cex = subheader_cex, - decision.labels[1], adj = 1 - ) - - text( - x = final_classtable_x[1] - .065, - y = mean(final_classtable_y), cex = header_cex, - "Decision" - ) - - # text(x = final_classtable_x[1] - .05, - # y = mean(final_classtable_y), cex = header_cex, - # "Decision", srt = 90, pos = 3) - - - # Add final frequencies: ---- - - text(final_classtable_x[1] + .75 * diff(final_classtable_x), - final_classtable_y[1] + .25 * diff(final_classtable_y), - prettyNum(final_stats$cr, big.mark = ","), - cex = 1.5 - ) - - text(final_classtable_x[1] + .25 * diff(final_classtable_x), - final_classtable_y[1] + .25 * diff(final_classtable_y), - prettyNum(final_stats$mi, big.mark = ","), - cex = 1.5 - ) - - text(final_classtable_x[1] + .75 * diff(final_classtable_x), - final_classtable_y[1] + .75 * diff(final_classtable_y), - prettyNum(final_stats$fa, big.mark = ","), - cex = 1.5 - ) - - text(final_classtable_x[1] + .25 * diff(final_classtable_x), - final_classtable_y[1] + .75 * diff(final_classtable_y), - prettyNum(final_stats$hi, big.mark = ","), - cex = 1.5 - ) - - - # Add symbols: ---- - - points(final_classtable_x[1] + .55 * diff(final_classtable_x), - final_classtable_y[1] + .05 * diff(final_classtable_y), - pch = noise_ball_pch, bg = col_correct_bg, col = col_correct_border, cex = ball_cex - ) - - points(final_classtable_x[1] + .05 * diff(final_classtable_x), - final_classtable_y[1] + .55 * diff(final_classtable_y), - pch = signal_ball_pch, bg = col_correct_bg, cex = ball_cex, col = col_correct_border - ) - - points(final_classtable_x[1] + .55 * diff(final_classtable_x), - final_classtable_y[1] + .55 * diff(final_classtable_y), - pch = noise_ball_pch, bg = col_error_bg, col = col_error_border, cex = ball_cex - ) - - points(final_classtable_x[1] + .05 * diff(final_classtable_x), - final_classtable_y[1] + .05 * diff(final_classtable_y), - pch = signal_ball_pch, bg = col_error_bg, col = col_error_border, cex = ball_cex - ) - - - # Add labels: ---- - - text(final_classtable_x[1] + .62 * diff(final_classtable_x), - final_classtable_y[1] + .07 * diff(final_classtable_y), - "cr", - cex = 1, font = 3, adj = 0 - ) - - text(final_classtable_x[1] + .12 * diff(final_classtable_x), - final_classtable_y[1] + .07 * diff(final_classtable_y), - "mi", - cex = 1, font = 3, adj = 0 - ) - - text(final_classtable_x[1] + .62 * diff(final_classtable_x), - final_classtable_y[1] + .57 * diff(final_classtable_y), - "fa", - cex = 1, font = 3, adj = 0 - ) - - text(final_classtable_x[1] + .12 * diff(final_classtable_x), - final_classtable_y[1] + .57 * diff(final_classtable_y), - "hi", - cex = 1, font = 3, adj = 0 - ) - } # if (show.confusion). - + plot_confusion( + lloc = lloc, + header_y = header_y, + subheader_y = subheader_y, + header_cex = header_cex, + subheader_cex = subheader_cex, + truth.labels = truth.labels, + decision.labels = decision.labels, + final_stats = final_stats, + ball_cex = ball_cex + ) # Levels: ---- @@ -2135,3 +2006,156 @@ plot_fft <- function(level_stats, } # if (identical exit 1 / right etc. } # for (level_i etc. loop. } + +plot_confusion <- function(lloc, + header_y = 1, + header_cex = 1.1, + subheader_y = .925, + subheader_cex = .9, + final_stats = NULL, + noise_ball_pch = 21, + signal_ball_pch = 24, + grayscale = FALSE, + ball_cex = c(1, 1), + classtable_lwd = 1, + truth.labels = c("FALSE", "TRUE"), + decision.labels = c("FALSE", "TRUE")) { + if (!grayscale) { + col_error_bg <- "#FF7352CC" + col_error_border <- "#AD1A0AE6" + col_correct_bg <- "#89FF6FCC" + col_correct_border <- "#24AB18E6" + } else { + # Grayscale colors + + col_error_bg <- gray(.1) + col_error_border <- gray(0) + col_correct_bg <- gray(1) + col_correct_border <- gray(0) + } + + # x/y coordinates: + final_classtable_x <- c(lloc$center_x[lloc$element == "classtable"] - lloc$width[lloc$element == "classtable"] / 2, lloc$center_x[lloc$element == "classtable"] + lloc$width[lloc$element == "classtable"] / 2) + final_classtable_y <- c(lloc$center_y[lloc$element == "classtable"] - lloc$height[lloc$element == "classtable"] / 2, lloc$center_y[lloc$element == "classtable"] + lloc$height[lloc$element == "classtable"] / 2) + + rect(final_classtable_x[1], final_classtable_y[1], + final_classtable_x[2], final_classtable_y[2], + lwd = classtable_lwd + ) + + segments(mean(final_classtable_x), final_classtable_y[1], mean(final_classtable_x), final_classtable_y[2], col = gray(0), lwd = classtable_lwd) + segments(final_classtable_x[1], mean(final_classtable_y), final_classtable_x[2], mean(final_classtable_y), col = gray(0), lwd = classtable_lwd) + + # Column titles: ---- + + text( + x = mean(mean(final_classtable_x)), + y = header_y, + "Truth", pos = 1, cex = header_cex + ) + + text( + x = final_classtable_x[1] + .25 * diff(final_classtable_x), + y = subheader_y, pos = 1, cex = subheader_cex, + truth.labels[2] + ) + + text( + x = final_classtable_x[1] + .75 * diff(final_classtable_x), + y = subheader_y, pos = 1, cex = subheader_cex, + truth.labels[1] + ) + + + # Row titles: ---- + + text( + x = final_classtable_x[1] - .01, + y = final_classtable_y[1] + .75 * diff(final_classtable_y), cex = subheader_cex, + decision.labels[2], adj = 1 + ) + + text( + x = final_classtable_x[1] - .01, + y = final_classtable_y[1] + .25 * diff(final_classtable_y), cex = subheader_cex, + decision.labels[1], adj = 1 + ) + + text( + x = final_classtable_x[1] - .065, + y = mean(final_classtable_y), cex = header_cex, + "Decision" + ) + + text(final_classtable_x[1] + .75 * diff(final_classtable_x), + final_classtable_y[1] + .25 * diff(final_classtable_y), + prettyNum(final_stats$cr, big.mark = ","), + cex = 1.5 + ) + + text(final_classtable_x[1] + .25 * diff(final_classtable_x), + final_classtable_y[1] + .25 * diff(final_classtable_y), + prettyNum(final_stats$mi, big.mark = ","), + cex = 1.5 + ) + + text(final_classtable_x[1] + .75 * diff(final_classtable_x), + final_classtable_y[1] + .75 * diff(final_classtable_y), + prettyNum(final_stats$fa, big.mark = ","), + cex = 1.5 + ) + + text(final_classtable_x[1] + .25 * diff(final_classtable_x), + final_classtable_y[1] + .75 * diff(final_classtable_y), + prettyNum(final_stats$hi, big.mark = ","), + cex = 1.5 + ) + + # Add symbols: ---- + + points(final_classtable_x[1] + .55 * diff(final_classtable_x), + final_classtable_y[1] + .05 * diff(final_classtable_y), + pch = noise_ball_pch, bg = col_correct_bg, col = col_correct_border, cex = ball_cex + ) + + points(final_classtable_x[1] + .05 * diff(final_classtable_x), + final_classtable_y[1] + .55 * diff(final_classtable_y), + pch = signal_ball_pch, bg = col_correct_bg, cex = ball_cex, col = col_correct_border + ) + + points(final_classtable_x[1] + .55 * diff(final_classtable_x), + final_classtable_y[1] + .55 * diff(final_classtable_y), + pch = noise_ball_pch, bg = col_error_bg, col = col_error_border, cex = ball_cex + ) + + points(final_classtable_x[1] + .05 * diff(final_classtable_x), + final_classtable_y[1] + .05 * diff(final_classtable_y), + pch = signal_ball_pch, bg = col_error_bg, col = col_error_border, cex = ball_cex + ) + + # Add labels: ---- + + text(final_classtable_x[1] + .62 * diff(final_classtable_x), + final_classtable_y[1] + .07 * diff(final_classtable_y), + "cr", + cex = 1, font = 3, adj = 0 + ) + + text(final_classtable_x[1] + .12 * diff(final_classtable_x), + final_classtable_y[1] + .07 * diff(final_classtable_y), + "mi", + cex = 1, font = 3, adj = 0 + ) + + text(final_classtable_x[1] + .62 * diff(final_classtable_x), + final_classtable_y[1] + .57 * diff(final_classtable_y), + "fa", + cex = 1, font = 3, adj = 0 + ) + + text(final_classtable_x[1] + .12 * diff(final_classtable_x), + final_classtable_y[1] + .57 * diff(final_classtable_y), + "hi", + cex = 1, font = 3, adj = 0 + ) +} From b8cd45e76e2acfaca619f13f74601ff4d832d3e4 Mon Sep 17 00:00:00 2001 From: Nathaniel Phillips Date: Fri, 24 May 2024 12:46:49 -0400 Subject: [PATCH 07/12] created plot_roc --- R/plotFFTrees_function.R | 405 ++++++++++++++++----------------------- 1 file changed, 170 insertions(+), 235 deletions(-) diff --git a/R/plotFFTrees_function.R b/R/plotFFTrees_function.R index 05a99325..ece61fec 100644 --- a/R/plotFFTrees_function.R +++ b/R/plotFFTrees_function.R @@ -1111,241 +1111,10 @@ plot.FFTrees <- function(x = NULL, # ROC curve: ----- if (show.roc) { - # Parameters: - roc_border_lwd <- 1 - roc_border_col <- gray(0) - - roc_title <- "ROC" - roc_title_font <- 1 - - roc_curve_col <- gray(.01) # ~black - roc_curve_lwd <- 1.1 - - diag_col <- gray(.01) # ~black - diag_lty <- 3 - - x_lbl <- expression(1 - Specificity ~ (FAR)) # to plot minus, rather than dash - y_lbl <- expression(Sensitivity ~ (HR)) - - x_d <- .015 # distance of x-axis labels (on left) to x-axis - - # y-locations of legend labels (default: using full height): - roc_lbl_y <- seq(.10, .90, length.out = 5) # SVM, RF, LR, CART, FFT - - - if (what == "roc") { # ROC as main plot: - - # Rescale key coordinates: - lloc$center_x[lloc$element == "roc"] <- .50 - lloc$center_y[lloc$element == "roc"] <- .55 - - lloc$width[lloc$element == "roc"] <- .70 - lloc$height[lloc$element == "roc"] <- .80 - - # Reset some parameters: - if (is.null(main) == FALSE) { - roc_title <- main - } - - roc_border_lwd <- .80 - roc_border_col <- gray(.25) - - roc_curve_col <- gray(.10) # "green2" - roc_curve_lwd <- 1.5 - - diag_col <- gray(.60) # as in showcues() - diag_lty <- 1 # as in showcues() - - x_d <- .035 - - # y-locations of legend labels (cluster labels on top right): - roc_lbl_y <- seq(.55, .95, length.out = 5) # SVM, RF, LR, CART, FFT - } # if (what == "roc"). - - - # ROC plot coordinates: - final_roc_x <- c(lloc$center_x[lloc$element == "roc"] - lloc$width[lloc$element == "roc"] / 2, lloc$center_x[lloc$element == "roc"] + lloc$width[lloc$element == "roc"] / 2) - final_roc_y <- c(lloc$center_y[lloc$element == "roc"] - lloc$height[lloc$element == "roc"] / 2, lloc$center_y[lloc$element == "roc"] + lloc$height[lloc$element == "roc"] / 2) - - - if (what == "roc") { # ROC as main plot: - - # Title: - title(main = roc_title, ...) # + graphical parameters - - # Background: - rect(final_roc_x[1], final_roc_y[1], final_roc_x[2], final_roc_y[2], - col = gray(.96) - ) # as in showcues() - - # Grid: - x_ax_seq <- seq(final_roc_x[1], final_roc_x[2], length.out = 11) - y_ax_seq <- seq(final_roc_y[1], final_roc_y[2], length.out = 11) - abline(v = x_ax_seq, lwd = c(2, rep(1, 4)), col = gray(1)) # x-grid - abline(h = y_ax_seq, lwd = c(2, rep(1, 4)), col = gray(1)) # y-grid - - # Axis ticks: - segments(x_ax_seq, final_roc_y[1], x_ax_seq, (final_roc_y[1] - .025), lty = 1, lwd = 1, col = gray(.10)) # x-axis - segments(final_roc_x[1], y_ax_seq, (final_roc_x[1] - .015), y_ax_seq, lty = 1, lwd = 1, col = gray(.10)) # y-axis - - # Tick labels: - text(x_ax_seq, (final_roc_y[1] - .025), labels = scales::comma(seq(0, 1, by = .1), accuracy = .1), pos = 1, cex = .9) # x-lbl - text((final_roc_x[1] - .015), y_ax_seq, labels = scales::comma(seq(0, 1, by = .1), accuracy = .1), pos = 2, cex = .9) # y-llb - - # Axis labels: - text(mean(final_roc_x), final_roc_y[1] - .125, labels = x_lbl, cex = 1) # x-lab - text(final_roc_x[1] - (3.5 * x_d), mean(final_roc_y), labels = y_lbl, cex = 1, srt = 90) # y-lab - - # Subtitle: Note data used - subnote <- paste0("ROC for '", data, "' data:") - text( - x = (final_roc_x[1] - .015), y = (final_roc_y[2] + .03), - labels = subnote, pos = 4, cex = subheader_cex - ) - } else { # ROC as miniature plot: - - # Title: - text(lloc$center_x[lloc$element == "roc"], header_y, - labels = roc_title, - font = roc_title_font, pos = 1, cex = header_cex - ) - - # x-axis: - text(c(final_roc_x[1], final_roc_x[2]), - c(final_roc_y[1], final_roc_y[1]) - .04, - labels = c(0, 1) - ) - - text(mean(final_roc_x), final_roc_y[1] - .08, labels = x_lbl) # x-lab - - # y-axis: - text(c(final_roc_x[1], final_roc_x[1], final_roc_x[1]) - x_d, - c(final_roc_y[1], mean(final_roc_y[1:2]), final_roc_y[2]), - labels = c(0, .5, 1) - ) - - text(final_roc_x[1] - (2.5 * x_d), mean(final_roc_y), labels = y_lbl, srt = 90) # y-lab - - # AUC label: - # text(final.roc.center[1], subheader_y, paste("AUC =", round(final.auc, 2)), pos = 1) - - # Plot bg: - # - # rect(final_roc_x[1], - # final_roc_y[1], - # final_roc_x[2], - # final_roc_y[2], - # col = gray(1), lwd = .5) - - # Gridlines: - # # Horizontal: - # segments(x0 = rep(final_roc_x[1], 9), - # y0 = seq(final_roc_y[1], final_roc_y[2], length.out = 5)[2:10], - # x1 = rep(final_roc_x[2], 9), - # y1 = seq(final_roc_y[1], final_roc_y[2], length.out = 5)[2:10], - # lty = 1, col = gray(.8), lwd = c(.5), lend = 3 - # ) - # - # # Vertical: - # segments(y0 = rep(final_roc_y[1], 9), - # x0 = seq(final_roc_x[1], final_roc_x[2], length.out = 5)[2:10], - # y1 = rep(final_roc_y[2], 9), - # x1 = seq(final_roc_x[1], final_roc_x[2], length.out = 5)[2:10], - # lty = 1, col = gray(.8), lwd = c(.5), lend = 3 - # ) - } - - # Plot border: - rect(final_roc_x[1], - final_roc_y[1], - final_roc_x[2], - final_roc_y[2], - border = roc_border_col, - lwd = roc_border_lwd - ) - - # Diagonal: - segments(final_roc_x[1], - final_roc_y[1], - final_roc_x[2], - final_roc_y[2], - col = diag_col, - lwd = 1, - lty = diag_lty - ) - - # FFTs: ---- - - { - if (!grayscale) { - col_fft_point_col <- scales::alpha("green", .1) - col_fft_point_bg <- scales::alpha("white", .9) - col_fft_point_bg_2 <- scales::alpha("green", .2) - col_fft_point_col_2 <- scales::alpha("green", .6) - } else { - col_fft_point_col <- gray(0) - col_fft_point_bg <- gray(1) - col_fft_point_bg_2 <- gray(1) - col_fft_point_col_2 <- gray(0) - } - - roc_order <- order(fft_spec_vec, decreasing = TRUE) # from highest to lowest spec - # roc_order <- 1:x$trees$n - - fft_sens_vec_ord <- fft_sens_vec[roc_order] - fft_spec_vec_ord <- fft_spec_vec[roc_order] - - # Add segments and points for all trees but tree: - - if (length(roc_order) > 1) { - segments(final_roc_x[1] + c(0, 1 - fft_spec_vec_ord) * lloc$width[lloc$element == "roc"], - final_roc_y[1] + c(0, fft_sens_vec_ord) * lloc$height[lloc$element == "roc"], - final_roc_x[1] + c(1 - fft_spec_vec_ord, 1) * lloc$width[lloc$element == "roc"], - final_roc_y[1] + c(fft_sens_vec_ord, 1) * lloc$height[lloc$element == "roc"], - lwd = roc_curve_lwd, - col = roc_curve_col - ) - - points(final_roc_x[1] + ((1 - fft_spec_vec_ord[-(which(roc_order == tree))]) * lloc$width[lloc$element == "roc"]), - final_roc_y[1] + (fft_sens_vec_ord[-(which(roc_order == tree))] * lloc$height[lloc$element == "roc"]), - pch = 21, cex = 2.5, col = col_fft_point_col_2, - bg = col_fft_point_bg - ) - - text(final_roc_x[1] + ((1 - fft_spec_vec_ord[-(which(roc_order == tree))]) * lloc$width[lloc$element == "roc"]), - final_roc_y[1] + (fft_sens_vec_ord[-(which(roc_order == tree))] * lloc$height[lloc$element == "roc"]), - labels = roc_order[which(roc_order != tree)], cex = 1, col = gray(.50) - ) - } - - # Add larger point for plotted tree: - - # white point (to hide point from above): - points(final_roc_x[1] + ((1 - fft_spec_vec[tree]) * lloc$width[lloc$element == "roc"]), - final_roc_y[1] + (fft_sens_vec[tree] * lloc$height[lloc$element == "roc"]), - pch = 21, cex = 3, col = col_fft_point_col_2, # col = scales::alpha("green", .30), - bg = scales::alpha("white", 1), lwd = 1 - ) - - # green point: - points(final_roc_x[1] + ((1 - fft_spec_vec[tree]) * lloc$width[lloc$element == "roc"]), - final_roc_y[1] + (fft_sens_vec[tree] * lloc$height[lloc$element == "roc"]), - pch = 21, cex = 3, col = col_fft_point_col_2, # col = scales::alpha("green", .30), - bg = col_fft_point_bg_2, lwd = 1 - ) - - text(final_roc_x[1] + ((1 - fft_spec_vec[tree]) * lloc$width[lloc$element == "roc"]), - final_roc_y[1] + (fft_sens_vec[tree] * lloc$height[lloc$element == "roc"]), - labels = tree, cex = 1.25, col = gray(.20), font = 2 - ) - } # FFTs. - } # if (show.roc). - } # if (show.bottom). - - # # Reset plotting space: - # par(mfrow = c(1, 1)) - # par(mar = c(5, 4, 4, 1) + .1) - } # if (what != "cues"). + plot_roc(lloc = lloc, tree_stats = tree_stats, tree = tree) + } + } + } # Output: ------ @@ -2159,3 +1928,169 @@ plot_confusion <- function(lloc, cex = 1, font = 3, adj = 0 ) } + +plot_roc <- function(lloc, main = NULL, header_y = 1, + subheader_y = .925, + header_cex = 1.10, + subheader_cex = .90, + grayscale = FALSE, + tree_stats = NULL, + tree = 1) { + # Parameters: + roc_border_lwd <- 1 + roc_border_col <- gray(0) + + roc_title <- "ROC" + roc_title_font <- 1 + + roc_curve_col <- gray(.01) # ~black + roc_curve_lwd <- 1.1 + + diag_col <- gray(.01) # ~black + diag_lty <- 3 + + fft_sens_vec <- tree_stats$sens + fft_spec_vec <- tree_stats$spec + + x_lbl <- expression(1 - Specificity ~ (FAR)) # to plot minus, rather than dash + y_lbl <- expression(Sensitivity ~ (HR)) + + x_d <- .015 # distance of x-axis labels (on left) to x-axis + + # y-locations of legend labels (default: using full height): + roc_lbl_y <- seq(.10, .90, length.out = 5) # SVM, RF, LR, CART, FFT + + + # Reset some parameters: + if (is.null(main) == FALSE) { + roc_title <- main + } + + roc_border_lwd <- .80 + roc_border_col <- gray(.25) + + roc_curve_col <- gray(.10) # "green2" + roc_curve_lwd <- 1.5 + + diag_col <- gray(.60) # as in showcues() + diag_lty <- 1 # as in showcues() + + x_d <- .035 + + # y-locations of legend labels (cluster labels on top right): + roc_lbl_y <- seq(.55, .95, length.out = 5) # SVM, RF, LR, CART, FFT + + # ROC plot coordinates: + final_roc_x <- c(lloc$center_x[lloc$element == "roc"] - lloc$width[lloc$element == "roc"] / 2, lloc$center_x[lloc$element == "roc"] + lloc$width[lloc$element == "roc"] / 2) + final_roc_y <- c(lloc$center_y[lloc$element == "roc"] - lloc$height[lloc$element == "roc"] / 2, lloc$center_y[lloc$element == "roc"] + lloc$height[lloc$element == "roc"] / 2) + + # Set par: + par(xpd = TRUE) + + # Title: + text(lloc$center_x[lloc$element == "roc"], header_y, + labels = roc_title, + font = roc_title_font, pos = 1, cex = header_cex + ) + + # x-axis: + text(c(final_roc_x[1], final_roc_x[2]), + c(final_roc_y[1], final_roc_y[1]) - .04, + labels = c(0, 1) + ) + + text(mean(final_roc_x), final_roc_y[1] - .08, labels = x_lbl) # x-lab + + # y-axis: + text(c(final_roc_x[1], final_roc_x[1], final_roc_x[1]) - x_d, + c(final_roc_y[1], mean(final_roc_y[1:2]), final_roc_y[2]), + labels = c(0, .5, 1) + ) + + text(final_roc_x[1] - (2.5 * x_d), mean(final_roc_y), labels = y_lbl, srt = 90) # y-lab + + # Plot border: + rect(final_roc_x[1], + final_roc_y[1], + final_roc_x[2], + final_roc_y[2], + border = roc_border_col, + lwd = roc_border_lwd + ) + + # Diagonal: + segments(final_roc_x[1], + final_roc_y[1], + final_roc_x[2], + final_roc_y[2], + col = diag_col, + lwd = 1, + lty = diag_lty + ) + + # FFTs: ---- + + { + if (!grayscale) { + col_fft_point_col <- scales::alpha("green", .1) + col_fft_point_bg <- scales::alpha("white", .9) + col_fft_point_bg_2 <- scales::alpha("green", .2) + col_fft_point_col_2 <- scales::alpha("green", .6) + } else { + col_fft_point_col <- gray(0) + col_fft_point_bg <- gray(1) + col_fft_point_bg_2 <- gray(1) + col_fft_point_col_2 <- gray(0) + } + + roc_order <- order(fft_spec_vec, decreasing = TRUE) # from highest to lowest spec + # roc_order <- 1:x$trees$n + + fft_sens_vec_ord <- fft_sens_vec[roc_order] + fft_spec_vec_ord <- fft_spec_vec[roc_order] + + # Add segments and points for all trees but tree: + + if (length(roc_order) > 1) { + segments(final_roc_x[1] + c(0, 1 - fft_spec_vec_ord) * lloc$width[lloc$element == "roc"], + final_roc_y[1] + c(0, fft_sens_vec_ord) * lloc$height[lloc$element == "roc"], + final_roc_x[1] + c(1 - fft_spec_vec_ord, 1) * lloc$width[lloc$element == "roc"], + final_roc_y[1] + c(fft_sens_vec_ord, 1) * lloc$height[lloc$element == "roc"], + lwd = roc_curve_lwd, + col = roc_curve_col + ) + + points(final_roc_x[1] + ((1 - fft_spec_vec_ord[-(which(roc_order == tree))]) * lloc$width[lloc$element == "roc"]), + final_roc_y[1] + (fft_sens_vec_ord[-(which(roc_order == tree))] * lloc$height[lloc$element == "roc"]), + pch = 21, cex = 2.5, col = col_fft_point_col_2, + bg = col_fft_point_bg + ) + + text(final_roc_x[1] + ((1 - fft_spec_vec_ord[-(which(roc_order == tree))]) * lloc$width[lloc$element == "roc"]), + final_roc_y[1] + (fft_sens_vec_ord[-(which(roc_order == tree))] * lloc$height[lloc$element == "roc"]), + labels = roc_order[which(roc_order != tree)], cex = 1, col = gray(.50) + ) + } + + # Add larger point for plotted tree: + + # white point (to hide point from above): + points(final_roc_x[1] + ((1 - fft_spec_vec[tree]) * lloc$width[lloc$element == "roc"]), + final_roc_y[1] + (fft_sens_vec[tree] * lloc$height[lloc$element == "roc"]), + pch = 21, cex = 3, col = col_fft_point_col_2, # col = scales::alpha("green", .30), + bg = scales::alpha("white", 1), lwd = 1 + ) + + # green point: + points(final_roc_x[1] + ((1 - fft_spec_vec[tree]) * lloc$width[lloc$element == "roc"]), + final_roc_y[1] + (fft_sens_vec[tree] * lloc$height[lloc$element == "roc"]), + pch = 21, cex = 3, col = col_fft_point_col_2, # col = scales::alpha("green", .30), + bg = col_fft_point_bg_2, lwd = 1 + ) + + text(final_roc_x[1] + ((1 - fft_spec_vec[tree]) * lloc$width[lloc$element == "roc"]), + final_roc_y[1] + (fft_sens_vec[tree] * lloc$height[lloc$element == "roc"]), + labels = tree, cex = 1.25, col = gray(.20), font = 2 + ) + } +} From c1672ddf61da1fd81e7ecf77b2c985fdade02ff7 Mon Sep 17 00:00:00 2001 From: Nathaniel Phillips Date: Fri, 24 May 2024 12:54:57 -0400 Subject: [PATCH 08/12] more updates to plot_roc --- R/plotFFTrees_function.R | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/R/plotFFTrees_function.R b/R/plotFFTrees_function.R index ece61fec..1e43aab1 100644 --- a/R/plotFFTrees_function.R +++ b/R/plotFFTrees_function.R @@ -213,8 +213,6 @@ plot.FFTrees <- function(x = NULL, } } - - valid_what <- c( "all", "default", "cues", "tree", "icontree", "roc" @@ -1253,7 +1251,6 @@ plot_icon_array <- function(x_lim = c(-10, 0), ball_lwd = .70, freq_text = TRUE, freq_text_cex = 1.2, - # rev_order = FALSE, # is NOT used anywhere? box_col = NULL, box_bg = NULL, n_per_icon = NULL, @@ -1929,7 +1926,9 @@ plot_confusion <- function(lloc, ) } -plot_roc <- function(lloc, main = NULL, header_y = 1, +plot_roc <- function(lloc, + main = NULL, + header_y = 1, subheader_y = .925, header_cex = 1.10, subheader_cex = .90, @@ -1960,7 +1959,6 @@ plot_roc <- function(lloc, main = NULL, header_y = 1, # y-locations of legend labels (default: using full height): roc_lbl_y <- seq(.10, .90, length.out = 5) # SVM, RF, LR, CART, FFT - # Reset some parameters: if (is.null(main) == FALSE) { roc_title <- main @@ -1975,7 +1973,7 @@ plot_roc <- function(lloc, main = NULL, header_y = 1, diag_col <- gray(.60) # as in showcues() diag_lty <- 1 # as in showcues() - x_d <- .035 + x_d <- .015 # y-locations of legend labels (cluster labels on top right): roc_lbl_y <- seq(.55, .95, length.out = 5) # SVM, RF, LR, CART, FFT From 4f1deb4df637489850ee3ea12a02d259d5a0beb3 Mon Sep 17 00:00:00 2001 From: Nathaniel Phillips Date: Fri, 24 May 2024 15:41:29 -0400 Subject: [PATCH 09/12] lots of plotting updates. moved some level_stats data wrangling from plot.FFTrees() to fftrees_apply() --- R/fftrees_apply.R | 25 +- R/plotFFTrees_function.R | 563 ++++++++++++++++++--------------------- 2 files changed, 281 insertions(+), 307 deletions(-) diff --git a/R/fftrees_apply.R b/R/fftrees_apply.R index 572a7e88..2aa76989 100644 --- a/R/fftrees_apply.R +++ b/R/fftrees_apply.R @@ -636,6 +636,30 @@ fftrees_apply <- function(x, # Add final tree results to level_stats_ls and decisions_ls: ---- + + # Add marginal classification statistics to level_stats / Frequencies per level: + + level_stats_i$hi_m <- NA # initialize marginal freqs + level_stats_i$fa_m <- NA + level_stats_i$mi_m <- NA + level_stats_i$cr_m <- NA + + for (i in 1:level_n) { + if (i == 1) { + level_stats_i$hi_m[1] <- level_stats_i$hi[1] + level_stats_i$fa_m[1] <- level_stats_i$fa[1] + level_stats_i$mi_m[1] <- level_stats_i$mi[1] + level_stats_i$cr_m[1] <- level_stats_i$cr[1] + } + + if (i > 1) { + level_stats_i$hi_m[i] <- level_stats_i$hi[i] - level_stats_i$hi[i - 1] + level_stats_i$fa_m[i] <- level_stats_i$fa[i] - level_stats_i$fa[i - 1] + level_stats_i$mi_m[i] <- level_stats_i$mi[i] - level_stats_i$mi[i - 1] + level_stats_i$cr_m[i] <- level_stats_i$cr[i] - level_stats_i$cr[i - 1] + } + } # for n_levels. + level_stats_ls[[tree_i]] <- level_stats_i decisions_ls[[tree_i]] <- decisions_df[ , names(decisions_df) %in% c("current_decision", "current_cue_values") == FALSE] @@ -670,7 +694,6 @@ fftrees_apply <- function(x, } - # Add results to x$trees (given mydata type): ---- x$trees$stats[[mydata]] <- tibble::as_tibble(tree_stats) diff --git a/R/plotFFTrees_function.R b/R/plotFFTrees_function.R index 1e43aab1..9c3ae676 100644 --- a/R/plotFFTrees_function.R +++ b/R/plotFFTrees_function.R @@ -160,7 +160,7 @@ plot.FFTrees <- function(x = NULL, decision.labels = NULL, truth.labels = NULL, # - cue.cex = NULL, + cue.cex = 1.5, threshold.cex = NULL, decision.cex = 1, # @@ -186,7 +186,7 @@ plot.FFTrees <- function(x = NULL, grayscale = FALSE, # graphical parameters: ...) { - # Prepare: ------ + # Setup ------------------------------------------------------------------------ par0 <- par(no.readonly = TRUE) on.exit(par(par0), add = TRUE) @@ -328,8 +328,6 @@ plot.FFTrees <- function(x = NULL, hlines <- FALSE } # if (what == "roc"). - show_icon_guide_legend <- FALSE - if (show.header & show.tree & (show.confusion | show.levels | show.roc)) { show.top <- TRUE show.middle <- TRUE @@ -487,7 +485,9 @@ plot.FFTrees <- function(x = NULL, # decision_v <- x$trees$decisions[[data]][[tree]]$decision tree_stats <- x$trees$stats[[data]] - level_stats <- x$trees$level_stats[[data]][x$trees$level_stats[[data]]$tree == tree, ] + + level_stats <- x |> + pluck_level_stats(data_type = data, tree = tree) # Get criterion (from object x): criterion_name <- x$criterion_name # (only ONCE) @@ -508,48 +508,12 @@ plot.FFTrees <- function(x = NULL, n_levels <- nrow(level_stats) - # Add marginal classification statistics to level_stats / Frequencies per level: - - level_stats$hi_m <- NA # initialize marginal freqs - level_stats$fa_m <- NA - level_stats$mi_m <- NA - level_stats$cr_m <- NA - - for (i in 1:n_levels) { - if (i == 1) { - level_stats$hi_m[1] <- level_stats$hi[1] - level_stats$fa_m[1] <- level_stats$fa[1] - level_stats$mi_m[1] <- level_stats$mi[1] - level_stats$cr_m[1] <- level_stats$cr[1] - } - - if (i > 1) { - level_stats$hi_m[i] <- level_stats$hi[i] - level_stats$hi[i - 1] - level_stats$fa_m[i] <- level_stats$fa[i] - level_stats$fa[i - 1] - level_stats$mi_m[i] <- level_stats$mi[i] - level_stats$mi[i - 1] - level_stats$cr_m[i] <- level_stats$cr[i] - level_stats$cr[i - 1] - } - } # for n_levels. - - # print(level_stats) # tree with marginal frequency values (for each level) - - - ## Set plotting parameters: ---- - f_cex <- 1 # cex scaling factor decision_node_cex <- 4 * f_cex exit_node_cex <- 4 * f_cex panel_title_cex <- 2 * f_cex - if (is.null(cue.cex)) { - cue.cex <- c(1.50, 1.50, 1.25, 1, 1, 1) - } else { - if (length(cue.cex) < 6) { - cue.cex <- rep(cue.cex, length.out = 6) - } - } - if (is.null(threshold.cex)) { threshold.cex <- c(1.50, 1.50, 1.25, 1, 1, 1) } else { @@ -557,7 +521,6 @@ plot.FFTrees <- function(x = NULL, threshold.cex <- rep(threshold.cex, length.out = 6) } } - # print(threshold.cex) # 4debugging # Panel parameters: panel_line_lwd <- 1 @@ -590,13 +553,6 @@ plot.FFTrees <- function(x = NULL, segment_lty <- 1 segment_lwd <- 1 - # continue_segment_lwd <- 1 # is NOT used anywhere? - # continue_segment_lty <- 1 # is NOT used anywhere? - - # exit_segment_lwd <- 1 # is NOT used anywhere? - # exit_segment_lty <- 1 # is NOT used anywhere? - - # Define plotting_parameters_df: if (show.top & show.middle & show.bottom) { # plot "all": @@ -643,17 +599,6 @@ plot.FFTrees <- function(x = NULL, col_exit_node_bg <- "white" - # error.colfun <- circlize::colorRamp2(c(0, 50, 100), - # colors = c("white", "red", "black")) - # - # correct.colfun <- circlize::colorRamp2(c(0, 50, 100), - # colors = c("white", "green", "black")) - # - # col_error_bg <- scales::alpha(error.colfun(35), .8) - # col_error_border <- scales::alpha(error.colfun(65), .9) - # col_correct_bg <- scales::alpha(correct.colfun(35), .8) - # col_correct_border <- scales::alpha(correct.colfun(65), .9) - if (!grayscale) { col_error_bg <- "#FF7352CC" col_error_border <- "#AD1A0AE6" @@ -716,16 +661,17 @@ plot.FFTrees <- function(x = NULL, arrow_head_length <- .08 arrow_col <- gray(0) # = black - # spec_circle_x <- .40 # is NOT used anywhere? - # dprime_circle_x <- .50 # is NOT used anywhere? - # sens_circle_x <- .60 # is NOT used anywhere? + if (is.null(label.performance)) { # user argument not set: - # stat_circle_y <- .30 # is NOT used anywhere? + if (data == "train") { + label.performance <- "Accuracy (Training)" + } + if (data == "test") { + label.performance <- "Accuracy (Testing)" + } + } - # sens_circle_col <- "green" # is NOT used anywhere? - # spec_circle_col <- "red" # is NOT used anywhere? - # dprime_circle_col <- "blue" # is NOT used anywhere? - # stat_outer_circle_col <- gray(.50) # is NOT used anywhere? + # Top ---------------------------------------------------------------------- if (show.top) { par(mar = c(0, 0, 1, 0)) @@ -736,30 +682,33 @@ plot.FFTrees <- function(x = NULL, xlab = "", ylab = "", yaxt = "n", xaxt = "n" ) - # 1. Title: ---- - par(xpd = TRUE) - # (a) lines: - if (hlines) { - segments(0, .95, 1, .95, col = col_panel_line, lwd = panel_line_lwd, lty = panel_line_lty) # top hline - - x_dev <- get_x_dev(main) - y_dev <- .20 - rect((.50 - x_dev), (1 - y_dev), (.50 + x_dev), (1 + y_dev), col = "white", border = NA) # title background - } - - # (b) label: - text(x = .50, y = .96, main, cex = panel_title_cex, ...) # title 1 (top): main + plot_title( + main = main, + hlines = hlines, + col_panel_line = col_panel_line, + panel_line_lwd = panel_line_lwd, + panel_line_lty = panel_line_lty, + panel_title_cex = panel_title_cex + ) - # (b) Show balls: - n_true_pos <- with(final_stats, hi + mi) - n_true_neg <- with(final_stats, fa + cr) + plot_level_bar( + title = paste("p(", truth.labels[1], ")", sep = ""), + value = 1 - crit_br, + value_label = scales::percent(1 - crit_br), + max_value = 1, + rect_min_y = .1, + rect_max_y = .6, + rect_min_x = .175, + rect_max_x = .225, + label_pos = "left" + ) plot_icon_array( x_lim = c(.33, .67), y_lim = c(.12, .52), - n_vec = c(n_true_neg, n_true_pos), + n_vec = c(with(final_stats, fa + cr), with(final_stats, hi + mi)), pch_vec = c(noise_ball_pch, signal_ball_pch), bg_vec = c(noise_ball_bg, signal_ball_bg), col_vec = c(noise_ball_col, signal_ball_col), @@ -772,8 +721,6 @@ plot.FFTrees <- function(x = NULL, par(xpd = FALSE) - # (a) p_signal level (on right): ---- - plot_level_bar( title = paste("p(", truth.labels[2], ")", sep = ""), value = crit_br, @@ -785,23 +732,9 @@ plot.FFTrees <- function(x = NULL, rect_max_x = .825, label_pos = "right" ) - - # (b) p_noise level (on left): ---- - - plot_level_bar( - title = paste("p(", truth.labels[1], ")", sep = ""), - value = 1 - crit_br, - value_label = scales::percent(1 - crit_br), - max_value = 1, - rect_min_y = .1, - rect_max_y = .6, - rect_min_x = .175, - rect_max_x = .225, - label_pos = "left" - ) } - # 2. Main TREE: ------ + # Middle ---------------------------------------------------------------------- if (show.middle) { if ((show.top == FALSE) & (show.bottom == FALSE)) { @@ -822,18 +755,24 @@ plot.FFTrees <- function(x = NULL, ) if (show.top | show.bottom) { - if (hlines) { - x_dev <- .28 # scaling factor, rather than difference - segments(-plot_width, 0, -plot_width * x_dev, 0, col = col_panel_line, lwd = panel_line_lwd, lty = panel_line_lty) - segments(plot_width, 0, plot_width * x_dev, 0, col = col_panel_line, lwd = panel_line_lwd, lty = panel_line_lty) - } - if (is.null(label.tree)) { label.tree <- paste("FFT #", tree, " (of ", x$trees$n, ")", sep = "") } - text(x = 0, y = 0, label.tree, cex = panel_title_cex, ...) # title 2 (middle): (a) tree label - } # if (show.top | show.bottom). + plot_title( + main = label.tree, + hlines = hlines, + y = 0, + y_dev = 20, + x_dev = 8, + x_start = -plot_width, + x_end = plot_width, + col_panel_line = col_panel_line, + panel_line_lwd = panel_line_lwd, + panel_line_lty = panel_line_lty, + panel_title_cex = panel_title_cex + ) + } if (show.top == FALSE & show.bottom == FALSE) { if (is.null(main) & is.null(x$params$main)) { @@ -841,126 +780,25 @@ plot.FFTrees <- function(x = NULL, } mtext(text = main, side = 3, cex = panel_title_cex, ...) # title 2 (middle): (b) main label - } # if (show.top == FALSE & show.bottom == FALSE). - - - if (show.iconguide) { - # Parameters: - if (what == "ico") { - f_x <- 1.2 # scaling factor (to stretch in x-dim) - f_y <- 0.8 # scaling factor (to shift up) - } else { # default scaling factors: - - f_x <- 1 - f_y <- 1 - } - - get_exit_word <- get_exit_word(data) # either 'train':'decide' or 'test':'predict' - - - # (a) Noise panel (on left): ---- - - # Parameters: - - if (what == "ico") { - leg_head_y <- .02 - leg_ball_y <- .14 - } else { - leg_head_y <- .05 - leg_ball_y <- .15 - } - - - # Heading: - text(-plot_width * .60 * f_x, - -plot_height * leg_head_y * f_y, - paste(get_exit_word, decision.labels[1], sep = " "), - cex = 1.2, font = 3 - ) - - # Noise balls: - points(c(-plot_width * .70, -plot_width * .50) * f_x, - c(-plot_height * leg_ball_y, -plot_height * leg_ball_y) * f_y, - pch = c(noise_ball_pch, signal_ball_pch), - bg = c(col_correct_bg, col_error_bg), - col = c(col_correct_border, col_error_border), - cex = ball_cex * 1.5 - ) - - # Labels: - text(c(-plot_width * .70, -plot_width * .50) * f_x, - c(-plot_height * leg_ball_y, -plot_height * leg_ball_y) * f_y, - labels = c("Correct\nRejection", "Miss"), - pos = c(2, 4), offset = .80, cex = 1 - ) - - - - # (b) Signal panel (on right): ---- - - # Heading: - text(plot_width * .60 * f_x, - -plot_height * leg_head_y * f_y, - paste(get_exit_word, decision.labels[2], sep = " "), - cex = 1.2, font = 3 - ) - - # Signal balls: - points(c(plot_width * .50, plot_width * .70) * f_x, - c(-plot_height * leg_ball_y, -plot_height * leg_ball_y) * f_y, - pch = c(noise_ball_pch, signal_ball_pch), - bg = c(col_error_bg, col_correct_bg), - col = c(col_error_border, col_correct_border), - cex = ball_cex * 1.5 - ) - - # Labels: - text(c(plot_width * .50, plot_width * .70) * f_x, - c(-plot_height * leg_ball_y, -plot_height * leg_ball_y) * f_y, - labels = c("False\nAlarm", "Hit"), - pos = c(2, 4), offset = .80, cex = 1 - ) - - - # (c) Additional lines (below icon guide): ---- - if (what == "ico" & hlines) { - x_hline <- plot_width * 1.0 * f_x - y_hline <- -plot_height * .22 * f_y - - segments(-x_hline, y_hline, x_hline, y_hline, col = col_panel_line, lwd = panel_line_lwd, lty = panel_line_lty) - rect(-x_hline * .33, (y_hline - .5), x_hline * .33, (y_hline + .5), col = "white", border = NA) - } - - - # (d) n.per.icon legend 2 (middle): ---- - - if (what == "ico") { - show_icon_guide_legend <- TRUE - } # special case - - if (show_icon_guide_legend) { - if (what == "ico") { # special case: - - x_s2 <- plot_width - x_s1 <- plot_width - .80 # left of default - y_s1 <- plot_height * -1.10 # lower than default - } else { # defaults: - - x_s2 <- plot_width - x_s1 <- plot_width - .40 - y_s1 <- plot_height * -1 - } + } - text(x_s1, y_s1, labels = paste("Showing ", n.per.icon, " cases per icon:", sep = ""), pos = 2, cex = ball_cex) - points(x_s1, y_s1, pch = noise_ball_pch, cex = ball_cex) - points(x_s2, y_s1, pch = signal_ball_pch, cex = ball_cex) - } # if (show_icon_guide_legend). - } # if (show.iconguide). + plot_icon_guide( + what = what, + data = data, + plot_width = plot_width, + plot_height = plot_height, + decision.labels = decision.labels, + noise_ball_pch = noise_ball_pch, + signal_ball_pch = signal_ball_pch, + col_correct_border = col_correct_border, + col_error_border = col_error_border, + col_correct_bg = col_correct_bg, + col_error_bg = col_error_bg, + ball_cex = ball_cex + ) par(xpd = FALSE) - # Plot main TREE: ------ - plot_fft( level_stats = level_stats, cue.cex = cue.cex, @@ -970,23 +808,14 @@ plot.FFTrees <- function(x = NULL, ball_loc = ball_loc, show.icons = show.icons, n.per.icon = n.per.icon, - grayscale = grayscale + grayscale = grayscale, + add = TRUE ) - } # if (show.middle). - - if (show.bottom == TRUE) { # obtain tree statistics: - - fft_sens_vec <- tree_stats$sens - fft_spec_vec <- tree_stats$spec - - # General plotting space: ---- + } - # Parameters: - header_y <- 1.0 - subheader_y <- .925 + # Bottom ---------------------------------------------------------------------- - header_cex <- 1.10 - subheader_cex <- .90 + if (show.bottom) { # obtain tree statistics: par(mar = c(0, 0, 2, 0)) @@ -997,32 +826,20 @@ plot.FFTrees <- function(x = NULL, yaxt = "n", xaxt = "n" ) - if (what != "roc") { # Set par: par(xpd = TRUE) - # Bottom title: ---- - - if (hlines) { - segments(0, 1.1, 1, 1.1, col = col_panel_line, lwd = panel_line_lwd, lty = panel_line_lty) - - x_dev <- .20 - rect((.50 - x_dev), 1, (.50 + x_dev), 1.2, col = "white", border = NA) # label background - } - - # Bottom label: - if (is.null(label.performance)) { # user argument not set: - - if (data == "train") { - label.performance <- "Accuracy (Training)" - } - if (data == "test") { - label.performance <- "Accuracy (Testing)" - } - } - - text(x = .50, y = 1.1, labels = label.performance, cex = panel_title_cex, ...) # title 3 (bottom): Performance + plot_title( + main = label.performance, + hlines = hlines, + x_dev = .2, + y = 1.1, + col_panel_line = col_panel_line, + panel_line_lwd = panel_line_lwd, + panel_line_lty = panel_line_lty, + panel_title_cex = panel_title_cex + ) par(xpd = FALSE) } # if (what != "roc"). @@ -1066,24 +883,14 @@ plot.FFTrees <- function(x = NULL, lloc$reference_val[lloc$element == "acc"] <- max(crit_br, 1 - crit_br) lloc$reference_label[lloc$element == "acc"] <- "BL" - # print(lloc) # 4debugging - - # Classification table: ---- - plot_confusion( lloc = lloc, - header_y = header_y, - subheader_y = subheader_y, - header_cex = header_cex, - subheader_cex = subheader_cex, truth.labels = truth.labels, decision.labels = decision.labels, final_stats = final_stats, ball_cex = ball_cex ) - # Levels: ---- - if (show.levels) { for (element_i in c("mcu", "pci", "sens", "spec", "acc", "bacc")) { plot_level_bar( @@ -1106,20 +913,16 @@ plot.FFTrees <- function(x = NULL, } } - # ROC curve: ----- - if (show.roc) { plot_roc(lloc = lloc, tree_stats = tree_stats, tree = tree) } } } - - # Output: ------ - - # Output x may differ from input x when applying new 'test' data (as df): return(invisible(x)) -} # plot.FFTrees(). +} + +# Helpers plot_level_bar <- function(title = "", value = NULL, @@ -1373,15 +1176,18 @@ plot_icon_array <- function(x_lim = c(-10, 0), par(xpd = FALSE) } -plot_fft <- function(level_stats, - cue.cex = NULL, - threshold.cex = NULL, - decision.cex = NULL, - decision.labels = NULL, +plot_fft <- function(level_stats = NULL, + cue.cex = 1.5, + threshold.cex = 1, + decision.cex = 1, + decision.labels = c("FALSE", "TRUE"), ball_loc = "variable", show.icons = TRUE, + plot_width = NULL, + plot_height = NULL, n.per.icon = NULL, - grayscale = FALSE) { + grayscale = FALSE, + add = FALSE) { subplot_center <- c(0, -4) label_box_height <- 2 label_box_width <- 5 @@ -1441,23 +1247,43 @@ plot_fft <- function(level_stats, n_levels <- nrow(level_stats) - # local variables: if (n_levels < 6) { label_box_text_cex <- plotting_parameters_df$label_box_text_cex[n_levels] break_label_cex <- plotting_parameters_df$break_label_cex[n_levels] - plot_height <- plotting_parameters_df$plot_height[n_levels] - plot_width <- plotting_parameters_df$plot_width[n_levels] + + if (is.null(plot_height)) { + plot_height <- plotting_parameters_df$plot_height[n_levels] + } + + if (is.null(plot_width)) { + plot_width <- plotting_parameters_df$plot_width[n_levels] + } } else { # n_levels >= 6: label_box_text_cex <- plotting_parameters_df$label_box_text_cex[6] break_label_cex <- plotting_parameters_df$break_label_cex[6] - plot_height <- plotting_parameters_df$plot_height[6] - plot_width <- plotting_parameters_df$plot_width[6] + + if (is.null(plot_height)) { + plot_height <- plotting_parameters_df$plot_height[6] + } + + if (is.null(plot_width)) { + plot_width <- plotting_parameters_df$plot_width[6] + } } cue.labels <- level_stats$cue + if (!add) { + plot.new() + + plot.window( + xlim = c(-plot_width, plot_width), + ylim = c(-plot_height, 0) + ) # Sets up the plotting + } + for (level_i in 1:min(c(n_levels, 6))) { cur_cue <- cue.labels[level_i] @@ -1466,7 +1292,6 @@ plot_fft <- function(level_stats, mi_i <- level_stats$mi_m[level_i] cr_i <- level_stats$cr_m[level_i] - if (level_i == 1) { rect(subplot_center[1] - label_box_width / 2, subplot_center[2] + 2 - label_box_height / 2, @@ -1541,7 +1366,6 @@ plot_fft <- function(level_stats, ) } - if ((max(c(cr_i, mi_i), na.rm = TRUE) > 0) & (show.icons == TRUE)) { plot_icon_array( x_lim = ball_x_lim, @@ -1618,7 +1442,6 @@ plot_fft <- function(level_stats, } } # if (new level on right). - if ((level_stats$exit[level_i] %in% exit_types[c(2, 3)]) | (paste(level_stats$exit[level_i]) %in% paste(exit_types[c(2, 3)], collapse = ", "))) { segments(subplot_center[1], subplot_center[2] + 1, @@ -1691,7 +1514,6 @@ plot_fft <- function(level_stats, pos_dir_symbol <- dir_symbol[which(level_stats$direction[level_i] == c("<=", "<", "=", "!=", ">", ">="))] neg_dir_symbol <- dir_symbol[which(level_stats$direction[level_i] == rev(c("<=", "<", "=", "!=", ">", ">=")))] - text_outline(subplot_center[1] + 1, subplot_center[2], labels = paste(pos_dir_symbol, " ", level_stats$threshold[level_i], sep = ""), @@ -1713,7 +1535,6 @@ plot_fft <- function(level_stats, ) } # if (exit node on right). - if ((level_stats$exit[level_i] %in% exit_types[c(1)]) | (paste(level_stats$exit[level_i]) %in% paste(exit_types[c(1)], collapse = ", "))) { segments(subplot_center[1], subplot_center[2] + 1, @@ -1927,19 +1748,17 @@ plot_confusion <- function(lloc, } plot_roc <- function(lloc, + title = "ROC", main = NULL, header_y = 1, + border_lwd = 1, + border_col = gray(0), subheader_y = .925, header_cex = 1.10, subheader_cex = .90, grayscale = FALSE, tree_stats = NULL, tree = 1) { - # Parameters: - roc_border_lwd <- 1 - roc_border_col <- gray(0) - - roc_title <- "ROC" roc_title_font <- 1 roc_curve_col <- gray(.01) # ~black @@ -1964,9 +1783,6 @@ plot_roc <- function(lloc, roc_title <- main } - roc_border_lwd <- .80 - roc_border_col <- gray(.25) - roc_curve_col <- gray(.10) # "green2" roc_curve_lwd <- 1.5 @@ -1987,7 +1803,7 @@ plot_roc <- function(lloc, # Title: text(lloc$center_x[lloc$element == "roc"], header_y, - labels = roc_title, + labels = title, font = roc_title_font, pos = 1, cex = header_cex ) @@ -2012,8 +1828,8 @@ plot_roc <- function(lloc, final_roc_y[1], final_roc_x[2], final_roc_y[2], - border = roc_border_col, - lwd = roc_border_lwd + border = border_col, + lwd = border_lwd ) # Diagonal: @@ -2092,3 +1908,138 @@ plot_roc <- function(lloc, ) } } + + +plot_icon_guide <- function(what = NULL, + data = NULL, + plot_width = NULL, + plot_height = NULL, + decision.labels = NULL, + noise_ball_pch = NULL, + signal_ball_pch = NULL, + col_correct_border = NULL, + col_error_border = NULL, + col_correct_bg = NULL, + col_error_bg = NULL, + ball_cex = NULL, + show_icon_guide_legend = TRUE) { + # Parameters: + if (what == "ico") { + f_x <- 1.2 # scaling factor (to stretch in x-dim) + f_y <- 0.8 # scaling factor (to shift up) + } else { # default scaling factors: + + f_x <- 1 + f_y <- 1 + } + + get_exit_word <- get_exit_word(data) # either 'train':'decide' or 'test':'predict' + + if (what == "ico") { + leg_head_y <- .02 + leg_ball_y <- .14 + } else { + leg_head_y <- .05 + leg_ball_y <- .15 + } + + text(-plot_width * .60 * f_x, + -plot_height * leg_head_y * f_y, + paste(get_exit_word, decision.labels[1], sep = " "), + cex = 1.2, font = 3 + ) + + points(c(-plot_width * .70, -plot_width * .50) * f_x, + c(-plot_height * leg_ball_y, -plot_height * leg_ball_y) * f_y, + pch = c(noise_ball_pch, signal_ball_pch), + bg = c(col_correct_bg, col_error_bg), + col = c(col_correct_border, col_error_border), + cex = ball_cex * 1.5 + ) + + text(c(-plot_width * .70, -plot_width * .50) * f_x, + c(-plot_height * leg_ball_y, -plot_height * leg_ball_y) * f_y, + labels = c("Correct\nRejection", "Miss"), + pos = c(2, 4), offset = .80, cex = 1 + ) + + text(plot_width * .60 * f_x, + -plot_height * leg_head_y * f_y, + paste(get_exit_word, decision.labels[2], sep = " "), + cex = 1.2, font = 3 + ) + + points(c(plot_width * .50, plot_width * .70) * f_x, + c(-plot_height * leg_ball_y, -plot_height * leg_ball_y) * f_y, + pch = c(noise_ball_pch, signal_ball_pch), + bg = c(col_error_bg, col_correct_bg), + col = c(col_error_border, col_correct_border), + cex = ball_cex * 1.5 + ) + + text(c(plot_width * .50, plot_width * .70) * f_x, + c(-plot_height * leg_ball_y, -plot_height * leg_ball_y) * f_y, + labels = c("False\nAlarm", "Hit"), + pos = c(2, 4), offset = .80, cex = 1 + ) + + if (what == "ico") { + x_hline <- plot_width * 1.0 * f_x + y_hline <- -plot_height * .22 * f_y + + segments(-x_hline, y_hline, x_hline, y_hline, col = col_panel_line, lwd = panel_line_lwd, lty = panel_line_lty) + rect(-x_hline * .33, (y_hline - .5), x_hline * .33, (y_hline + .5), col = "white", border = NA) + } +} + +plot_title <- function(hlines = TRUE, + main = "TITLE", + y = .95, + x_start = 0, + x_end = 1, + y_dev = .2, + x_dev = .15, + col_panel_line = "black", + panel_line_lwd = 1, + panel_line_lty = 1, + panel_title_cex = 3) { + # (a) lines: + if (hlines) { + segments(x_start, y, x_end, y, + col = col_panel_line, + lwd = panel_line_lwd, + lty = panel_line_lty + ) # top hline + + rect((.50 - x_dev), + (1 - y_dev), + (.50 + x_dev), + (1 + y_dev), + col = "white", border = NA + ) # title background + } + + # (b) label: + text(x = .50, y = y, main, cex = panel_title_cex) # title 1 (top): main +} + + +# Pluck +pluck_level_stats <- function(fft, + data_type = c("train", "test"), + tree = 1) { + assert_fft_has_tree(fft, tree) + data_type <- match.arg(data_type) + + out <- fft$trees$level_stats[[data_type]] + + out <- out[out$tree == tree, ] + + return(out) +} + + +# Assert +assert_fft_has_tree <- function(fft, tree) { + assertthat::assert_that(tree %in% fft$trees$level_stats$train$tree) +} From a913f133d4e109b1035be946cb75d04be114e8dd Mon Sep 17 00:00:00 2001 From: Nathaniel Phillips Date: Fri, 24 May 2024 15:52:16 -0400 Subject: [PATCH 10/12] added assertthat to imports --- DESCRIPTION | 1 + 1 file changed, 1 insertion(+) diff --git a/DESCRIPTION b/DESCRIPTION index 60262826..1bd3af1c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -15,6 +15,7 @@ LazyData: true Encoding: UTF-8 Depends: R(>= 3.5.0) Imports: + assertthat, caret, cli, dplyr, From 67475bb2e7d828af3ed62072a960dbdebdcf5c5a Mon Sep 17 00:00:00 2001 From: Nathaniel Phillips Date: Fri, 24 May 2024 15:55:07 -0400 Subject: [PATCH 11/12] bug fix --- R/plotFFTrees_function.R | 3 +++ 1 file changed, 3 insertions(+) diff --git a/R/plotFFTrees_function.R b/R/plotFFTrees_function.R index 9c3ae676..dba491c2 100644 --- a/R/plotFFTrees_function.R +++ b/R/plotFFTrees_function.R @@ -1923,6 +1923,9 @@ plot_icon_guide <- function(what = NULL, col_error_bg = NULL, ball_cex = NULL, show_icon_guide_legend = TRUE) { + + col_panel_line <- "black" + # Parameters: if (what == "ico") { f_x <- 1.2 # scaling factor (to stretch in x-dim) From efa83c1a22e61ed69837f9268e2b7f2f5db3bbba Mon Sep 17 00:00:00 2001 From: Nathaniel Phillips Date: Thu, 30 May 2024 08:22:28 -0400 Subject: [PATCH 12/12] updates to n_per_icon --- R/plotFFTrees_function.R | 56 +++++++++++++++++----------------------- 1 file changed, 24 insertions(+), 32 deletions(-) diff --git a/R/plotFFTrees_function.R b/R/plotFFTrees_function.R index dba491c2..42a3e90f 100644 --- a/R/plotFFTrees_function.R +++ b/R/plotFFTrees_function.R @@ -34,7 +34,7 @@ #' \item{'cues'}{Plot only the marginal accuracy of cues in ROC space. #' Note that cue accuracies are \emph{not} shown when calling \code{what = 'all'} and use the \code{\link{showcues}} function.} #' \item{'icontree'}{Plot tree diagram with icon arrays on exit nodes. -#' Consider also setting \code{n.per.icon} and \code{show.iconguide}.} +#' Consider also setting \code{n_per_icon} and \code{show.iconguide}.} #' \item{'tree'}{Plot only the tree diagram.} #' \item{'roc'}{Plot only the performance of tree(s) (and comparison algorithms) in ROC space.} #' } @@ -74,7 +74,7 @@ #' @param label.tree A label for the FFT (optional, as character string). #' @param label.performance A label for the performance section (optional, as character string). #' -#' @param n.per.icon The number of cases represented by each icon (as numeric). +#' @param n_per_icon The number of cases represented by each icon (as numeric). #' @param level.type The type of performance levels to be drawn at the bottom (as character string, either \code{"bar"} or \code{"line"}. #' Default: \code{level.type = "bar"}. #' @@ -114,7 +114,7 @@ #' #' # Visualize tree diagram with icon arrays on exit nodes: #' plot(heart_fft, -#' what = "icontree", n.per.icon = 2, +#' what = "icontree", n_per_icon = 2, #' main = "Diagnosing heart disease" #' ) #' @@ -127,7 +127,7 @@ #' main = "Predicting heart disease", #' cue.labels = c("1. thal?", "2. cp?", "3. ca?", "4. exang"), #' decision.labels = c("ok", "treat"), truth.labels = c("Healthy", "Sick"), -#' n.per.icon = 2, +#' n_per_icon = 2, #' show.header = TRUE, show.confusion = TRUE, show.levels = TRUE, show.roc = TRUE, #' hlines = FALSE, font = 3, col = "steelblue" #' ) @@ -177,7 +177,7 @@ plot.FFTrees <- function(x = NULL, hlines = TRUE, label.tree = NULL, label.performance = NULL, - n.per.icon = NULL, + n_per_icon = NULL, level.type = "bar", # deprecated arguments: which.tree = NULL, # deprecated: Use tree instead. @@ -568,7 +568,7 @@ plot.FFTrees <- function(x = NULL, plotting_parameters_df <- data.frame( n_levels = 1:6, plot_height = c(10, 12, 15, 19, 23, 25), - plot_width = c(14, 16, 20, 24, 28, 32) * 0.80, # stretch wider (but not too wide for n.per.icon = 1) + plot_width = c(14, 16, 20, 24, 28, 32) * 0.80, # stretch wider (but not too wide for n_per_icon = 1) label_box_text_cex = cue.cex, break_label_cex = threshold.cex ) @@ -638,16 +638,6 @@ plot.FFTrees <- function(x = NULL, ball_box_fixed_x_shift <- c(ball_box_min_shift_p * plot_width, ball_box_max_shift_p * plot_width) - # Determine N per ball: - if (is.null(n.per.icon)) { - max_n_side <- max(c(n_pos_cases, n_neg_cases)) - - i <- max_n_side / c(1, 5, 10^(1:10)) - i[i > 50] <- 0 - - n.per.icon <- c(1, 5, 10^(1:10))[which(i == max(i))] - } - noise_ball_pch <- ball_pch[1] signal_ball_pch <- ball_pch[2] noise_ball_col <- ball_col[1] @@ -713,7 +703,7 @@ plot.FFTrees <- function(x = NULL, bg_vec = c(noise_ball_bg, signal_ball_bg), col_vec = c(noise_ball_col, signal_ball_col), ball_cex = ball_cex, - n_per_icon = n.per.icon, + n_per_icon = n_per_icon, truth.labels = truth.labels, show_truth_labels = TRUE, show_exemplar_total = TRUE @@ -807,7 +797,7 @@ plot.FFTrees <- function(x = NULL, decision.labels = decision.labels, ball_loc = ball_loc, show.icons = show.icons, - n.per.icon = n.per.icon, + n_per_icon = n_per_icon, grayscale = grayscale, add = TRUE ) @@ -844,7 +834,6 @@ plot.FFTrees <- function(x = NULL, par(xpd = FALSE) } # if (what != "roc"). - # Level parameters: level_height_max <- .65 level_width <- .05 @@ -1096,15 +1085,9 @@ plot_icon_array <- function(x_lim = c(-10, 0), # box_y_center <- sum(y_lim) / 2 # is NOT used anywhere? # box_x_width <- x_lim[2] - x_lim[1] # is NOT used anywhere? - if (is.null(n_per_icon)) { # determine cases per ball/icon: - max_n_side <- max(c(a_n, b_n)) - - i <- max_n_side / c(1, 5, 10, 50, 100, 1000, 10000) - i[i > 50] <- 0 - - n_per_icon <- c(1, 5, 10, 50, 100, 1000, 10000)[which(i == max(i))] + n_per_icon <- calculate_n_per_icon(max(c(a_n, b_n))) } # Determine general ball/icon locations: @@ -1168,7 +1151,7 @@ plot_icon_array <- function(x_lim = c(-10, 0), }) if (show_legend) { - text(.98, 0, labels = paste("Showing ", n.per.icon, " cases per icon:", sep = ""), pos = 2) + text(.98, 0, labels = paste("Showing ", n_per_icon, " cases per icon:", sep = ""), pos = 2) points(.98, 0, pch = noise_ball_pch, cex = ball_cex) points(.99, 0, pch = signal_ball_pch, cex = ball_cex) } @@ -1185,7 +1168,7 @@ plot_fft <- function(level_stats = NULL, show.icons = TRUE, plot_width = NULL, plot_height = NULL, - n.per.icon = NULL, + n_per_icon = NULL, grayscale = FALSE, add = FALSE) { subplot_center <- c(0, -4) @@ -1275,6 +1258,10 @@ plot_fft <- function(level_stats = NULL, cue.labels <- level_stats$cue + if (is.null(n_per_icon)) { + n_per_icon <- calculate_n_per_icon(max(c(level_stats$hi, level_stats$fa, level_stats$mi, level_stats$cr))) + } + if (!add) { plot.new() @@ -1376,7 +1363,7 @@ plot_fft <- function(level_stats = NULL, bg_vec = c(col_correct_bg, col_error_bg), col_vec = c(col_correct_border, col_error_border), freq_text = TRUE, - n_per_icon = n.per.icon, + n_per_icon = n_per_icon, show_truth_labels = FALSE, show_exemplar_total = FALSE ) @@ -1504,7 +1491,7 @@ plot_fft <- function(level_stats = NULL, bg_vec = c(col_error_bg, col_correct_bg), col_vec = c(col_error_border, col_correct_border), freq_text = TRUE, - n_per_icon = n.per.icon, + n_per_icon = n_per_icon, show_truth_labels = FALSE, show_exemplar_total = FALSE ) } @@ -1923,7 +1910,6 @@ plot_icon_guide <- function(what = NULL, col_error_bg = NULL, ball_cex = NULL, show_icon_guide_legend = TRUE) { - col_panel_line <- "black" # Parameters: @@ -2041,8 +2027,14 @@ pluck_level_stats <- function(fft, return(out) } - # Assert assert_fft_has_tree <- function(fft, tree) { assertthat::assert_that(tree %in% fft$trees$level_stats$train$tree) } + +calculate_n_per_icon <- function(n_max) { + i <- n_max / c(1, 5, 10, 50, 100, 1000, 10000, 100000) + i[i > 50] <- 0 + + n_per_icon <- c(1, 5, 10, 50, 100, 1000, 10000, 100000)[which(i == max(i))] +}