From 298c2491c7240da71dc007febc6c08b803d68e02 Mon Sep 17 00:00:00 2001 From: Marc Bosch Date: Thu, 23 Apr 2026 13:22:00 +0200 Subject: [PATCH 1/7] first try for type meanse --- R/align_layer.R | 41 +- R/assertions.R | 204 +++++++-- R/bubble.R | 61 ++- R/by_aesthetics.R | 188 +++++++-- R/dodge.R | 25 +- R/environment.R | 14 +- R/facet.R | 542 ++++++++++++++++++------ R/get_saved_par.R | 47 ++- R/hooks.R | 2 - R/legend.R | 121 ++++-- R/legend_gradient.R | 29 +- R/legend_multi.R | 17 +- R/lim.R | 43 +- R/sanitize_axes.R | 9 +- R/sanitize_datapoints.R | 36 +- R/sanitize_facet.R | 2 +- R/sanitize_ribbon_alpha.R | 4 +- R/sanitize_type.R | 114 ++--- R/sanitize_xylab.R | 16 +- R/setup_device.R | 47 ++- R/tinyAxis.R | 20 +- R/tinyformula.R | 44 +- R/tinylabel.R | 20 +- R/tinyplot.R | 740 ++++++++++++++++++++------------- R/tinyplot_add.R | 1 - R/tinytheme.R | 375 ++++++++++------- R/title.R | 13 +- R/tpar.R | 331 +++++++++++---- R/type_abline.R | 27 +- R/type_area.R | 75 ++-- R/type_barplot.R | 382 ++++++++++------- R/type_boxplot.R | 282 +++++++------ R/type_density.R | 238 ++++++----- R/type_errorbar.R | 98 ++--- R/type_glm.R | 152 ++++--- R/type_histogram.R | 246 ++++++----- R/type_hline.R | 22 +- R/type_jitter.R | 156 +++---- R/type_lines.R | 54 +-- R/type_lm.R | 109 ++--- R/type_loess.R | 110 +++-- R/type_meanse.R | 110 +++++ R/type_pointrange.R | 59 +-- R/type_points.R | 17 +- R/type_polygon.R | 42 +- R/type_polypath.R | 55 +-- R/type_rect.R | 46 ++- R/type_ribbon.R | 213 ++++++---- R/type_ridge.R | 493 +++++++++++++++------- R/type_rug.R | 65 ++- R/type_segments.R | 31 +- R/type_spineplot.R | 846 +++++++++++++++++++++++--------------- R/type_spline.R | 106 +++-- R/type_summary.R | 6 +- R/type_text.R | 4 +- R/type_violin.R | 467 ++++++++++++--------- R/type_vline.R | 22 +- R/utils.R | 27 +- 58 files changed, 4995 insertions(+), 2671 deletions(-) create mode 100644 R/type_meanse.R diff --git a/R/align_layer.R b/R/align_layer.R index 1ed43fb3..d349ae79 100644 --- a/R/align_layer.R +++ b/R/align_layer.R @@ -3,23 +3,36 @@ align_layer = function(settings) { # Retrieve xlabs and plot/device metadata from original layer tinyplot_env = get(".tinyplot_env", envir = parent.env(environment())) - xlabs_orig = tryCatch(get("xlabs_orig", envir = tinyplot_env), error = function(e) NULL) - usr_orig = tryCatch(get("usr_orig", envir = tinyplot_env), error = function(e) NULL) - dev_orig = tryCatch(get("dev_orig", envir = tinyplot_env), error = function(e) NULL) - + xlabs_orig = tryCatch( + get("xlabs_orig", envir = tinyplot_env), + error = function(e) NULL + ) + usr_orig = tryCatch( + get("usr_orig", envir = tinyplot_env), + error = function(e) NULL + ) + dev_orig = tryCatch( + get("dev_orig", envir = tinyplot_env), + error = function(e) NULL + ) + # Validate that we're adding to the same plot (not a stale xlabs from previous plot) if (is.null(usr_orig) || is.null(dev_orig) || dev_orig != dev.cur()) { return(invisible()) } # Normalize current usr for comparison (accounting for flipped plots) - usr_layer = if (isTRUE(settings$flip)) par("usr")[c(3,4,1,2)] else par("usr") + usr_layer = if (isTRUE(settings$flip)) { + par("usr")[c(3, 4, 1, 2)] + } else { + par("usr") + } if (!identical(usr_orig, usr_layer)) { return(invisible()) } - + # xlabs of current layer xlabs_layer = settings[["xlabs"]] - + # Only adjust if original layer has named xlabs if (!is.null(names(xlabs_orig))) { if (is.factor(settings$datapoints[["x"]])) { @@ -30,16 +43,20 @@ align_layer = function(settings) { settings$datapoints[["x"]] } ) - settings$datapoints = settings$datapoints[order(settings$datapoints[["x"]]), ] + settings$datapoints = settings$datapoints[ + order(settings$datapoints[["x"]]), + ] } else if (!is.null(names(xlabs_layer))) { # Case 2: match implicit integer -> label mapping (e.g., lines added to errorbars) if (setequal(names(xlabs_layer), names(xlabs_orig))) { # If mappings already agree and no dodge, no realignment needed - if (identical(xlabs_layer, xlabs_orig) && is.null(settings$dodge)) return(invisible()) + if (identical(xlabs_layer, xlabs_orig) && is.null(settings$dodge)) { + return(invisible()) + } orig_order = xlabs_orig[names(xlabs_layer)[settings$datapoints[["x"]]]] x_layer = settings$datapoints[["x"]] if (is.null(settings$dodge)) { - x_new = x_layer[orig_order] + x_new = x_layer[orig_order] } else { names(x_layer) = names(xlabs_layer)[round(x_layer)] x_new = x_layer + (xlabs_orig[names(round(x_layer))] - round(x_layer)) @@ -51,7 +68,9 @@ align_layer = function(settings) { settings$datapoints[[v]] = x_new } } - settings$datapoints = settings$datapoints[order(settings$datapoints[["x"]]), ] + settings$datapoints = settings$datapoints[ + order(settings$datapoints[["x"]]), + ] settings$datapoints[["rowid"]] = seq_len(nrow(settings$datapoints)) } } diff --git a/R/assertions.R b/R/assertions.R index 5e48f97d..732dfecf 100644 --- a/R/assertions.R +++ b/R/assertions.R @@ -10,11 +10,18 @@ check_dependency = function(library_name) { assert_dependency = function(library_name) { flag = check_dependency(library_name) - if (!isTRUE(flag)) stop(flag, call. = FALSE) + if (!isTRUE(flag)) { + stop(flag, call. = FALSE) + } return(invisible()) } -assert_choice = function(x, choice, null.ok = FALSE, name = as.character(substitute(x))) { +assert_choice = function( + x, + choice, + null.ok = FALSE, + name = as.character(substitute(x)) +) { if (is.null(x) && isTRUE(null.ok)) { return(TRUE) } @@ -56,7 +63,11 @@ check_string = function(x, null.ok = FALSE) { return(FALSE) } -assert_string = function(x, null.ok = FALSE, name = as.character(substitute(x))) { +assert_string = function( + x, + null.ok = FALSE, + name = as.character(substitute(x)) +) { msg = sprintf("`%s` must be a string.", name) if (!isTRUE(check_string(x, null.ok = null.ok))) { stop(msg, call. = FALSE) @@ -80,17 +91,30 @@ assert_flag = function(x, null.ok = FALSE, name = as.character(substitute(x))) { } } -assert_length = function(x, len = 1, null.ok = FALSE, name = as.character(substitute(x))) { +assert_length = function( + x, + len = 1, + null.ok = FALSE, + name = as.character(substitute(x)) +) { if (is.null(x) && isTRUE(null.ok)) { return(invisible(TRUE)) } - msg = sprintf("`%s` must be one of these lengths: %s", name, paste(len, collapse = ", ")) + msg = sprintf( + "`%s` must be one of these lengths: %s", + name, + paste(len, collapse = ", ") + ) if (!length(x) %in% len) { stop(msg, call. = FALSE) } } -assert_logical = function(x, null.ok = FALSE, name = as.character(substitute(x))) { +assert_logical = function( + x, + null.ok = FALSE, + name = as.character(substitute(x)) +) { if (is.null(x) && isTRUE(null.ok)) { return(invisible(TRUE)) } @@ -99,7 +123,13 @@ assert_logical = function(x, null.ok = FALSE, name = as.character(substitute(x)) } -check_integerish = function(x, len = NULL, lower = NULL, upper = NULL, null.ok = TRUE) { +check_integerish = function( + x, + len = NULL, + lower = NULL, + upper = NULL, + null.ok = TRUE +) { if (is.null(x) && isTRUE(null.ok)) { return(TRUE) } @@ -122,23 +152,62 @@ check_integerish = function(x, len = NULL, lower = NULL, upper = NULL, null.ok = return(TRUE) } -assert_integerish = function(x, len = NULL, lower = NULL, upper = NULL, null.ok = FALSE, name = as.character(substitute(x))) { +assert_integerish = function( + x, + len = NULL, + lower = NULL, + upper = NULL, + null.ok = FALSE, + name = as.character(substitute(x)) +) { if (isTRUE(null.ok) && is.null(x)) { return(invisible()) } msg = sprintf("`%s` must be integer-ish", name) - if (is.null(x) && !isTRUE(null.ok)) stop(sprintf("%s should not be NULL.", name), call. = FALSE) - if (!isTRUE(check_integerish(x, len = len, lower = lower, upper = upper, null.ok = null.ok))) { - if (!is.numeric(x)) msg = paste0(msg, "; it is not numeric") - if (!is.null(len) && length(x) != len) msg = paste0(msg, sprintf("; its length must be %s", len)) - if (!is.null(lower) && any(x < lower)) msg = paste0(msg, sprintf("; all values must be greater than or equal to %s", lower)) - if (!is.null(upper) && any(x > upper)) msg = paste0(msg, sprintf("; all values must be less than or equal to %s", upper)) - if (isTRUE(any(abs(x - round(x)) > (.Machine$double.eps)^0.5))) msg = paste0(msg, "; all values must be close to integers") + if (is.null(x) && !isTRUE(null.ok)) { + stop(sprintf("%s should not be NULL.", name), call. = FALSE) + } + if ( + !isTRUE(check_integerish( + x, + len = len, + lower = lower, + upper = upper, + null.ok = null.ok + )) + ) { + if (!is.numeric(x)) { + msg = paste0(msg, "; it is not numeric") + } + if (!is.null(len) && length(x) != len) { + msg = paste0(msg, sprintf("; its length must be %s", len)) + } + if (!is.null(lower) && any(x < lower)) { + msg = paste0( + msg, + sprintf("; all values must be greater than or equal to %s", lower) + ) + } + if (!is.null(upper) && any(x > upper)) { + msg = paste0( + msg, + sprintf("; all values must be less than or equal to %s", upper) + ) + } + if (isTRUE(any(abs(x - round(x)) > (.Machine$double.eps)^0.5))) { + msg = paste0(msg, "; all values must be close to integers") + } stop(msg, call. = FALSE) } } -check_numeric = function(x, len = NULL, lower = NULL, upper = NULL, null.ok = TRUE) { +check_numeric = function( + x, + len = NULL, + lower = NULL, + upper = NULL, + null.ok = TRUE +) { if (is.null(x) && isTRUE(null.ok)) { return(TRUE) } @@ -157,27 +226,72 @@ check_numeric = function(x, len = NULL, lower = NULL, upper = NULL, null.ok = TR return(TRUE) } -assert_numeric = function(x, len = NULL, lower = NULL, upper = NULL, null.ok = FALSE, name = as.character(substitute(x))) { +assert_numeric = function( + x, + len = NULL, + lower = NULL, + upper = NULL, + null.ok = FALSE, + name = as.character(substitute(x)) +) { msg = sprintf("`%s` must be numeric", name) - if (!isTRUE(check_numeric(x, len = len, lower = lower, upper = upper, null.ok = null.ok))) { - if (!is.null(len) && length(x) != len) msg = paste0(msg, sprintf("; its length must be %s", len)) - if (!is.null(lower) && any(x < lower)) msg = paste0(msg, sprintf("; all values must be greater than or equal to %s", lower)) - if (!is.null(upper) && any(x > upper)) msg = paste0(msg, sprintf("; all values must be less than or equal to %s", upper)) + if ( + !isTRUE(check_numeric( + x, + len = len, + lower = lower, + upper = upper, + null.ok = null.ok + )) + ) { + if (!is.null(len) && length(x) != len) { + msg = paste0(msg, sprintf("; its length must be %s", len)) + } + if (!is.null(lower) && any(x < lower)) { + msg = paste0( + msg, + sprintf("; all values must be greater than or equal to %s", lower) + ) + } + if (!is.null(upper) && any(x > upper)) { + msg = paste0( + msg, + sprintf("; all values must be less than or equal to %s", upper) + ) + } stop(msg, call. = FALSE) } } -assert_data_frame = function(x, min_rows = 0, min_cols = 0, name = as.character(substitute(x))) { +assert_data_frame = function( + x, + min_rows = 0, + min_cols = 0, + name = as.character(substitute(x)) +) { msg = sprintf("`%s` must be a data.frame.", name) - if (!is.data.frame(x)) stop(msg, call. = FALSE) + if (!is.data.frame(x)) { + stop(msg, call. = FALSE) + } msg = sprintf("Number of rows in `%s` must be at least `%s`", name, min_rows) - if (nrow(x) < min_rows) stop(msg, call. = FALSE) - msg = sprintf("Number of columns in `%s` must be at least `%s`", name, min_cols) + if (nrow(x) < min_rows) { + stop(msg, call. = FALSE) + } + msg = sprintf( + "Number of columns in `%s` must be at least `%s`", + name, + min_cols + ) if (ncol(x) < min_cols) stop(msg, call. = FALSE) } -check_character = function(x, len = NULL, null.ok = FALSE, name = as.character(substitute(x))) { +check_character = function( + x, + len = NULL, + null.ok = FALSE, + name = as.character(substitute(x)) +) { if (isTRUE(null.ok) && is.null(x)) { return(TRUE) } else if (!is.character(x)) { @@ -190,7 +304,12 @@ check_character = function(x, len = NULL, null.ok = FALSE, name = as.character(s return(TRUE) } -assert_character = function(x, len = NULL, null.ok = FALSE, name = as.character(substitute(x))) { +assert_character = function( + x, + len = NULL, + null.ok = FALSE, + name = as.character(substitute(x)) +) { flag = check_character(x, len = len, null.ok = null.ok, name = name) if (!isTRUE(flag)) { stop(flag, call. = FALSE) @@ -199,11 +318,19 @@ assert_character = function(x, len = NULL, null.ok = FALSE, name = as.character( } } -assert_list = function(x, named = FALSE, len = NULL, null.ok = FALSE, name = as.character(substitute(x))) { +assert_list = function( + x, + named = FALSE, + len = NULL, + null.ok = FALSE, + name = as.character(substitute(x)) +) { if (isTRUE(null.ok) && is.null(x)) { return(invisible(TRUE)) } - if (!is.list(x)) stop("Input is not a list.", call. = FALSE) + if (!is.list(x)) { + stop("Input is not a list.", call. = FALSE) + } if (isTRUE(named)) { if (is.null(names(x))) { stop(sprintf("`%s` should be named list.", name), call. = FALSE) @@ -216,7 +343,11 @@ assert_list = function(x, named = FALSE, len = NULL, null.ok = FALSE, name = as. } } -assert_function = function(x, null.ok = FALSE, name = as.character(substitute(x))) { +assert_function = function( + x, + null.ok = FALSE, + name = as.character(substitute(x)) +) { if (isTRUE(null.ok) && is.null(x)) { return(invisible(TRUE)) } @@ -226,7 +357,11 @@ assert_function = function(x, null.ok = FALSE, name = as.character(substitute(x) } } -check_atomic_vector = function(x, null.ok = FALSE, name = as.character(substitute(x))) { +check_atomic_vector = function( + x, + null.ok = FALSE, + name = as.character(substitute(x)) +) { if (isTRUE(null.ok) && is.null(x)) { return(invisible(TRUE)) } @@ -243,7 +378,11 @@ check_atomic_vector = function(x, null.ok = FALSE, name = as.character(substitut return(out) } -assert_atomic_vector = function(x, null.ok = FALSE, name = as.character(substitute(x))) { +assert_atomic_vector = function( + x, + null.ok = FALSE, + name = as.character(substitute(x)) +) { flag = check_atomic_vector(x, null.ok = null.ok, name = name) if (!isTRUE(flag)) { stop(flag, call. = FALSE) @@ -258,4 +397,3 @@ assert_class = function(x, classname) { stop(msg, call. = FALSE) } } - diff --git a/R/bubble.R b/R/bubble.R index 424ac5c8..335afe3c 100644 --- a/R/bubble.R +++ b/R/bubble.R @@ -1,55 +1,74 @@ bubble = function(settings) { # Only process for points and text types - if (!(settings$type %in% c("p", "text"))) return(invisible()) - + if (!(settings$type %in% c("p", "text"))) { + return(invisible()) + } + cex = settings$cex - + # Only process if cex is a vector matching data length - if (is.null(cex) || length(cex) != nrow(settings$datapoints)) return(invisible()) - + if (is.null(cex) || length(cex) != nrow(settings$datapoints)) { + return(invisible()) + } + clim = settings$clim %||% c(0.5, 2.5) - + bubble = TRUE - + ## Identify the pretty break points for our bubble labels bubble_labs = pretty(cex, n = 5) len_labs = length(bubble_labs) cex = rescale_num(sqrt(c(bubble_labs, cex)) / pi, to = clim) bubble_cex = cex[1:len_labs] - cex = cex[(len_labs+1):length(cex)] - + cex = cex[(len_labs + 1):length(cex)] + # catch for cases where pretty breaks leads to smallest category of 0 if (bubble_labs[1] == 0) { bubble_labs = bubble_labs[-1] bubble_cex = bubble_cex[-1] } names(bubble_cex) = format(bubble_labs) - + if (max(clim) > 2.5) { settings$legend_args[["x.intersp"]] = max(clim) / 2.5 settings$legend_args[["y.intersp"]] = sapply(bubble_cex / 2.5, max, 1) } ## fixme: can't assign pt.cex here b/c of dual legend gotcha (don't want to - ## override the "normal" pt.cex too) + ## override the "normal" pt.cex too) # legend_args[["pt.cex"]] = legend_args[["pt.cex"]] %||% (settings[["cex"]] %||% par("cex")) - + # Must update settings with bubble/bubble_cex/cex before calling sanitize_bubble env2env(environment(), settings, c("bubble", "bubble_cex", "cex")) - + sanitize_bubble(settings) } sanitize_bubble = function(settings) { - env2env(settings, environment(), c("datapoints", "pch", "alpha", "bg", "cex", "bubble")) - - if (!bubble) return(invisible()) - + env2env( + settings, + environment(), + c("datapoints", "pch", "alpha", "bg", "cex", "bubble") + ) + + if (!bubble) { + return(invisible()) + } + datapoints[["cex"]] = cex - bubble_pch = if (!is.null(pch) && length(pch)==1) pch else par("pch") + bubble_pch = if (!is.null(pch) && length(pch) == 1) pch else par("pch") bubble_alpha = if (!is.null(alpha)) alpha else 1 - bubble_bg_alpha = if (!is.null(bg) && length(bg)==1 && is.numeric(bg) && bg > 0 && bg <=1) bg else 1 + bubble_bg_alpha = if ( + !is.null(bg) && length(bg) == 1 && is.numeric(bg) && bg > 0 && bg <= 1 + ) { + bg + } else { + 1 + } - env2env(environment(), settings, c("datapoints", "bubble_pch", "bubble_alpha", "bubble_bg_alpha")) + env2env( + environment(), + settings, + c("datapoints", "bubble_pch", "bubble_alpha", "bubble_bg_alpha") + ) } - diff --git a/R/by_aesthetics.R b/R/by_aesthetics.R index 39803346..ba018f28 100755 --- a/R/by_aesthetics.R +++ b/R/by_aesthetics.R @@ -7,16 +7,33 @@ by_aesthetics = function(settings) { settings, environment(), c( - "datapoints", "by", "type", "null_by", "pch", "bg", "lty", "lwd", - "bubble", "cex", "alpha", "col", "fill", "ribbon.alpha" + "datapoints", + "by", + "type", + "null_by", + "pch", + "bg", + "lty", + "lwd", + "bubble", + "cex", + "alpha", + "col", + "fill", + "ribbon.alpha" ) ) # Detect grouping characteristics by_ordered = FALSE by_continuous = !null_by && inherits(datapoints$by, c("numeric", "integer")) - if (isTRUE(by_continuous) && type %in% c("l", "b", "o", "ribbon", "polygon", "polypath", "boxplot")) { - warning("\nContinuous legends not supported for this plot type. Reverting to discrete legend.") + if ( + isTRUE(by_continuous) && + type %in% c("l", "b", "o", "ribbon", "polygon", "polypath", "boxplot") + ) { + warning( + "\nContinuous legends not supported for this plot type. Reverting to discrete legend." + ) by_continuous = FALSE } else if (!null_by) { by_ordered = is.ordered(by) @@ -66,7 +83,17 @@ by_aesthetics = function(settings) { env2env( environment(), settings, - c("by_continuous", "by_ordered", "ngrps", "pch", "lty", "lwd", "cex", "col", "bg") + c( + "by_continuous", + "by_ordered", + "ngrps", + "pch", + "lty", + "lwd", + "cex", + "col", + "bg" + ) ) } @@ -75,7 +102,6 @@ by_aesthetics = function(settings) { ## helper functions ----- # - apply_alpha = function(cols, alpha, adjustcolor) { if (is.null(cols) || is.null(alpha) || identical(alpha, 0)) { return(cols) @@ -89,8 +115,11 @@ is_by_keyword = function(x) { warn_recycle_colors = function(ncols, ngrps) { warning( - "\nFewer colours (", ncols, ") provided than there are groups (", - ngrps, "). Recycling to make up the shortfall." + "\nFewer colours (", + ncols, + ") provided than there are groups (", + ngrps, + "). Recycling to make up the shortfall." ) } @@ -111,9 +140,20 @@ expand_colors_to_ngrps = function(values, ngrps, gradient) { assert_len_1_or_ngrps = function(x, ngrps, name, allow_character = FALSE) { types = if (allow_character) "numeric or character" else "numeric" valid_type = is.numeric(x) || (allow_character && is.character(x)) - valid = is.atomic(x) && is.vector(x) && valid_type && (length(x) == 1 || length(x) == ngrps) + valid = is.atomic(x) && + is.vector(x) && + valid_type && + (length(x) == 1 || length(x) == ngrps) if (!valid) { - stop(sprintf("`%s` must be `NULL`, or a %s vector of length 1 or %s.", name, types, ngrps), call. = FALSE) + stop( + sprintf( + "`%s` must be `NULL`, or a %s vector of length 1 or %s.", + name, + types, + ngrps + ), + call. = FALSE + ) } } @@ -123,7 +163,14 @@ match_palette_name = function(name, candidates) { } ## Handle direct color input via `col` arg. Returns colors or NULL if not applicable. -resolve_manual_colors = function(col, ngrps, gradient, ordered, alpha, adjustcolor) { +resolve_manual_colors = function( + col, + ngrps, + gradient, + ordered, + alpha, + adjustcolor +) { if (is.null(col) || !is.atomic(col) || !is.vector(col)) { return(NULL) } @@ -145,12 +192,22 @@ resolve_manual_colors = function(col, ngrps, gradient, ordered, alpha, adjustcol } } - if (gradient) cols = rev(cols) + if (gradient) { + cols = rev(cols) + } apply_alpha(cols, alpha, adjustcolor) } ## High-level palette resolution: theme fallback, defaults, then delegate to resolve_palette_spec. -resolve_palette_colors = function(palette, theme_palette, ngrps, ordered, gradient, alpha, adjustcolor) { +resolve_palette_colors = function( + palette, + theme_palette, + ngrps, + ordered, + gradient, + alpha, + adjustcolor +) { palette_choice = palette # Pick theme palette if no explicit palette provided @@ -201,12 +258,21 @@ resolve_palette_colors = function(palette, theme_palette, ngrps, ordered, gradie ) } - if (gradient || ordered) cols = rev(cols) + if (gradient || ordered) { + cols = rev(cols) + } cols } ## Parse palette arg (vector, string, call, or function) into colors. -resolve_palette_spec = function(palette, ngrps, gradient, ordered, alpha, adjustcolor) { +resolve_palette_spec = function( + palette, + ngrps, + gradient, + ordered, + alpha, + adjustcolor +) { cols = NULL if (is.character(palette) && length(palette) > 1) { # Direct color vector @@ -217,7 +283,9 @@ resolve_palette_spec = function(palette, ngrps, gradient, ordered, alpha, adjust idx = match_palette_name(palette, discrete_pals) if (!is.na(idx)) { - if (idx < 1L) stop("'palette' is ambiguous") + if (idx < 1L) { + stop("'palette' is ambiguous") + } matched_name = discrete_pals[idx] max_colors = length(palette.colors(palette = matched_name)) @@ -233,7 +301,9 @@ resolve_palette_spec = function(palette, ngrps, gradient, ordered, alpha, adjust hcl_pals = hcl.pals() idx = match_palette_name(palette, hcl_pals) if (!is.na(idx)) { - if (idx < 1L) stop("'palette' is ambiguous") + if (idx < 1L) { + stop("'palette' is ambiguous") + } cols = hcl.colors(n = ngrps, palette = palette) } else { stop( @@ -259,7 +329,9 @@ resolve_palette_spec = function(palette, ngrps, gradient, ordered, alpha, adjust cols = unlist(args, recursive = TRUE, use.names = FALSE) } else { args[["n"]] = ngrps - if (any(names(args) == "")) args[which(names(args) == "")] = NULL + if (any(names(args) == "")) { + args[which(names(args) == "")] = NULL + } cols = tryCatch( do.call(fun_name, args), error = function(e) do.call(eval(palette), args) @@ -285,18 +357,39 @@ resolve_palette_spec = function(palette, ngrps, gradient, ordered, alpha, adjust ## subsidiary functions ----- # -by_col = function(col, palette, alpha, by_ordered, by_continuous, ngrps, adjustcolor) { +by_col = function( + col, + palette, + alpha, + by_ordered, + by_continuous, + ngrps, + adjustcolor +) { ordered = if (is.null(by_ordered)) FALSE else by_ordered gradient = if (is.null(by_continuous)) FALSE else by_continuous assert_logical(ordered) assert_logical(gradient) - if (is.null(alpha)) alpha = 1 - if (gradient) ngrps = 100L + if (is.null(alpha)) { + alpha = 1 + } + if (gradient) { + ngrps = 100L + } - if (is_by_keyword(col)) col = NULL + if (is_by_keyword(col)) { + col = NULL + } - cols = resolve_manual_colors(col, ngrps, gradient, ordered, alpha, adjustcolor) + cols = resolve_manual_colors( + col, + ngrps, + gradient, + ordered, + alpha, + adjustcolor + ) if (!is.null(cols)) { return(cols) } @@ -316,8 +409,23 @@ by_col = function(col, palette, alpha, by_ordered, by_continuous, ngrps, adjustc } -by_bg = function(bg, fill, col, palette, alpha, by_ordered, by_continuous, ngrps, type, by, ribbon.alpha, adjustcolor) { - if (is.null(bg) && !is.null(fill)) bg = fill +by_bg = function( + bg, + fill, + col, + palette, + alpha, + by_ordered, + by_continuous, + ngrps, + type, + by, + ribbon.alpha, + adjustcolor +) { + if (is.null(bg) && !is.null(fill)) { + bg = fill + } if (!is.null(bg) && length(bg) == 1 && is.numeric(bg) && bg >= 0 && bg <= 1) { alpha = bg bg = "by" @@ -351,7 +459,9 @@ by_pch = function(ngrps, type, pch = NULL) { no_pch = FALSE if (identical(type, "text")) { pch = rep(15, ngrps) - } else if (!type %in% c("p", "b", "o", "pointrange", "errorbar", "boxplot", "qq")) { + } else if ( + !type %in% c("p", "b", "o", "pointrange", "errorbar", "boxplot", "qq") + ) { no_pch = TRUE pch = NULL @@ -383,7 +493,27 @@ by_pch = function(ngrps, type, pch = NULL) { by_lty = function(ngrps, type, lty = NULL) { # We only care about line types, otherwise return NULL - if (!type %in% c("l", "b", "o", "c", "h", "s", "S", "ribbon", "barplot", "boxplot", "rect", "segments", "qq", "abline", "hline", "vline")) { + if ( + !type %in% + c( + "l", + "b", + "o", + "c", + "h", + "s", + "S", + "ribbon", + "barplot", + "boxplot", + "rect", + "segments", + "qq", + "abline", + "hline", + "vline" + ) + ) { lty = NULL # special "by" convenience keyword @@ -466,7 +596,9 @@ by_cex = function(ngrps, type, bubble = FALSE, cex = NULL) { } # placehodler - if (bubble) no_cex = TRUE + if (bubble) { + no_cex = TRUE + } if (!no_cex) { assert_len_1_or_ngrps(cex, ngrps, "cex") diff --git a/R/dodge.R b/R/dodge.R index 3a4242b8..60f120d7 100644 --- a/R/dodge.R +++ b/R/dodge.R @@ -7,7 +7,7 @@ #' columns. #' @param dodge Adjustment parameter for dodging overlapping points or ranges in #' grouped plots along the x-axis (or y-axis for flipped plots). Either: -#' +#' #' - numeric value in the range `[0,1)`. Note that values are scaled #' relative to the spacing of x-axis breaks, e.g. `dodge = 0.1` places the #' outermost groups one-tenth of the way to adjacent breaks, `dodge = 0.5` @@ -15,7 +15,7 @@ #' - logical. If `TRUE`, the dodge width is calculated automatically based on #' the number of groups (0.1 per group for 2-4 groups, 0.45 for 5+ groups). If #' `FALSE` or 0, no dodging is performed. -#' +#' #' Default value is 0 (no dodging). While we do not check, it is _strongly_ #' recommended that dodging only be used in cases where the x-axis comprises a #' limited number of discrete breaks. @@ -51,11 +51,17 @@ dodge_positions = function( if (is.null(settings)) { settings = get("settings", envir = parent.frame()) } - + if (is.logical(dodge)) { if (isTRUE(dodge)) { n = nlevels(datapoints$by) - dodge = if (n == 1) 0 else if (n <= 5) (n - 1) * 0.1 else 0.45 + dodge = if (n == 1) { + 0 + } else if (n <= 5) { + (n - 1) * 0.1 + } else { + 0.45 + } } else { dodge = 0 } @@ -63,20 +69,22 @@ dodge_positions = function( assert_numeric(dodge, len = 1, lower = 0, upper = 1) if (dodge >= 1) { - stop("`dodge` must be in the range [0,1).", call. = FALSE) + stop("`dodge` must be in the range [0,1).", call. = FALSE) } assert_logical(fixed.dodge) - + if (dodge == 0) { return(datapoints) } else if (dodge > 0.5) { warning( - "Argument `dodge = ", dodge, "` exceeds 0.5. ", + "Argument `dodge = ", + dodge, + "` exceeds 0.5. ", "Large dodge values may position outer groups closer to neighboring axis breaks." ) } settings$dodge = dodge - + # Auto-detect columns to dodge if not specified if (is.null(cols)) { cols = c("x", "xmin", "xmax") @@ -106,4 +114,3 @@ dodge_positions = function( datapoints } - diff --git a/R/environment.R b/R/environment.R index e147caa3..314e175c 100644 --- a/R/environment.R +++ b/R/environment.R @@ -4,7 +4,9 @@ ## query environment get_environment_variable = function(name = NULL) { ## either one 'name' or entire environment as list - if(is.null(name)) return(as.list(.tinyplot_env)) + if (is.null(name)) { + return(as.list(.tinyplot_env)) + } name = as.character(name)[1L] return(.tinyplot_env[[name]]) } @@ -13,16 +15,16 @@ get_environment_variable = function(name = NULL) { set_environment_variable = function(...) { ## check for unnamed arguments dots = list(...) - if(is.null(names(dots))) { + if (is.null(names(dots))) { stop("arguments must be named") - } else if(any(names(dots) == "")) { + } else if (any(names(dots) == "")) { warning("ignoring unnamed arguments") dots = dots[names != ""] } - + ## set environment variables - if(length(dots) > 0L) { - for(i in names(dots)) { + if (length(dots) > 0L) { + for (i in names(dots)) { .tinyplot_env[[i]] = dots[[i]] } } diff --git a/R/facet.R b/R/facet.R index fde5f529..956845ad 100644 --- a/R/facet.R +++ b/R/facet.R @@ -1,63 +1,105 @@ #' Draw facet windows -#' +#' #' @description Internal functions called from `tinyplot` in order to draw the -#' plot window with different facets, grids, axes, etc. -#' +#' plot window with different facets, grids, axes, etc. +#' #' `facet_layout` determines the layout of the facets, based on a set of inputs. -#' +#' #' `draw_facet_window` is the main workhorse function for setting the exterior #' plot elements as part of a `tinyplot` call, including adjustment of margins #' for dynamic themes, etc. -#' +#' #' @keywords internal #' @rdname facet draw_facet_window = function( - # add arg first, since that determines what happens (if at all) - add, - # facet-specific args - cex_fct_adj, - facet.args, - facet_newlines, facet_font, facet_rect, facet_text, - facet_col, facet_bg, facet_border, - facet, facets, ifacet, - nfacets, nfacet_cols, nfacet_rows, - # axes args - axes, flip, frame.plot, oxaxis, oyaxis, - xlabs, xlim, null_xlim, xaxt, xaxs, xaxb, xaxl, - ylabs, ylim, null_ylim, yaxt, yaxs, yaxb, yaxl, - asp, log, - # other args (in approx. alphabetical + group ordering) - dots, - draw, - grid, - has_legend, - type, - x, xmax, xmin, - y, ymax, ymin, - tpars = NULL - ) { - - if (is.null(tpars)) tpars = tpar() - + # add arg first, since that determines what happens (if at all) + add, + # facet-specific args + cex_fct_adj, + facet.args, + facet_newlines, + facet_font, + facet_rect, + facet_text, + facet_col, + facet_bg, + facet_border, + facet, + facets, + ifacet, + nfacets, + nfacet_cols, + nfacet_rows, + # axes args + axes, + flip, + frame.plot, + oxaxis, + oyaxis, + xlabs, + xlim, + null_xlim, + xaxt, + xaxs, + xaxb, + xaxl, + ylabs, + ylim, + null_ylim, + yaxt, + yaxs, + yaxb, + yaxl, + asp, + log, + # other args (in approx. alphabetical + group ordering) + dots, + draw, + grid, + has_legend, + type, + x, + xmax, + xmin, + y, + ymax, + ymin, + tpars = NULL +) { + if (is.null(tpars)) { + tpars = tpar() + } + # if add is TRUE, just return inputs without any calculations if (isTRUE(add)) { return(as.list(environment())) } - + # if breaks are provided use these (but only if x/ylabs are null) - if (!is.null(xaxb) && !is.null(xlabs)) xlabs = xaxb - if (!is.null(yaxb) && !is.null(ylabs)) ylabs = yaxb - + if (!is.null(xaxb) && !is.null(xlabs)) { + xlabs = xaxb + } + if (!is.null(yaxb) && !is.null(ylabs)) { + ylabs = yaxb + } + # draw background color only in the grid rectangle grid.bg = get_tpar("grid.bg", tpar_list = tpars) if (!is.null(grid.bg)) { corners = par("usr") - rect(corners[1], corners[3], corners[2], corners[4], col = grid.bg, border = NA) + rect( + corners[1], + corners[3], + corners[2], + corners[4], + col = grid.bg, + border = NA + ) } ## dynamic margins flag dynmar = isTRUE(get_tpar("dynmar", tpar_list = tpars)) - + ## optionally allow to modify and restore the style of axis interval calculation if (!is.null(xaxs) || !is.null(yaxs)) { op = par() @@ -111,7 +153,7 @@ draw_facet_window = function( fmar[3] = fmar[3] + facet_newlines * facet_text / cex_fct_adj omar = par("mar") - + ## Dynamic plot margin adjustments if (dynmar) { if (par("las") %in% 1:2) { @@ -120,16 +162,27 @@ draw_facet_window = function( if (type == "ridge") { yaxlabs = levels(y) } else if (!is.null(ylabs)) { - yaxlabs = if (!is.null(names(ylabs))) names(ylabs) else ylabs + yaxlabs = if (!is.null(names(ylabs))) names(ylabs) else ylabs } else if (type == "boxplot" && isTRUE(flip) && !is.null(xlabs)) { - yaxlabs = if (!is.null(names(xlabs))) names(xlabs) else xlabs + yaxlabs = if (!is.null(names(xlabs))) names(xlabs) else xlabs } else { # yaxl = axTicks(2) - yaxlabs = axisTicks(usr = extendrange(ylim, f = 0.04), log = par("ylog")) + yaxlabs = axisTicks( + usr = extendrange(ylim, f = 0.04), + log = par("ylog") + ) + } + if (!is.null(yaxl)) { + yaxlabs = tinylabel(yaxlabs, yaxl) } - if (!is.null(yaxl)) yaxlabs = tinylabel(yaxlabs, yaxl) # whtsbp = grconvertX(max(strwidth(yaxl, "figure")), from = "nfc", to = "lines") - 1 - whtsbp = grconvertX(max(strwidth(yaxlabs, "figure")), from = "nfc", to = "lines") - grconvertX(0, from = "nfc", to = "lines") - 1 + whtsbp = grconvertX( + max(strwidth(yaxlabs, "figure")), + from = "nfc", + to = "lines" + ) - + grconvertX(0, from = "nfc", to = "lines") - + 1 if (whtsbp > 0) { omar = omar + c(0, whtsbp, 0, 0) * cex_fct_adj fmar[2] = fmar[2] + whtsbp * cex_fct_adj @@ -142,10 +195,22 @@ draw_facet_window = function( if (par("las") %in% 2:3) { # extra whitespace bump on the x axis # xaxlabs = axTicks(1) - xaxlabs = if (is.null(xlabs)) axisTicks(usr = extendrange(xlim, f = 0.04), log = par("xlog")) else - if (!is.null(names(xlabs))) names(xlabs) else xlabs - if (!is.null(xaxl)) xaxlabs = tinylabel(xaxlabs, xaxl) - whtsbp = grconvertX(max(strwidth(xaxlabs, "figure")), from = "nfc", to = "lines") - 1 + xaxlabs = if (is.null(xlabs)) { + axisTicks(usr = extendrange(xlim, f = 0.04), log = par("xlog")) + } else if (!is.null(names(xlabs))) { + names(xlabs) + } else { + xlabs + } + if (!is.null(xaxl)) { + xaxlabs = tinylabel(xaxlabs, xaxl) + } + whtsbp = grconvertX( + max(strwidth(xaxlabs, "figure")), + from = "nfc", + to = "lines" + ) - + 1 if (whtsbp > 0) { omar = omar + c(whtsbp, 0, 0, 0) * cex_fct_adj fmar[1] = fmar[1] + whtsbp * cex_fct_adj @@ -186,23 +251,36 @@ draw_facet_window = function( # Dynamic plot margin adjustments omar = par("mar") omar = omar - c(0, 0, 1, 0) # reduce top whitespace since no facet (title) - if (type == "spineplot") omar[4] = 2.1 # FIXME catch for spineplot RHS axis labs + if (type == "spineplot") { + omar[4] = 2.1 + } # FIXME catch for spineplot RHS axis labs if (par("las") %in% 1:2) { # extra whitespace bump on the y axis ## overrides for ridge and some types that use integer spacing with (named) axis labels ## FXIME if (type == "ridge") { yaxlabs = levels(y) } else if (!is.null(ylabs)) { - yaxlabs = if (!is.null(names(ylabs))) names(ylabs) else ylabs + yaxlabs = if (!is.null(names(ylabs))) names(ylabs) else ylabs } else if (type == "boxplot" && isTRUE(flip) && !is.null(xlabs)) { - yaxlabs = if (!is.null(names(xlabs))) names(xlabs) else xlabs + yaxlabs = if (!is.null(names(xlabs))) names(xlabs) else xlabs } else { # yaxl = axTicks(2) - yaxlabs = axisTicks(usr = extendrange(ylim, f = 0.04), log = par("ylog")) + yaxlabs = axisTicks( + usr = extendrange(ylim, f = 0.04), + log = par("ylog") + ) + } + if (!is.null(yaxl)) { + yaxlabs = tinylabel(yaxlabs, yaxl) } - if (!is.null(yaxl)) yaxlabs = tinylabel(yaxlabs, yaxl) # whtsbp = grconvertX(max(strwidth(yaxlabs, "figure")), from = "nfc", to = "lines") - 1 - whtsbp = grconvertX(max(strwidth(yaxlabs, "figure")), from = "nfc", to = "lines") - grconvertX(0, from = "nfc", to = "lines") - 1 + whtsbp = grconvertX( + max(strwidth(yaxlabs, "figure")), + from = "nfc", + to = "lines" + ) - + grconvertX(0, from = "nfc", to = "lines") - + 1 if (whtsbp > 0) { omar[2] = omar[2] + whtsbp } @@ -210,15 +288,27 @@ draw_facet_window = function( if (par("las") %in% 2:3) { # extra whitespace bump on the x axis # xaxl = axTicks(1) - xaxlabs = if (is.null(xlabs)) axisTicks(usr = extendrange(xlim, f = 0.04), log = par("xlog")) else - if (!is.null(names(xlabs))) names(xlabs) else xlabs - if (!is.null(xaxl)) xaxlabs = tinylabel(xaxlabs, xaxl) - whtsbp = grconvertX(max(strwidth(xaxlabs, "figure")), from = "nfc", to = "lines") - 1 + xaxlabs = if (is.null(xlabs)) { + axisTicks(usr = extendrange(xlim, f = 0.04), log = par("xlog")) + } else if (!is.null(names(xlabs))) { + names(xlabs) + } else { + xlabs + } + if (!is.null(xaxl)) { + xaxlabs = tinylabel(xaxlabs, xaxl) + } + whtsbp = grconvertX( + max(strwidth(xaxlabs, "figure")), + from = "nfc", + to = "lines" + ) - + 1 if (whtsbp > 0) { omar[1] = omar[1] + whtsbp } } - par(mar = omar) + par(mar = omar) } ## Loop over the individual facet windows and draw the plot region @@ -228,7 +318,9 @@ draw_facet_window = function( if (nfacets > 1) { mfgi = ceiling(ii / nfacet_cols) mfgj = ii %% nfacet_cols - if (mfgj == 0) mfgj = nfacet_cols + if (mfgj == 0) { + mfgj = nfacet_cols + } par(mfg = c(mfgi, mfgj)) } @@ -247,7 +339,9 @@ draw_facet_window = function( if (type == "boxplot" && isTRUE(flip)) { log_flip = log if (!is.null(log)) { - if (log == "x") log_flip = "y" + if (log == "x") { + log_flip = "y" + } if (log == "y") log_flip = "x" } do.call( @@ -266,10 +360,10 @@ draw_facet_window = function( yside = 2 } - # axes, frame.plot and grid if (isTRUE(axes) || isTRUE(facet.args[["free"]])) { - args_x = list(x, + args_x = list( + x, side = xside, type = xaxt, labeller = xaxl, @@ -277,7 +371,8 @@ draw_facet_window = function( lwd = get_tpar(c("lwd.xaxs", "lwd.axis"), 1, tpar_list = tpars), lty = get_tpar(c("lty.xaxs", "lty.axis"), 1, tpar_list = tpars) ) - args_y = list(y, + args_y = list( + y, side = yside, type = yaxt, labeller = yaxl, @@ -285,10 +380,35 @@ draw_facet_window = function( lwd = get_tpar(c("lwd.yaxs", "lwd.axis"), 1, tpar_list = tpars), lty = get_tpar(c("lty.yaxs", "lty.axis"), 1, tpar_list = tpars) ) - if (!is.null(xaxb)) args_x$at = xaxb - if (!is.null(yaxb)) args_y$at = yaxb - type_range_x = type %in% c("barplot", "pointrange", "errorbar", "ribbon", "boxplot", "p", "violin") && !is.null(xlabs) - type_range_y = !is.null(ylabs) && (type == "p" || (isTRUE(flip) && type %in% c("barplot", "pointrange", "errorbar", "ribbon", "boxplot", "violin"))) + if (!is.null(xaxb)) { + args_x$at = xaxb + } + if (!is.null(yaxb)) { + args_y$at = yaxb + } + type_range_x = type %in% + c( + "barplot", + "pointrange", + "errorbar", + "ribbon", + "boxplot", + "p", + "violin" + ) && + !is.null(xlabs) + type_range_y = !is.null(ylabs) && + (type == "p" || + (isTRUE(flip) && + type %in% + c( + "barplot", + "pointrange", + "errorbar", + "ribbon", + "boxplot", + "violin" + ))) if (type_range_x) { args_x = modifyList(args_x, list(at = xlabs, labels = names(xlabs))) } @@ -309,31 +429,97 @@ draw_facet_window = function( if (isTRUE(facet.args[["free"]])) { # First, we need to calculate the plot extent and axes range of each # individual facet. - xfree = if (!is.null(facet)) split(c(x, xmin, xmax), facet)[[ii]] else c(x, xmin, xmax) - yfree = if (!is.null(facet)) split(c(y, ymin, ymax), facet)[[ii]] else c(y, ymin, ymax) - if (null_xlim) xlim = range(xfree, na.rm = TRUE) - if (null_ylim) ylim = range(yfree, na.rm = TRUE) + xfree = if (!is.null(facet)) { + split(c(x, xmin, xmax), facet)[[ii]] + } else { + c(x, xmin, xmax) + } + yfree = if (!is.null(facet)) { + split(c(y, ymin, ymax), facet)[[ii]] + } else { + c(y, ymin, ymax) + } + if (null_xlim) { + xlim = range(xfree, na.rm = TRUE) + } + if (null_ylim) { + ylim = range(yfree, na.rm = TRUE) + } xext = extendrange(xlim, f = 0.04) yext = extendrange(ylim, f = 0.04) # We'll save this in a special .fusr env var (list) that we'll re-use # when it comes to plotting the actual elements later if (ii == 1) { - fusr = replicate(4, vector("double", length = nfacets), simplify = FALSE) - assign(".fusr", fusr, envir = get(".tinyplot_env", envir = parent.env(environment()))) + fusr = replicate( + 4, + vector("double", length = nfacets), + simplify = FALSE + ) + assign( + ".fusr", + fusr, + envir = get(".tinyplot_env", envir = parent.env(environment())) + ) } - fusr = get(".fusr", envir = get(".tinyplot_env", envir = parent.env(environment()))) + fusr = get( + ".fusr", + envir = get(".tinyplot_env", envir = parent.env(environment())) + ) fusr[[ii]] = c(xext, yext) - assign(".fusr", fusr, envir = get(".tinyplot_env", envir = parent.env(environment()))) + assign( + ".fusr", + fusr, + envir = get(".tinyplot_env", envir = parent.env(environment())) + ) # Explicitly set (override) the current facet extent par(usr = fusr[[ii]]) # if plot frame is true then print axes per normal... - if (type %in% c("barplot", "pointrange", "errorbar", "ribbon", "boxplot", "p", "violin") && !is.null(xlabs)) { - tinyAxis(xfree, side = xside, at = xlabs, labels = names(xlabs), type = xaxt, labeller = xaxl) + if ( + type %in% + c( + "barplot", + "pointrange", + "errorbar", + "ribbon", + "boxplot", + "p", + "violin" + ) && + !is.null(xlabs) + ) { + tinyAxis( + xfree, + side = xside, + at = xlabs, + labels = names(xlabs), + type = xaxt, + labeller = xaxl + ) } else { tinyAxis(xfree, side = xside, type = xaxt, labeller = xaxl) } - if (isTRUE(flip) && type %in% c("barplot", "pointrange", "errorbar", "ribbon", "boxplot", "p", "violin") && !is.null(ylabs)) { - tinyAxis(yfree, side = yside, at = ylabs, labels = names(ylabs), type = yaxt, labeller = yaxl) + if ( + isTRUE(flip) && + type %in% + c( + "barplot", + "pointrange", + "errorbar", + "ribbon", + "boxplot", + "p", + "violin" + ) && + !is.null(ylabs) + ) { + tinyAxis( + yfree, + side = yside, + at = ylabs, + labels = names(ylabs), + type = yaxt, + labeller = yaxl + ) } else { tinyAxis(yfree, side = yside, type = yaxt, labeller = yaxl) } @@ -345,7 +531,9 @@ draw_facet_window = function( do.call(tinyAxis, args_y) } else { # ... else only print the "outside" axes. - if (ii %in% oxaxis) do.call(tinyAxis, args_x) + if (ii %in% oxaxis) { + do.call(tinyAxis, args_x) + } if (ii %in% oyaxis) do.call(tinyAxis, args_y) } } @@ -361,8 +549,12 @@ draw_facet_window = function( # catch for logged axes xlog = isTRUE(par("xlog")) ylog = isTRUE(par("ylog")) - if (xlog) corners[1:2] = 10^(corners[1:2]) - if (ylog) corners[3:4] = 10^(corners[3:4]) + if (xlog) { + corners[1:2] = 10^(corners[1:2]) + } + if (ylog) { + corners[3:4] = 10^(corners[3:4]) + } # special logic for facet grids if (is.null(facet_newlines) || facet_newlines == 0) { facet_title_lines = 1 @@ -376,24 +568,44 @@ draw_facet_window = function( if (isTRUE(facet_rect)) { line_height = (facet_title_lines + .1) * facet_text / cex_fct_adj if (ylog) { - line_height = grconvertY(line_height, from = "lines", to = "user") / grconvertY(0, from = "lines", to = "user") + line_height = grconvertY( + line_height, + from = "lines", + to = "user" + ) / + grconvertY(0, from = "lines", to = "user") rect_height = corners[4] * line_height } else { - line_height = grconvertY(line_height, from = "lines", to = "user") - grconvertY(0, from = "lines", to = "user") + line_height = grconvertY( + line_height, + from = "lines", + to = "user" + ) - + grconvertY(0, from = "lines", to = "user") rect_height = corners[4] + line_height } rect( - corners[1], corners[4], corners[2], rect_height, - col = facet_bg, border = facet_border, + corners[1], + corners[4], + corners[2], + rect_height, + col = facet_bg, + border = facet_border, xpd = NA ) } - xpos = if (xlog) 10^(mean(log10(corners[1:2]))) else mean(corners[1:2]) + xpos = if (xlog) { + 10^(mean(log10(corners[1:2]))) + } else { + mean(corners[1:2]) + } if (ylog) { - ypos = grconvertY(0.4, from = "lines", to = "user") / grconvertY(0, from = "lines", to = "user") + ypos = grconvertY(0.4, from = "lines", to = "user") / + grconvertY(0, from = "lines", to = "user") ypos = corners[4] * ypos } else { - ypos = grconvertY(0.4, from = "lines", to = "user") - grconvertY(0, from = "lines", to = "user") + ypos = grconvertY(0.4, from = "lines", to = "user") - + grconvertY(0, from = "lines", to = "user") ypos = corners[4] + ypos } text( @@ -412,26 +624,46 @@ draw_facet_window = function( if (isTRUE(facet_rect)) { line_height = (facet_title_lines + .1) * facet_text / cex_fct_adj if (xlog) { - line_height = grconvertX(line_height, from = "lines", to = "user") / grconvertX(0, from = "lines", to = "user") + line_height = grconvertX( + line_height, + from = "lines", + to = "user" + ) / + grconvertX(0, from = "lines", to = "user") rect_width = corners[2] * line_height } else { - line_height = grconvertX(line_height, from = "lines", to = "user") - grconvertX(0, from = "lines", to = "user") + line_height = grconvertX( + line_height, + from = "lines", + to = "user" + ) - + grconvertX(0, from = "lines", to = "user") rect_width = corners[2] + line_height } rect( - corners[2], corners[3], rect_width, corners[4], - col = facet_bg, border = facet_border, + corners[2], + corners[3], + rect_width, + corners[4], + col = facet_bg, + border = facet_border, xpd = NA ) } if (xlog) { - xpos = grconvertX(0.4, from = "lines", to = "user") / grconvertX(0, from = "lines", to = "user") + xpos = grconvertX(0.4, from = "lines", to = "user") / + grconvertX(0, from = "lines", to = "user") xpos = corners[2] * xpos } else { - xpos = grconvertX(0.4, from = "lines", to = "user") - grconvertX(0, from = "lines", to = "user") + xpos = grconvertX(0.4, from = "lines", to = "user") - + grconvertX(0, from = "lines", to = "user") xpos = corners[2] + xpos } - ypos = if (ylog) 10^(mean(log10(corners[3:4]))) else mean(corners[3:4]) + ypos = if (ylog) { + 10^(mean(log10(corners[3:4]))) + } else { + mean(corners[3:4]) + } text( x = xpos, y = ypos, @@ -448,24 +680,32 @@ draw_facet_window = function( if (isTRUE(facet_rect)) { line_height = (facet_title_lines + .1) * facet_text / cex_fct_adj if (ylog) { - line_height = grconvertY(line_height, from = "lines", to = "user") / grconvertY(0, from = "lines", to = "user") + line_height = grconvertY(line_height, from = "lines", to = "user") / + grconvertY(0, from = "lines", to = "user") rect_height = corners[4] * line_height } else { - line_height = grconvertY(line_height, from = "lines", to = "user") - grconvertY(0, from = "lines", to = "user") + line_height = grconvertY(line_height, from = "lines", to = "user") - + grconvertY(0, from = "lines", to = "user") rect_height = corners[4] + line_height } rect( - corners[1], corners[4], corners[2], rect_height, - col = facet_bg, border = facet_border, + corners[1], + corners[4], + corners[2], + rect_height, + col = facet_bg, + border = facet_border, xpd = NA ) } xpos = if (xlog) 10^(mean(log10(corners[1:2]))) else mean(corners[1:2]) if (ylog) { - ypos = grconvertY(0.4, from = "lines", to = "user") / grconvertY(0, from = "lines", to = "user") + ypos = grconvertY(0.4, from = "lines", to = "user") / + grconvertY(0, from = "lines", to = "user") ypos = corners[4] * ypos } else { - ypos = grconvertY(0.4, from = "lines", to = "user") - grconvertY(0, from = "lines", to = "user") + ypos = grconvertY(0.4, from = "lines", to = "user") - + grconvertY(0, from = "lines", to = "user") ypos = corners[4] + ypos } text( @@ -482,10 +722,14 @@ draw_facet_window = function( } # plot frame - if (frame.plot) box() + if (frame.plot) { + box() + } # panel grid lines - if (is.null(grid)) grid = get_tpar("grid", tpar_list = tpars) + if (is.null(grid)) { + grid = get_tpar("grid", tpar_list = tpars) + } if (!is.null(grid)) { if (is.logical(grid)) { ## If grid is TRUE create a default grid. Rather than just calling the default grid() @@ -495,22 +739,56 @@ draw_facet_window = function( if (isTRUE(grid)) { gnx = gny = NULL if (!is.null(xaxb)) { - abline(v = xaxb, col = get_tpar("grid.col", tpar_list = tpars), lty = get_tpar("grid.lty", tpar_list = tpars), lwd = get_tpar("grid.lwd", tpar_list = tpars)) + abline( + v = xaxb, + col = get_tpar("grid.col", tpar_list = tpars), + lty = get_tpar("grid.lty", tpar_list = tpars), + lwd = get_tpar("grid.lwd", tpar_list = tpars) + ) gnx = NA } else if (!any(c(par("xlog"), type == "boxplot"))) { - xg = if (!inherits(x, c("POSIXt", "Date"))) axTicks(side = 1) else axTicksDateTime(side = 1, x = x) - abline(v = xg, col = get_tpar("grid.col", tpar_list = tpars), lty = get_tpar("grid.lty", tpar_list = tpars), lwd = get_tpar("grid.lwd", tpar_list = tpars)) + xg = if (!inherits(x, c("POSIXt", "Date"))) { + axTicks(side = 1) + } else { + axTicksDateTime(side = 1, x = x) + } + abline( + v = xg, + col = get_tpar("grid.col", tpar_list = tpars), + lty = get_tpar("grid.lty", tpar_list = tpars), + lwd = get_tpar("grid.lwd", tpar_list = tpars) + ) gnx = NA } if (!is.null(yaxb)) { - abline(h = yaxb, col = get_tpar("grid.col", tpar_list = tpars), lty = get_tpar("grid.lty", tpar_list = tpars), lwd = get_tpar("grid.lwd", tpar_list = tpars)) + abline( + h = yaxb, + col = get_tpar("grid.col", tpar_list = tpars), + lty = get_tpar("grid.lty", tpar_list = tpars), + lwd = get_tpar("grid.lwd", tpar_list = tpars) + ) gny = NA } else if (!any(c(par("ylog"), type == "boxplot"))) { - yg = if (!inherits(y, c("POSIXt", "Date"))) axTicks(side = 2) else axTicksDateTime(side = 2, x = x) - abline(h = yg, col = get_tpar("grid.col", tpar_list = tpars), lty = get_tpar("grid.lty", tpar_list = tpars), lwd = get_tpar("grid.lwd", tpar_list = tpars)) + yg = if (!inherits(y, c("POSIXt", "Date"))) { + axTicks(side = 2) + } else { + axTicksDateTime(side = 2, x = x) + } + abline( + h = yg, + col = get_tpar("grid.col", tpar_list = tpars), + lty = get_tpar("grid.lty", tpar_list = tpars), + lwd = get_tpar("grid.lwd", tpar_list = tpars) + ) gny = NA } - grid(nx = gnx, ny = gny, col = get_tpar("grid.col", tpar_list = tpars), lty = get_tpar("grid.lty", tpar_list = tpars), lwd = get_tpar("grid.lwd", tpar_list = tpars)) + grid( + nx = gnx, + ny = gny, + col = get_tpar("grid.col", tpar_list = tpars), + lty = get_tpar("grid.lty", tpar_list = tpars), + lwd = get_tpar("grid.lwd", tpar_list = tpars) + ) } } else { grid @@ -598,23 +876,33 @@ facet_layout = function(settings) { env2env( environment(), settings, - c("datapoints", "facets", "ifacet", "nfacets", "nfacet_rows", "nfacet_cols", "oxaxis", "oyaxis", "cex_fct_adj") + c( + "datapoints", + "facets", + "ifacet", + "nfacets", + "nfacet_rows", + "nfacet_cols", + "oxaxis", + "oyaxis", + "cex_fct_adj" + ) ) } - # # helper functions # - # utility function for converting facet formulas into variables get_facet_fml = function(formula, data = NULL) { xfacet = yfacet = NULL ## catch one-sided formula ~ x or ~ x | z with no "y" variable - if (!inherits(formula, "formula")) formula = as.formula(formula) + if (!inherits(formula, "formula")) { + formula = as.formula(formula) + } no_yfacet = length(formula) == 2L fml_rhs = if (no_yfacet) 2L else 3L @@ -622,7 +910,14 @@ get_facet_fml = function(formula, data = NULL) { m = match.call(expand.dots = FALSE) if (!is.null(data)) { - m = m[c(1L, match(c("formula", "data", "subset", "na.action", "drop.unused.levels"), names(m), 0L))] + m = m[c( + 1L, + match( + c("formula", "data", "subset", "na.action", "drop.unused.levels"), + names(m), + 0L + ) + )] } m$formula = formula @@ -638,7 +933,9 @@ get_facet_fml = function(formula, data = NULL) { yfacet_loc = 1L xfacet_loc = 2L } - if (NCOL(mf) < xfacet_loc) stop("formula should specify at least one variable on the right-hand side") + if (NCOL(mf) < xfacet_loc) { + stop("formula should specify at least one variable on the right-hand side") + } yfacet = if (no_yfacet) NULL else mf[, yfacet_loc] xfacet = mf[, xfacet_loc:NCOL(mf)] @@ -664,10 +961,11 @@ is_facet_position = function(position, ifacet, facet_window_args) { id = facet_window_args$ifacet nc = facet_window_args$nfacet_cols ni = tail(id, 1L) - switch(position, - "left" = ifacet %in% seq(1L, ni, by = nc), - "right" = ifacet %in% pmin(ni, seq(1L, ni, by = nc) + nc - 1L), - "top" = ifacet %in% head(id, nc), + switch( + position, + "left" = ifacet %in% seq(1L, ni, by = nc), + "right" = ifacet %in% pmin(ni, seq(1L, ni, by = nc) + nc - 1L), + "top" = ifacet %in% head(id, nc), "bottom" = ifacet %in% tail(id, nc), NA ) diff --git a/R/get_saved_par.R b/R/get_saved_par.R index 6998eee6..3303c34e 100644 --- a/R/get_saved_par.R +++ b/R/get_saved_par.R @@ -1,5 +1,5 @@ #' @title Retrieve the saved graphical parameters -#' +#' #' @description Convenience function for retrieving the graphical parameters #' (i.e., the full list of `tag = value` pairs held in #' \code{\link[graphics]{par}}) from either immediately before or @@ -7,7 +7,7 @@ #' #' @param when character. From when should the saved parameters be retrieved? #' Either "before" (the default) or "after" the preceding `tinyplot` call. -#' +#' #' @details A potential side-effect of [tinyplot] is that it can change a user's #' \code{\link[graphics]{par}} settings. For example, it may adjust the inner #' and outer plot margins to make space for an automatic legend; see @@ -21,19 +21,19 @@ #' original graphical parameters after the fact (e.g., once all these extra #' annotations have been added). That is the purpose of this [get_saved_par] #' function. -#' +#' #' Of course, users may prefer to manually capture and reset graphical #' parameters, as per the standard method described in the #' \code{\link[graphics]{par}} documentation. For example: -#' +#' #' ``` -#' op = par(no.readonly = TRUE) # save current par settings +#' op = par(no.readonly = TRUE) # save current par settings #' # #' par(op) # reset original pars #' ``` -#' +#' #' This standard manual approach may be safer than [get_saved_par] because it -#' offers more precise control. Specifically, the value of [get_saved_par] +#' offers more precise control. Specifically, the value of [get_saved_par] #' itself will be reset after ever new [tinyplot] call; i.e. it may inherit an #' already-changed set of parameters. Users should bear these trade-offs in #' mind when deciding which approach to use. As a general rule, @@ -41,21 +41,21 @@ #' \code{\link[graphics]{par}} settings even if a user forgot to save them #' beforehand. But one should avoid invoking it after a series of consecutive #' [tinyplot] calls. -#' +#' #' Finally, note that users can always call \code{\link[grDevices]{dev.off}} #' to reset all \code{\link[graphics]{par}} settings to their defaults. -#' +#' #' @returns A list of \code{\link[graphics]{par}} settings. -#' +#' #' @examples #' # #' # Contrived example where we draw a grouped scatterplot with a legend and #' # manually add corresponding best fit lines for each group... #' # -#' +#' #' # First draw the grouped scatterplot #' tinyplot(Sepal.Length ~ Petal.Length | Species, iris) -#' +#' #' # Preserving adjusted par settings is good for adding elements to our plot #' for (s in levels(iris$Species)) { #' abline( @@ -63,23 +63,23 @@ #' col = which(levels(iris$Species)==s) #' ) #' } -#' +#' #' # Get saved par from before the preceding tinyplot call (but don't use yet) #' sp = get_saved_par("before") -#' +#' #' # Note the changed margins will affect regular plots too, which is probably #' # not desirable #' plot(1:10) -#' +#' #' # Reset the original parameters (could use `par(sp)` here) #' tpar(sp) #' # Redraw our simple plot with our corrected right margin #' plot(1:10) -#' +#' #' # #' # Quick example going the other way, "correcting" for par.restore = TRUE... #' # -#' +#' #' tinyplot(Sepal.Length ~ Petal.Length | Species, iris, restore.par = TRUE) #' # Our added best lines will be wrong b/c of misaligned par #' for (s in levels(iris$Species)) { @@ -97,7 +97,7 @@ #' col = which(levels(iris$Species)==s) #' ) #' } -#' +#' #' # reset again to original saved par settings before exit #' tpar(sp) #' @@ -105,12 +105,19 @@ get_saved_par = function(when = c("before", "after", "first")) { when = match.arg(when) par_env_name = paste0(".saved_par_", when) - return(get(par_env_name, envir = get(".tinyplot_env", envir = parent.env(environment())))) + return(get( + par_env_name, + envir = get(".tinyplot_env", envir = parent.env(environment())) + )) } # (non-exported) companion function(s) for setting the original pars set_saved_par = function(when = c("before", "after", "first"), value) { when = match.arg(when) par_env_name = paste0(".saved_par_", when) - assign(par_env_name, value, envir = get(".tinyplot_env", envir = parent.env(environment()))) + assign( + par_env_name, + value, + envir = get(".tinyplot_env", envir = parent.env(environment())) + ) } diff --git a/R/hooks.R b/R/hooks.R index e04fc085..590eea98 100644 --- a/R/hooks.R +++ b/R/hooks.R @@ -1,8 +1,6 @@ # Copied from https://raw.githubusercontent.com/r-lib/evaluate/refs/heads/main/R/hooks.R # license: MIT + file LICENSE - - #' Set and remove hooks #' #' This interface wraps the base [setHook()] function to provide a return diff --git a/R/legend.R b/R/legend.R index c41ecb71..53aeabe5 100644 --- a/R/legend.R +++ b/R/legend.R @@ -15,7 +15,6 @@ #' @keywords internal sanitize_legend = function(legend, legend_args) { if (is.null(legend_args[["x"]])) { - # Normalize legend to a list largs = if (is.null(legend)) { list(x = "right!") @@ -23,24 +22,32 @@ sanitize_legend = function(legend, legend_args) { list(x = legend) } else if (is.list(legend)) { # Handle unnamed first element as position - if (length(legend) >= 1 && is.character(legend[[1]]) && - (is.null(names(legend)) || names(legend)[1] == "")) { + if ( + length(legend) >= 1 && + is.character(legend[[1]]) && + (is.null(names(legend)) || names(legend)[1] == "") + ) { names(legend)[1] = "x" } legend } else if (inherits(legend, c("call", "name"))) { # Convert call to list and handle unnamed first arg as position - new_legend = as.list(legend)[-1] # Remove function name - if (length(new_legend) >= 1 && (is.null(names(new_legend)) || names(new_legend)[1] == "")) { + new_legend = as.list(legend)[-1] # Remove function name + if ( + length(new_legend) >= 1 && + (is.null(names(new_legend)) || names(new_legend)[1] == "") + ) { names(new_legend)[1] = "x" } new_legend } else { - list(x = "right!") # Fallback + list(x = "right!") # Fallback } # Ensure position exists - if (is.null(largs[["x"]])) largs[["x"]] = "right!" + if (is.null(largs[["x"]])) { + largs[["x"]] = "right!" + } # Merge legend_args = modifyList(legend_args, largs, keep.null = TRUE) @@ -56,15 +63,18 @@ sanitize_legend = function(legend, legend_args) { # Unit conversion helpers (used extensively throughout legend positioning) lines_to_npc_x = function(val) { - grconvertX(val, from = "lines", to = "npc") - grconvertX(0, from = "lines", to = "npc") + grconvertX(val, from = "lines", to = "npc") - + grconvertX(0, from = "lines", to = "npc") } lines_to_user_x = function(val) { - grconvertX(val, from = "lines", to = "user") - grconvertX(0, from = "lines", to = "user") + grconvertX(val, from = "lines", to = "user") - + grconvertX(0, from = "lines", to = "user") } lines_to_user_y = function(val) { - grconvertY(val, from = "lines", to = "user") - grconvertY(0, from = "lines", to = "user") + grconvertY(val, from = "lines", to = "user") - + grconvertY(0, from = "lines", to = "user") } @@ -103,12 +113,14 @@ legend_outer_margins = function(legend_env, apply = TRUE) { par(mar = omar) } } - } else if (legend_env$outer_end) { # Set inner margins before fake legend is drawn if (legend_env$outer_bottom) { omar[1] = par("mgp")[1] + 1 * par("cex.lab") - if (legend_env$has_sub && (is.null(.tpar[["side.sub"]]) || .tpar[["side.sub"]] == 1)) { + if ( + legend_env$has_sub && + (is.null(.tpar[["side.sub"]]) || .tpar[["side.sub"]] == 1) + ) { omar[1] = omar[1] + 1 * par("cex.sub") } } else { @@ -125,7 +137,10 @@ legend_outer_margins = function(legend_env, apply = TRUE) { omar = par("mar") if (legend_env$outer_bottom) { omar[1] = theme_clean$mgp[1] + 1 * par("cex.lab") - if (legend_env$has_sub && (is.null(.tpar[["side.sub"]]) || .tpar[["side.sub"]] == 1)) { + if ( + legend_env$has_sub && + (is.null(.tpar[["side.sub"]]) || .tpar[["side.sub"]] == 1) + ) { omar[1] = omar[1] + 1 * par("cex.sub") } } else { @@ -150,9 +165,11 @@ legend_outer_margins = function(legend_env, apply = TRUE) { # Step 3: Apply soma if drawing if (apply) { soma = if (legend_env$outer_side) { - grconvertX(legend_env$dims$rect$w, to = "lines") - grconvertX(0, to = "lines") + grconvertX(legend_env$dims$rect$w, to = "lines") - + grconvertX(0, to = "lines") } else if (legend_env$outer_end) { - grconvertY(legend_env$dims$rect$h, to = "lines") - grconvertY(0, to = "lines") + grconvertY(legend_env$dims$rect$h, to = "lines") - + grconvertY(0, to = "lines") } else { 0 } @@ -164,7 +181,9 @@ legend_outer_margins = function(legend_env, apply = TRUE) { if (legend_env$outer_bottom) { legend_env$ooma[1] = soma } else { - legend_env$omar[3] = legend_env$omar[3] + soma - legend_env$topmar_epsilon + legend_env$omar[3] = legend_env$omar[3] + + soma - + legend_env$topmar_epsilon par(mar = legend_env$omar) } } @@ -182,23 +201,25 @@ measure_legend_inset = function(legend_env) { inset_val = inset_val + lines_to_npc_x(par("mar")[2]) } c(1 + inset_val, 0) - } else if (legend_env$outer_end) { # Note: Y-direction uses grconvertY (not lines_to_npc_x which is X-only) inset_val = grconvertY(legend_env$lmar[1], from = "lines", to = "npc") - - grconvertY(0, from = "lines", to = "npc") + grconvertY(0, from = "lines", to = "npc") if (legend_env$outer_bottom) { # Extra space needed for "bottom!" because of lhs inner margin inset_bump = grconvertY(par("mar")[1], from = "lines", to = "npc") - - grconvertY(0, from = "lines", to = "npc") + grconvertY(0, from = "lines", to = "npc") inset_val = inset_val + inset_bump } else { - epsilon_bump = grconvertY(legend_env$topmar_epsilon, from = "lines", to = "npc") - - grconvertY(0, from = "lines", to = "npc") + epsilon_bump = grconvertY( + legend_env$topmar_epsilon, + from = "lines", + to = "npc" + ) - + grconvertY(0, from = "lines", to = "npc") inset_val = inset_val + epsilon_bump } c(0, 1 + inset_val) - } else { 0 } @@ -221,9 +242,11 @@ tinylegend = function(legend_env) { # Calculate and apply soma (outer margin adjustment based on legend size) soma = if (legend_env$outer_side) { - grconvertX(legend_env$dims$rect$w, to = "lines") - grconvertX(0, to = "lines") + grconvertX(legend_env$dims$rect$w, to = "lines") - + grconvertX(0, to = "lines") } else if (legend_env$outer_end) { - grconvertY(legend_env$dims$rect$h, to = "lines") - grconvertY(0, to = "lines") + grconvertY(legend_env$dims$rect$h, to = "lines") - + grconvertY(0, to = "lines") } else { 0 } @@ -248,7 +271,11 @@ tinylegend = function(legend_env) { # (Uses hook to preserve existing plot with par(new = TRUE)) oldhook = getHook("before.plot.new") setHook("before.plot.new", function() par(new = TRUE), action = "append") - setHook("before.plot.new", function() par(mar = legend_env$omar), action = "append") + setHook( + "before.plot.new", + function() par(mar = legend_env$omar), + action = "append" + ) plot.new() setHook("before.plot.new", oldhook, action = "replace") @@ -263,7 +290,10 @@ tinylegend = function(legend_env) { if (legend_env$gradient) { # Ensure col is set correctly for gradients if (!more_than_n_unique(legend_env$args[["col"]], 1)) { - if (!is.null(legend_env$args[["pt.bg"]]) && length(legend_env$args[["pt.bg"]]) == 100) { + if ( + !is.null(legend_env$args[["pt.bg"]]) && + length(legend_env$args[["pt.bg"]]) == 100 + ) { legend_env$args[["col"]] = legend_env$args[["pt.bg"]] } } @@ -316,8 +346,6 @@ measure_fake_legend = function(legend_env) { } - - # ## Legend Context & Preparation ----- # @@ -406,13 +434,21 @@ prepare_legend = function(settings) { } } - legend_draw_flag = (is.null(legend) || !is.character(legend) || legend != "none" || bubble) && !isTRUE(add) + legend_draw_flag = (is.null(legend) || + !is.character(legend) || + legend != "none" || + bubble) && + !isTRUE(add) has_sub = !is.null(sub) # Generate labels for discrete legends if (legend_draw_flag && isFALSE(by_continuous) && (!bubble || multi_legend)) { if (ngrps > 1) { - lgnd_labs = if (is.factor(datapoints$by)) levels(datapoints$by) else unique(datapoints$by) + lgnd_labs = if (is.factor(datapoints$by)) { + levels(datapoints$by) + } else { + unique(datapoints$by) + } } else { lgnd_labs = ylab } @@ -490,7 +526,9 @@ build_legend_args = function( legend_args = sanitize_legend(legend, legend_args) # Set defaults - if (!exists("title", where = legend_args)) legend_args[["title"]] = by_dep + if (!exists("title", where = legend_args)) { + legend_args[["title"]] = by_dep + } legend_args[["pch"]] = legend_args[["pch"]] %||% pch legend_args[["lty"]] = legend_args[["lty"]] %||% lty legend_args[["col"]] = legend_args[["col"]] %||% col @@ -520,7 +558,8 @@ build_legend_args = function( if (identical(type, "spineplot")) { legend_args[["pt.bg"]] = legend_args[["pt.bg"]] %||% legend_args[["col"]] } else if (identical(type, "ridge") && isFALSE(gradient)) { - legend_args[["pt.bg"]] = legend_args[["pt.bg"]] %||% sapply(legend_args[["col"]], function(ccol) seq_palette(ccol, n = 2)[2]) + legend_args[["pt.bg"]] = legend_args[["pt.bg"]] %||% + sapply(legend_args[["col"]], function(ccol) seq_palette(ccol, n = 2)[2]) } else { legend_args[["pt.bg"]] = legend_args[["pt.bg"]] %||% bg } @@ -539,7 +578,10 @@ build_legend_args = function( if (!is.null(legend_args[["labeller"]])) { labeller = legend_args[["labeller"]] legend_args[["labeller"]] = NULL - legend_args[["legend"]] = tinylabel(legend_args[["legend"]], labeller = labeller) + legend_args[["legend"]] = tinylabel( + legend_args[["legend"]], + labeller = labeller + ) } if (isTRUE(gradient)) { @@ -574,7 +616,9 @@ build_legend_args = function( # Additional positioning adjustments if (outer_end) { # Enforce horizontal legend if user hasn't specified ncol arg - if (is.null(legend_args[["ncol"]]) || gradient) legend_args[["horiz"]] = TRUE + if (is.null(legend_args[["ncol"]]) || gradient) { + legend_args[["horiz"]] = TRUE + } } else if (!outer_side) { legend_args[["inset"]] = 0 } @@ -590,8 +634,13 @@ build_legend_args = function( # Add a space to all labs except the outermost right ones nlabs = length(legend_args[["legend"]]) nidx = nlabs - if (mcol_flag) nidx = tail(1:nlabs, (nlabs %/% legend_args[["ncol"]])) - legend_args[["legend"]][-nidx] = paste(legend_args[["legend"]][-nidx], " ") + if (mcol_flag) { + nidx = tail(1:nlabs, (nlabs %/% legend_args[["ncol"]])) + } + legend_args[["legend"]][-nidx] = paste( + legend_args[["legend"]][-nidx], + " " + ) } # Catch for horizontal ribbon legend spacing if (type == "ribbon") { diff --git a/R/legend_gradient.R b/R/legend_gradient.R index e00b727b..f657f490 100644 --- a/R/legend_gradient.R +++ b/R/legend_gradient.R @@ -47,10 +47,14 @@ draw_gradient_swatch = function( inner = !any(c(outer_side, outer_end)) inner_right = inner_bottom = FALSE if (inner) { - if (!is.null(legend_args[["x"]]) && grepl("left$|right$", legend_args[["x"]])) { + if ( + !is.null(legend_args[["x"]]) && grepl("left$|right$", legend_args[["x"]]) + ) { inner_right = grepl("right$", legend_args[["x"]]) } - if (!is.null(legend_args[["x"]]) && grepl("^bottoml|^top", legend_args[["x"]])) { + if ( + !is.null(legend_args[["x"]]) && grepl("^bottoml|^top", legend_args[["x"]]) + ) { inner_bottom = grepl("^bottom", legend_args[["x"]]) } } @@ -66,7 +70,6 @@ draw_gradient_swatch = function( rasterbox[2] = fklgnd$rect$top - fklgnd$rect$h - lines_to_user_y(1.5 + 0.2) rasterbox[3] = rasterbox[1] + lines_to_user_x(1.25) rasterbox[4] = rasterbox[2] + fklgnd$rect$h - } else if (outer_side) { rb1_adj = lines_to_user_x(lmar[1] + 0.2) rb3_adj = lines_to_user_x(1.25) @@ -88,7 +91,8 @@ draw_gradient_swatch = function( if (outer_right) { rasterbox[1] = corners[2] + rb1_adj if (user_inset) { - rasterbox[1] = rasterbox[1] - (corners[2] - legend_args[["inset"]][1]) / 2 + rasterbox[1] = rasterbox[1] - + (corners[2] - legend_args[["inset"]][1]) / 2 } rasterbox[2] = rb2_adj rasterbox[3] = rasterbox[1] + rb3_adj @@ -100,7 +104,6 @@ draw_gradient_swatch = function( rasterbox[3] = rasterbox[1] - rb3_adj rasterbox[4] = rasterbox[2] + rb4_adj } - } else if (outer_end) { rb1_adj = (corners[2] - corners[1] - lines_to_user_x(5 + 1)) / 2 rb3_adj = lines_to_user_x(5 + 1) @@ -134,7 +137,13 @@ draw_gradient_swatch = function( # Add labels, tick marks, and title if (isFALSE(horiz)) { - draw_gradient_labels_vertical(rasterbox, lgnd_labs, legend_args, inner, outer_right) + draw_gradient_labels_vertical( + rasterbox, + lgnd_labs, + legend_args, + inner, + outer_right + ) } else { draw_gradient_labels_horizontal(rasterbox, lgnd_labs, legend_args) } @@ -142,7 +151,13 @@ draw_gradient_swatch = function( # Draw vertical gradient legend labels, ticks, and title -draw_gradient_labels_vertical = function(rasterbox, lgnd_labs, legend_args, inner, outer_right) { +draw_gradient_labels_vertical = function( + rasterbox, + lgnd_labs, + legend_args, + inner, + outer_right +) { labs_idx = !is.na(lgnd_labs) lgnd_labs[labs_idx] = paste0(" ", format(lgnd_labs[labs_idx])) diff --git a/R/legend_multi.R b/R/legend_multi.R index 8bc4b082..2771003a 100644 --- a/R/legend_multi.R +++ b/R/legend_multi.R @@ -137,10 +137,9 @@ prepare_legend_multi = function(settings) { #' #' @keywords internal draw_multi_legend = function( - legend_list, - position = "right!" + legend_list, + position = "right!" ) { - # Validate inputs if (!is.list(legend_list) || length(legend_list) != 2) { stop("Currently only 2 legends are supported in multi-legend mode") @@ -175,7 +174,7 @@ draw_multi_legend = function( legend_dims = vector("list", length(legend_list)) for (ll in seq_along(legend_list)) { legend_ll = legend_list[[ll]] - legend_ll$new_plot = ll == 1 # Only draw new plot for first legend + legend_ll$new_plot = ll == 1 # Only draw new plot for first legend legend_ll$draw = FALSE legend_dims[[ll]] = do.call(draw_legend, legend_ll) } @@ -201,7 +200,9 @@ draw_multi_legend = function( width_order = order(lwidths) # Quick idx for original order (needed for vertical legend placement) - for (i in seq_along(legend_list)) legend_list[[i]]$idx = i + for (i in seq_along(legend_list)) { + legend_list[[i]]$idx = i + } for (o in seq_along(width_order)) { io = width_order[o] @@ -210,7 +211,11 @@ draw_multi_legend = function( legend_o$draw = TRUE legend_o$legend_args$inset = c(0, 0) legend_o$legend_args$inset[1] = if (o == 1) -abs(diff(lwidths)) / 2 else 0 - legend_o$legend_args$inset[2] = if (legend_o$idx == 1) linset + 0.01 else 1 - linset + 0.01 + legend_o$legend_args$inset[2] = if (legend_o$idx == 1) { + linset + 0.01 + } else { + 1 - linset + 0.01 + } legend_o$idx = NULL do.call(draw_legend, legend_o) } diff --git a/R/lim.R b/R/lim.R index 7eb13aad..4c22cdaa 100644 --- a/R/lim.R +++ b/R/lim.R @@ -5,9 +5,16 @@ lim_args = function(settings) { settings, environment(), c( - "xaxb", "xlabs", "xlim", "null_xlim", - "yaxb", "ylabs", "ylim", "null_ylim", - "datapoints", "type" + "xaxb", + "xlabs", + "xlim", + "null_xlim", + "yaxb", + "ylabs", + "ylim", + "null_ylim", + "datapoints", + "type" ) ) @@ -23,22 +30,36 @@ lim_args = function(settings) { } if (is.null(xlim)) { - xlim = range(as.numeric(c( - datapoints[["x"]], datapoints[["xmin"]], - datapoints[["xmax"]])), finite = TRUE) + xlim = range( + as.numeric(c( + datapoints[["x"]], + datapoints[["xmin"]], + datapoints[["xmax"]] + )), + finite = TRUE + ) } if (is.null(ylim)) { - ylim = range(as.numeric(c( - datapoints[["y"]], datapoints[["ymin"]], - datapoints[["ymax"]])), finite = TRUE) + ylim = range( + as.numeric(c( + datapoints[["y"]], + datapoints[["ymin"]], + datapoints[["ymax"]] + )), + finite = TRUE + ) } if (identical(type, "boxplot")) { xlim = xlim + c(-0.5, 0.5) } - if (null_xlim && !is.null(xaxb) && type != "spineplot") xlim = range(c(xlim, xaxb)) - if (null_ylim && !is.null(yaxb) && type != "spineplot") ylim = range(c(ylim, yaxb)) + if (null_xlim && !is.null(xaxb) && type != "spineplot") { + xlim = range(c(xlim, xaxb)) + } + if (null_ylim && !is.null(yaxb) && type != "spineplot") { + ylim = range(c(ylim, yaxb)) + } # update settings env2env( diff --git a/R/sanitize_axes.R b/R/sanitize_axes.R index a04dceff..b5e3c6d1 100644 --- a/R/sanitize_axes.R +++ b/R/sanitize_axes.R @@ -9,7 +9,9 @@ sanitize_axes = function(settings) { axes = xaxt = yaxt = "none" } else if (isTRUE(axes)) { axes = "standard" - if (is.null(xaxt)) xaxt = get_tpar("xaxt", default = "standard") + if (is.null(xaxt)) { + xaxt = get_tpar("xaxt", default = "standard") + } if (is.null(yaxt)) yaxt = get_tpar("yaxt", default = "standard") } else { xaxt = yaxt = axes @@ -21,8 +23,9 @@ sanitize_axes = function(settings) { xaxt = substr(match.arg(xaxt, axis_types), 1L, 1L) yaxt = substr(match.arg(yaxt, axis_types), 1L, 1L) axes = any(c(xaxt, yaxt) != "n") - if (is.null(frame.plot) || !is.logical(frame.plot)) frame.plot = all(c(xaxt, yaxt) %in% c("s", "a")) - + if (is.null(frame.plot) || !is.logical(frame.plot)) { + frame.plot = all(c(xaxt, yaxt) %in% c("s", "a")) + } env2env(environment(), settings, c("axes", "xaxt", "yaxt", "frame.plot")) } diff --git a/R/sanitize_datapoints.R b/R/sanitize_datapoints.R index c3d0873c..a9785e12 100644 --- a/R/sanitize_datapoints.R +++ b/R/sanitize_datapoints.R @@ -4,18 +4,33 @@ sanitize_datapoints = function(settings) { settings, environment(), c( - "x", "xmin", "xmax", "xaxt", - "y", "ymin", "ymax", "ygroup", - "facet", "null_by", "by", "type" + "x", + "xmin", + "xmax", + "xaxt", + "y", + "ymin", + "ymax", + "ygroup", + "facet", + "null_by", + "by", + "type" ) ) ## coerce character and logical variables to factors ## (aside: we won't risk converting x and y logicals to factors b/c it can ## mess up types that rely on predict underneath the hood, e.g type_lm) - if (!is.null(x) && is.character(x)) x = factor(x) - if (!is.null(y) && is.character(y)) y = factor(y) - if (!null_by && is.logical(by)) by = factor(by) + if (!is.null(x) && is.character(x)) { + x = factor(x) + } + if (!is.null(y) && is.character(y)) { + y = factor(y) + } + if (!null_by && is.logical(by)) { + by = factor(by) + } if (is.null(x)) { ## Special catch for rect and segment plots without a specified y-var @@ -39,8 +54,13 @@ sanitize_datapoints = function(settings) { } datapoints = list( - x = x, xmin = xmin, xmax = xmax, - y = y, ymin = ymin, ymax = ymax, ygroup = ygroup + x = x, + xmin = xmin, + xmax = xmax, + y = y, + ymin = ymin, + ymax = ymax, + ygroup = ygroup ) datapoints = Filter(function(z) length(z) > 0, datapoints) datapoints = data.frame(datapoints) diff --git a/R/sanitize_facet.R b/R/sanitize_facet.R index baddd8a5..65ee7b14 100644 --- a/R/sanitize_facet.R +++ b/R/sanitize_facet.R @@ -19,7 +19,7 @@ sanitize_facet = function(settings) { } facet_attr = attributes(facet) # TODO: better way to restore facet attributes? null_facet = is.null(facet) - + # update settings env2env( environment(), diff --git a/R/sanitize_ribbon_alpha.R b/R/sanitize_ribbon_alpha.R index 7bc273e8..dbc3f685 100644 --- a/R/sanitize_ribbon_alpha.R +++ b/R/sanitize_ribbon_alpha.R @@ -1,5 +1,7 @@ sanitize_ribbon_alpha = function(ribbon.alpha) { assert_numeric(ribbon.alpha, len = 1, lower = 0, upper = 1, null.ok = TRUE) - if (is.null(ribbon.alpha)) ribbon.alpha = .tpar[["ribbon.alpha"]] + if (is.null(ribbon.alpha)) { + ribbon.alpha = .tpar[["ribbon.alpha"]] + } return(ribbon.alpha) } diff --git a/R/sanitize_type.R b/R/sanitize_type.R index dc50fd57..bab86f10 100644 --- a/R/sanitize_type.R +++ b/R/sanitize_type.R @@ -9,31 +9,47 @@ sanitize_type = function(settings) { } known_types = c( - "p", "l", "o", "b", "c", "h", "j", "s", "S", "n", + "p", + "l", + "o", + "b", + "c", + "h", + "j", + "s", + "S", + "n", "abline", "area", - "bar", "barplot", - "box", "boxplot", + "bar", + "barplot", + "box", + "boxplot", "density", "errorbar", "function", "glm", - "hist", "histogram", + "hist", + "histogram", "hline", - "j", "jitter", + "j", + "jitter", "lines", "lm", "loess", + "mean_se", "pointrange", "points", - "polygon", "polypath", + "polygon", + "polypath", "qq", "rect", "ribbon", "ridge", "rug", "segments", - "spine", "spineplot", + "spine", + "spineplot", "spline", "summary", "text", @@ -56,7 +72,11 @@ sanitize_type = function(settings) { } else if ((is.factor(x) || is.character(x)) && is.null(y)) { # enforce barplot type for ~ factor(y) type = type_barplot - } else if (!is.null(x) && (is.factor(x) || is.character(x)) && !(is.factor(y) || is.character(y))) { + } else if ( + !is.null(x) && + (is.factor(x) || is.character(x)) && + !(is.factor(y) || is.character(y)) + ) { # enforce boxplot type for y ~ factor(x) type = type_boxplot } else if (!is.null(x) && (is.factor(y) || is.character(y))) { @@ -68,48 +88,50 @@ sanitize_type = function(settings) { } if (is.character(type)) { - type = switch(type, - "abline" = type_abline, - "area" = type_area, - "bar" = type_barplot, - "barplot" = type_barplot, - "box" = type_boxplot, - "boxplot" = type_boxplot, - "density" = type_density, - "errorbar" = type_errorbar, - "function" = type_function, - "glm" = type_glm, - "hist" = type_histogram, - "histogram" = type_histogram, - "hline" = type_hline, - "j" = type_jitter, - "jitter" = type_jitter, - "l" = type_lines, - "lines" = type_lines, - "lm" = type_lm, - "loess" = type_loess, - "p" = type_points, + type = switch( + type, + "abline" = type_abline, + "area" = type_area, + "bar" = type_barplot, + "barplot" = type_barplot, + "box" = type_boxplot, + "boxplot" = type_boxplot, + "density" = type_density, + "errorbar" = type_errorbar, + "function" = type_function, + "glm" = type_glm, + "hist" = type_histogram, + "histogram" = type_histogram, + "hline" = type_hline, + "j" = type_jitter, + "jitter" = type_jitter, + "l" = type_lines, + "lines" = type_lines, + "lm" = type_lm, + "loess" = type_loess, + "mean_se" = type_mean_se, + "p" = type_points, "pointrange" = type_pointrange, - "points" = type_points, - "polygon" = type_polygon, - "polypath" = type_polypath, - "qq" = type_qq, - "rect" = type_rect, - "ribbon" = type_ribbon, - "ridge" = type_ridge, - "rug" = type_rug, - "segments" = type_segments, - "spine" = type_spineplot, - "spineplot" = type_spineplot, - "spline" = type_spline, - "summary" = type_summary, - "text" = type_text, - "violin" = type_violin, - "vline" = type_vline, + "points" = type_points, + "polygon" = type_polygon, + "polypath" = type_polypath, + "qq" = type_qq, + "rect" = type_rect, + "ribbon" = type_ribbon, + "ridge" = type_ridge, + "rug" = type_rug, + "segments" = type_segments, + "spine" = type_spineplot, + "spineplot" = type_spineplot, + "spline" = type_spline, + "summary" = type_summary, + "text" = type_text, + "violin" = type_violin, + "vline" = type_vline, type # default case ) } -# browser() + # browser() if (is.function(type)) { args = intersect(names(formals(type)), names(dots)) args = if (length(args) >= 1L) dots[args] else list() diff --git a/R/sanitize_xylab.R b/R/sanitize_xylab.R index e367edd1..8fa1d418 100644 --- a/R/sanitize_xylab.R +++ b/R/sanitize_xylab.R @@ -4,8 +4,16 @@ sanitize_xylab = function(settings) { environment(), c( "type", - "x", "xlab", "x_dep", "xmin_dep", "xmax_dep", - "y", "ylab", "y_dep", "ymin_dep", "ymax_dep" + "x", + "xlab", + "x_dep", + "xmin_dep", + "xmax_dep", + "y", + "ylab", + "y_dep", + "ymin_dep", + "ymax_dep" ) ) @@ -46,7 +54,9 @@ sanitize_xylab = function(settings) { } else if (!is.null(ymin_dep) && !is.null(ymax_dep)) { out_ylab = sprintf("[%s, %s]", ymin_dep, ymax_dep) } - } else if ((is_range || is_ribbon) && !is.null(ymin_dep) && !is.null(ymax_dep)) { + } else if ( + (is_range || is_ribbon) && !is.null(ymin_dep) && !is.null(ymax_dep) + ) { out_ylab = sprintf("[%s, %s]", ymin_dep, ymax_dep) } else if (!is.null(y_dep)) { out_ylab = y_dep diff --git a/R/setup_device.R b/R/setup_device.R index 76441fca..66413914 100644 --- a/R/setup_device.R +++ b/R/setup_device.R @@ -6,28 +6,49 @@ setup_device = function(settings) { filepath = file filewidth = width fileheight = height - if (is.null(filewidth)) filewidth = .tpar[["file.width"]] - if (is.null(fileheight)) fileheight = .tpar[["file.height"]] + if (is.null(filewidth)) { + filewidth = .tpar[["file.width"]] + } + if (is.null(fileheight)) { + fileheight = .tpar[["file.height"]] + } fileres = .tpar[["file.res"]] # catch to close interactive device if one isn't already open fkdev = is.null(dev.list()) # grab existing device pars to pass on to next one dop = par(no.readonly = TRUE) # close interactive device if not already open - if (isTRUE(fkdev)) dev.off() + if (isTRUE(fkdev)) { + dev.off() + } exttype = file_ext(filepath) if (exttype == "pdf" && .tpar[["cairo"]]) { exttype = "cairo" } else if (exttype == "jpg") { exttype = "jpeg" } - switch(exttype, - png = png(filepath, width = filewidth, height = fileheight, units = "in", res = fileres), - jpeg = jpeg(filepath, width = filewidth, height = fileheight, units = "in", res = fileres), + switch( + exttype, + png = png( + filepath, + width = filewidth, + height = fileheight, + units = "in", + res = fileres + ), + jpeg = jpeg( + filepath, + width = filewidth, + height = fileheight, + units = "in", + res = fileres + ), pdf = pdf(filepath, width = filewidth, height = fileheight), cairo = cairo_pdf(filepath, width = filewidth, height = fileheight), svg = svg(filepath, width = filewidth, height = fileheight), - stop("\nUnsupported file extension. Only '.png', '.jpg', '.pdf', or '.svg' are allowed.\n") + stop( + "\nUnsupported file extension. Only '.png', '.jpg', '.pdf', or '.svg' are allowed.\n" + ) ) dop$new = FALSE # catch for some interfaces par(dop) @@ -37,14 +58,20 @@ setup_device = function(settings) { devwidth = width devheight = height # if one of width or height is missing, set equal to the other - if (is.null(devwidth)) devwidth = devheight - if (is.null(devheight)) devheight = devwidth + if (is.null(devwidth)) { + devwidth = devheight + } + if (is.null(devheight)) { + devheight = devwidth + } # catch to close interactive device if one isn't already open fkdev = is.null(dev.list()) # grab existing device pars to pass on to next one dop = par(no.readonly = TRUE) # close interactive device if not already open - if (isTRUE(fkdev)) dev.off() + if (isTRUE(fkdev)) { + dev.off() + } dev.new(width = devwidth, height = devheight) dop$new = FALSE # catch for some interfaces par(dop) diff --git a/R/tinyAxis.R b/R/tinyAxis.R index 36136ffe..36ff6bf2 100644 --- a/R/tinyAxis.R +++ b/R/tinyAxis.R @@ -1,5 +1,5 @@ #' @title Generic function for adding an axis to a (tiny)plot -#' +#' #' @description Internal function used for adding an axis to a [`tinyplot`] #' call. #' @details `tinyAxis` provides a thin(ish) wrapper around @@ -17,7 +17,7 @@ #' @inheritParams tinylabel #' @examples #' \dontrun{ -#' +#' #' # plot without axes #' tinyplot(0:10, axes = "n") #' # add x-axis (labels only) @@ -44,9 +44,17 @@ tinyAxis = function(x = NULL, ..., type = "standard", labeller = NULL) { } if (!is.null(labeller)) { if (!is.null(args$at)) { - args$labels = if (!is.null(args$labels)) tinylabel(args$labels, labeller) else tinylabel(args$at, labeller) + args$labels = if (!is.null(args$labels)) { + tinylabel(args$labels, labeller) + } else { + tinylabel(args$at, labeller) + } } else { - args$at = if (!inherits(x, c("POSIXt", "Date"))) axTicks(args$side) else axTicksDateTime(args$side, x = x) + args$at = if (!inherits(x, c("POSIXt", "Date"))) { + axTicks(args$side) + } else { + axTicksDateTime(args$side, x = x) + } args$labels = tinylabel(args$at, labeller) } } @@ -61,13 +69,13 @@ axTicksDateTime = function(side, x, ...) { range = extendrange(x) rangeDateTime = .POSIXct(range, tz = tz) } else { - range = sort(par("usr")[if (side%%2) 1L:2L else 3:4L]) + range = sort(par("usr")[if (side %% 2) 1L:2L else 3:4L]) range[1L] = ceiling(range[1L]) range[2L] = floor(range[2L]) rangeDateTime = range class(rangeDateTime) = "Date" } - z = pretty(rangeDateTime, n = par("lab")[2 - side%%2]) + z = pretty(rangeDateTime, n = par("lab")[2 - side %% 2]) keep = z >= range[1L] & z <= range[2L] z = z[keep] return(z) diff --git a/R/tinyformula.R b/R/tinyformula.R index 29189061..da5364e5 100644 --- a/R/tinyformula.R +++ b/R/tinyformula.R @@ -14,19 +14,27 @@ tinyformula = function(formula, facet = NULL) { ## - full: e.g. ~ x + y + z + a + b ## preliminaries - if (!inherits(formula, "formula")) formula = as.formula(formula) + if (!inherits(formula, "formula")) { + formula = as.formula(formula) + } nf = length(formula) ## basic formula types - x = ~ x - y = if (nf == 2L) NULL else ~ y - by = if (!inherits(formula[[nf]], "call") || formula[[nf]][[1L]] != as.name("|")) NULL else ~ z + x = ~x + y = if (nf == 2L) NULL else ~y + by = if ( + !inherits(formula[[nf]], "call") || formula[[nf]][[1L]] != as.name("|") + ) { + NULL + } else { + ~z + } if (is.null(facet) || !inherits(facet, "formula")) { xfacet = NULL yfacet = NULL } else { - xfacet = ~ a - yfacet = if (length(facet) == 2L) NULL else ~ b + xfacet = ~a + yfacet = if (length(facet) == 2L) NULL else ~b } ## fill with actual terms @@ -53,10 +61,18 @@ tinyformula = function(formula, facet = NULL) { ## combine everything full = x - if (!is.null(y)) full[[2L]] = call("+", full[[2L]], y[[2L]]) - if (!is.null(by)) full[[2L]] = call("+", full[[2L]], by[[2L]]) - if (!is.null(xfacet)) full[[2L]] = call("+", full[[2L]], xfacet[[2L]]) - if (!is.null(yfacet)) full[[2L]] = call("+", full[[2L]], yfacet[[2L]]) + if (!is.null(y)) { + full[[2L]] = call("+", full[[2L]], y[[2L]]) + } + if (!is.null(by)) { + full[[2L]] = call("+", full[[2L]], by[[2L]]) + } + if (!is.null(xfacet)) { + full[[2L]] = call("+", full[[2L]], xfacet[[2L]]) + } + if (!is.null(yfacet)) { + full[[2L]] = call("+", full[[2L]], yfacet[[2L]]) + } ## return list of all formulas return(list( @@ -73,9 +89,13 @@ tinyframe = function(formula, data, drop = FALSE) { ## input ## - formula: (sub-)formula ## - data: model.frame from full formula - if (is.null(formula)) return(NULL) + if (is.null(formula)) { + return(NULL) + } vars = attr(terms(formula), "variables")[-1L] - if (is.null(vars)) return(NULL) + if (is.null(vars)) { + return(NULL) + } names = sapply(vars, deparse, width.cutoff = 500L) data[, names, drop = drop] } diff --git a/R/tinylabel.R b/R/tinylabel.R index baf09c02..0a1ed2cb 100644 --- a/R/tinylabel.R +++ b/R/tinylabel.R @@ -25,7 +25,7 @@ #' tinylabel(x, "comma") #' tinylabel(x, ",") # same #' tinylabel(x, "$") # or "dollar" -#' +#' #' # invoke tinylabel from a parent tinyplot call... #' # => x/yaxl for adjusting axes tick labels #' # => legend = list(labeller = ...) for adjusting the legend labels @@ -109,12 +109,12 @@ tinylabel = function(x, labeller = NULL, na.ignore = TRUE, na.rm = TRUE) { labeller_fun = function(label = "percent") { labels = c( - "%" = "percent", - "," = "comma", - "$" = "dollar", + "%" = "percent", + "," = "comma", + "$" = "dollar", "\u20ac" = "euro", "\u00a3" = "sterling", - "l" = "log" + "l" = "log" ) if (label %in% names(labels)) { label = labels[label] @@ -170,12 +170,12 @@ labeller_fun = function(label = "percent") { fun = switch( label, - percent = format_percent, - comma = format_comma, - dollar = format_dollar, - euro = format_euro, + percent = format_percent, + comma = format_comma, + dollar = format_dollar, + euro = format_euro, sterling = format_sterling, - log = format_log + log = format_log ) ## combine with absolute value if necessary diff --git a/R/tinyplot.R b/R/tinyplot.R index 3a980165..03eb8267 100644 --- a/R/tinyplot.R +++ b/R/tinyplot.R @@ -132,6 +132,8 @@ #' - [`type_vline()`]: vertical line(s). #' - [`type_function()`]: arbitrary function. #' - [`type_summary()`]: summarize `y` by unique values of `x`. +#' - [`type_meanse()`]: return mean and standard error of `y` by +#' uniue values of `x` #' @param legend one of the following options: #' - NULL (default), in which case the legend will be determined by the #' grouping variable. If there is no group variable (i.e., `by` is NULL) then @@ -227,7 +229,7 @@ #' - A vector or list of colours, e.g. `c("darkorange", "purple", "cyan4")`. #' If too few colours are provided for a discrete (qualitative) set of #' groups, then the colours will be recycled with a warning. For continuous -#' (sequential) groups, a gradient palette will be interpolated. +#' (sequential) groups, a gradient palette will be interpolated. #' @param col plotting color. Character, integer, or vector of length equal to #' the number of categories in the `by` variable. See `col`. Note that the #' default behaviour in `tinyplot` is to vary group colors along any variables @@ -281,7 +283,7 @@ #' relative to the default. Note that `NULL` is equivalent to 1.0, while `NA` #' renders the characters invisible. There are two additional considerations, #' specifically for points-alike plot types (e.g. `"p"`): -#' +#' #' - users can also supply a special `cex = "by"` convenience argument, in #' which case the character expansion will automatically adjust by group #' too. The range of this character expansion is controlled by the `clim` @@ -352,7 +354,7 @@ #' @param asp the y/xy/x aspect ratio, see `plot.window`. #' @param theme keyword string (e.g. `"clean"`) or list defining a theme. Passed #' on to [`tinytheme`], but reset upon exit so that the theme effect is only -#' temporary. Useful for invoking ephemeral themes. +#' temporary. Useful for invoking ephemeral themes. #' @param ... other graphical parameters. If `type` is a character specification #' (such as `"hist"`) then any argument names that match those from the corresponding #' `type_*()` function (such as \code{\link{type_hist}}) are passed on to that. @@ -413,11 +415,11 @@ #' pch = 16, #' cex = 2 #' ) -#' +#' #' # Use the special "by" convenience keyword if you would like to map these #' # aesthetic features over groups too (i.e., in addition to the default #' # colour grouping) -#' +#' #' tinyplot( #' Temp ~ Day | Month, #' data = aq, @@ -446,7 +448,7 @@ #' bg = 0.3, # numeric in [0,1] adds a grouped background fill with transparency #' col = "black" # override default color mapping; give all points a black border #' ) -#' +#' #' # Aside: For "bubble" plots, pass an appropriate vector to the `cex` arg. #' # This can be useful for depicting an additional dimension of the data (here: #' # Wind). @@ -589,58 +591,58 @@ tinyplot = #' @rdname tinyplot #' @export tinyplot.default = function( - x = NULL, - y = NULL, - xmin = NULL, - xmax = NULL, - ymin = NULL, - ymax = NULL, - by = NULL, - facet = NULL, - facet.args = NULL, - data = NULL, - type = NULL, - legend = NULL, - main = NULL, - sub = NULL, - xlab = NULL, - ylab = NULL, - ann = par("ann"), - xlim = NULL, - ylim = NULL, - axes = TRUE, - xaxt = NULL, - yaxt = NULL, - xaxs = NULL, - yaxs = NULL, - xaxb = NULL, - yaxb = NULL, - xaxl = NULL, - yaxl = NULL, - log = "", - flip = FALSE, - frame.plot = NULL, - grid = NULL, - palette = NULL, - pch = NULL, - lty = NULL, - lwd = NULL, - col = NULL, - bg = NULL, - fill = NULL, - alpha = NULL, - cex = NULL, - add = FALSE, - draw = NULL, - empty = FALSE, - restore.par = FALSE, - file = NULL, - width = NULL, - height = NULL, - asp = NA, - theme = NULL, - ...) { - + x = NULL, + y = NULL, + xmin = NULL, + xmax = NULL, + ymin = NULL, + ymax = NULL, + by = NULL, + facet = NULL, + facet.args = NULL, + data = NULL, + type = NULL, + legend = NULL, + main = NULL, + sub = NULL, + xlab = NULL, + ylab = NULL, + ann = par("ann"), + xlim = NULL, + ylim = NULL, + axes = TRUE, + xaxt = NULL, + yaxt = NULL, + xaxs = NULL, + yaxs = NULL, + xaxb = NULL, + yaxb = NULL, + xaxl = NULL, + yaxl = NULL, + log = "", + flip = FALSE, + frame.plot = NULL, + grid = NULL, + palette = NULL, + pch = NULL, + lty = NULL, + lwd = NULL, + col = NULL, + bg = NULL, + fill = NULL, + alpha = NULL, + cex = NULL, + add = FALSE, + draw = NULL, + empty = FALSE, + restore.par = FALSE, + file = NULL, + width = NULL, + height = NULL, + asp = NA, + theme = NULL, + ... +) { # Force evaluation of legend if it's a symbol to avoid downstream promise # issues. Let sanitize_legend handle it if (!missing(legend) && is.symbol(substitute(legend))) { @@ -651,13 +653,17 @@ tinyplot.default = function( ## save parameters and calls ----- # par_first = get_saved_par("first") - if (is.null(par_first)) set_saved_par("first", par()) - + if (is.null(par_first)) { + set_saved_par("first", par()) + } + # save for tinyplot_add() assert_logical(add) if (!add) { calls = sys.calls() - is_tinyplot_call = function(x) identical(tinyplot, try(eval(x[[1L]]), silent = TRUE)) + is_tinyplot_call = function(x) { + identical(tinyplot, try(eval(x[[1L]]), silent = TRUE)) + } idx = which(vapply(calls, is_tinyplot_call, FALSE)) if (length(idx) > 0) { set_environment_variable(.last_call = calls[[idx[1L]]]) @@ -690,7 +696,9 @@ tinyplot.default = function( } else if (is.list(theme)) { do.call(tinytheme, theme) } else { - warning('Argument `theme` must be a character of length 1 (e.g. "clean"), or a list. Ignoring.') + warning( + 'Argument `theme` must be a character of length 1 (e.g. "clean"), or a list. Ignoring.' + ) } if (is.character(theme) && theme == "default") { # Reset mar to pre-theme value so legend margin adjustment isn't @@ -713,102 +721,102 @@ tinyplot.default = function( settings_list = list( # save call to check user input later - call = match.call(), + call = match.call(), # save to file & device dimensions - file = file, - width = width, - height = height, + file = file, + width = width, + height = height, # deparsed input for use in labels - by_dep = deparse1(substitute(by)), - cex_dep = if (!is.null(cex)) deparse1(substitute(cex)) else NULL, - facet_dep = deparse1(substitute(facet)), - x_dep = if (is.null(x)) NULL else deparse1(substitute(x)), - xmax_dep = if (is.null(xmax)) NULL else deparse1(substitute(xmax)), - xmin_dep = if (is.null(xmin)) NULL else deparse1(substitute(xmin)), - y_dep = if (is.null(y)) NULL else deparse1(substitute(y)), - ymax_dep = if (is.null(ymax)) NULL else deparse1(substitute(ymax)), - ymin_dep = if (is.null(ymin)) NULL else deparse1(substitute(ymin)), + by_dep = deparse1(substitute(by)), + cex_dep = if (!is.null(cex)) deparse1(substitute(cex)) else NULL, + facet_dep = deparse1(substitute(facet)), + x_dep = if (is.null(x)) NULL else deparse1(substitute(x)), + xmax_dep = if (is.null(xmax)) NULL else deparse1(substitute(xmax)), + xmin_dep = if (is.null(xmin)) NULL else deparse1(substitute(xmin)), + y_dep = if (is.null(y)) NULL else deparse1(substitute(y)), + ymax_dep = if (is.null(ymax)) NULL else deparse1(substitute(ymax)), + ymin_dep = if (is.null(ymin)) NULL else deparse1(substitute(ymin)), # types - type = type, - type_data = NULL, - type_draw = NULL, - type_name = NULL, + type = type, + type_data = NULL, + type_draw = NULL, + type_name = NULL, # type-specific settings - bubble = FALSE, - bubble_pch = NULL, - bubble_alpha = NULL, + bubble = FALSE, + bubble_pch = NULL, + bubble_alpha = NULL, bubble_bg_alpha = NULL, - ygroup = NULL, # for type_ridge() + ygroup = NULL, # for type_ridge() # data points and labels - x = x, - xmax = xmax, - xmin = xmin, - xlab = xlab, - xlabs = NULL, - y = y, - ymax = ymax, - ymin = ymin, - ylab = ylab, - ylabs = NULL, + x = x, + xmax = xmax, + xmin = xmin, + xlab = xlab, + xlabs = NULL, + y = y, + ymax = ymax, + ymin = ymin, + ylab = ylab, + ylabs = NULL, # axes - axes = axes, - xaxt = xaxt, - xaxb = xaxb, - xaxl = xaxl, - xaxs = xaxs, - yaxt = yaxt, - yaxb = yaxb, - yaxl = yaxl, - yaxs = yaxs, - frame.plot = frame.plot, - xlim = xlim, - ylim = ylim, + axes = axes, + xaxt = xaxt, + xaxb = xaxb, + xaxl = xaxl, + xaxs = xaxs, + yaxt = yaxt, + yaxb = yaxb, + yaxl = yaxl, + yaxs = yaxs, + frame.plot = frame.plot, + xlim = xlim, + ylim = ylim, # flags to check user input (useful later on) - null_by = is.null(by), - null_xlim = is.null(xlim), - null_ylim = is.null(ylim), + null_by = is.null(by), + null_xlim = is.null(xlim), + null_ylim = is.null(ylim), # when palette functions need pre-processing this check raises error - null_palette = tryCatch(is.null(palette), error = function(e) FALSE), - x_by = identical(x, by), # for "boxplot", "spineplot" and "ridge" + null_palette = tryCatch(is.null(palette), error = function(e) FALSE), + x_by = identical(x, by), # for "boxplot", "spineplot" and "ridge" # unevaluated expressions with side effects - draw = substitute(draw), - facet = facet, - facet.args = facet.args, - palette = substitute(palette), - legend = if (add) FALSE else substitute(legend), + draw = substitute(draw), + facet = facet, + facet.args = facet.args, + palette = substitute(palette), + legend = if (add) FALSE else substitute(legend), # aesthetics - lty = lty, - lwd = lwd, - col = col, - bg = bg, - log = log, - fill = fill, - alpha = alpha, - cex = cex, - pch = if (is.null(pch)) get_tpar("pch", default = NULL) else pch, + lty = lty, + lwd = lwd, + col = col, + bg = bg, + log = log, + fill = fill, + alpha = alpha, + cex = cex, + pch = if (is.null(pch)) get_tpar("pch", default = NULL) else pch, # ribbon.alpha overwritten by some type_data() functions # sanitize_ribbon_alpha: returns default alpha transparency for ribbon-type plots - ribbon.alpha = sanitize_ribbon_alpha(NULL), + ribbon.alpha = sanitize_ribbon_alpha(NULL), # misc - add = add, - by = by, - dodge = NULL, - dots = dots, - flip = flip, + add = add, + by = by, + dodge = NULL, + dots = dots, + flip = flip, group_offsets = NULL, - offsets_axis = NULL, - type_info = list() # pass type-specific info from type_data to type_draw + offsets_axis = NULL, + type_info = list() # pass type-specific info from type_data to type_draw ) settings = new.env() @@ -819,8 +827,9 @@ tinyplot.default = function( # # Write plot to output file or window with fixed dimensions setup_device(settings) - if (!is.null(settings$file)) on.exit(dev.off(), add = TRUE) - + if (!is.null(settings$file)) { + on.exit(dev.off(), add = TRUE) + } # ## sanitize arguments ----- @@ -835,11 +844,13 @@ tinyplot.default = function( } # alias: bg = fill - if (is.null(bg) && !is.null(fill)) settings$bg = fill + if (is.null(bg) && !is.null(fill)) { + settings$bg = fill + } # validate types and returns a list with name, data, and draw components sanitize_type(settings) - + # standardize axis arguments and returns consistent axes, xaxt, yaxt, frame.plot sanitize_axes(settings) @@ -856,9 +867,8 @@ tinyplot.default = function( settings$by = factor(settings$by) } - # flag if x==by, currently only used for - # - + # flag if x==by, currently only used for + # # facet: parse facet formula and prepares variables when facet==by sanitize_facet(settings) @@ -870,7 +880,6 @@ tinyplot.default = function( # combine x, y, xmax, by, facet etc. into a single `datapoints` data.frame sanitize_datapoints(settings) - # ## transform datapoints using type_data() ----- # @@ -881,9 +890,21 @@ tinyplot.default = function( # ensure axis aligment of any added layers if (!add) { - assign("xlabs_orig", settings[["xlabs"]], envir = get(".tinyplot_env", envir = parent.env(environment()))) - assign(".group_offsets", settings[["group_offsets"]], envir = get(".tinyplot_env", envir = parent.env(environment()))) - assign(".offsets_axis", settings[["offsets_axis"]], envir = get(".tinyplot_env", envir = parent.env(environment()))) + assign( + "xlabs_orig", + settings[["xlabs"]], + envir = get(".tinyplot_env", envir = parent.env(environment())) + ) + assign( + ".group_offsets", + settings[["group_offsets"]], + envir = get(".tinyplot_env", envir = parent.env(environment())) + ) + assign( + ".offsets_axis", + settings[["offsets_axis"]], + envir = get(".tinyplot_env", envir = parent.env(environment())) + ) } else { align_layer(settings) } @@ -891,21 +912,19 @@ tinyplot.default = function( # flip -> swap x and y after type_data, except for boxplots (which has its own bespoke flip logic) flip_datapoints(settings) - # ## bubble plot ----- # - + # Transform cex values for bubble charts. Handles size transformation, legend # gotchas, and aesthetic sanitization. # Currently limited to "p" and "text" types, but could expand to others. bubble(settings) - # ## axis breaks and limits ----- # - + # do this after computing yaxb because limits will depend on the previous calculations if (!add) { lim_args(settings) @@ -918,18 +937,16 @@ tinyplot.default = function( # facet_layout processes facet simplification, attribute restoration, and layout facet_layout(settings) - # ## aesthetics by group ----- # - - by_aesthetics(settings) + by_aesthetics(settings) # ## legends ----- # - + prepare_legend(settings) # @@ -941,7 +958,9 @@ tinyplot.default = function( if (legend_draw_flag) { if (!multi_legend) { ## simple case: single legend only - if (is.null(lgnd_cex)) lgnd_cex = cex * cex_fct_adj + if (is.null(lgnd_cex)) { + lgnd_cex = cex * cex_fct_adj + } draw_legend( legend = legend, legend_args = legend_args, @@ -963,11 +982,10 @@ tinyplot.default = function( env2env(settings, environment(), c("legend_args", "lgby", "lgbub")) # draw multi-legend draw_multi_legend(list(lgby, lgbub), position = legend_args[["x"]]) - } has_legend = TRUE - } else if (legend_args[["x"]] == "none" && !isTRUE(add)) { + } else if (legend_args[["x"]] == "none" && !isTRUE(add)) { omar = par("mar") ooma = par("oma") topmar_epsilon = 0.1 @@ -982,7 +1000,6 @@ tinyplot.default = function( plot.new() } - # ## title and subtitle ----- # @@ -991,13 +1008,12 @@ tinyplot.default = function( draw_title(main, sub, xlab, ylab, legend, legend_args, opar) } - # ## facets: draw ----- # - # Two-phase plotting logic: First determine and draw all exterior elements - # (facet windows, axes, grid, etc.), then circle back to each facet and + # Two-phase plotting logic: First determine and draw all exterior elements + # (facet windows, axes, grid, etc.), then circle back to each facet and # draw the interior elements (grouped points, lines, etc.) omar = NULL # Placeholder variable for now, which we re-assign as part of facet margins @@ -1006,7 +1022,9 @@ tinyplot.default = function( facet_newlines = facet_text = facet_rect = facet_font = facet_col = facet_bg = facet_border = NULL if (!is.null(facet) && !add) { - if (is.null(omar)) omar = par("mar") + if (is.null(omar)) { + omar = par("mar") + } # Grab some of the customizable facet args that we'll be using later facet_rect = FALSE @@ -1016,13 +1034,25 @@ tinyplot.default = function( facet_bg = .tpar[["facet.bg"]] facet_border = .tpar[["facet.border"]] if (!is.null(facet.args)) { - if (!is.null(facet.args[["cex"]])) facet_text = facet.args[["cex"]] - if (!is.null(facet.args[["col"]])) facet_col = facet.args[["col"]] - if (!is.null(facet.args[["font"]])) facet_font = facet.args[["font"]] - if (!is.null(facet.args[["bg"]])) facet_bg = facet.args[["bg"]] - if (!is.null(facet.args[["border"]])) facet_border = facet.args[["border"]] + if (!is.null(facet.args[["cex"]])) { + facet_text = facet.args[["cex"]] + } + if (!is.null(facet.args[["col"]])) { + facet_col = facet.args[["col"]] + } + if (!is.null(facet.args[["font"]])) { + facet_font = facet.args[["font"]] + } + if (!is.null(facet.args[["bg"]])) { + facet_bg = facet.args[["bg"]] + } + if (!is.null(facet.args[["border"]])) { + facet_border = facet.args[["border"]] + } + } + if (!is.null(facet_bg) || !is.null(facet_border)) { + facet_rect = TRUE } - if (!is.null(facet_bg) || !is.null(facet_border)) facet_rect = TRUE # Need extra adjustment to top margin if facet titles have "\n" newline # separator. (Note that we'll also need to take account for this in the @@ -1045,57 +1075,110 @@ tinyplot.default = function( # facet-specific args cex_fct_adj = cex_fct_adj, facet.args = facet.args, - facet_newlines = facet_newlines, facet_font = facet_font, - facet_rect = facet_rect, facet_text = facet_text, - facet_col = facet_col, facet_bg = facet_bg, facet_border = facet_border, + facet_newlines = facet_newlines, + facet_font = facet_font, + facet_rect = facet_rect, + facet_text = facet_text, + facet_col = facet_col, + facet_bg = facet_bg, + facet_border = facet_border, facet = facet, - facets = facets, ifacet = ifacet, - nfacets = nfacets, nfacet_cols = nfacet_cols, nfacet_rows = nfacet_rows, + facets = facets, + ifacet = ifacet, + nfacets = nfacets, + nfacet_cols = nfacet_cols, + nfacet_rows = nfacet_rows, # axes args - axes = axes, flip = flip, frame.plot = frame.plot, - oxaxis = oxaxis, oyaxis = oyaxis, - xlabs = xlabs, xlim = xlim, null_xlim = null_xlim, xaxt = xaxt, xaxs = xaxs, xaxb = xaxb, xaxl = xaxl, - ylabs = ylabs, ylim = ylim, null_ylim = null_ylim, yaxt = yaxt, yaxs = yaxs, yaxb = yaxb, yaxl = yaxl, - asp = asp, log = log, + axes = axes, + flip = flip, + frame.plot = frame.plot, + oxaxis = oxaxis, + oyaxis = oyaxis, + xlabs = xlabs, + xlim = xlim, + null_xlim = null_xlim, + xaxt = xaxt, + xaxs = xaxs, + xaxb = xaxb, + xaxl = xaxl, + ylabs = ylabs, + ylim = ylim, + null_ylim = null_ylim, + yaxt = yaxt, + yaxs = yaxs, + yaxb = yaxb, + yaxl = yaxl, + asp = asp, + log = log, # other args (in approx. alphabetical + group ordering) dots = dots, draw = draw, grid = grid, has_legend = has_legend, type = type, - x = x, xmax = xmax, xmin = xmin, - y = y, ymax = ymax, ymin = ymin, + x = x, + xmax = xmax, + xmin = xmin, + y = y, + ymax = ymax, + ymin = ymin, tpars = tpars ), list = list( add = add, cex_fct_adj = cex_fct_adj, facet.args = facet.args, - facet_newlines = facet_newlines, facet_font = facet_font, - facet_rect = facet_rect, facet_text = facet_text, - facet_col = facet_col, facet_bg = facet_bg, facet_border = facet_border, + facet_newlines = facet_newlines, + facet_font = facet_font, + facet_rect = facet_rect, + facet_text = facet_text, + facet_col = facet_col, + facet_bg = facet_bg, + facet_border = facet_border, facet = datapoints$facet, - facets = facets, ifacet = ifacet, - nfacets = nfacets, nfacet_cols = nfacet_cols, nfacet_rows = nfacet_rows, - axes = axes, flip = flip, frame.plot = frame.plot, - oxaxis = oxaxis, oyaxis = oyaxis, - xlabs = xlabs, xlim = xlim, null_xlim = null_xlim, xaxt = xaxt, xaxs = xaxs, xaxb = xaxb, xaxl = xaxl, - ylabs = ylabs, ylim = ylim, null_ylim = null_ylim, yaxt = yaxt, yaxs = yaxs, yaxb = yaxb, yaxl = yaxl, - asp = asp, log = log, + facets = facets, + ifacet = ifacet, + nfacets = nfacets, + nfacet_cols = nfacet_cols, + nfacet_rows = nfacet_rows, + axes = axes, + flip = flip, + frame.plot = frame.plot, + oxaxis = oxaxis, + oyaxis = oyaxis, + xlabs = xlabs, + xlim = xlim, + null_xlim = null_xlim, + xaxt = xaxt, + xaxs = xaxs, + xaxb = xaxb, + xaxl = xaxl, + ylabs = ylabs, + ylim = ylim, + null_ylim = null_ylim, + yaxt = yaxt, + yaxs = yaxs, + yaxb = yaxb, + yaxl = yaxl, + asp = asp, + log = log, dots = dots, draw = draw, grid = grid, has_legend = has_legend, type = type, - x = datapoints$x, xmax = datapoints$xmax, xmin = datapoints$xmin, - y = datapoints$y, ymax = datapoints$ymax, ymin = datapoints$ymin, + x = datapoints$x, + xmax = datapoints$xmax, + xmin = datapoints$xmin, + y = datapoints$y, + ymax = datapoints$ymax, + ymin = datapoints$ymin, tpars = tpar() # https://github.com/grantmcdermott/tinyplot/issues/474 ), getNamespace("tinyplot") ) list2env(facet_window_args, environment()) - # ## split and draw datapoints ----- # @@ -1116,10 +1199,19 @@ tinyplot.default = function( # Split group-level data again to grab any "by" groups idata = split_data[[i]] iby = idata[["by"]] - if (!null_by) { ## maybe all(iby=="") + if (!null_by) { + ## maybe all(iby=="") if (isTRUE(by_continuous)) { - idata[["col"]] = col[round(rescale_num(idata$by, from = range(datapoints$by), to = c(1, 100)))] - idata[["bg"]] = bg[round(rescale_num(idata$by, from = range(datapoints$by), to = c(1, 100)))] + idata[["col"]] = col[round(rescale_num( + idata$by, + from = range(datapoints$by), + to = c(1, 100) + ))] + idata[["bg"]] = bg[round(rescale_num( + idata$by, + from = range(datapoints$by), + to = c(1, 100) + ))] idata = list(idata) } else { idata = lapply(idata, split, iby) @@ -1140,25 +1232,29 @@ tinyplot.default = function( } } } - + # Set the facet "window" manually # See: https://github.com/grantmcdermott/tinyplot/issues/65 if (nfacets > 1) { mfgi = ceiling(i / nfacet_cols) mfgj = i %% nfacet_cols - if (mfgj == 0) mfgj = nfacet_cols + if (mfgj == 0) { + mfgj = nfacet_cols + } par(mfg = c(mfgi, mfgj)) # For free facets, we need to reset par(usr) based extent of that # particular facet... which we calculated and saved to the .fusr env var # (list) back in draw_facet_window() if (isTRUE(facet.args[["free"]])) { - fusr = get(".fusr", envir = get(".tinyplot_env", envir = parent.env(environment()))) + fusr = get( + ".fusr", + envir = get(".tinyplot_env", envir = parent.env(environment())) + ) par(usr = fusr[[i]]) } } - ## Inner loop over the "by" groupings for (ii in seq_along(idata)) { icol = col[ii] @@ -1167,7 +1263,7 @@ tinyplot.default = function( ilty = lty[ii] ilwd = lwd[ii] icex = if (bubble) idata[[ii]][["cex"]] else cex[[ii]] - + ix = idata[[ii]][["x"]] iy = idata[[ii]][["y"]] iz = idata[[ii]][["z"]] @@ -1184,14 +1280,21 @@ tinyplot.default = function( # empty plot flag empty_plot = FALSE - if (isTRUE(empty) || isTRUE(type == "n") || ((length(ix) == 0) && !(type %in% c("histogram", "hist", "rect", "segments", "spineplot")))) { + if ( + isTRUE(empty) || + isTRUE(type == "n") || + ((length(ix) == 0) && + !(type %in% + c("histogram", "hist", "rect", "segments", "spineplot"))) + ) { empty_plot = TRUE } # Draw the individual plot elements... if (!isTRUE(empty_plot)) { if (is.null(type_draw)) { - type_draw = switch(type, + type_draw = switch( + type, "ribbon" = type_ribbon()$draw, "polygon" = type_polygon()$draw, "rect" = type_rect()$draw, @@ -1239,7 +1342,6 @@ tinyplot.default = function( } } } - # ## save end pars for possible recall later ----- @@ -1248,62 +1350,72 @@ tinyplot.default = function( if (!add) { # Capture device and usr before recordGraphics (in current plot context) current_dev = dev.cur() - current_usr = if (isTRUE(settings$flip)) par("usr")[c(3,4,1,2)] else par("usr") - + current_usr = if (isTRUE(settings$flip)) { + par("usr")[c(3, 4, 1, 2)] + } else { + par("usr") + } + # Store usr and dev for validating layer alignment - assign("usr_orig", current_usr, envir = get(".tinyplot_env", envir = parent.env(environment()))) - assign("dev_orig", current_dev, envir = get(".tinyplot_env", envir = parent.env(environment()))) - + assign( + "usr_orig", + current_usr, + envir = get(".tinyplot_env", envir = parent.env(environment())) + ) + assign( + "dev_orig", + current_dev, + envir = get(".tinyplot_env", envir = parent.env(environment())) + ) + recordGraphics( { apar = par(no.readonly = TRUE) set_saved_par(when = "after", apar) }, - list = list(), + list = list(), env = getNamespace('tinyplot') ) } - } - - #' @rdname tinyplot #' @importFrom stats as.formula model.frame terms #' @export tinyplot.formula = function( - x = NULL, - data = parent.frame(), - facet = NULL, - facet.args = NULL, - type = NULL, - xmin = NULL, - xmax = NULL, - ymin = NULL, - ymax = NULL, - xlim = NULL, - ylim = NULL, - # log = "", - main = NULL, - sub = NULL, - xlab = NULL, - ylab = NULL, - ann = par("ann"), - axes = TRUE, - frame.plot = NULL, - asp = NA, - grid = NULL, - pch = NULL, - col = NULL, - lty = NULL, - lwd = NULL, - restore.par = FALSE, - formula = NULL, - subset = NULL, - na.action = NULL, - drop.unused.levels = TRUE, - ...) { + x = NULL, + data = parent.frame(), + facet = NULL, + facet.args = NULL, + type = NULL, + xmin = NULL, + xmax = NULL, + ymin = NULL, + ymax = NULL, + xlim = NULL, + ylim = NULL, + # log = "", + main = NULL, + sub = NULL, + xlab = NULL, + ylab = NULL, + ann = par("ann"), + axes = TRUE, + frame.plot = NULL, + asp = NA, + grid = NULL, + pch = NULL, + col = NULL, + lty = NULL, + lwd = NULL, + restore.par = FALSE, + formula = NULL, + subset = NULL, + na.action = NULL, + drop.unused.levels = TRUE, + ... +) { ## formula for variables must be specified through 'x' or 'formula' but not both if (is.null(x)) { if (missing(formula)) { @@ -1313,7 +1425,9 @@ tinyplot.formula = function( if (missing(formula)) { formula = x } else { - warning("only one of the arguments 'x' and 'formula' should be specified, defaulting to the 'formula' argument") + warning( + "only one of the arguments 'x' and 'formula' should be specified, defaulting to the 'formula' argument" + ) } } @@ -1331,7 +1445,24 @@ tinyplot.formula = function( ## set up model frame m = match.call(expand.dots = FALSE) - m = m[c(1L, match(c("formula", "data", "subset", "na.action", "drop.unused.levels", "xmin", "xmax", "ymin", "ymax"), names(m), 0L))] + m = m[c( + 1L, + match( + c( + "formula", + "data", + "subset", + "na.action", + "drop.unused.levels", + "xmin", + "xmax", + "ymin", + "ymax" + ), + names(m), + 0L + ) + )] m$formula = tf$full ## need stats:: for non-standard evaluation m[[1L]] = quote(stats::model.frame) @@ -1341,8 +1472,12 @@ tinyplot.formula = function( x = tinyframe(tf$x, mf) if (!is.null(x)) { xnam = names(x)[[1L]] - if (length(names(x)) > 1L) warning(paste("formula should specify at most one x-variable, using:", xnam), - "\nif you want to use arithmetic operators, make sure to wrap them inside I()") + if (length(names(x)) > 1L) { + warning( + paste("formula should specify at most one x-variable, using:", xnam), + "\nif you want to use arithmetic operators, make sure to wrap them inside I()" + ) + } x = x[[xnam]] } else { xnam = NULL @@ -1352,8 +1487,12 @@ tinyplot.formula = function( y = tinyframe(tf$y, mf) if (!is.null(y)) { ynam = names(y)[[1L]] - if (length(names(y)) > 1L) warning(paste("formula should specify at most one y-variable, using:", ynam), - "\nif you want to use arithmetic operators, make sure to wrap them inside I()") + if (length(names(y)) > 1L) { + warning( + paste("formula should specify at most one y-variable, using:", ynam), + "\nif you want to use arithmetic operators, make sure to wrap them inside I()" + ) + } y = y[[ynam]] } else { ynam = NULL @@ -1370,8 +1509,20 @@ tinyplot.formula = function( if (!is.null(tf$xfacet) || !is.null(tf$yfacet)) { xfacet = tinyframe(tf$xfacet, mf) yfacet = tinyframe(tf$yfacet, mf) - if (!is.null(xfacet)) xfacet = if (ncol(xfacet) == 1L) xfacet[[1L]] else interaction(xfacet, sep = ":") - if (!is.null(yfacet)) yfacet = if (ncol(yfacet) == 1L) yfacet[[1L]] else interaction(yfacet, sep = ":") + if (!is.null(xfacet)) { + xfacet = if (ncol(xfacet) == 1L) { + xfacet[[1L]] + } else { + interaction(xfacet, sep = ":") + } + } + if (!is.null(yfacet)) { + yfacet = if (ncol(yfacet) == 1L) { + yfacet[[1L]] + } else { + interaction(yfacet, sep = ":") + } + } if (is.null(yfacet)) { facet = xfacet } else { @@ -1382,9 +1533,15 @@ tinyplot.formula = function( } ## nice axis and legend labels - dens_type = !is.null(type) && (is.atomic(type) && identical(type, "density")) || (!is.atomic(type) && identical(type$name, "density")) - hist_type = !is.null(type) && (is.atomic(type) && type %in% c("hist", "histogram")) || (!is.atomic(type) && identical(type$name, "histogram")) - barp_type = !is.null(type) && (is.atomic(type) && identical(type, "barplot")) || (!is.atomic(type) && identical(type$name, "barplot")) + dens_type = !is.null(type) && + (is.atomic(type) && identical(type, "density")) || + (!is.atomic(type) && identical(type$name, "density")) + hist_type = !is.null(type) && + (is.atomic(type) && type %in% c("hist", "histogram")) || + (!is.atomic(type) && identical(type$name, "histogram")) + barp_type = !is.null(type) && + (is.atomic(type) && identical(type, "barplot")) || + (!is.atomic(type) && identical(type$name, "barplot")) if (is.null(x) && is.null(y)) { # Exception: both x and y NULL (e.g., ~ 0 with type = "segments"). # Build labels from xmin/xmax/ymin/ymax names in the original call (m), @@ -1410,20 +1567,31 @@ tinyplot.formula = function( if (is.factor(x) || is.character(x) || barp_type) { if (is.null(xlab)) xlab = xnam } else { - if (is.null(ylab)) ylab = xnam + if (is.null(ylab)) { + ylab = xnam + } if (is.null(xlab)) xlab = "Index" } } else { - if (is.null(ylab)) ylab = ynam + if (is.null(ylab)) { + ylab = ynam + } if (is.null(xlab)) xlab = xnam } if (!is.null(by)) { - legend_args[["title"]] = if (length(bynam) == 1L) bynam else sprintf("interaction(%s)", paste(bynam, collapse = ", ")) + legend_args[["title"]] = if (length(bynam) == 1L) { + bynam + } else { + sprintf("interaction(%s)", paste(bynam, collapse = ", ")) + } } tinyplot.default( - x = x, y = y, by = by, - facet = facet, facet.args = facet.args, + x = x, + y = y, + by = by, + facet = facet, + facet.args = facet.args, data = data, type = type, xmin = mf[["(xmin)"]], @@ -1455,12 +1623,12 @@ tinyplot.formula = function( #' @rdname tinyplot #' @export tinyplot.density = function( - x = NULL, - type = c("l", "area"), - ...) { - + x = NULL, + type = c("l", "area"), + ... +) { dots = list(...) - + if (!is.null(dots[["by"]]) || !is.null(dots[["facet"]])) { stop( '\nGrouped and/or faceted plots are no longer supported with the tinyplot.density() method. ', @@ -1468,12 +1636,14 @@ tinyplot.density = function( '\n\nThis breaking change was introduced in tinyplot v0.3.0.' ) } - + type = match.arg(type) - + ## override if bg = "by" - if (!is.null(dots[["bg"]]) || !is.null(dots[["fill"]])) type = "area" - + if (!is.null(dots[["bg"]]) || !is.null(dots[["fill"]])) { + type = "area" + } + if (inherits(x, "density")) { object = x # legend_args = list(x = NULL) @@ -1488,10 +1658,10 @@ tinyplot.density = function( } object = density(x) } - + x = object$x y = object$y - + if (type == "area") { ymin = rep(0, length(y)) ymax = y @@ -1500,23 +1670,37 @@ tinyplot.density = function( # legend_args[["lty"]] = 0 # legend_args[["pt.lwd"]] = 1 } - + # splice in change arguments dots[["x"]] = x dots[["y"]] = y dots[["type"]] = type - + ## axes range - if (is.null(dots[["xlim"]])) dots[["xlim"]] = range(x) - if (is.null(dots[["ylim"]])) dots[["ylim"]] = range(y) - + if (is.null(dots[["xlim"]])) { + dots[["xlim"]] = range(x) + } + if (is.null(dots[["ylim"]])) { + dots[["ylim"]] = range(y) + } + ## nice labels and titles - if (is.null(dots[["ylab"]])) dots[["ylab"]] = "Density" - if (is.null(dots[["xlab"]])) dots[["xlab"]] = paste0("N = ", object$n, " Bandwidth = ", sprintf("%.4g", object$bw)) - if (is.null(dots[["main"]])) dots[["main"]] = paste0(paste(object$call, collapse = "(x = "), ")") - + if (is.null(dots[["ylab"]])) { + dots[["ylab"]] = "Density" + } + if (is.null(dots[["xlab"]])) { + dots[["xlab"]] = paste0( + "N = ", + object$n, + " Bandwidth = ", + sprintf("%.4g", object$bw) + ) + } + if (is.null(dots[["main"]])) { + dots[["main"]] = paste0(paste(object$call, collapse = "(x = "), ")") + } + do.call(tinyplot.default, args = dots) - } diff --git a/R/tinyplot_add.R b/R/tinyplot_add.R index baf234b9..9257e61d 100644 --- a/R/tinyplot_add.R +++ b/R/tinyplot_add.R @@ -64,7 +64,6 @@ tinyplot_add = function(...) { } - #' @export #' @name plt_add #' @rdname tinyplot_add diff --git a/R/tinytheme.R b/R/tinytheme.R index 5fc29348..e78fe728 100644 --- a/R/tinytheme.R +++ b/R/tinytheme.R @@ -13,15 +13,15 @@ #' _dynamic_, in the sense that they attempt to reduce whitespace in a way #' that is responsive to the length of axes labels, tick marks, etc. These #' dynamic plots are marked with an asterisk (*) below. -#' +#' #' - `"default"`: inherits the user's default base graphics settings. #' - `"basic"`: light modification of `"default"`, only adding filled points, a panel background grid, and light gray background to facet titles. #' - `"clean"` (*): builds on `"basic"` by moving the subtitle above the plotting area, adding horizontal axis labels, employing tighter default plot margins and title gaps to reduce whitespace, and setting different default palettes ("Tableau 10" for discrete colors and "agSunset" for gradient colors). The first of our dynamic themes and the foundation for several derivative themes that follow below. #' - `"clean2"` (*): removes the plot frame (box) from `"clean"`. -#' - `"classic"` (*): connects the axes in a L-shape, but removes the other top and right-hand edges of the plot frame (box). Also sets the "Okabe-Ito" palette as a default for discrete colors. Inspired by the **ggplot2** theme of the same name. -#' - `"bw"` (*): similar to `"clean"`, except uses thinner lines for the plot frame (box), solid grid lines, and sets the "Okabe-Ito" palette as a default for discrete colors. Inspired by the **ggplot2** theme of the same name. -#' - `"minimal"` (*): removes the plot frame (box) from `"bw"`, as well as the background for facet titles. Inspired by the **ggplot2** theme of the same name. -#' - `"ipsum"` (*): similar to `"minimal"`, except subtitle is italicised and axes titles are aligned to the far edges. Inspired by the **hrbrthemes** theme of the same name for **ggplot2**. +#' - `"classic"` (*): connects the axes in a L-shape, but removes the other top and right-hand edges of the plot frame (box). Also sets the "Okabe-Ito" palette as a default for discrete colors. Inspired by the **ggplot2** theme of the same name. +#' - `"bw"` (*): similar to `"clean"`, except uses thinner lines for the plot frame (box), solid grid lines, and sets the "Okabe-Ito" palette as a default for discrete colors. Inspired by the **ggplot2** theme of the same name. +#' - `"minimal"` (*): removes the plot frame (box) from `"bw"`, as well as the background for facet titles. Inspired by the **ggplot2** theme of the same name. +#' - `"ipsum"` (*): similar to `"minimal"`, except subtitle is italicised and axes titles are aligned to the far edges. Inspired by the **hrbrthemes** theme of the same name for **ggplot2**. #' - `"dark"` (*): similar to `"minimal"`, but set against a dark background with foreground and a palette colours lightened for appropriate contrast. #' - `"ridge"` (*): a specialized theme for ridge plots (see [`type_ridge()`]). Builds off of `"clean"`, but adds ridge-specific tweaks (e.g. default "Zissou 1" palette for discrete colors, solid horizontal grid lines, and minor adjustments to y-axis labels). Not recommended for non-ridge plots. #' - `"ridge2"` (*): removes the plot frame (box) from `"ridge"`, but retains the x-axis line. Again, not recommended for non-ridge plots. @@ -39,21 +39,21 @@ #' without arguments. Altenatively, invoke the `tinyplot(..., theme = )` #' argument for an ephemeral theme that is automatically reset at the end of the #' plot call. -#' +#' #' **Caveat emptor:** Themes are a somewhat experimental feature of `tinyplot`. #' While we feel confident that themes should work as expected for most #' "standard" cases, there may be some sharp edges. Please report any unexpected #' behaviour to our GitHub repo: #' -#' +#' #' Known current limitations include: -#' +#' #' - Themes do not work well when `legend = "top!"`. #' - Dynamic margin spacing does not account for multi-line strings (e.g., axes #' or main titles that contain "\\n"). #' #' @return The function returns nothing. It is called for its side effects. -#' +#' #' @seealso [`tpar`] which does the heavy lifting under the hood. #' #' @examples @@ -64,26 +64,26 @@ #' sub = "Data courtesy of the Harvard PRIM-H project" #' ) #' p() -#' +#' #' # Set a theme #' tinytheme("bw") #' p() -#' +#' #' # A set theme is persistent and will apply to subsequent plots #' tinyplot(0:10) #' #' # Try a different theme #' tinytheme("dark") #' p() -#' +#' #' # Customize the theme by overriding default settings #' tinytheme("bw", fg = "green", font.main = 2, font.sub = 3, family = "Palatino") #' p() -#' +#' #' # Another custom theme example #' tinytheme("bw", font.main = 2, col.axis = "darkcyan", family = "HersheyScript") #' p() -#' +#' #' # Aside: One or two specialized themes are only meant for certain plot types #' tinytheme("ridge2") #' tinyplot(I(cut(lat, 10)) ~ depth, data = quakes, type = "ridge") @@ -91,43 +91,50 @@ #' # Reset the theme #' tinytheme() #' p() -#' +#' #' # For an ephemeral theme, use `tinyplot(..., theme = )` directly #' tinyplot(0:10, theme = "clean", main = "This theme is ephemeral") #' tinyplot(10:0, main = "See, no more theme") -#' +#' #' # Themes showcase #' ## We'll use a slightly more intricate plot (long y-axis labs and facets) #' ## to demonstrate dynamic margin adjustment etc. -#' +#' #' thms = eval(formals(tinytheme)$theme) -#' +#' #' for (thm in thms) { #' tinytheme(thm) #' tinyplot( #' I(Sepal.Length*1e4) ~ Petal.Length | Species, facet = "by", data = iris, -#' yaxl = ",", +#' yaxl = ",", #' main = paste0('tinytheme("', thm, '")'), #' sub = "A subtitle" #' ) #' box("outer", lty = 2) #' } -#' +#' #' # Reset #' tinytheme() #' #' @export tinytheme = function( - theme = c( - "default", "basic", - "clean", "clean2", "bw", "classic", - "minimal", "ipsum", "dark", - "ridge", "ridge2", - "tufte", "void" - ), - ... - ) { - + theme = c( + "default", + "basic", + "clean", + "clean2", + "bw", + "classic", + "minimal", + "ipsum", + "dark", + "ridge", + "ridge2", + "tufte", + "void" + ), + ... +) { theme = match.arg(theme) # in notebooks, we don't want to close the device because no image. @@ -138,12 +145,25 @@ tinytheme = function( theme, c( "default", - sort(c("basic", "bw", "classic", "clean", "clean2", "dark", "ipsum", - "minimal", "ridge", "ridge2", "tufte", "void")) + sort(c( + "basic", + "bw", + "classic", + "clean", + "clean2", + "dark", + "ipsum", + "minimal", + "ridge", + "ridge2", + "tufte", + "void" + )) ) ) - settings = switch(theme, + settings = switch( + theme, "default" = theme_default, "basic" = theme_basic, "bw" = theme_bw, @@ -167,7 +187,7 @@ tinytheme = function( if (length(settings) > 0) { if (theme == "default") { # for default theme, we want to revert the original pars and turn off the - # before.new.plot hook (otherwise manual par(x = y) changes won't work) + # before.new.plot hook (otherwise manual par(x = y) changes won't work) tpar(settings, hook = FALSE) old_hooks = get_environment_variable(".tpar_hooks") remove_hooks(old_hooks) @@ -180,7 +200,6 @@ tinytheme = function( } - # ## Themes (these are read and set at initial load time) @@ -233,154 +252,190 @@ theme_default = list( yaxt = "standard" ) -# derivatives of "default" +# derivatives of "default" # - basic # - tufte # - void -theme_basic = modifyList(theme_default, list( - tinytheme = "basic", - facet.bg = "gray90", - facet.border = "black", - grid = TRUE, - pch = 16 -)) +theme_basic = modifyList( + theme_default, + list( + tinytheme = "basic", + facet.bg = "gray90", + facet.border = "black", + grid = TRUE, + pch = 16 + ) +) -theme_tufte = modifyList(theme_default, list( - tinytheme = "tufte", - adj.main = 0, - adj.sub = 0, - bty = "n", - font.main = 1, - lab = c(10, 10, 7), - # palette.sequential = "Grays", - pch = 16, - side.sub = 3, - tcl = 0.2 -)) +theme_tufte = modifyList( + theme_default, + list( + tinytheme = "tufte", + adj.main = 0, + adj.sub = 0, + bty = "n", + font.main = 1, + lab = c(10, 10, 7), + # palette.sequential = "Grays", + pch = 16, + side.sub = 3, + tcl = 0.2 + ) +) -theme_void = modifyList(theme_default, list( - tinytheme = "void", - adj.main = 0, - adj.sub = 0, - font.main = 1, - palette.qualitative = "Tableau 10", - palette.sequential = "ag_Sunset", - pch = 16, - side.sub = 3, - # tck = -.02, - xaxt = "none", - yaxt = "none" -)) +theme_void = modifyList( + theme_default, + list( + tinytheme = "void", + adj.main = 0, + adj.sub = 0, + font.main = 1, + palette.qualitative = "Tableau 10", + palette.sequential = "ag_Sunset", + pch = 16, + side.sub = 3, + # tck = -.02, + xaxt = "none", + yaxt = "none" + ) +) -# derivatives of "basic" +# derivatives of "basic" # - clean -theme_clean = modifyList(theme_basic, list( - ## Notes: - ## - 1. Reduce axis title gap by 0.5 lines and also reduce tcl to 0.3 lines. - ## - 2. Sub moves to top. - ## - 3. Also want to remove excess white on rhs of plot margin (when no legend). - ## - Together, 1, 2, and 3 imply that... - ## -- mgp[1] should be adjusted by 0.8 (= 0.5 + 0.3) - ## -- mgp[2] should be adjusted by 0.3 - ## -- mar[1] should be adjusted by 1.8 (= 1 (no sub) + 0.5 + 0.3 (tighter axis labs)) - ## -- mar[2] should be adjusted by 0.8 (= 0.5 + 0.3) - ## -- mar[3] should remain unchanged (main + sub will adjust automatically) - ## -- mar[4] should be adjusted by 1.5 (relative to 2.1) - ## - tinytheme = "clean", - adj.main = 0, - adj.sub = 0, - dynmar = TRUE, - las = 1, - mar = c(5.1, 4.1, 4.1, 2.1) - c(1+0.5+0.3, 0.5+0.3, 0, 1.5), ## test - mgp = c(3, 1, 0) - c(0.5+0.3, 0.3, 0), # i.e., subtract 0.5 lines + the (abs) value of the tcl adjustment - palette.qualitative = "Tableau 10", - palette.sequential = "ag_Sunset", - side.sub = 3, - tcl = -0.3 -)) +theme_clean = modifyList( + theme_basic, + list( + ## Notes: + ## - 1. Reduce axis title gap by 0.5 lines and also reduce tcl to 0.3 lines. + ## - 2. Sub moves to top. + ## - 3. Also want to remove excess white on rhs of plot margin (when no legend). + ## - Together, 1, 2, and 3 imply that... + ## -- mgp[1] should be adjusted by 0.8 (= 0.5 + 0.3) + ## -- mgp[2] should be adjusted by 0.3 + ## -- mar[1] should be adjusted by 1.8 (= 1 (no sub) + 0.5 + 0.3 (tighter axis labs)) + ## -- mar[2] should be adjusted by 0.8 (= 0.5 + 0.3) + ## -- mar[3] should remain unchanged (main + sub will adjust automatically) + ## -- mar[4] should be adjusted by 1.5 (relative to 2.1) + ## + tinytheme = "clean", + adj.main = 0, + adj.sub = 0, + dynmar = TRUE, + las = 1, + mar = c(5.1, 4.1, 4.1, 2.1) - c(1 + 0.5 + 0.3, 0.5 + 0.3, 0, 1.5), ## test + mgp = c(3, 1, 0) - c(0.5 + 0.3, 0.3, 0), # i.e., subtract 0.5 lines + the (abs) value of the tcl adjustment + palette.qualitative = "Tableau 10", + palette.sequential = "ag_Sunset", + side.sub = 3, + tcl = -0.3 + ) +) -# derivatives of "clean" +# derivatives of "clean" # - clean2 # - classic # - bw -theme_clean2 = modifyList(theme_clean, list( - tinytheme = "clean2", - facet.border = "gray90", - xaxt = "labels", - yaxt = "labels" -)) +theme_clean2 = modifyList( + theme_clean, + list( + tinytheme = "clean2", + facet.border = "gray90", + xaxt = "labels", + yaxt = "labels" + ) +) -theme_classic = modifyList(theme_clean, list( - tinytheme = "classic", - bty = "l", - facet.bg = NULL, - font.main = 1, - grid = FALSE, - palette.qualitative = "Okabe-Ito" -)) +theme_classic = modifyList( + theme_clean, + list( + tinytheme = "classic", + bty = "l", + facet.bg = NULL, + font.main = 1, + grid = FALSE, + palette.qualitative = "Okabe-Ito" + ) +) -theme_bw = modifyList(theme_clean, list( - tinytheme = "bw", - font.main = 1, - grid.lty = 1, - grid.lwd = 0.5, - lwd = 0.5, - lwd.axis = 0.5, - palette.qualitative = "Okabe-Ito" -)) +theme_bw = modifyList( + theme_clean, + list( + tinytheme = "bw", + font.main = 1, + grid.lty = 1, + grid.lwd = 0.5, + lwd = 0.5, + lwd.axis = 0.5, + palette.qualitative = "Okabe-Ito" + ) +) # derivatives of "bw" # - minimal # - ipsum # - dark - -theme_minimal = modifyList(theme_bw, list( - tinytheme = "minimal", - bty = "n", - facet.bg = NULL, - facet.border = NULL, - xaxt = "labels", - yaxt = "labels" -)) -theme_ipsum = modifyList(theme_minimal, list( - tinytheme = "ipsum", - bty = "n", - font.sub = 3, - adj.ylab = 1, - adj.xlab = 1 -)) +theme_minimal = modifyList( + theme_bw, + list( + tinytheme = "minimal", + bty = "n", + facet.bg = NULL, + facet.border = NULL, + xaxt = "labels", + yaxt = "labels" + ) +) -theme_dark = modifyList(theme_minimal, list( - tinytheme = "dark", - bg = "#1A1A1A", - fg = "#BBBBBB", - # col = "white", - col.xaxs = "#BBBBBB", - col.yaxs = "#BBBBBB", - col.lab = "#BBBBBB", - col.main = "#BBBBBB", - col.sub = "#BBBBBB", - col.axis = "#BBBBBB", - # facet.bg = "gray20", - grid.col = "#6D6D6D", - palette.qualitative = "Set 2", - palette.sequential = "Sunset" -)) +theme_ipsum = modifyList( + theme_minimal, + list( + tinytheme = "ipsum", + bty = "n", + font.sub = 3, + adj.ylab = 1, + adj.xlab = 1 + ) +) + +theme_dark = modifyList( + theme_minimal, + list( + tinytheme = "dark", + bg = "#1A1A1A", + fg = "#BBBBBB", + # col = "white", + col.xaxs = "#BBBBBB", + col.yaxs = "#BBBBBB", + col.lab = "#BBBBBB", + col.main = "#BBBBBB", + col.sub = "#BBBBBB", + col.axis = "#BBBBBB", + # facet.bg = "gray20", + grid.col = "#6D6D6D", + palette.qualitative = "Set 2", + palette.sequential = "Sunset" + ) +) # derivative of clean/clean2 -theme_ridge = modifyList(theme_clean, list( - tinytheme = "ridge", - palette.qualitative = "Zissou 1", - grid = FALSE -)) -theme_ridge2 = modifyList(theme_clean2, list( - tinytheme = "ridge2", - palette.qualitative = "Zissou 1", - grid = FALSE -)) +theme_ridge = modifyList( + theme_clean, + list( + tinytheme = "ridge", + palette.qualitative = "Zissou 1", + grid = FALSE + ) +) +theme_ridge2 = modifyList( + theme_clean2, + list( + tinytheme = "ridge2", + palette.qualitative = "Zissou 1", + grid = FALSE + ) +) diff --git a/R/title.R b/R/title.R index 74311d05..e76a2508 100644 --- a/R/title.R +++ b/R/title.R @@ -9,7 +9,10 @@ draw_title = function(main, sub, xlab, ylab, legend, legend_args, opar) { legend_eval = tryCatch(paste0(legend)[[2]], error = function(e) NULL) } - adj_title = !is.null(legend) && ((is.character(legend) && legend == "top!") || (!is.null(legend_args[["x"]]) && legend_args[["x"]] == "top!") || (is.list(legend_eval) && legend_eval[[1]] == "top!")) + adj_title = !is.null(legend) && + ((is.character(legend) && legend == "top!") || + (!is.null(legend_args[["x"]]) && legend_args[["x"]] == "top!") || + (is.list(legend_eval) && legend_eval[[1]] == "top!")) # For the "top!" legend case, bump main title up to make space for the # legend beneath it: Take the normal main title line gap (i.e., 1.7 lines) @@ -26,7 +29,9 @@ draw_title = function(main, sub, xlab, ylab, legend, legend_args, opar) { if (!is.null(sub)) { if (isTRUE(get_tpar("side.sub", 1) == 3)) { - if (is.null(line_main)) line_main = par("mgp")[3] + 1.7 - .1 + if (is.null(line_main)) { + line_main = par("mgp")[3] + 1.7 - .1 + } line_main = line_main + 1.2 } if (isTRUE(get_tpar("side.sub", 1) == 3)) { @@ -55,12 +60,12 @@ draw_title = function(main, sub, xlab, ylab, legend, legend_args, opar) { cex.main = get_tpar("cex.main", 1.4), col.main = get_tpar("col.main", "black"), font.main = get_tpar("font.main", 2), - adj = get_tpar(c("adj.main", "adj"), 3)) + adj = get_tpar(c("adj.main", "adj"), 3) + ) args = Filter(function(x) !is.null(x), args) do.call(title, args) } - # Axis titles args = list(xlab = xlab) args[["adj"]] = get_tpar(c("adj.xlab", "adj")) diff --git a/R/tpar.R b/R/tpar.R index 763b6374..f2244778 100644 --- a/R/tpar.R +++ b/R/tpar.R @@ -13,7 +13,7 @@ #' parameters typically supported by \code{\link[graphics]{par}}, as well as #' the `tinyplot`-specific ones described in the 'Graphical Parameters' #' section below. -#' @param hook Logical. If `TRUE`, base graphical parameters persist across +#' @param hook Logical. If `TRUE`, base graphical parameters persist across #' plots via a hook applied before each new plot (see `?setHook`). #' #' @md @@ -73,13 +73,13 @@ #' #' @importFrom graphics par #' @importFrom utils modifyList -#' +#' #' @seealso [`graphics::par`] which `tpar` builds on top of. [`get_saved_par`] #' is a convenience function for retrieving graphical parameters at different #' stages of a `tinyplot` call (and used for internal accounting purposes). #' [`tinytheme`] allows users to easily set a group of graphics parameters #' in a single function call, according to a variety of predefined themes. -#' +#' #' @examples #' # Return a list of existing base and tinyplot graphic params #' tpar("las", "pch", "facet.bg", "facet.cex", "grid") @@ -115,7 +115,6 @@ #' #' @export tpar = function(..., hook = FALSE) { - opts = list(...) if (length(opts) == 1 && is.null(names(opts))) { if (inherits(opts[[1]], "list") && !is.null(names(opts[[1]]))) { @@ -154,7 +153,6 @@ tpar = function(..., hook = FALSE) { } } - ###### Retrieve parameters # User didn't assign any new values, but may have requested explicit (print @@ -168,7 +166,9 @@ tpar = function(..., hook = FALSE) { used_par = intersect(opts, known_par) } if (length(used_par)) { - if (!is.null(nam)) used_par = opts[used_par] + if (!is.null(nam)) { + used_par = opts[used_par] + } used_par_old = par(used_par) tpar_old = modifyList(as.list(.tpar), used_par_old, keep.null = TRUE) } @@ -180,7 +180,9 @@ tpar = function(..., hook = FALSE) { ret_par = par(used_par) ret = modifyList(ret, ret_par, keep.null = TRUE) } - if (length(ret) == 1) ret = ret[[1]] + if (length(ret) == 1) { + ret = ret[[1]] + } return(ret) } else { # no specific request; return all existing values invisibly @@ -190,7 +192,9 @@ tpar = function(..., hook = FALSE) { # a la `oldpar = par(param = new_value)` } else { `names<-`(lapply(nam, function(x) .tpar[[x]]), nam) - if (length(base_par) > 0 && isFALSE(hook)) tpar_old = modifyList(tpar_old, base_par_old, keep.null = TRUE) + if (length(base_par) > 0 && isFALSE(hook)) { + tpar_old = modifyList(tpar_old, base_par_old, keep.null = TRUE) + } return(invisible(tpar_old)) } } @@ -198,7 +202,9 @@ tpar = function(..., hook = FALSE) { # Two levels of priority: .tpar[["name"]] -> par("name") get_tpar = function(opts, default = NULL, tpar_list = NULL) { - if (is.null(tpar_list)) tpar_list = .tpar + if (is.null(tpar_list)) { + tpar_list = .tpar + } # parameter priority # .tpar[["name"]] -> par("name") for (o in opts) { @@ -211,51 +217,50 @@ get_tpar = function(opts, default = NULL, tpar_list = NULL) { return(p) } } - } return(default) } known_tpar = c( - "adj.main", - "adj.sub", - "adj.xlab", - "adj.ylab", - "cex.xlab", - "cex.ylab", - "col.xaxs", - "col.yaxs", - "cairo", - "dynmar", - "facet.bg", - "facet.border", - "facet.cex", - "facet.col", - "facet.font", - "file.height", - "file.res", - "file.width", - "fmar", - "grid", - "grid.bg", - "grid.col", - "grid.lty", - "grid.lwd", - "lmar", - "lty.xaxs", - "lty.yaxs", - "lwd.xaxs", - "lwd.yaxs", - "lwd.axis", - "pch", - "palette.qualitative", - "palette.sequential", - "ribbon.alpha", - "side.sub", - "tinytheme", - "xaxt", - "yaxt" + "adj.main", + "adj.sub", + "adj.xlab", + "adj.ylab", + "cex.xlab", + "cex.ylab", + "col.xaxs", + "col.yaxs", + "cairo", + "dynmar", + "facet.bg", + "facet.border", + "facet.cex", + "facet.col", + "facet.font", + "file.height", + "file.res", + "file.width", + "fmar", + "grid", + "grid.bg", + "grid.col", + "grid.lty", + "grid.lwd", + "lmar", + "lty.xaxs", + "lty.yaxs", + "lwd.xaxs", + "lwd.yaxs", + "lwd.axis", + "pch", + "palette.qualitative", + "palette.sequential", + "ribbon.alpha", + "side.sub", + "tinytheme", + "xaxt", + "yaxt" ) @@ -267,29 +272,108 @@ assign_tpar = function(opts) { assert_tpar = function(.tpar) { - assert_numeric(.tpar[["adj.main"]], len = 1, lower = 0, upper = 1, null.ok = TRUE, name = "adj.main") - assert_numeric(.tpar[["adj.sub"]], len = 1, lower = 0, upper = 1, null.ok = TRUE, name = "adj.sub") - assert_numeric(.tpar[["adj.xlab"]], len = 1, lower = 0, upper = 1, null.ok = TRUE, name = "adj.xlab") - assert_numeric(.tpar[["adj.ylab"]], len = 1, lower = 0, upper = 1, null.ok = TRUE, name = "adj.ylab") + assert_numeric( + .tpar[["adj.main"]], + len = 1, + lower = 0, + upper = 1, + null.ok = TRUE, + name = "adj.main" + ) + assert_numeric( + .tpar[["adj.sub"]], + len = 1, + lower = 0, + upper = 1, + null.ok = TRUE, + name = "adj.sub" + ) + assert_numeric( + .tpar[["adj.xlab"]], + len = 1, + lower = 0, + upper = 1, + null.ok = TRUE, + name = "adj.xlab" + ) + assert_numeric( + .tpar[["adj.ylab"]], + len = 1, + lower = 0, + upper = 1, + null.ok = TRUE, + name = "adj.ylab" + ) assert_flag(.tpar[["cairo"]], name = "cairo") assert_flag(.tpar[["dynmar"]], null.ok = FALSE, name = "dynmar") assert_numeric(.tpar[["lmar"]], len = 2, null.ok = TRUE, name = "lmar") - assert_numeric(.tpar[["ribbon.alpha"]], len = 1, lower = 0, upper = 1, null.ok = TRUE, name = "ribbon.alpha") - assert_numeric(.tpar[["grid.lwd"]], len = 1, lower = 0, null.ok = TRUE, name = "grid.lwd") + assert_numeric( + .tpar[["ribbon.alpha"]], + len = 1, + lower = 0, + upper = 1, + null.ok = TRUE, + name = "ribbon.alpha" + ) + assert_numeric( + .tpar[["grid.lwd"]], + len = 1, + lower = 0, + null.ok = TRUE, + name = "grid.lwd" + ) assert_flag(.tpar[["grid"]], null.ok = TRUE, name = "grid") - assert_numeric(.tpar[["file.res"]], len = 1, lower = 0, null.ok = TRUE, name = "file.res") - assert_numeric(.tpar[["file.height"]], len = 1, lower = 0, null.ok = TRUE, name = "file.height") - assert_numeric(.tpar[["file.width"]], len = 1, lower = 0, null.ok = TRUE, name = "file.width") - assert_numeric(.tpar[["facet.font"]], len = 1, null.ok = TRUE, name = "facet.font") - assert_numeric(.tpar[["facet.cex"]], len = 1, null.ok = TRUE, name = "facet.cex") - assert_numeric(.tpar[["side.sub"]], len = 1, null.ok = TRUE, name = "side.sub") + assert_numeric( + .tpar[["file.res"]], + len = 1, + lower = 0, + null.ok = TRUE, + name = "file.res" + ) + assert_numeric( + .tpar[["file.height"]], + len = 1, + lower = 0, + null.ok = TRUE, + name = "file.height" + ) + assert_numeric( + .tpar[["file.width"]], + len = 1, + lower = 0, + null.ok = TRUE, + name = "file.width" + ) + assert_numeric( + .tpar[["facet.font"]], + len = 1, + null.ok = TRUE, + name = "facet.font" + ) + assert_numeric( + .tpar[["facet.cex"]], + len = 1, + null.ok = TRUE, + name = "facet.cex" + ) + assert_numeric( + .tpar[["side.sub"]], + len = 1, + null.ok = TRUE, + name = "side.sub" + ) assert_string(.tpar[["grid.bg"]], null.ok = TRUE, name = "grid.bg") assert_numeric(.tpar[["fmar"]], len = 4, null.ok = TRUE, name = "fmar") facet.col = .tpar[["facet.col"]] if (!is.null(facet.col)) { - if (!is.null(facet.col) && !is.numeric(facet.col) && !is.character(facet.col)) { - stop("facet.col needs to be NULL, or a numeric or character", call. = FALSE) + if ( + !is.null(facet.col) && !is.numeric(facet.col) && !is.character(facet.col) + ) { + stop( + "facet.col needs to be NULL, or a numeric or character", + call. = FALSE + ) } assert_true(length(facet.col) == 1, name = "length(facet.col)==1") } @@ -297,15 +381,25 @@ assert_tpar = function(.tpar) { facet.bg = .tpar$facet.bg if (!is.null(facet.bg)) { if (!is.numeric(facet.bg) && !is.character(facet.bg)) { - stop("facet.bg needs to be NULL, or a numeric or character", call. = FALSE) + stop( + "facet.bg needs to be NULL, or a numeric or character", + call. = FALSE + ) } assert_true(length(facet.bg) == 1, name = "length(facet.bg)==1") } facet.border = .tpar$facet.border if (!is.null(facet.border)) { - if (!is.numeric(facet.border) && !is.character(facet.border) && !is.na(facet.border)) { - stop("facet.border needs to be NULL, or a numeric, character, or NA", call. = FALSE) + if ( + !is.numeric(facet.border) && + !is.character(facet.border) && + !is.na(facet.border) + ) { + stop( + "facet.border needs to be NULL, or a numeric, character, or NA", + call. = FALSE + ) } assert_true(length(facet.border) == 1, name = "length(facet.border)==1") } @@ -322,37 +416,104 @@ init_tpar = function(rm_hook = FALSE) { } } - .tpar$cairo = if (is.null(getOption("tinyplot_cairo"))) capabilities("cairo") else as.logical(getOption("tinyplot_cairo")) - - - .tpar$dynmar = if (is.null(getOption("tinyplot_dynmar"))) FALSE else as.logical(getOption("tinyplot_dynmar")) - + .tpar$cairo = if (is.null(getOption("tinyplot_cairo"))) { + capabilities("cairo") + } else { + as.logical(getOption("tinyplot_cairo")) + } + + .tpar$dynmar = if (is.null(getOption("tinyplot_dynmar"))) { + FALSE + } else { + as.logical(getOption("tinyplot_dynmar")) + } + # Figure output options if written to file - .tpar$file.width = if (is.null(getOption("tinyplot_file.width"))) 7 else as.numeric(getOption("tinyplot_file.width")) - .tpar$file.height = if (is.null(getOption("tinyplot_file.height"))) 7 else as.numeric(getOption("tinyplot_file.height")) - .tpar$file.res = if (is.null(getOption("tinyplot_file.res"))) 300 else as.numeric(getOption("tinyplot_file.res")) + .tpar$file.width = if (is.null(getOption("tinyplot_file.width"))) { + 7 + } else { + as.numeric(getOption("tinyplot_file.width")) + } + .tpar$file.height = if (is.null(getOption("tinyplot_file.height"))) { + 7 + } else { + as.numeric(getOption("tinyplot_file.height")) + } + .tpar$file.res = if (is.null(getOption("tinyplot_file.res"))) { + 300 + } else { + as.numeric(getOption("tinyplot_file.res")) + } # Facet margin, i.e. gap between the individual facet windows - .tpar$fmar = if (is.null(getOption("tinyplot_fmar"))) c(1, 1, 1, 1) else as.numeric(getOption("tinyplot_fmar")) + .tpar$fmar = if (is.null(getOption("tinyplot_fmar"))) { + c(1, 1, 1, 1) + } else { + as.numeric(getOption("tinyplot_fmar")) + } # Other facet options - .tpar$facet.cex = if (is.null(getOption("tinyplot_facet.cex"))) 1 else as.numeric(getOption("tinyplot_facet.cex")) - .tpar$facet.font = if (is.null(getOption("tinyplot_facet.font"))) NULL else as.numeric(getOption("tinyplot_facet.font")) - .tpar$facet.col = if (is.null(getOption("tinyplot_facet.col"))) NULL else getOption("tinyplot_facet.col") - .tpar$facet.bg = if (is.null(getOption("tinyplot_facet.bg"))) NULL else getOption("tinyplot_facet.bg") - .tpar$facet.border = if (is.null(getOption("tinyplot_facet.border"))) NA else getOption("tinyplot_facet.border") + .tpar$facet.cex = if (is.null(getOption("tinyplot_facet.cex"))) { + 1 + } else { + as.numeric(getOption("tinyplot_facet.cex")) + } + .tpar$facet.font = if (is.null(getOption("tinyplot_facet.font"))) { + NULL + } else { + as.numeric(getOption("tinyplot_facet.font")) + } + .tpar$facet.col = if (is.null(getOption("tinyplot_facet.col"))) { + NULL + } else { + getOption("tinyplot_facet.col") + } + .tpar$facet.bg = if (is.null(getOption("tinyplot_facet.bg"))) { + NULL + } else { + getOption("tinyplot_facet.bg") + } + .tpar$facet.border = if (is.null(getOption("tinyplot_facet.border"))) { + NA + } else { + getOption("tinyplot_facet.border") + } # Plot grid - .tpar$grid = if (is.null(getOption("tinyplot_grid"))) FALSE else as.logical(getOption("tinyplot_grid")) - .tpar$grid.col = if (is.null(getOption("tinyplot_grid.col"))) "lightgray" else getOption("tinyplot_grid.col") - .tpar$grid.lty = if (is.null(getOption("tinyplot_grid.lty"))) "dotted" else getOption("tinyplot_grid.lty") - .tpar$grid.lwd = if (is.null(getOption("tinyplot_grid.lwd"))) 1 else as.numeric(getOption("tinyplot_grid.lwd")) + .tpar$grid = if (is.null(getOption("tinyplot_grid"))) { + FALSE + } else { + as.logical(getOption("tinyplot_grid")) + } + .tpar$grid.col = if (is.null(getOption("tinyplot_grid.col"))) { + "lightgray" + } else { + getOption("tinyplot_grid.col") + } + .tpar$grid.lty = if (is.null(getOption("tinyplot_grid.lty"))) { + "dotted" + } else { + getOption("tinyplot_grid.lty") + } + .tpar$grid.lwd = if (is.null(getOption("tinyplot_grid.lwd"))) { + 1 + } else { + as.numeric(getOption("tinyplot_grid.lwd")) + } # Legend margin, i.e. gap between the legend and the plot elements - .tpar$lmar = if (is.null(getOption("tinyplot_lmar"))) c(1.0, 0.1) else as.numeric(getOption("tinyplot_lmar")) + .tpar$lmar = if (is.null(getOption("tinyplot_lmar"))) { + c(1.0, 0.1) + } else { + as.numeric(getOption("tinyplot_lmar")) + } # Alpha fill (transparency) default for ribbon and area plots - .tpar$ribbon.alpha = if (is.null(getOption("tinyplot_ribbon.alpha"))) 0.2 else as.numeric(getOption("tinyplot_ribbon.alpha")) + .tpar$ribbon.alpha = if (is.null(getOption("tinyplot_ribbon.alpha"))) { + 0.2 + } else { + as.numeric(getOption("tinyplot_ribbon.alpha")) + } } ## initialize internal environment for tpar variables diff --git a/R/type_abline.R b/R/type_abline.R index 0e4a4c27..72fb7903 100644 --- a/R/type_abline.R +++ b/R/type_abline.R @@ -107,12 +107,24 @@ type_abline = function(a = 0, b = 1) { env2env(environment(), settings, "type_info") } draw_abline = function() { - fun = function(ifacet, iby, data_facet, icol, ilty, ilwd, - ngrps, nfacets, by_continuous, facet_by, - type_info, - ...) { + fun = function( + ifacet, + iby, + data_facet, + icol, + ilty, + ilwd, + ngrps, + nfacets, + by_continuous, + facet_by, + type_info, + ... + ) { # flag for aesthetics by groups - grp_aes = type_info[["ul_col"]] == 1 || type_info[["ul_lty"]] == ngrps || type_info[["ul_lwd"]] == ngrps + grp_aes = type_info[["ul_col"]] == 1 || + type_info[["ul_lty"]] == ngrps || + type_info[["ul_lwd"]] == ngrps if (length(a) != 1) { if (!length(a) %in% c(ngrps, nfacets, ngrps * nfacets)) { @@ -156,7 +168,10 @@ type_abline = function(a = 0, b = 1) { icol = 1 } - if (type_info[["ul_col"]] != 1 && !(type_info[["ul_lty"]] == ngrps || type_info[["ul_lwd"]] == ngrps)) { + if ( + type_info[["ul_col"]] != 1 && + !(type_info[["ul_lty"]] == ngrps || type_info[["ul_lwd"]] == ngrps) + ) { icol = 1 } diff --git a/R/type_area.R b/R/type_area.R index 13f96bfc..07b62a08 100644 --- a/R/type_area.R +++ b/R/type_area.R @@ -1,44 +1,53 @@ #' @rdname type_ribbon #' @export type_area = function(alpha = NULL) { - out = list( - draw = NULL, - data = data_area(alpha = alpha), - name = "area" - ) - class(out) = "tinyplot_type" - return(out) + out = list( + draw = NULL, + data = data_area(alpha = alpha), + name = "area" + ) + class(out) = "tinyplot_type" + return(out) } data_area = function(alpha = alpha) { - ribbon.alpha = if (is.null(alpha)) .tpar[["ribbon.alpha"]] else (alpha) - fun = function(settings, ...) { - env2env(settings, environment(), "datapoints") - datapoints$ymax = datapoints$y - datapoints$ymin = rep.int(0, nrow(datapoints)) - ymax = datapoints$ymax - ymin = datapoints$ymin - type = "ribbon" + ribbon.alpha = if (is.null(alpha)) .tpar[["ribbon.alpha"]] else (alpha) + fun = function(settings, ...) { + env2env(settings, environment(), "datapoints") + datapoints$ymax = datapoints$y + datapoints$ymin = rep.int(0, nrow(datapoints)) + ymax = datapoints$ymax + ymin = datapoints$ymin + type = "ribbon" - # ribbon.alpha comes from parent scope, so assign it locally - ribbon.alpha = ribbon.alpha + # ribbon.alpha comes from parent scope, so assign it locally + ribbon.alpha = ribbon.alpha - # legend customizations - settings$legend_args[["pch"]] = settings$legend_args[["pch"]] %||% 22 - settings$legend_args[["pt.cex"]] = settings$legend_args[["pt.cex"]] %||% 3.5 - settings$legend_args[["pt.lwd"]] = settings$legend_args[["pt.lwd"]] %||% par("lwd") - settings$legend_args[["lty"]] = settings$legend_args[["lty"]] %||% 0 - settings$legend_args[["y.intersp"]] = settings$legend_args[["y.intersp"]] %||% 1.25 - settings$legend_args[["seg.len"]] = settings$legend_args[["seg.len"]] %||% 1.25 + # legend customizations + settings$legend_args[["pch"]] = settings$legend_args[["pch"]] %||% 22 + settings$legend_args[["pt.cex"]] = settings$legend_args[["pt.cex"]] %||% 3.5 + settings$legend_args[["pt.lwd"]] = settings$legend_args[["pt.lwd"]] %||% + par("lwd") + settings$legend_args[["lty"]] = settings$legend_args[["lty"]] %||% 0 + settings$legend_args[["y.intersp"]] = settings$legend_args[[ + "y.intersp" + ]] %||% + 1.25 + settings$legend_args[["seg.len"]] = settings$legend_args[["seg.len"]] %||% + 1.25 - env2env(environment(), settings, c( - "datapoints", - "ymax", - "ymin", - "type", - "ribbon.alpha" - )) - } - return(fun) + env2env( + environment(), + settings, + c( + "datapoints", + "ymax", + "ymin", + "type", + "ribbon.alpha" + ) + ) + } + return(fun) } diff --git a/R/type_barplot.R b/R/type_barplot.R index 9211ea90..377431ce 100644 --- a/R/type_barplot.R +++ b/R/type_barplot.R @@ -34,11 +34,11 @@ #' tinyplot(~ cyl | vs, data = mtcars, type = "barplot") #' tinyplot(~ cyl | vs, data = mtcars, type = "barplot", beside = TRUE) #' tinyplot(~ cyl | vs, data = mtcars, type = "barplot", beside = TRUE, fill = 0.2) -#' +#' #' # Reorder x variable categories either by their character levels or numeric indexes #' tinyplot(~ cyl, data = mtcars, type = "barplot", xlevels = c("8", "6", "4")) #' tinyplot(~ cyl, data = mtcars, type = "barplot", xlevels = 3:1) -#' +#' #' # Note: Above we used automatic argument passing for `beside`. But this #' # wouldn't work for `width`, since it would conflict with the top-level #' # `tinyplot(..., width = )` argument. It's safer to pass these args @@ -47,11 +47,11 @@ #' type = type_barplot(beside = TRUE, drop.zeros = TRUE, width = 0.65)) #' #' tinytheme("clean2") -#' +#' #' # Example for numeric y aggregated by x (default: FUN = mean) + facets #' tinyplot(extra ~ ID | group, facet = "by", data = sleep, #' type = "barplot", fill = 0.6) -#' +#' #' # Fancy frequency table: #' tinyplot(Freq ~ Sex | Survived, facet = ~ Class, data = as.data.frame(Titanic), #' type = "barplot", facet.args = list(nrow = 1), flip = TRUE, fill = 0.6) @@ -64,11 +64,27 @@ #' center = TRUE, flip = TRUE, facet.args = list(ncol = 1), yaxl = "percent") #' #' tinytheme() -#' +#' #' @export -type_barplot = function(width = 5/6, beside = FALSE, center = FALSE, FUN = NULL, xlevels = NULL, xaxlabels = NULL, drop.zeros = FALSE) { +type_barplot = function( + width = 5 / 6, + beside = FALSE, + center = FALSE, + FUN = NULL, + xlevels = NULL, + xaxlabels = NULL, + drop.zeros = FALSE +) { out = list( - data = data_barplot(width = width, beside = beside, center = center, FUN = FUN, xlevels = xlevels, xaxlabels = xaxlabels, drop.zeros = drop.zeros), + data = data_barplot( + width = width, + beside = beside, + center = center, + FUN = FUN, + xlevels = xlevels, + xaxlabels = xaxlabels, + drop.zeros = drop.zeros + ), draw = draw_rect(), name = "barplot" ) @@ -77,153 +93,221 @@ type_barplot = function(width = 5/6, beside = FALSE, center = FALSE, FUN = NULL, } #' @importFrom stats aggregate -data_barplot = function(width = 5/6, beside = FALSE, center = FALSE, FUN = NULL, xlevels = NULL, xaxlabels = NULL, drop.zeros = FALSE) { - fun = function(settings, ...) { - env2env( - settings, - environment(), - c( - "datapoints", "null_by", "facet_by", - "xlab", "ylab", "xlim", "ylim", "yaxl", "xaxt", - "null_palette", "col", "bg" - ) +data_barplot = function( + width = 5 / 6, + beside = FALSE, + center = FALSE, + FUN = NULL, + xlevels = NULL, + xaxlabels = NULL, + drop.zeros = FALSE +) { + fun = function(settings, ...) { + env2env( + settings, + environment(), + c( + "datapoints", + "null_by", + "facet_by", + "xlab", + "ylab", + "xlim", + "ylim", + "yaxl", + "xaxt", + "null_palette", + "col", + "bg" + ) + ) + + ## tabulate/aggregate datapoints + if (is.null(datapoints$y)) { + if (is.null(xlab) || xlab == "Index") { + xlab = ylab + } + if (is.null(settings$y_dep) && is.null(ylab)) { + ylab = "Count" + } + datapoints$y = numeric(nrow(datapoints)) + if (!is.null(FUN)) { + warning("without 'y' variable 'FUN' specification is ignored") + } + FUN = length + } else { + if (is.null(FUN)) FUN = function(x, ...) mean(x, ..., na.rm = TRUE) + } + if (!is.factor(datapoints$x)) { + datapoints$x = factor(datapoints$x) + } + if (!is.null(xlevels)) { + xlevels = if (is.numeric(xlevels)) { + levels(datapoints$x)[xlevels] + } else { + xlevels + } + if (anyNA(xlevels) || !all(xlevels %in% levels(datapoints$x))) { + warning("not all 'xlevels' correspond to levels of 'x'") + } + datapoints$x = factor(datapoints$x, levels = xlevels) + } + if (!is.null(xaxlabels)) { + levels(datapoints$x) = xaxlabels + } + datapoints = aggregate( + datapoints[, "y", drop = FALSE], + datapoints[, c("x", "by", "facet")], + FUN = FUN, + drop = FALSE + ) + datapoints$y[is.na(datapoints$y)] = 0 #FIXME: always?# + if (!is.factor(datapoints$by)) { + datapoints$by = factor(datapoints$by) + } + if (!is.factor(datapoints$facet)) { + datapoints$facet = factor(datapoints$facet) + } + + if ( + isFALSE(null_by) && isFALSE(facet_by) && !beside && any(datapoints$y < 0) + ) { + warning("'beside' must be TRUE if there are negative 'y' values") + beside = TRUE + } + if (beside & !isFALSE(center)) { + warning("'center' is currently only supported for 'beside = FALSE'") + } + offset_sum = function(z, center = TRUE, na.rm = TRUE) { + n = length(z) + if (isFALSE(center) || n < 1L) { + return(0) + } + mid = if (isTRUE(center)) n / 2 else center + z[floor(mid) + 1L] = (mid - floor(mid)) * z[floor(mid) + 1L] + sum(z[0L:floor(mid) + 1L], na.rm = TRUE) + } + if (is.null(xlim)) { + xlim = c(1, nlevels(datapoints$x)) + c(-0.5, 0.5) * width + } + if (is.null(ylim)) { + ylim = if (beside || length(unique(datapoints$by)) == 1L) { + c( + pmin(0, min(datapoints$y, na.rm = TRUE) * 1.02), + pmax(0, max(datapoints$y, na.rm = TRUE) * 1.02) ) + } else { + range(unlist(tapply( + datapoints$y, + interaction(datapoints$x, datapoints$facet), + function(z) { + c(0, sum(z, na.rm = TRUE)) - offset_sum(z, center = center) + } + ))) * + 1.02 + } + } - ## tabulate/aggregate datapoints - if (is.null(datapoints$y)) { - if (is.null(xlab) || xlab == "Index") xlab = ylab - if (is.null(settings$y_dep) && is.null(ylab)) ylab = "Count" - datapoints$y = numeric(nrow(datapoints)) - if (!is.null(FUN)) warning("without 'y' variable 'FUN' specification is ignored") - FUN = length - } else { - if (is.null(FUN)) FUN = function(x, ...) mean(x, ..., na.rm = TRUE) - } - if (!is.factor(datapoints$x)) datapoints$x = factor(datapoints$x) - if (!is.null(xlevels)) { - xlevels = if(is.numeric(xlevels)) levels(datapoints$x)[xlevels] else xlevels - if (anyNA(xlevels) || !all(xlevels %in% levels(datapoints$x))) warning("not all 'xlevels' correspond to levels of 'x'") - datapoints$x = factor(datapoints$x, levels = xlevels) - } - if (!is.null(xaxlabels)) levels(datapoints$x) = xaxlabels - datapoints = aggregate(datapoints[, "y", drop = FALSE], datapoints[, c("x", "by", "facet")], FUN = FUN, drop = FALSE) - datapoints$y[is.na(datapoints$y)] = 0 #FIXME: always?# - if (!is.factor(datapoints$by)) datapoints$by = factor(datapoints$by) - if (!is.factor(datapoints$facet)) datapoints$facet = factor(datapoints$facet) - - if (isFALSE(null_by) && isFALSE(facet_by) && !beside && any(datapoints$y < 0)) { - warning("'beside' must be TRUE if there are negative 'y' values") - beside = TRUE - } - if (beside & !isFALSE(center)) { - warning("'center' is currently only supported for 'beside = FALSE'") - } - offset_sum = function(z, center = TRUE, na.rm = TRUE) { - n = length(z) - if (isFALSE(center) || n < 1L) return(0) - mid = if (isTRUE(center)) n/2 else center - z[floor(mid) + 1L] = (mid - floor(mid)) * z[floor(mid) + 1L] - sum(z[0L:floor(mid) + 1L], na.rm = TRUE) - } - if (is.null(xlim)) xlim = c(1, nlevels(datapoints$x)) + c(-0.5, 0.5) * width - if (is.null(ylim)) ylim = if (beside || length(unique(datapoints$by)) == 1L) { - c(pmin(0, min(datapoints$y, na.rm = TRUE) * 1.02), pmax(0, max(datapoints$y, na.rm = TRUE) * 1.02)) - } else { - range(unlist(tapply( - datapoints$y, - interaction(datapoints$x, datapoints$facet), - function(z) c(0, sum(z, na.rm = TRUE)) - offset_sum(z, center = center) - ))) * 1.02 - } + ## default color palette + ngrps = length(unique(datapoints$by)) + if (ngrps == 1L && null_palette) { + if (is.null(col)) { + col = par("fg") + } + if (is.null(bg)) bg = "grey" + } else { + if (is.null(bg)) bg = "by" + } - ## default color palette - ngrps = length(unique(datapoints$by)) - if (ngrps == 1L && null_palette) { - if (is.null(col)) col = par("fg") - if (is.null(bg)) bg = "grey" - } else { - if (is.null(bg)) bg = "by" - } + ## calculate bar rectangles per facet + sdat = split(datapoints, datapoints$facet) + datapoints = lapply(sdat, function(df) { + df = df[order(df$x), , drop = FALSE] + nx = nlevels(df$x) + nb = nlevels(df$by) - ## calculate bar rectangles per facet - sdat = split(datapoints, datapoints$facet) - datapoints = lapply(sdat, function(df) { - - df = df[order(df$x), , drop = FALSE] - nx = nlevels(df$x) - nb = nlevels(df$by) - - if (beside) { - xl = as.numeric(df$x) - width/2 + (as.numeric(df$by) - 1) * width/nb * as.numeric(!facet_by) - xr = if (facet_by) xl + width else xl + width/nb - yb = 0 - yt = df$y - } else { - cs = tapply(df$y, df$x, function(z) cumsum(c(0, z)) - offset_sum(z, center = center)) - xl = as.numeric(df$x) - width/2 - xr = xl + width - yb = if (facet_by) 0 else unlist(lapply(cs, `[`, -(nb + 1L))) - yt = if (facet_by) df$y else unlist(lapply(cs, `[`, -1L)) - } - - df$xmin = xl - df$xmax = xr - df$ymin = yb - df$ymax = yt - df$nx = nx - - if (drop.zeros) { - yb = rep_len(yb, length(yt)) - yok = abs(yt - yb) > 0 - df = df[yok, , drop = FALSE] - } - - return(df) + if (beside) { + xl = as.numeric(df$x) - + width / 2 + + (as.numeric(df$by) - 1) * width / nb * as.numeric(!facet_by) + xr = if (facet_by) xl + width else xl + width / nb + yb = 0 + yt = df$y + } else { + cs = tapply(df$y, df$x, function(z) { + cumsum(c(0, z)) - offset_sum(z, center = center) }) - datapoints = do.call("rbind", datapoints) - nx = datapoints$nx[1] - datapoints$nx = NULL - xlabs = 1L:nx - names(xlabs) = levels(datapoints$x) - - if (!isFALSE(center)) { - if (is.null(yaxl)) { - yaxl = abs - } else if (is.character(yaxl)) { - yaxl = paste0("abs_", yaxl) - } - } + xl = as.numeric(df$x) - width / 2 + xr = xl + width + yb = if (facet_by) 0 else unlist(lapply(cs, `[`, -(nb + 1L))) + yt = if (facet_by) df$y else unlist(lapply(cs, `[`, -1L)) + } - axes = TRUE - frame.plot = FALSE - xaxs = "r" - xaxt = if (xaxt == "s") "l" else xaxt - yaxs = "i" - - # legend customizations - settings$legend_args[["lty"]] = settings$legend_args[["lty"]] %||% 0 - settings$legend_args[["pch"]] = settings$legend_args[["pch"]] %||% 22 - settings$legend_args[["pt.cex"]] = settings$legend_args[["pt.cex"]] %||% 3.5 - settings$legend_args[["y.intersp"]] = settings$legend_args[["y.intersp"]] %||% 1.25 - settings$legend_args[["seg.len"]] = settings$legend_args[["seg.len"]] %||% 1.25 - - env2env(environment(), settings, c( - "datapoints", - "xlab", - "ylab", - "xlim", - "ylim", - "axes", - "xlabs", - "frame.plot", - "xaxs", - "xaxt", - "yaxl", - "yaxs", - "col", - "bg" - )) + df$xmin = xl + df$xmax = xr + df$ymin = yb + df$ymax = yt + df$nx = nx + + if (drop.zeros) { + yb = rep_len(yb, length(yt)) + yok = abs(yt - yb) > 0 + df = df[yok, , drop = FALSE] + } + + return(df) + }) + datapoints = do.call("rbind", datapoints) + nx = datapoints$nx[1] + datapoints$nx = NULL + xlabs = 1L:nx + names(xlabs) = levels(datapoints$x) + + if (!isFALSE(center)) { + if (is.null(yaxl)) { + yaxl = abs + } else if (is.character(yaxl)) { + yaxl = paste0("abs_", yaxl) + } } - return(fun) -} + axes = TRUE + frame.plot = FALSE + xaxs = "r" + xaxt = if (xaxt == "s") "l" else xaxt + yaxs = "i" + + # legend customizations + settings$legend_args[["lty"]] = settings$legend_args[["lty"]] %||% 0 + settings$legend_args[["pch"]] = settings$legend_args[["pch"]] %||% 22 + settings$legend_args[["pt.cex"]] = settings$legend_args[["pt.cex"]] %||% 3.5 + settings$legend_args[["y.intersp"]] = settings$legend_args[[ + "y.intersp" + ]] %||% + 1.25 + settings$legend_args[["seg.len"]] = settings$legend_args[["seg.len"]] %||% + 1.25 + + env2env( + environment(), + settings, + c( + "datapoints", + "xlab", + "ylab", + "xlim", + "ylim", + "axes", + "xlabs", + "frame.plot", + "xaxs", + "xaxt", + "yaxl", + "yaxs", + "col", + "bg" + ) + ) + } + return(fun) +} diff --git a/R/type_boxplot.R b/R/type_boxplot.R index 6610846c..65a63f9a 100644 --- a/R/type_boxplot.R +++ b/R/type_boxplot.R @@ -1,5 +1,5 @@ #' Boxplot type -#' +#' #' @description Type function for producing box-and-whisker plots. #' Arguments are passed to \code{\link[graphics]{boxplot}}, although `tinyplot` #' scaffolding allows added functionality such as grouping and faceting. @@ -10,14 +10,14 @@ #' @examples #' # "boxplot" type convenience string #' tinyplot(count ~ spray, data = InsectSprays, type = "boxplot") -#' +#' #' # Note: Specifying the type here is redundant. Like base plot, tinyplot #' # automatically produces a boxplot if x is a factor and y is numeric #' tinyplot(count ~ spray, data = InsectSprays) -#' +#' #' # Grouped boxplot example #' tinyplot(len ~ dose | supp, data = ToothGrowth, type = "boxplot") -#' +#' #' # Use `type_boxplot()` to pass extra arguments for customization #' tinyplot( #' len ~ dose | supp, data = ToothGrowth, lty = 1, @@ -25,14 +25,15 @@ #' ) #' @export type_boxplot = function( - range = 1.5, - width = NULL, - varwidth = FALSE, - notch = FALSE, - outline = TRUE, - boxwex = 0.8, - staplewex = 0.5, - outwex = 0.5) { + range = 1.5, + width = NULL, + varwidth = FALSE, + notch = FALSE, + outline = TRUE, + boxwex = 0.8, + staplewex = 0.5, + outwex = 0.5 +) { out = list( draw = draw_boxplot( range = range, @@ -42,7 +43,8 @@ type_boxplot = function( outline = outline, boxwex = boxwex, staplewex = staplewex, - outwex = outwex), + outwex = outwex + ), data = data_boxplot(boxwex = boxwex), name = "boxplot" ) @@ -51,119 +53,169 @@ type_boxplot = function( } +draw_boxplot = function( + range, + width, + varwidth, + notch, + outline, + boxwex, + staplewex, + outwex +) { + fun = function( + iby, + ix, + iy, + ipch, + ilty, + icol, + ibg, + x_by = FALSE, + facet_by = FALSE, + ngrps = 1, + flip, + ... + ) { + at_ix = unique(ix) + if (isTRUE(x_by)) { + boxwex = boxwex * 2 + } -draw_boxplot = function(range, width, varwidth, notch, outline, boxwex, staplewex, outwex) { - fun = function(iby, ix, iy, ipch, ilty, icol, ibg, x_by = FALSE, facet_by = FALSE, ngrps = 1, flip, ...) { - - at_ix = unique(ix) - if (isTRUE(x_by)) boxwex = boxwex * 2 - - # Handle multiple groups - if (ngrps > 1 && isFALSE(x_by) && isFALSE(facet_by)) { - group_offsets = get_environment_variable(".group_offsets") - boxwex = boxwex / ngrps - 0.01 - at_ix = at_ix + group_offsets[iby] - } - - boxplot( - formula = iy ~ ix, - pch = ipch, - lty = ilty, - border = icol, - col = ibg, - horizontal = flip, - add = TRUE, axes = FALSE, - at = at_ix, - range = range, - width = width, - varwidth = varwidth, - notch = notch, - outline = outline, - boxwex = boxwex, - staplewex = staplewex, - outwex = outwex - ) + # Handle multiple groups + if (ngrps > 1 && isFALSE(x_by) && isFALSE(facet_by)) { + group_offsets = get_environment_variable(".group_offsets") + boxwex = boxwex / ngrps - 0.01 + at_ix = at_ix + group_offsets[iby] } - return(fun) -} + boxplot( + formula = iy ~ ix, + pch = ipch, + lty = ilty, + border = icol, + col = ibg, + horizontal = flip, + add = TRUE, + axes = FALSE, + at = at_ix, + range = range, + width = width, + varwidth = varwidth, + notch = notch, + outline = outline, + boxwex = boxwex, + staplewex = staplewex, + outwex = outwex + ) + } + return(fun) +} data_boxplot = function(boxwex = 0.8) { - fun = function(settings, ...) { - env2env(settings, environment(), c("datapoints", "by", "facet", "null_facet", "null_palette", "x", "col", "bg", "null_by")) - # Convert x to factor if it's not already - datapoints$x = as.factor(datapoints$x) + fun = function(settings, ...) { + env2env( + settings, + environment(), + c( + "datapoints", + "by", + "facet", + "null_facet", + "null_palette", + "x", + "col", + "bg", + "null_by" + ) + ) + # Convert x to factor if it's not already + datapoints$x = as.factor(datapoints$x) - # Handle factor levels and maintain order - xlvls = levels(datapoints$x) - xlabs = seq_along(xlvls) - names(xlabs) = xlvls - datapoints$x = as.integer(datapoints$x) + # Handle factor levels and maintain order + xlvls = levels(datapoints$x) + xlabs = seq_along(xlvls) + names(xlabs) = xlvls + datapoints$x = as.integer(datapoints$x) - if (null_by && null_facet) { - xord = order(datapoints$x) - } else if (null_facet) { - xord = order(datapoints$by, datapoints$x) - } else if (null_by) { - xord = order(datapoints$facet, datapoints$x) - } else { - xord = order(datapoints$by, datapoints$facet, datapoints$x) - } + if (null_by && null_facet) { + xord = order(datapoints$x) + } else if (null_facet) { + xord = order(datapoints$by, datapoints$x) + } else if (null_by) { + xord = order(datapoints$facet, datapoints$x) + } else { + xord = order(datapoints$by, datapoints$facet, datapoints$x) + } - # Check if user provided palette before substitute) - if (length(unique(datapoints[["by"]])) == 1 && null_palette) { - if (is.null(col)) col = par("fg") - if (is.null(bg)) bg = "lightgray" - } else { - if (is.null(bg)) bg = "by" - } + # Check if user provided palette before substitute) + if (length(unique(datapoints[["by"]])) == 1 && null_palette) { + if (is.null(col)) { + col = par("fg") + } + if (is.null(bg)) bg = "lightgray" + } else { + if (is.null(bg)) bg = "by" + } - # Reorder x, y, ymin, and ymax based on the order determined - datapoints = datapoints[xord,] + # Reorder x, y, ymin, and ymax based on the order determined + datapoints = datapoints[xord, ] - # Return the result as a list called 'out' - x = datapoints$x - y = datapoints$y - ymin = datapoints$ymin - ymax = datapoints$ymax - by = if (length(unique(datapoints$by)) > 1) datapoints$by else by - facet = if (length(unique(datapoints$facet)) > 1) datapoints$facet else facet - - # Compute group offsets for multi-group boxplots - ngrps = length(unique(datapoints$by)) - if (ngrps > 1 && !settings$x_by) { - boxwex_grp = boxwex / ngrps - 0.01 - group_offsets = seq( - -((boxwex - boxwex_grp) / 2), - ((boxwex - boxwex_grp) / 2), - length.out = ngrps - ) - } else { - group_offsets = rep(0, max(ngrps, 1)) - } - offsets_axis = "x" + # Return the result as a list called 'out' + x = datapoints$x + y = datapoints$y + ymin = datapoints$ymin + ymax = datapoints$ymax + by = if (length(unique(datapoints$by)) > 1) datapoints$by else by + facet = if (length(unique(datapoints$facet)) > 1) { + datapoints$facet + } else { + facet + } - # legend customizations - settings$legend_args[["pch"]] = settings$legend_args[["pch"]] %||% 22 - settings$legend_args[["pt.cex"]] = settings$legend_args[["pt.cex"]] %||% 3.5 - settings$legend_args[["y.intersp"]] = settings$legend_args[["y.intersp"]] %||% 1.25 - settings$legend_args[["seg.len"]] = settings$legend_args[["seg.len"]] %||% 1.25 - - env2env(environment(), settings, c( - "x", - "y", - "ymin", - "ymax", - "xlabs", - "datapoints", - "col", - "bg", - "by", - "facet", - "group_offsets", - "offsets_axis" - )) + # Compute group offsets for multi-group boxplots + ngrps = length(unique(datapoints$by)) + if (ngrps > 1 && !settings$x_by) { + boxwex_grp = boxwex / ngrps - 0.01 + group_offsets = seq( + -((boxwex - boxwex_grp) / 2), + ((boxwex - boxwex_grp) / 2), + length.out = ngrps + ) + } else { + group_offsets = rep(0, max(ngrps, 1)) } - return(fun) + offsets_axis = "x" + + # legend customizations + settings$legend_args[["pch"]] = settings$legend_args[["pch"]] %||% 22 + settings$legend_args[["pt.cex"]] = settings$legend_args[["pt.cex"]] %||% 3.5 + settings$legend_args[["y.intersp"]] = settings$legend_args[[ + "y.intersp" + ]] %||% + 1.25 + settings$legend_args[["seg.len"]] = settings$legend_args[["seg.len"]] %||% + 1.25 + + env2env( + environment(), + settings, + c( + "x", + "y", + "ymin", + "ymax", + "xlabs", + "datapoints", + "col", + "bg", + "by", + "facet", + "group_offsets", + "offsets_axis" + ) + ) + } + return(fun) } diff --git a/R/type_density.R b/R/type_density.R index 979b9d3a..8a3af59b 100644 --- a/R/type_density.R +++ b/R/type_density.R @@ -1,5 +1,5 @@ #' Density plot type -#' +#' #' @md #' @description Type function for density plots. #' @inheritParams stats::density @@ -30,7 +30,7 @@ #' visually compare densities across subgroups. Hence, it is often useful to #' employ the same ("joint") bandwidth across all subgroups. The following #' strategies are available via the `joint.bw` argument: -#' +#' #' - The default `joint.bw = "mean"` first computes the individual bandwidths #' for each group but then computes their mean, weighted by the number of #' observations in each group. This will work well when all groups have @@ -38,14 +38,14 @@ #' potentially rather different locations. The weighted averaging stabilizes #' potential fluctuations in the individual bandwidths, especially when some #' subgroups are rather small. -#' +#' #' - Alternatively, `joint.bw = "full"` can be used to compute the joint #' bandwidth from the full joint distribution (merging all groups). This will #' yield an even more robust bandwidth, especially when the groups overlap #' substantially (i.e., have similar locations and scales). However, it may #' lead to too large bandwidths and thus too much smoothing, especially when #' the locations of the groups differ substantially. -#' +#' #' - Finally, `joint.bw = "none"` disables the joint bandwidth so that each #' group just employs its individual bandwidth. This is often the best choice #' if the amounts of scatter differ substantially between the groups, thus @@ -58,20 +58,20 @@ #' @examples #' # "density" type convenience string #' tinyplot(~Sepal.Length, data = iris, type = "density") -#' +#' #' # grouped density example #' tinyplot(~Sepal.Length | Species, data = iris, type = "density") -#' +#' #' # use `bg = "by"` (or, equivalent `fill = "by"`) to get filled densities #' tinyplot(~Sepal.Length | Species, data = iris, type = "density", fill = "by") -#' +#' #' # use `type_density()` to pass extra arguments for customization #' tinyplot( #' ~Sepal.Length | Species, data = iris, #' type = type_density(bw = "SJ"), #' main = "Bandwidth computed using Sheather & Jones (1991)" #' ) -#' +#' #' # The default for grouped density plots is to use the mean of the #' # individual subgroup bandwidths (weighted by group size) as the #' # joint bandwidth. Alternatively, the bandwidth from the "full" @@ -81,98 +81,148 @@ #' tinyplot_add(joint.bw = "full", lty = 2) # full data #' tinyplot_add(joint.bw = "none", lty = 3) # none (individual) #' legend("topright", c("Mean", "Full", "None"), lty = 1:3, bty = "n", title = "Joint BW") -#' +#' #' @importFrom stats density weighted.mean -#' @importFrom stats bw.SJ bw.bcv bw.nrd bw.nrd0 bw.ucv +#' @importFrom stats bw.SJ bw.bcv bw.nrd bw.nrd0 bw.ucv #' @export type_density = function( - bw = "nrd0", - joint.bw = c("mean", "full", "none"), - adjust = 1, - kernel = c("gaussian", "epanechnikov", "rectangular", "triangular", "biweight", "cosine", "optcosine"), - n = 512, - # more args from density here? - alpha = NULL - ) { - kernel = match.arg(kernel, c("gaussian", "epanechnikov", "rectangular", "triangular", "biweight", "cosine", "optcosine")) - if (is.logical(joint.bw)) { - joint.bw = ifelse(joint.bw, "mean", "none") - } - joint.bw = match.arg(joint.bw, c("mean", "full", "none")) - out = list( - data = data_density(bw = bw, adjust = adjust, kernel = kernel, n = n, - joint.bw = joint.bw, alpha = alpha), - draw = NULL, - name = "density" + bw = "nrd0", + joint.bw = c("mean", "full", "none"), + adjust = 1, + kernel = c( + "gaussian", + "epanechnikov", + "rectangular", + "triangular", + "biweight", + "cosine", + "optcosine" + ), + n = 512, + # more args from density here? + alpha = NULL +) { + kernel = match.arg( + kernel, + c( + "gaussian", + "epanechnikov", + "rectangular", + "triangular", + "biweight", + "cosine", + "optcosine" ) - class(out) = "tinyplot_type" - return(out) + ) + if (is.logical(joint.bw)) { + joint.bw = ifelse(joint.bw, "mean", "none") + } + joint.bw = match.arg(joint.bw, c("mean", "full", "none")) + out = list( + data = data_density( + bw = bw, + adjust = adjust, + kernel = kernel, + n = n, + joint.bw = joint.bw, + alpha = alpha + ), + draw = NULL, + name = "density" + ) + class(out) = "tinyplot_type" + return(out) } -data_density = function(bw = "nrd0", adjust = 1, kernel = "gaussian", n = 512, - joint.bw = "none", alpha = NULL) { - fun = function(settings, ...) { - env2env(settings, environment(), c("by", "bg", "facet", "ylab", "col", "ribbon.alpha", "datapoints")) - ribbon.alpha = if (is.null(alpha)) .tpar[["ribbon.alpha"]] else (alpha) - - if (is.null(ylab)) ylab = "Density" - - datapoints = split(datapoints, list(datapoints$by, datapoints$facet)) - datapoints = Filter(function(k) nrow(k) > 0, datapoints) - - if (joint.bw == "none" || is.numeric(bw)) { - dens_bw = bw - } else { - if (joint.bw == "mean") { - # Use weighted mean of subgroup bandwidths - bws = sapply(datapoints, function(dat) bw_fun(kernel = bw, dat$x)) - ws = sapply(datapoints, nrow) - dens_bw = weighted.mean(bws, ws) - } else if (joint.bw == "full") { - dens_bw = bw_fun(kernel = bw, unlist(sapply(datapoints, `[[`, "x"))) - } - } - - datapoints = lapply(datapoints, function(dat) { - d = density(dat$x, bw = dens_bw, kernel = kernel, n = n) - out = data.frame( - by = dat$by[1], # already split - facet = dat$facet[1], # already split - y = d$y, - x = d$x - ) - return(out) - }) - datapoints = do.call(rbind, datapoints) - datapoints$ymax = datapoints$y - datapoints$ymin = rep.int(0, nrow(datapoints)) - - # flags for legend and fill - dtype = if (!is.null(bg)) "ribbon" else "l" +data_density = function( + bw = "nrd0", + adjust = 1, + kernel = "gaussian", + n = 512, + joint.bw = "none", + alpha = NULL +) { + fun = function(settings, ...) { + env2env( + settings, + environment(), + c("by", "bg", "facet", "ylab", "col", "ribbon.alpha", "datapoints") + ) + ribbon.alpha = if (is.null(alpha)) .tpar[["ribbon.alpha"]] else (alpha) - type = dtype - by = if (length(unique(datapoints$by)) == 1) by else datapoints$by - facet = if (length(unique(datapoints$facet)) == 1) facet else datapoints$facet - - # legend customizations (only for filled density plots) - if (!is.null(bg)) { - settings$legend_args[["pch"]] = settings$legend_args[["pch"]] %||% 22 - settings$legend_args[["pt.cex"]] = settings$legend_args[["pt.cex"]] %||% 3.5 - settings$legend_args[["pt.lwd"]] = settings$legend_args[["pt.lwd"]] %||% par("lwd") - settings$legend_args[["lty"]] = settings$legend_args[["lty"]] %||% 0 - settings$legend_args[["y.intersp"]] = settings$legend_args[["y.intersp"]] %||% 1.25 - settings$legend_args[["seg.len"]] = settings$legend_args[["seg.len"]] %||% 1.25 - } - - env2env(environment(), settings, c( - "ylab", - "type", - "ribbon.alpha", - "datapoints", - "by", - "facet" - )) + if (is.null(ylab)) { + ylab = "Density" } - return(fun) -} + datapoints = split(datapoints, list(datapoints$by, datapoints$facet)) + datapoints = Filter(function(k) nrow(k) > 0, datapoints) + + if (joint.bw == "none" || is.numeric(bw)) { + dens_bw = bw + } else { + if (joint.bw == "mean") { + # Use weighted mean of subgroup bandwidths + bws = sapply(datapoints, function(dat) bw_fun(kernel = bw, dat$x)) + ws = sapply(datapoints, nrow) + dens_bw = weighted.mean(bws, ws) + } else if (joint.bw == "full") { + dens_bw = bw_fun(kernel = bw, unlist(sapply(datapoints, `[[`, "x"))) + } + } + + datapoints = lapply(datapoints, function(dat) { + d = density(dat$x, bw = dens_bw, kernel = kernel, n = n) + out = data.frame( + by = dat$by[1], # already split + facet = dat$facet[1], # already split + y = d$y, + x = d$x + ) + return(out) + }) + datapoints = do.call(rbind, datapoints) + datapoints$ymax = datapoints$y + datapoints$ymin = rep.int(0, nrow(datapoints)) + + # flags for legend and fill + dtype = if (!is.null(bg)) "ribbon" else "l" + + type = dtype + by = if (length(unique(datapoints$by)) == 1) by else datapoints$by + facet = if (length(unique(datapoints$facet)) == 1) { + facet + } else { + datapoints$facet + } + + # legend customizations (only for filled density plots) + if (!is.null(bg)) { + settings$legend_args[["pch"]] = settings$legend_args[["pch"]] %||% 22 + settings$legend_args[["pt.cex"]] = settings$legend_args[["pt.cex"]] %||% + 3.5 + settings$legend_args[["pt.lwd"]] = settings$legend_args[["pt.lwd"]] %||% + par("lwd") + settings$legend_args[["lty"]] = settings$legend_args[["lty"]] %||% 0 + settings$legend_args[["y.intersp"]] = settings$legend_args[[ + "y.intersp" + ]] %||% + 1.25 + settings$legend_args[["seg.len"]] = settings$legend_args[["seg.len"]] %||% + 1.25 + } + + env2env( + environment(), + settings, + c( + "ylab", + "type", + "ribbon.alpha", + "datapoints", + "by", + "facet" + ) + ) + } + return(fun) +} diff --git a/R/type_errorbar.R b/R/type_errorbar.R index 9c6fae60..359861ba 100644 --- a/R/type_errorbar.R +++ b/R/type_errorbar.R @@ -6,10 +6,10 @@ #' @inheritParams graphics::arrows #' @examples #' tinytheme("basic") -#' +#' #' # #' ## Basic coefficient plot(s) -#' +#' #' mod = lm(mpg ~ wt * factor(am), mtcars) #' coefs = data.frame(names(coef(mod)), coef(mod), confint(mod)) #' colnames(coefs) = c("term", "est", "lwr", "upr") @@ -24,7 +24,7 @@ #' #' # #' ## Flipped plots -#' +#' #' # For flipped errobar / pointrange plots, it is recommended to use a dynamic #' # theme that applies horizontal axis tick labels #' @@ -32,9 +32,9 @@ #' tinyplot(est ~ term, ymin = lwr, ymax = upr, data = coefs, type = "errorbar", #' flip = TRUE) #' tinyplot_add(type = 'vline', lty = 2) -#' +#' #' tinytheme("basic") # back to basic theme for the remaining examples -#' +#' #' # #' ## Dodging groups #' @@ -70,7 +70,7 @@ #' ymin = conf.low, ymax = conf.high, #' data = models, #' type = type_pointrange(dodge = 0.1, fixed.dodge = TRUE)) -#' +#' #' # Aside 2: layering #' # For layering on top of dodged plots, rather pass the dodging arguments #' # through the top-level call if you'd like the dodging behaviour to be @@ -87,51 +87,51 @@ #' #' @export type_errorbar = function(length = 0.05, dodge = 0, fixed.dodge = FALSE) { - out = list( - draw = draw_errorbar(length = length), - data = data_pointrange(dodge = dodge, fixed.dodge = fixed.dodge), - name = "p" - ) - class(out) = "tinyplot_type" - return(out) + out = list( + draw = draw_errorbar(length = length), + data = data_pointrange(dodge = dodge, fixed.dodge = fixed.dodge), + name = "p" + ) + class(out) = "tinyplot_type" + return(out) } draw_errorbar = function(length = 0.05) { - fun = function( - ix, - iy, - ixmin, - iymin, - ixmax, - iymax, - icol, - ibg, - ipch, - ilwd, - icex, - ... - ) { - arrows( - x0 = ixmin, - y0 = iymin, - x1 = ixmax, - y1 = iymax, - col = icol, - lwd = ilwd, - length = length, - angle = 90, - code = 3 - ) - draw_points()( - ix = ix, - iy = iy, - icol = icol, - ibg = ibg, - ipch = ipch, - ilwd = ilwd, - icex = icex - ) - } - return(fun) + fun = function( + ix, + iy, + ixmin, + iymin, + ixmax, + iymax, + icol, + ibg, + ipch, + ilwd, + icex, + ... + ) { + arrows( + x0 = ixmin, + y0 = iymin, + x1 = ixmax, + y1 = iymax, + col = icol, + lwd = ilwd, + length = length, + angle = 90, + code = 3 + ) + draw_points()( + ix = ix, + iy = iy, + icol = icol, + ibg = ibg, + ipch = ipch, + ilwd = ilwd, + icex = icex + ) + } + return(fun) } diff --git a/R/type_glm.R b/R/type_glm.R index 63f015b5..89c9c7a5 100644 --- a/R/type_glm.R +++ b/R/type_glm.R @@ -15,64 +15,94 @@ #' # Use `type_glm()` to pass extra arguments for customization #' tinyplot(am ~ mpg, data = mtcars, type = type_glm(family = "binomial")) #' @export -type_glm = function(family = "gaussian", se = TRUE, level = 0.95, type = "response") { - assert_flag(se) - out = list( - draw = draw_ribbon(), - data = data_glm(family = family, se = se, level = level, type = type), - name = if (isTRUE(se)) "ribbon" else "l" - ) - class(out) = "tinyplot_type" - return(out) +type_glm = function( + family = "gaussian", + se = TRUE, + level = 0.95, + type = "response" +) { + assert_flag(se) + out = list( + draw = draw_ribbon(), + data = data_glm(family = family, se = se, level = level, type = type), + name = if (isTRUE(se)) "ribbon" else "l" + ) + class(out) = "tinyplot_type" + return(out) } data_glm = function(family, se, level, type, ...) { - fun = function(settings, ...) { - env2env(settings, environment(), "datapoints") - dat = split(datapoints, list(datapoints$facet, datapoints$by)) - dat = lapply(dat, function(x) { - if (nrow(x) == 0) { - return(x) - } - if (nrow(x) < 3) { - x$y = NA - return(x) - } - fit = glm(y ~ x, data = x, family = family) - nd = data.frame(x = seq(min(x$x, na.rm = TRUE), max(x$x, na.rm = TRUE), length.out = 100)) - nd$by = x$by[1] - nd$facet = x$facet[1] - if (se == TRUE) { - if (identical(type, "response")) { - p = predict(fit, newdata = nd, type = "link", se.fit = TRUE) - p = ci(p$fit, p$se.fit, conf.level = level, fit$df.residual, backtransform = stats::family(fit)$linkinv) - nd$y = p$estimate - nd$ymax = p$conf.high - nd$ymin = p$conf.low - } else { - nd$y = predict(fit, newdata = nd, type = type) - nd = ci(nd$y, nd$se, level, fit$df.residual, backtransform = stats::family(fit)$linkinv) - } - } else { - nd$y = predict(fit, nd, type = type) - } - nd - }) - datapoints = do.call(rbind, dat) - datapoints = datapoints[order(datapoints$facet, datapoints$by, datapoints$x), ] - - # legend customizations - same as ribbon but add line through square - settings$legend_args[["pch"]] = settings$legend_args[["pch"]] %||% 22 - settings$legend_args[["pt.cex"]] = settings$legend_args[["pt.cex"]] %||% 3.5 - settings$legend_args[["pt.lwd"]] = settings$legend_args[["pt.lwd"]] %||% 0 - settings$legend_args[["lty"]] = settings$legend_args[["lty"]] %||% par("lty") - settings$legend_args[["y.intersp"]] = settings$legend_args[["y.intersp"]] %||% 1.25 - settings$legend_args[["seg.len"]] = settings$legend_args[["seg.len"]] %||% 1.25 - - env2env(environment(), settings, "datapoints") - } - return(fun) + fun = function(settings, ...) { + env2env(settings, environment(), "datapoints") + dat = split(datapoints, list(datapoints$facet, datapoints$by)) + dat = lapply(dat, function(x) { + if (nrow(x) == 0) { + return(x) + } + if (nrow(x) < 3) { + x$y = NA + return(x) + } + fit = glm(y ~ x, data = x, family = family) + nd = data.frame( + x = seq( + min(x$x, na.rm = TRUE), + max(x$x, na.rm = TRUE), + length.out = 100 + ) + ) + nd$by = x$by[1] + nd$facet = x$facet[1] + if (se == TRUE) { + if (identical(type, "response")) { + p = predict(fit, newdata = nd, type = "link", se.fit = TRUE) + p = ci( + p$fit, + p$se.fit, + conf.level = level, + fit$df.residual, + backtransform = stats::family(fit)$linkinv + ) + nd$y = p$estimate + nd$ymax = p$conf.high + nd$ymin = p$conf.low + } else { + nd$y = predict(fit, newdata = nd, type = type) + nd = ci( + nd$y, + nd$se, + level, + fit$df.residual, + backtransform = stats::family(fit)$linkinv + ) + } + } else { + nd$y = predict(fit, nd, type = type) + } + nd + }) + datapoints = do.call(rbind, dat) + datapoints = datapoints[ + order(datapoints$facet, datapoints$by, datapoints$x), + ] + + # legend customizations - same as ribbon but add line through square + settings$legend_args[["pch"]] = settings$legend_args[["pch"]] %||% 22 + settings$legend_args[["pt.cex"]] = settings$legend_args[["pt.cex"]] %||% 3.5 + settings$legend_args[["pt.lwd"]] = settings$legend_args[["pt.lwd"]] %||% 0 + settings$legend_args[["lty"]] = settings$legend_args[["lty"]] %||% + par("lty") + settings$legend_args[["y.intersp"]] = settings$legend_args[[ + "y.intersp" + ]] %||% + 1.25 + settings$legend_args[["seg.len"]] = settings$legend_args[["seg.len"]] %||% + 1.25 + + env2env(environment(), settings, "datapoints") + } + return(fun) } @@ -80,11 +110,11 @@ data_glm = function(family, se, level, type, ...) { #' @importFrom stats qt #' @keywords internal ci = function(estimate, std.error, conf.level, df, backtransform = identity) { - crit = qt(1 - (1 - conf.level) / 2, df) - out = list( - estimate = backtransform(estimate), - conf.low = backtransform(estimate - crit * std.error), - conf.high = backtransform(estimate + crit * std.error) - ) - return(out) + crit = qt(1 - (1 - conf.level) / 2, df) + out = list( + estimate = backtransform(estimate), + conf.low = backtransform(estimate - crit * std.error), + conf.high = backtransform(estimate + crit * std.error) + ) + return(out) } diff --git a/R/type_histogram.R b/R/type_histogram.R index 5d504d22..6716b3fa 100644 --- a/R/type_histogram.R +++ b/R/type_histogram.R @@ -71,19 +71,26 @@ #' ) #' #' @export -type_histogram = function(breaks = "Sturges", - freq = NULL, right = TRUE, - free.breaks = FALSE, drop.zeros = TRUE) { - out = list( - data = data_histogram( - breaks = breaks, - free.breaks = free.breaks, drop.zeros = drop.zeros, - freq = freq, right = right), - draw = draw_rect(), - name = "histogram" - ) - class(out) = "tinyplot_type" - return(out) +type_histogram = function( + breaks = "Sturges", + freq = NULL, + right = TRUE, + free.breaks = FALSE, + drop.zeros = TRUE +) { + out = list( + data = data_histogram( + breaks = breaks, + free.breaks = free.breaks, + drop.zeros = drop.zeros, + freq = freq, + right = right + ), + draw = draw_rect(), + name = "histogram" + ) + class(out) = "tinyplot_type" + return(out) } #' @export #' @name type_hist @@ -91,91 +98,146 @@ type_histogram = function(breaks = "Sturges", type_hist = type_histogram -data_histogram = function(breaks = "Sturges", - free.breaks = FALSE, drop.zeros = TRUE, - freq = NULL, right = TRUE) { - hbreaks = breaks - hfree.breaks = free.breaks - hdrop.zeros = drop.zeros - hfreq = freq - hright = right +data_histogram = function( + breaks = "Sturges", + free.breaks = FALSE, + drop.zeros = TRUE, + freq = NULL, + right = TRUE +) { + hbreaks = breaks + hfree.breaks = free.breaks + hdrop.zeros = drop.zeros + hfreq = freq + hright = right - fun = function(settings, .breaks = hbreaks, .freebreaks = hfree.breaks, .freq = hfreq, .right = hright, .drop.zeros = hdrop.zeros, ...) { - env2env(settings, environment(), c("palette", "bg", "col", "plot", "datapoints", "ymin", "ymax", "xmin", "xmax", "freq", "ylab", "xlab", "facet", "ribbon.alpha")) + fun = function( + settings, + .breaks = hbreaks, + .freebreaks = hfree.breaks, + .freq = hfreq, + .right = hright, + .drop.zeros = hdrop.zeros, + ... + ) { + env2env( + settings, + environment(), + c( + "palette", + "bg", + "col", + "plot", + "datapoints", + "ymin", + "ymax", + "xmin", + "xmax", + "freq", + "ylab", + "xlab", + "facet", + "ribbon.alpha" + ) + ) - hbreaks = ifelse(!sapply(.breaks, is.null), .breaks, "Sturges") + hbreaks = ifelse(!sapply(.breaks, is.null), .breaks, "Sturges") - if (is.null(by) && is.null(palette)) { - if (is.null(col)) col = par("fg") - if (is.null(bg)) bg = "lightgray" - } else { - if (is.null(bg)) bg = ribbon.alpha - } + if (is.null(by) && is.null(palette)) { + if (is.null(col)) { + col = par("fg") + } + if (is.null(bg)) bg = "lightgray" + } else { + if (is.null(bg)) bg = ribbon.alpha + } - if (!.freebreaks) xbreaks = hist(datapoints$x, breaks = hbreaks, right = .right, plot = FALSE)$breaks - datapoints = split(datapoints, list(datapoints$by, datapoints$facet)) - datapoints = Filter(function(k) nrow(k) > 0, datapoints) + if (!.freebreaks) { + xbreaks = hist( + datapoints$x, + breaks = hbreaks, + right = .right, + plot = FALSE + )$breaks + } + datapoints = split(datapoints, list(datapoints$by, datapoints$facet)) + datapoints = Filter(function(k) nrow(k) > 0, datapoints) - datapoints = lapply(datapoints, function(k) { - if (.freebreaks) xbreaks = breaks - h = hist(k$x, breaks = xbreaks, right = .right, plot = FALSE) - # zero count cases - if (.drop.zeros) { - nzidx = which(h$counts > 0) - h$density = h$density[nzidx] - h$counts = h$counts[nzidx] - h$breaks = h$breaks[c(1, nzidx + 1)] - h$mids = h$mids[nzidx] - } - freq = if (!is.null(.freq)) .freq else is.null(.freq) && h$equidist - out = data.frame( - by = k$by[1], # already split - facet = k$facet[1], # already split - ymin = 0, - ymax = if (freq) h$counts else h$density, - xmin = h$breaks[-1], - xmax = h$mids + (h$mids - h$breaks[-1]), - freq = freq - ) - return(out) - }) - datapoints = do.call(rbind, datapoints) + datapoints = lapply(datapoints, function(k) { + if (.freebreaks) { + xbreaks = breaks + } + h = hist(k$x, breaks = xbreaks, right = .right, plot = FALSE) + # zero count cases + if (.drop.zeros) { + nzidx = which(h$counts > 0) + h$density = h$density[nzidx] + h$counts = h$counts[nzidx] + h$breaks = h$breaks[c(1, nzidx + 1)] + h$mids = h$mids[nzidx] + } + freq = if (!is.null(.freq)) .freq else is.null(.freq) && h$equidist + out = data.frame( + by = k$by[1], # already split + facet = k$facet[1], # already split + ymin = 0, + ymax = if (freq) h$counts else h$density, + xmin = h$breaks[-1], + xmax = h$mids + (h$mids - h$breaks[-1]), + freq = freq + ) + return(out) + }) + datapoints = do.call(rbind, datapoints) - if (is.null(ylab)) { - ylab = ifelse(datapoints$freq[1], "Frequency", "Density") - } + if (is.null(ylab)) { + ylab = ifelse(datapoints$freq[1], "Frequency", "Density") + } - x = c(datapoints$xmin, datapoints$xmax) - y = c(datapoints$ymin, datapoints$ymax) - ymin = datapoints$ymin - ymax = datapoints$ymax - xmin = datapoints$xmin - xmax = datapoints$xmax - by = if (length(unique(datapoints$by)) == 1) by else datapoints$by - facet = if (length(unique(datapoints$facet)) == 1) facet else datapoints$facet - - # legend customizations - settings$legend_args[["pch"]] = settings$legend_args[["pch"]] %||% 22 - settings$legend_args[["pt.cex"]] = settings$legend_args[["pt.cex"]] %||% 3.5 - settings$legend_args[["pt.lwd"]] = settings$legend_args[["pt.lwd"]] %||% par("lwd") - settings$legend_args[["lty"]] = settings$legend_args[["lty"]] %||% 0 - settings$legend_args[["y.intersp"]] = settings$legend_args[["y.intersp"]] %||% 1.25 - settings$legend_args[["seg.len"]] = settings$legend_args[["seg.len"]] %||% 1.25 - - env2env(environment(), settings, c( - "x", - "y", - "ymin", - "ymax", - "xmin", - "xmax", - "ylab", - "col", - "bg", - "datapoints", - "by", - "facet" - )) + x = c(datapoints$xmin, datapoints$xmax) + y = c(datapoints$ymin, datapoints$ymax) + ymin = datapoints$ymin + ymax = datapoints$ymax + xmin = datapoints$xmin + xmax = datapoints$xmax + by = if (length(unique(datapoints$by)) == 1) by else datapoints$by + facet = if (length(unique(datapoints$facet)) == 1) { + facet + } else { + datapoints$facet } - return(fun) + + # legend customizations + settings$legend_args[["pch"]] = settings$legend_args[["pch"]] %||% 22 + settings$legend_args[["pt.cex"]] = settings$legend_args[["pt.cex"]] %||% 3.5 + settings$legend_args[["pt.lwd"]] = settings$legend_args[["pt.lwd"]] %||% + par("lwd") + settings$legend_args[["lty"]] = settings$legend_args[["lty"]] %||% 0 + settings$legend_args[["y.intersp"]] = settings$legend_args[[ + "y.intersp" + ]] %||% + 1.25 + settings$legend_args[["seg.len"]] = settings$legend_args[["seg.len"]] %||% + 1.25 + + env2env( + environment(), + settings, + c( + "x", + "y", + "ymin", + "ymax", + "xmin", + "xmax", + "ylab", + "col", + "bg", + "datapoints", + "by", + "facet" + ) + ) + } + return(fun) } diff --git a/R/type_hline.R b/R/type_hline.R index 3ac9bece..986086a4 100644 --- a/R/type_hline.R +++ b/R/type_hline.R @@ -20,12 +20,24 @@ type_hline = function(h = 0) { env2env(environment(), settings, "type_info") } draw_hline = function() { - fun = function(ifacet, iby, data_facet, icol, ilty, ilwd, - ngrps, nfacets, by_continuous, facet_by, - type_info, - ...) { + fun = function( + ifacet, + iby, + data_facet, + icol, + ilty, + ilwd, + ngrps, + nfacets, + by_continuous, + facet_by, + type_info, + ... + ) { # flag for aesthetics by groups - grp_aes = type_info[["ul_col"]] == 1 || type_info[["ul_lty"]] == ngrps || type_info[["ul_lwd"]] == ngrps + grp_aes = type_info[["ul_col"]] == 1 || + type_info[["ul_lty"]] == ngrps || + type_info[["ul_lwd"]] == ngrps if (length(h) != 1) { if (!length(h) %in% c(ngrps, nfacets, ngrps * nfacets)) { diff --git a/R/type_jitter.R b/R/type_jitter.R index 21363f0d..9c84fe42 100644 --- a/R/type_jitter.R +++ b/R/type_jitter.R @@ -13,94 +13,98 @@ #' tinyplot(Sepal.Length ~ Species, data = iris, type = type_jitter(factor = 0.5)) #' @export type_jitter = function(factor = 1, amount = NULL) { - out = list( - draw = draw_points(), - data = data_jitter(factor = factor, amount = amount), - name = "p" - ) - class(out) = "tinyplot_type" - return(out) + out = list( + draw = draw_points(), + data = data_jitter(factor = factor, amount = amount), + name = "p" + ) + class(out) = "tinyplot_type" + return(out) } jitter_restore = function(obj, factor, amount) { - if (inherits(obj, "POSIXlt")) { - obj = as.POSIXct(obj) - } - if (inherits(obj, c("Date", "POSIXt", "yearmon", "yearqtr"))) { - obj_attrs = attributes(obj) - out = jitter(unclass(obj), factor = factor, amount = amount) - attributes(out) = obj_attrs - } else { - out = jitter(obj, factor = factor, amount = amount) - } - return(out) + if (inherits(obj, "POSIXlt")) { + obj = as.POSIXct(obj) + } + if (inherits(obj, c("Date", "POSIXt", "yearmon", "yearqtr"))) { + obj_attrs = attributes(obj) + out = jitter(unclass(obj), factor = factor, amount = amount) + attributes(out) = obj_attrs + } else { + out = jitter(obj, factor = factor, amount = amount) + } + return(out) } data_jitter = function(factor, amount) { - fun = function(settings, ...) { - env2env(settings, environment(), c("datapoints", "add")) + fun = function(settings, ...) { + env2env(settings, environment(), c("datapoints", "add")) - x = datapoints$x - y = datapoints$y - if (is.factor(x)) { - xlvls = levels(x) - xlabs = seq_along(xlvls) - names(xlabs) = xlvls - x = as.integer(x) - } else { - xlabs = NULL - } - if (is.factor(y)) { - ylvls = levels(y) - ylabs = seq_along(ylvls) - names(ylabs) = ylvls - y = as.integer(y) - } else { - ylabs = NULL - } + x = datapoints$x + y = datapoints$y + if (is.factor(x)) { + xlvls = levels(x) + xlabs = seq_along(xlvls) + names(xlabs) = xlvls + x = as.integer(x) + } else { + xlabs = NULL + } + if (is.factor(y)) { + ylvls = levels(y) + ylabs = seq_along(ylvls) + names(ylabs) = ylvls + y = as.integer(y) + } else { + ylabs = NULL + } - # Apply group offsets from base layer (e.g., boxplot, violin, ridge) - group_offsets = get_environment_variable(".group_offsets") - offsets_axis = get_environment_variable(".offsets_axis") - if (isTRUE(add) && !is.null(group_offsets)) { - if (identical(offsets_axis, "x") && is.factor(datapoints$by)) { - # x-axis offsets (boxplot, violin): keyed by group level - if (is.null(xlabs)) { - xf = as.factor(x) - xlvls = levels(xf) - xlabs = seq_along(xlvls) - names(xlabs) = xlvls - x = as.integer(xf) - } - x = x + group_offsets[as.integer(datapoints$by)] - } else if (identical(offsets_axis, "y")) { - # y-axis offsets (ridge): keyed by y-level name - if (is.null(ylabs)) { - yf = as.factor(y) - ylvls = levels(yf) - ylabs = seq_along(ylvls) - names(ylabs) = ylvls - y = as.integer(yf) - } - y_labels = names(ylabs)[y] - y = group_offsets[y_labels] - } + # Apply group offsets from base layer (e.g., boxplot, violin, ridge) + group_offsets = get_environment_variable(".group_offsets") + offsets_axis = get_environment_variable(".offsets_axis") + if (isTRUE(add) && !is.null(group_offsets)) { + if (identical(offsets_axis, "x") && is.factor(datapoints$by)) { + # x-axis offsets (boxplot, violin): keyed by group level + if (is.null(xlabs)) { + xf = as.factor(x) + xlvls = levels(xf) + xlabs = seq_along(xlvls) + names(xlabs) = xlvls + x = as.integer(xf) + } + x = x + group_offsets[as.integer(datapoints$by)] + } else if (identical(offsets_axis, "y")) { + # y-axis offsets (ridge): keyed by y-level name + if (is.null(ylabs)) { + yf = as.factor(y) + ylvls = levels(yf) + ylabs = seq_along(ylvls) + names(ylabs) = ylvls + y = as.integer(yf) } + y_labels = names(ylabs)[y] + y = group_offsets[y_labels] + } + } - x = jitter_restore(x, factor = factor, amount = amount) - y = jitter_restore(y, factor = factor, amount = amount) + x = jitter_restore(x, factor = factor, amount = amount) + y = jitter_restore(y, factor = factor, amount = amount) - datapoints$x = x - datapoints$y = y + datapoints$x = x + datapoints$y = y - env2env(environment(), settings, c( - "datapoints", - "x", - "y", - "xlabs", - "ylabs" - )) - } + env2env( + environment(), + settings, + c( + "datapoints", + "x", + "y", + "xlabs", + "ylabs" + ) + ) + } } diff --git a/R/type_lines.R b/R/type_lines.R index d88fc714..8e7a5d27 100644 --- a/R/type_lines.R +++ b/R/type_lines.R @@ -1,17 +1,17 @@ #' Lines plot type #' #' @description Type function for plotting lines. -#' +#' #' @inheritParams graphics::plot.default #' @inheritParams dodge_positions -#' +#' #' @examples #' # "l" type convenience character string #' tinyplot(circumference ~ age | Tree, data = Orange, type = "l") -#' +#' #' # Use `type_lines()` to pass extra arguments for customization #' tinyplot(circumference ~ age | Tree, data = Orange, type = type_lines(type = "s")) -#' +#' #' @export type_lines = function(type = "l", dodge = 0, fixed.dodge = FALSE) { out = list( @@ -25,7 +25,9 @@ type_lines = function(type = "l", dodge = 0, fixed.dodge = FALSE) { data_lines = function(dodge = 0, fixed.dodge = FALSE) { - if (is.null(dodge) || dodge == 0) return(NULL) + if (is.null(dodge) || dodge == 0) { + return(NULL) + } fun = function(settings, ...) { env2env(settings, environment(), c("datapoints", "xlabs")) @@ -46,29 +48,33 @@ data_lines = function(dodge = 0, fixed.dodge = FALSE) { } x = datapoints$x - env2env(environment(), settings, c( - "x", - "xlabs", - "datapoints" - )) + env2env( + environment(), + settings, + c( + "x", + "xlabs", + "datapoints" + ) + ) } fun } draw_lines = function(type = "l") { - fun = function(ix, iy, icol, ipch, ibg, ilty, ilwd, icex = 1, ...) { - lines( - x = ix, - y = iy, - col = icol, - type = type, - pch = ipch, - bg = ibg, - lty = ilty, - lwd = ilwd, - cex = icex - ) - } - return(fun) + fun = function(ix, iy, icol, ipch, ibg, ilty, ilwd, icex = 1, ...) { + lines( + x = ix, + y = iy, + col = icol, + type = type, + pch = ipch, + bg = ibg, + lty = ilty, + lwd = ilwd, + cex = icex + ) + } + return(fun) } diff --git a/R/type_lm.R b/R/type_lm.R index 7a09cf75..9cc5f958 100644 --- a/R/type_lm.R +++ b/R/type_lm.R @@ -17,56 +17,69 @@ #' tinyplot(Sepal.Width ~ Petal.Width, data = iris, type = type_lm(level = 0.8)) #' @export type_lm = function(se = TRUE, level = 0.95) { - assert_flag(se) - out = list( - draw = draw_ribbon(), - data = data_lm(se = se, level = level), - name = if (isTRUE(se)) "ribbon" else "l" - ) - class(out) = "tinyplot_type" - return(out) + assert_flag(se) + out = list( + draw = draw_ribbon(), + data = data_lm(se = se, level = level), + name = if (isTRUE(se)) "ribbon" else "l" + ) + class(out) = "tinyplot_type" + return(out) } data_lm = function(se, level, ...) { - fun = function(settings, ...) { - env2env(settings, environment(), "datapoints") - dat = split(datapoints, list(datapoints$facet, datapoints$by)) - dat = lapply(dat, function(x) { - if (nrow(x) == 0) { - return(x) - } - if (nrow(x) < 3) { - x$y = NA - return(x) - } - fit = lm(y ~ x, data = x) - nd = data.frame(x = seq(min(x$x, na.rm = TRUE), max(x$x, na.rm = TRUE), length.out = 100)) - nd$by = x$by[1] - nd$facet = x$facet[1] - if (se == TRUE) { - p = predict(fit, newdata = nd, se.fit = TRUE) - p = ci(p$fit, p$se.fit, conf.level = level, fit$df.residual) - nd$y = p$estimate - nd$ymax = p$conf.high - nd$ymin = p$conf.low - } else { - nd$y = predict(fit, newdata = nd) - } - nd - }) - datapoints = do.call(rbind, dat) - datapoints = datapoints[order(datapoints$facet, datapoints$by, datapoints$x), ] - - # legend customizations - same as ribbon but add line through square - settings$legend_args[["pch"]] = settings$legend_args[["pch"]] %||% 22 - settings$legend_args[["pt.cex"]] = settings$legend_args[["pt.cex"]] %||% 3.5 - settings$legend_args[["pt.lwd"]] = settings$legend_args[["pt.lwd"]] %||% 0 - settings$legend_args[["lty"]] = settings$legend_args[["lty"]] %||% par("lty") - settings$legend_args[["y.intersp"]] = settings$legend_args[["y.intersp"]] %||% 1.25 - settings$legend_args[["seg.len"]] = settings$legend_args[["seg.len"]] %||% 1.25 - - env2env(environment(), settings, "datapoints") - } - return(fun) + fun = function(settings, ...) { + env2env(settings, environment(), "datapoints") + dat = split(datapoints, list(datapoints$facet, datapoints$by)) + dat = lapply(dat, function(x) { + if (nrow(x) == 0) { + return(x) + } + if (nrow(x) < 3) { + x$y = NA + return(x) + } + fit = lm(y ~ x, data = x) + nd = data.frame( + x = seq( + min(x$x, na.rm = TRUE), + max(x$x, na.rm = TRUE), + length.out = 100 + ) + ) + nd$by = x$by[1] + nd$facet = x$facet[1] + if (se == TRUE) { + p = predict(fit, newdata = nd, se.fit = TRUE) + p = ci(p$fit, p$se.fit, conf.level = level, fit$df.residual) + nd$y = p$estimate + nd$ymax = p$conf.high + nd$ymin = p$conf.low + } else { + nd$y = predict(fit, newdata = nd) + } + nd + }) + datapoints = do.call(rbind, dat) + datapoints = datapoints[ + order(datapoints$facet, datapoints$by, datapoints$x), + ] + + # legend customizations - same as ribbon but add line through square + settings$legend_args[["pch"]] = settings$legend_args[["pch"]] %||% 22 + settings$legend_args[["pt.cex"]] = settings$legend_args[["pt.cex"]] %||% 3.5 + settings$legend_args[["pt.lwd"]] = settings$legend_args[["pt.lwd"]] %||% 0 + settings$legend_args[["lty"]] = settings$legend_args[["lty"]] %||% + par("lty") + settings$legend_args[["y.intersp"]] = settings$legend_args[[ + "y.intersp" + ]] %||% + 1.25 + settings$legend_args[["seg.len"]] = settings$legend_args[["seg.len"]] %||% + 1.25 + + env2env(environment(), settings, "datapoints") + } + return(fun) } diff --git a/R/type_loess.R b/R/type_loess.R index c0c5aeee..64ba3800 100644 --- a/R/type_loess.R +++ b/R/type_loess.R @@ -15,52 +15,74 @@ #' tinyplot(dist ~ speed, data = cars, type = type_loess(span = 0.5, degree = 1)) #' @export type_loess = function( - span = 0.75, - degree = 2, - family = "gaussian", - control = loess.control(), - se = TRUE, - level = 0.95) { - out = list( - draw = draw_ribbon(), - data = data_loess(span = span, degree = degree, family = family, control = control, se = se, level = level), - name = if (isTRUE(se)) "ribbon" else "l" - ) - class(out) = "tinyplot_type" - return(out) + span = 0.75, + degree = 2, + family = "gaussian", + control = loess.control(), + se = TRUE, + level = 0.95 +) { + out = list( + draw = draw_ribbon(), + data = data_loess( + span = span, + degree = degree, + family = family, + control = control, + se = se, + level = level + ), + name = if (isTRUE(se)) "ribbon" else "l" + ) + class(out) = "tinyplot_type" + return(out) } data_loess = function(span, degree, family, control, se, level, ...) { - fun = function(settings, ...) { - env2env(settings, environment(), "datapoints") - datapoints = split(datapoints, list(datapoints$facet, datapoints$by)) - datapoints = Filter(function(k) nrow(k) > 0, datapoints) - datapoints = lapply(datapoints, function(dat) { - fit = loess(y ~ x, data = dat, span = span, degree = degree, family = family, control = control) - if (se == TRUE) { - p = predict(fit, newdata = dat, se = TRUE) - p = ci(p$fit, p$se.fit, conf.level = level, p$df) - dat$y = p$estimate - dat$ymax = p$conf.high - dat$ymin = p$conf.low - } else { - dat$y = predict(fit, dat) - } - dat - }) - datapoints = do.call(rbind, datapoints) - datapoints = datapoints[order(datapoints$facet, datapoints$by, datapoints$x), ] - - # legend customizations - same as ribbon but add line through square - settings$legend_args[["pch"]] = settings$legend_args[["pch"]] %||% 22 - settings$legend_args[["pt.cex"]] = settings$legend_args[["pt.cex"]] %||% 3.5 - settings$legend_args[["pt.lwd"]] = settings$legend_args[["pt.lwd"]] %||% 0 - settings$legend_args[["lty"]] = settings$legend_args[["lty"]] %||% par("lty") - settings$legend_args[["y.intersp"]] = settings$legend_args[["y.intersp"]] %||% 1.25 - settings$legend_args[["seg.len"]] = settings$legend_args[["seg.len"]] %||% 1.25 - - env2env(environment(), settings, "datapoints") - } - return(fun) + fun = function(settings, ...) { + env2env(settings, environment(), "datapoints") + datapoints = split(datapoints, list(datapoints$facet, datapoints$by)) + datapoints = Filter(function(k) nrow(k) > 0, datapoints) + datapoints = lapply(datapoints, function(dat) { + fit = loess( + y ~ x, + data = dat, + span = span, + degree = degree, + family = family, + control = control + ) + if (se == TRUE) { + p = predict(fit, newdata = dat, se = TRUE) + p = ci(p$fit, p$se.fit, conf.level = level, p$df) + dat$y = p$estimate + dat$ymax = p$conf.high + dat$ymin = p$conf.low + } else { + dat$y = predict(fit, dat) + } + dat + }) + datapoints = do.call(rbind, datapoints) + datapoints = datapoints[ + order(datapoints$facet, datapoints$by, datapoints$x), + ] + + # legend customizations - same as ribbon but add line through square + settings$legend_args[["pch"]] = settings$legend_args[["pch"]] %||% 22 + settings$legend_args[["pt.cex"]] = settings$legend_args[["pt.cex"]] %||% 3.5 + settings$legend_args[["pt.lwd"]] = settings$legend_args[["pt.lwd"]] %||% 0 + settings$legend_args[["lty"]] = settings$legend_args[["lty"]] %||% + par("lty") + settings$legend_args[["y.intersp"]] = settings$legend_args[[ + "y.intersp" + ]] %||% + 1.25 + settings$legend_args[["seg.len"]] = settings$legend_args[["seg.len"]] %||% + 1.25 + + env2env(environment(), settings, "datapoints") + } + return(fun) } diff --git a/R/type_meanse.R b/R/type_meanse.R new file mode 100644 index 00000000..3dec4e20 --- /dev/null +++ b/R/type_meanse.R @@ -0,0 +1,110 @@ +#' Plot mean and standard error of `y` at unique values of `x` +#' +#' @md +#' @description +#' Applies a summary function to `y` along unique values of `x`. For example, +#' plot the mean `y` value for each `x` value. Internally, +#' `type_summary()` applies a thin wrapper around \code{\link[stats]{ave}} and +#' then passes the result to [`type_lines`] for drawing. +#' +#' @param conf.int confidence error to plot the standard error. Defaults to .95 +#' @param na.rm a logical evaluating to TRUE or FALSE indicating whether NA +#' values should be stripped before the computation proceeds Defaults to TRUE. +#' @param ... Additional arguments are passed to the `lines()` function, +#' ex: `col="pink"`. +#' @examples +#' # Plot the mean and standard error of miles per gallon by cylinders +#' tinyplot(mpg ~ cyl, data = mtcars, data = mtcars, type = "mean_se") +#' + +#' +#' # Use 99% confidence intervals +#' tinyplot(mpg ~ cyl, data = mtcars, type = type_mean_se(conf.int = .99)) +#' +#' # Works with groups and/or facets too +#' tinyplot(mpg ~ cyl | gear, facet = "by", data = mtcars, type = "mean_se") +#' +#' +#' @export +type_mean_se = function(conf.int = .95, na.rm = TRUE, ...) { + pointrange_args = list(...) + + # function to get mean_se out of two vectors + mean_se_internal <- function(var, group, na.rm = TRUE, conf.int = .95) { + # just one group + + mean_se_basic <- function(z, na.rm = na.rm, conf.int = conf.int) { + m <- mean(z, na.rm = na.rm) + se <- sd(z, na.rm = na.rm) / sqrt(length(z)) + + mult <- qnorm(1 - ((1 - conf.int) / 2)) + + conf.low <- m - se * mult + conf.high <- m + se * mult + + out <- data.frame(m = m, ymin = conf.low, ymax = conf.high) + + # pending - change colnames + + return(out) + } + + if (missing(group)) { + mean_se_basic(z = var, na.rm = na.rm, conf.int = conf.int) + } else { + out <- tapply(var, group, \(x) { + mean_se_basic(x, na.rm = na.rm, conf.int = conf.int) + }) + + out <- do.call("rbind", out) + + out$group <- row.names(out) + row.names(out) <- NULL + + out <- out[, c(4, 1, 2, 3)] + + return(out) + } + } + + data_mean_se = function(fun = mean_se_internal) { + funky = function(settings, ...) { + env2env(settings, environment(), c("datapoints", "by", "facet")) + + datapoints = split( + datapoints, + list(datapoints$facet, datapoints$by), + drop = TRUE + ) + datapoints = lapply(datapoints, function(dat) { + ms <- mean_se_internal(dat$y, dat$x) + colnames(ms) <- c("x", "y", "ymin", "ymax") + ms$xmin <- ms$x + ms$xmax <- ms$x + ms$by <- dat$by[1] + ms$facet <- dat$facet[1] + ms = ms[order(ms$x), ] + return(ms) + }) + datapoints = do.call(rbind, datapoints) + + xlvls <- levels(factor(datapoints$x)) + datapoints$x = as.integer(factor(datapoints$x, levels = xlvls)) + xlabs <- seq_along(xlvls) + names(xlabs) <- xlvls + datapoints$x <- as.integer(datapoints$x) + datapoints$xmin <- datapoints$x + datapoints$xmax <- datapoints$x + + env2env(environment(), settings, c("datapoints", "xlabs")) + } + return(funky) + } + out = list( + draw = draw_pointrange(...), + data = data_mean_se(fun = fun), + name = "l" + ) + class(out) = "tinyplot_type" + return(out) +} diff --git a/R/type_pointrange.R b/R/type_pointrange.R index 967020ac..2a04e182 100644 --- a/R/type_pointrange.R +++ b/R/type_pointrange.R @@ -13,18 +13,20 @@ type_pointrange = function(dodge = 0, fixed.dodge = FALSE) { draw_pointrange = function() { fun = function( - ix, - iy, - ixmin, - iymin, - ixmax, - iymax, - icol, - ibg, - ipch, - ilwd, - icex, - ...) { + ix, + iy, + ixmin, + iymin, + ixmax, + iymax, + icol, + ibg, + ipch, + ilwd, + icex, + ... + ) { + segments( x0 = ixmin, y0 = iymin, @@ -49,7 +51,11 @@ draw_pointrange = function() { data_pointrange = function(dodge, fixed.dodge) { fun = function(settings, ...) { - env2env(settings, environment(), c("datapoints", "xlabs", "cex", "lty", "lwd")) + env2env( + settings, + environment(), + c("datapoints", "xlabs", "cex", "lty", "lwd") + ) if (is.character(datapoints$x)) { datapoints$x = as.factor(datapoints$x) @@ -71,17 +77,24 @@ data_pointrange = function(dodge, fixed.dodge) { } x = datapoints$x - + # legend customizations - settings$legend_args[["pt.cex"]] = settings$legend_args[["pt.cex"]] %||% (cex %||% par("cex")) - settings$legend_args[["lty"]] = settings$legend_args[["lty"]] %||% (lty %||% par("lty")) - settings$legend_args[["lwd"]] = settings$legend_args[["lwd"]] %||% (lwd %||% par("lwd")) - - env2env(environment(), settings, c( - "x", - "xlabs", - "datapoints" - )) + settings$legend_args[["pt.cex"]] = settings$legend_args[["pt.cex"]] %||% + (cex %||% par("cex")) + settings$legend_args[["lty"]] = settings$legend_args[["lty"]] %||% + (lty %||% par("lty")) + settings$legend_args[["lwd"]] = settings$legend_args[["lwd"]] %||% + (lwd %||% par("lwd")) + + env2env( + environment(), + settings, + c( + "x", + "xlabs", + "datapoints" + ) + ) } return(fun) } diff --git a/R/type_points.R b/R/type_points.R index 16e66663..fde240de 100644 --- a/R/type_points.R +++ b/R/type_points.R @@ -73,13 +73,18 @@ data_points = function(clim = c(0.5, 2.5), dodge = 0, fixed.dodge = FALSE) { } # legend customizations - settings$legend_args[["pt.lwd"]] = settings$legend_args[["pt.lwd"]] %||% settings$lwd + settings$legend_args[["pt.lwd"]] = settings$legend_args[["pt.lwd"]] %||% + settings$lwd - env2env(environment(), settings, c( - "datapoints", - "xlabs", - "ylabs" - )) + env2env( + environment(), + settings, + c( + "datapoints", + "xlabs", + "ylabs" + ) + ) } } diff --git a/R/type_polygon.R b/R/type_polygon.R index 3d01814f..5d81b6c4 100644 --- a/R/type_polygon.R +++ b/R/type_polygon.R @@ -2,16 +2,16 @@ #' #' @description Type function for plotting polygons. #' Arguments are passed to \code{\link[graphics]{polygon}}. -#' +#' #' @inheritParams graphics::polygon -#' +#' #' @examples #' # "polygon" type convenience character string #' tinyplot(1:9, c(2,1,2,1,NA,2,1,2,1), type = "polygon") -#' +#' #' # Use `type_polygon()` to pass extra arguments for customization #' tinyplot(1:9, c(2,1,2,1,NA,2,1,2,1), type = type_polygon(density = c(10, 20))) -#' +#' #' @export type_polygon = function(density = NULL, angle = 45) { out = list( @@ -29,25 +29,29 @@ data_polygon = function() { # legend customizations settings$legend_args[["pch"]] = settings$legend_args[["pch"]] %||% 22 settings$legend_args[["pt.cex"]] = settings$legend_args[["pt.cex"]] %||% 3.5 - settings$legend_args[["y.intersp"]] = settings$legend_args[["y.intersp"]] %||% 1.25 - settings$legend_args[["seg.len"]] = settings$legend_args[["seg.len"]] %||% 1.25 + settings$legend_args[["y.intersp"]] = settings$legend_args[[ + "y.intersp" + ]] %||% + 1.25 + settings$legend_args[["seg.len"]] = settings$legend_args[["seg.len"]] %||% + 1.25 } return(fun) } draw_polygon = function(density = density, angle = 45) { - fun = function(ix, iy, icol, ibg, ilty = par("lty"), ilwd = par("lwd"), ...) { - polygon( - x = ix, - y = iy, - border = icol, - col = ibg, - lty = ilty, - lwd = ilwd, - density = density, - angle = angle - ) - } - return(fun) + fun = function(ix, iy, icol, ibg, ilty = par("lty"), ilwd = par("lwd"), ...) { + polygon( + x = ix, + y = iy, + border = icol, + col = ibg, + lty = ilty, + lwd = ilwd, + density = density, + angle = angle + ) + } + return(fun) } diff --git a/R/type_polypath.R b/R/type_polypath.R index dbceacff..df6388ea 100644 --- a/R/type_polypath.R +++ b/R/type_polypath.R @@ -1,10 +1,10 @@ #' Polypath polygon type -#' +#' #' @description Type function for plotting polygons. #' Arguments are passed to \code{\link[graphics]{polypath}}. -#' +#' #' @inheritParams graphics::polypath -#' +#' #' @examples #' # "polypath" type convenience character string #' tinyplot( @@ -12,7 +12,7 @@ #' c(.1, .6, .6, .1, NA, .4, .9, .9, .4), #' type = "polypath", fill = "grey" #' ) -#' +#' #' # Use `type_polypath()` to pass extra arguments for customization #' tinyplot( #' c(.1, .1, .6, .6, NA, .4, .4, .9, .9), @@ -21,13 +21,13 @@ #' ) #' @export type_polypath = function(rule = "winding") { - out = list( - draw = draw_polypath(rule = rule), - data = data_polypath(), - name = "polypath" - ) - class(out) = "tinyplot_type" - return(out) + out = list( + draw = draw_polypath(rule = rule), + data = data_polypath(), + name = "polypath" + ) + class(out) = "tinyplot_type" + return(out) } @@ -36,25 +36,28 @@ data_polypath = function() { # legend customizations settings$legend_args[["pch"]] = settings$legend_args[["pch"]] %||% 22 settings$legend_args[["pt.cex"]] = settings$legend_args[["pt.cex"]] %||% 3.5 - settings$legend_args[["y.intersp"]] = settings$legend_args[["y.intersp"]] %||% 1.25 - settings$legend_args[["seg.len"]] = settings$legend_args[["seg.len"]] %||% 1.25 + settings$legend_args[["y.intersp"]] = settings$legend_args[[ + "y.intersp" + ]] %||% + 1.25 + settings$legend_args[["seg.len"]] = settings$legend_args[["seg.len"]] %||% + 1.25 } return(fun) } draw_polypath = function(rule = "winding") { - fun = function(ix, iy, icol, ibg, ilty, ilwd, dots, ...) { - polypath( - x = ix, - y = iy, - border = icol, - col = ibg, - lty = ilty, - lwd = ilwd, - rule = rule - ) - } - return(fun) + fun = function(ix, iy, icol, ibg, ilty, ilwd, dots, ...) { + polypath( + x = ix, + y = iy, + border = icol, + col = ibg, + lty = ilty, + lwd = ilwd, + rule = rule + ) + } + return(fun) } - diff --git a/R/type_rect.R b/R/type_rect.R index dd77cf35..01e3777b 100644 --- a/R/type_rect.R +++ b/R/type_rect.R @@ -1,28 +1,28 @@ #' Rectangle plot type #' #' @description Type function for plotting rectangles. -#' +#' #' @details Contrary to base \code{\link[graphics]{rect}}, rectangles in #' [tinyplot] must be specified using the `xmin`, `ymin`,`xmax`, and `ymax` -#' arguments. -#' +#' arguments. +#' #' @examples #' i = 4*(0:10) -#' +#' #' # "rect" type convenience character string #' tinyplot( #' xmin = 100+i, ymin = 300+i, xmax = 150+i, ymax = 380+i, #' by = i, fill = 0.2, #' type = "rect" #' ) -#' +#' #' # Same result with type_rect() #' tinyplot( #' xmin = 100+i, ymin = 300+i, xmax = 150+i, ymax = 380+i, #' by = i, fill = 0.2, #' type = type_rect() #' ) -#' +#' #' @export type_rect = function() { out = list( @@ -40,24 +40,32 @@ data_rect = function() { # legend customizations settings$legend_args[["pch"]] = settings$legend_args[["pch"]] %||% 22 settings$legend_args[["pt.cex"]] = settings$legend_args[["pt.cex"]] %||% 3.5 - settings$legend_args[["pt.lwd"]] = settings$legend_args[["pt.lwd"]] %||% par("lwd") + settings$legend_args[["pt.lwd"]] = settings$legend_args[["pt.lwd"]] %||% + par("lwd") settings$legend_args[["lty"]] = settings$legend_args[["lty"]] %||% 0 - settings$legend_args[["y.intersp"]] = settings$legend_args[["y.intersp"]] %||% 1.25 - settings$legend_args[["seg.len"]] = settings$legend_args[["seg.len"]] %||% 1.25 + settings$legend_args[["y.intersp"]] = settings$legend_args[[ + "y.intersp" + ]] %||% + 1.25 + settings$legend_args[["seg.len"]] = settings$legend_args[["seg.len"]] %||% + 1.25 } return(fun) } draw_rect = function() { - fun = function(ixmin, iymin, ixmax, iymax, ilty, ilwd, icol, ibg, ...) { - rect( - xleft = ixmin, ybottom = iymin, xright = ixmax, ytop = iymax, - lty = ilty, - lwd = ilwd, - border = icol, - col = ibg - ) - } - return(fun) + fun = function(ixmin, iymin, ixmax, iymax, ilty, ilwd, icol, ibg, ...) { + rect( + xleft = ixmin, + ybottom = iymin, + xright = ixmax, + ytop = iymax, + lty = ilty, + lwd = ilwd, + border = icol, + col = ibg + ) + } + return(fun) } diff --git a/R/type_ribbon.R b/R/type_ribbon.R index e303a93a..d8dc82b3 100644 --- a/R/type_ribbon.R +++ b/R/type_ribbon.R @@ -10,9 +10,9 @@ #' define a `y` interval (usually spanning from `ymin` to `ymax`) for each #' `x` value. Area plots are a special case of ribbon plot where `ymin` is #' set to 0 and `ymax` is set to `y`. -#' +#' #' @section Dodging ribbon plots: -#' +#' #' We support dodging for grouped ribbon plots, enabling similar functionality #' to dodged errorbar and pointrange plots. However, it is strongly recommended #' that dodging is only implemented for cases where the x-axis comprises a @@ -46,13 +46,13 @@ #' #' # Area plots are often used for time series charts #' tinyplot(AirPassengers, type = "area") -#' +#' #' # #' ## Dodged ribbon/area plots -#' +#' #' # Dodged ribbon or area plots can be useful in cases where there is strong #' # overlap across groups (and a limited number of discrete x-axis values). -#' +#' #' dat = data.frame( #' x = rep(c("Before", "After"), each = 2), #' grp = rep(c("A", "B"), 2), @@ -60,7 +60,7 @@ #' lwr = c(8, 8.5, 13, 13.3), #' upr = c(12, 12.5, 17, 17.3) #' ) -#' +#' #' tinyplot( #' y ~ x | grp, #' data = dat, @@ -68,7 +68,7 @@ #' type = type_ribbon(), #' main = "Overlappling ribbons" #' ) -#' +#' #' tinyplot( #' y ~ x | grp, #' data = dat, @@ -76,96 +76,153 @@ #' type = type_ribbon(dodge = 0.1), #' main = "Dodged ribbons" #' ) -#' +#' #' @export type_ribbon = function(alpha = NULL, dodge = 0, fixed.dodge = FALSE) { - out = list( - draw = draw_ribbon(), - data = data_ribbon(ribbon.alpha = alpha, dodge = dodge, fixed.dodge = fixed.dodge), - name = "ribbon" - ) - class(out) = "tinyplot_type" - return(out) + out = list( + draw = draw_ribbon(), + data = data_ribbon( + ribbon.alpha = alpha, + dodge = dodge, + fixed.dodge = fixed.dodge + ), + name = "ribbon" + ) + class(out) = "tinyplot_type" + return(out) } draw_ribbon = function() { - fun = function(ix, iy, ixmin, ixmax, iymin, iymax, ibg, ilty, ilwd, icol, ipch, i, flip = FALSE, ...) { - polyg = type_polygon()$draw - lin = type_lines()$draw - if (isFALSE(flip)) { - polyg(ix = c(ix, rev(ix)), iy = c(iymin, rev(iymax)), icol = NA, ibg = ibg) - } else { - polyg(c(ixmin, rev(ixmax)), iy = c(iy, rev(iy)), icol = NA, ibg = ibg) - } - lin(ix = ix, iy = iy, icol = icol, ipch = ipch, ibg = ibg, ilty = ilty, ilwd = ilwd, type = "l") + fun = function( + ix, + iy, + ixmin, + ixmax, + iymin, + iymax, + ibg, + ilty, + ilwd, + icol, + ipch, + i, + flip = FALSE, + ... + ) { + polyg = type_polygon()$draw + lin = type_lines()$draw + if (isFALSE(flip)) { + polyg( + ix = c(ix, rev(ix)), + iy = c(iymin, rev(iymax)), + icol = NA, + ibg = ibg + ) + } else { + polyg(c(ixmin, rev(ixmax)), iy = c(iy, rev(iy)), icol = NA, ibg = ibg) } - return(fun) + lin( + ix = ix, + iy = iy, + icol = icol, + ipch = ipch, + ibg = ibg, + ilty = ilty, + ilwd = ilwd, + type = "l" + ) + } + return(fun) } data_ribbon = function(ribbon.alpha = NULL, dodge = 0, fixed.dodge = FALSE) { - ribbon.alpha = sanitize_ribbon_alpha(ribbon.alpha) - fun = function(settings, ...) { - env2env(settings, environment(), c("datapoints", "xlabs", "null_by", "null_facet")) - # Convert x to factor if it's not already - if (is.character(datapoints$x)) { - datapoints$x = as.factor(datapoints$x) - } + ribbon.alpha = sanitize_ribbon_alpha(ribbon.alpha) + fun = function(settings, ...) { + env2env( + settings, + environment(), + c("datapoints", "xlabs", "null_by", "null_facet") + ) + # Convert x to factor if it's not already + if (is.character(datapoints$x)) { + datapoints$x = as.factor(datapoints$x) + } - if (is.factor(datapoints$x)) { - xlvls = levels(datapoints$x) - xlabs = seq_along(xlvls) - names(xlabs) = xlvls - datapoints$x = as.integer(datapoints$x) - } else { - xlabs = NULL - } - - # dodge (auto-detects x, xmin, xmax columns) - if (dodge != 0) { - datapoints = dodge_positions(datapoints, dodge, fixed.dodge) - } + if (is.factor(datapoints$x)) { + xlvls = levels(datapoints$x) + xlabs = seq_along(xlvls) + names(xlabs) = xlvls + datapoints$x = as.integer(datapoints$x) + } else { + xlabs = NULL + } - if (null_by && null_facet) { - xord = order(datapoints$x) - } else if (null_facet) { - xord = order(datapoints$by, datapoints$x) - } else if (null_by) { - xord = order(datapoints$facet, datapoints$x) - } else { - xord = order(datapoints$by, datapoints$facet, datapoints$x) - } + # dodge (auto-detects x, xmin, xmax columns) + if (dodge != 0) { + datapoints = dodge_positions(datapoints, dodge, fixed.dodge) + } - # Reorder x, y, ymin, and ymax based on the order determined - datapoints = datapoints[xord, ] + if (null_by && null_facet) { + xord = order(datapoints$x) + } else if (null_facet) { + xord = order(datapoints$by, datapoints$x) + } else if (null_by) { + xord = order(datapoints$facet, datapoints$x) + } else { + xord = order(datapoints$by, datapoints$facet, datapoints$x) + } - # Catch for missing ymin and ymax - if (is.null(datapoints$ymin)) datapoints$ymin = datapoints$y - if (is.null(datapoints$ymax)) datapoints$ymax = datapoints$y + # Reorder x, y, ymin, and ymax based on the order determined + datapoints = datapoints[xord, ] - x = datapoints$x - y = datapoints$y - ymin = datapoints$ymin - ymax = datapoints$ymax - by = if (length(unique(datapoints$by)) > 1) datapoints$by else NULL - facet = if (length(unique(datapoints$facet)) > 1) datapoints$facet else NULL + # Catch for missing ymin and ymax + if (is.null(datapoints$ymin)) { + datapoints$ymin = datapoints$y + } + if (is.null(datapoints$ymax)) { + datapoints$ymax = datapoints$y + } - # ribbon.alpha comes from parent scope, so assign it locally - ribbon.alpha = ribbon.alpha + x = datapoints$x + y = datapoints$y + ymin = datapoints$ymin + ymax = datapoints$ymax + by = if (length(unique(datapoints$by)) > 1) datapoints$by else NULL + facet = if (length(unique(datapoints$facet)) > 1) datapoints$facet else NULL - # legend customizations - settings$legend_args[["pch"]] = settings$legend_args[["pch"]] %||% 22 - settings$legend_args[["pt.cex"]] = settings$legend_args[["pt.cex"]] %||% 3.5 - settings$legend_args[["pt.lwd"]] = settings$legend_args[["pt.lwd"]] %||% 0 - settings$legend_args[["y.intersp"]] = settings$legend_args[["y.intersp"]] %||% 1.25 - settings$legend_args[["seg.len"]] = settings$legend_args[["seg.len"]] %||% 1.25 + # ribbon.alpha comes from parent scope, so assign it locally + ribbon.alpha = ribbon.alpha - vars_to_copy = c("x", "y", "ymin", "ymax", "xlabs", "datapoints", "ribbon.alpha") - if (!is.null(by)) vars_to_copy = c(vars_to_copy, "by") - if (!is.null(facet)) vars_to_copy = c(vars_to_copy, "facet") + # legend customizations + settings$legend_args[["pch"]] = settings$legend_args[["pch"]] %||% 22 + settings$legend_args[["pt.cex"]] = settings$legend_args[["pt.cex"]] %||% 3.5 + settings$legend_args[["pt.lwd"]] = settings$legend_args[["pt.lwd"]] %||% 0 + settings$legend_args[["y.intersp"]] = settings$legend_args[[ + "y.intersp" + ]] %||% + 1.25 + settings$legend_args[["seg.len"]] = settings$legend_args[["seg.len"]] %||% + 1.25 - env2env(environment(), settings, vars_to_copy) + vars_to_copy = c( + "x", + "y", + "ymin", + "ymax", + "xlabs", + "datapoints", + "ribbon.alpha" + ) + if (!is.null(by)) { + vars_to_copy = c(vars_to_copy, "by") } - return(fun) + if (!is.null(facet)) { + vars_to_copy = c(vars_to_copy, "facet") + } + + env2env(environment(), settings, vars_to_copy) + } + return(fun) } diff --git a/R/type_ridge.R b/R/type_ridge.R index 946863d5..2887c86d 100644 --- a/R/type_ridge.R +++ b/R/type_ridge.R @@ -67,12 +67,12 @@ #' transparency of the density fills. In most cases, will default to a value of #' 1, i.e. fully opaque. But for some `by` grouped plots (excepting the special #' cases where `by==y` or `by==x`), will default to 0.6. -#' +#' #' @section Technical note on gradient fills: -#' +#' #' `tinyplot` uses two basic approaches for drawing gradient fills in ridge line #' plots, e.g., if `type_ridge(gradient = TRUE)`. -#' +#' #' The first (and default) polygon-based approach involves dividing up the main #' density region into many smaller polygons along the x-axis. Each of these #' smaller polygons inherits a different color "segment" from the underlying @@ -82,9 +82,9 @@ #' is thus efficient from a plotting perspective and generally also performs #' well from an aesthetic perspective. However, it can occasionally produce #' undesirable plotting artifacts on some graphics devices---e.g., thin but -#' visible vertical lines---if alpha transparency is being used at the same +#' visible vertical lines---if alpha transparency is being used at the same #' time. -#' +#' #' For this reason, we also offer an alternative raster-based approach for #' gradient fills that users can invoke via #' `type_ridge(gradient = TRUE, raster = TRUE)`. The essential idea is that we @@ -93,7 +93,7 @@ #' color interpolation. The trade-off this time is potential smoothness #' artifacts around the top of the ridge densities at high resolutions, since we #' have converted a vector object into a raster object. -#' +#' #' Again, we expect that the choice between these two approaches will only #' matter for ridge plots that combine gradient fills with alpha transparency #' (and on certain graphics devices). We recommend that users experiment to @@ -106,29 +106,29 @@ #' Month2 = factor(month.name[Month], levels = month.name[5:9]), #' Late = ifelse(Day > 15, "Late", "Early") #' ) -#' +#' #' # default ridge plot (using the "ridge" convenience string) #' tinyplot(Month ~ Temp, data = aq, type = "ridge") -#' +#' #' # for ridge plots, we recommend pairing with the dedicated theme(s), which #' # facilitate nicer y-axis labels, grid lines, etc. -#' +#' #' tinytheme("ridge") #' tinyplot(Month ~ Temp, data = aq, type = "ridge") -#' +#' #' tinytheme("ridge2") # removes the plot frame (but keeps x-axis line) #' tinyplot(Month ~ Temp, data = aq, type = "ridge") -#' +#' #' # the "ridge(2)" themes are especially helpful for long y labels, due to #' # dyanmic plot adjustment #' tinyplot(Month2 ~ Temp, data = aq, type = "ridge") -#' +#' #' # pass customization arguments through type_ridge()... for example, use #' # the scale argument to change/avoid overlap of densities (more on scaling #' # further below) -#' +#' #' tinyplot(Month ~ Temp, data = aq, type = type_ridge(scale = 1)) -#' +#' #' ## by grouping is also supported. two special cases of interest: #' #' # 1) by == y (color by y groups) @@ -143,13 +143,13 @@ #' #' # gradient coloring along the x-axis can also be invoked manually without #' # a legend (the next two tinyplot calls are equivalent) -#' +#' #' # tinyplot(Month ~ Temp, data = aq, type = type_ridge(gradient = "agsunset")) #' tinyplot(Month ~ Temp, data = aq, type = type_ridge(gradient = TRUE)) -#' +#' #' # aside: when combining gradient fill with alpha transparency, it may be #' # better to use the raster-based approach (test on your graphics device) -#' +#' #' tinyplot(Month ~ Temp, data = aq, #' type = type_ridge(gradient = TRUE, alpha = 0.5), #' main = "polygon fill (default)") @@ -170,49 +170,67 @@ #' #' # faceting also works, although we recommend switching (back) to the "ridge" #' # theme for faceted ridge plots -#' +#' #' tinytheme("ridge") #' tinyplot(Month ~ Ozone, facet = ~ Late, data = aq, #' type = type_ridge(gradient = TRUE)) -#' +#' #' ## use the joint.max argument to vary the maximum density used for #' ## determining relative scaling... -#' +#' #' # jointly across all densities (default) vs. per facet #' tinyplot(Month ~ Temp, facet = ~ Late, data = aq, #' type = type_ridge(scale = 1)) #' tinyplot(Month ~ Temp, facet = ~ Late, data = aq, #' type = type_ridge(scale = 1, joint.max = "facet")) -#' +#' #' # jointly across all densities (default) vs. per by row #' tinyplot(Month ~ Temp | Late, data = aq, #' type = type_ridge(scale = 1)) #' tinyplot(Month ~ Temp | Late, data = aq, #' type = type_ridge(scale = 1, joint.max = "by")) -#' +#' #' # restore the default theme #' tinytheme() #' #' @export type_ridge = function( - scale = 1.5, - joint.max = c("all", "facet", "by"), - breaks = NULL, - probs = NULL, - ylevels = NULL, - bw = "nrd0", - joint.bw = c("mean", "full", "none"), - adjust = 1, - kernel = c("gaussian", "epanechnikov", "rectangular", "triangular", "biweight", "cosine", "optcosine"), - n = 512, - # more args from density here? - gradient = FALSE, - raster = FALSE, - col = NULL, - alpha = NULL - ) { - - kernel = match.arg(kernel, c("gaussian", "epanechnikov", "rectangular", "triangular", "biweight", "cosine", "optcosine")) + scale = 1.5, + joint.max = c("all", "facet", "by"), + breaks = NULL, + probs = NULL, + ylevels = NULL, + bw = "nrd0", + joint.bw = c("mean", "full", "none"), + adjust = 1, + kernel = c( + "gaussian", + "epanechnikov", + "rectangular", + "triangular", + "biweight", + "cosine", + "optcosine" + ), + n = 512, + # more args from density here? + gradient = FALSE, + raster = FALSE, + col = NULL, + alpha = NULL +) { + kernel = match.arg( + kernel, + c( + "gaussian", + "epanechnikov", + "rectangular", + "triangular", + "biweight", + "cosine", + "optcosine" + ) + ) if (is.logical(joint.bw)) { joint.bw = ifelse(joint.bw, "mean", "none") } @@ -220,18 +238,22 @@ type_ridge = function( out = list( draw = draw_ridge(), - data = data_ridge(bw = bw, adjust = adjust, kernel = kernel, n = n, - joint.bw = joint.bw, - scale = scale, - joint.max = joint.max, - gradient = gradient, - breaks = breaks, - probs = probs, - ylevels = ylevels, - raster = raster, - col = col, - alpha = alpha - ), + data = data_ridge( + bw = bw, + adjust = adjust, + kernel = kernel, + n = n, + joint.bw = joint.bw, + scale = scale, + joint.max = joint.max, + gradient = gradient, + breaks = breaks, + probs = probs, + ylevels = ylevels, + raster = raster, + col = col, + alpha = alpha + ), name = "ridge" ) class(out) = "tinyplot_type" @@ -240,18 +262,22 @@ type_ridge = function( # ## Underlying data_ridge function -data_ridge = function(bw = "nrd0", adjust = 1, kernel = "gaussian", n = 512, - joint.bw = "mean", - scale = 1.5, - joint.max = "all", - gradient = FALSE, - breaks = NULL, - probs = NULL, - ylevels = NULL, - raster = FALSE, - col = NULL, - alpha = NULL - ) { +data_ridge = function( + bw = "nrd0", + adjust = 1, + kernel = "gaussian", + n = 512, + joint.bw = "mean", + scale = 1.5, + joint.max = "all", + gradient = FALSE, + breaks = NULL, + probs = NULL, + ylevels = NULL, + raster = FALSE, + col = NULL, + alpha = NULL +) { fun = function(settings, ...) { env2env(settings, environment(), c("datapoints", "yaxt", "xaxt", "null_by")) @@ -269,30 +295,44 @@ data_ridge = function(bw = "nrd0", adjust = 1, kernel = "gaussian", n = 512, } # flag for (non-gradient) interior fill adjustment fill_by = anyby || y_by - if (isTRUE(x_by)) fill_by = FALSE + if (isTRUE(x_by)) { + fill_by = FALSE + } # if (isTRUE(anyby) && is.null(alpha)) alpha = 0.6 ## reorder levels of y-variable if requested if (!is.null(ylevels)) { - if (!is.factor(datapoints$y)) datapoints$y = factor(datapoints$y) - datapoints$y = factor(datapoints$y, levels = if(is.numeric(ylevels)) levels(datapoints$y)[ylevels] else ylevels) + if (!is.factor(datapoints$y)) { + datapoints$y = factor(datapoints$y) + } + datapoints$y = factor( + datapoints$y, + levels = if (is.numeric(ylevels)) { + levels(datapoints$y)[ylevels] + } else { + ylevels + } + ) if (y_by) datapoints$by = datapoints$y } ## - datapoints = split(datapoints, list(datapoints$y, datapoints$by, datapoints$facet)) + datapoints = split( + datapoints, + list(datapoints$y, datapoints$by, datapoints$facet) + ) if (joint.bw == "none" || is.numeric(bw)) { - dens_bw = bw + dens_bw = bw } else { - if (joint.bw == "mean") { - # Use weighted mean of subgroup bandwidths - bws = sapply(datapoints, function(dat) bw_fun(kernel = bw, dat$x)) - ws = sapply(datapoints, nrow) - dens_bw = weighted.mean(bws, ws) - } else if (joint.bw == "full") { - dens_bw = bw_fun(kernel = bw, unlist(sapply(datapoints, `[[`, "x"))) - } + if (joint.bw == "mean") { + # Use weighted mean of subgroup bandwidths + bws = sapply(datapoints, function(dat) bw_fun(kernel = bw, dat$x)) + ws = sapply(datapoints, nrow) + dens_bw = weighted.mean(bws, ws) + } else if (joint.bw == "full") { + dens_bw = bw_fun(kernel = bw, unlist(sapply(datapoints, `[[`, "x"))) + } } datapoints = lapply(datapoints, function(dat) { @@ -311,7 +351,8 @@ data_ridge = function(bw = "nrd0", adjust = 1, kernel = "gaussian", n = 512, if (is.character(joint.max)) { joint.max = match.arg(joint.max, c("all", "facet", "by")) - joint.max = switch(joint.max, + joint.max = switch( + joint.max, "all" = rep.int(1, nrow(datapoints)), "facet" = datapoints$facet, "by" = interaction(datapoints$facet, datapoints$y) @@ -354,7 +395,9 @@ data_ridge = function(bw = "nrd0", adjust = 1, kernel = "gaussian", n = 512, warning("only one of 'breaks' and 'quantile' must be specified") probs = NULL } else { - if (probs[1L] > 0) probs = c(0, probs) + if (probs[1L] > 0) { + probs = c(0, probs) + } if (probs[length(probs)] < 1) probs = c(probs, 1) } } @@ -363,13 +406,21 @@ data_ridge = function(bw = "nrd0", adjust = 1, kernel = "gaussian", n = 512, palette = if (!is.null(dotspal)) dotspal else gradient gradient = TRUE if (isTRUE(palette)) { - palette = if (!is.null(.tpar[["palette.sequential"]])) .tpar[["palette.sequential"]] else "viridis" + palette = if (!is.null(.tpar[["palette.sequential"]])) { + .tpar[["palette.sequential"]] + } else { + "viridis" + } } if (length(palette) > 1L || !is.character(palette)) { ## color vector already given if (is.null(breaks) && is.null(probs)) { - breaks = seq(from = xlim[1L], to = xlim[2L], length.out = length(palette) + 1L) + breaks = seq( + from = xlim[1L], + to = xlim[2L], + length.out = length(palette) + 1L + ) } else { npal = pmax(length(breaks), length(probs)) - 1L if (length(palette) != npal) { @@ -380,9 +431,15 @@ data_ridge = function(bw = "nrd0", adjust = 1, kernel = "gaussian", n = 512, } } else { ## only palette name given - npal = if (is.null(breaks) && is.null(probs)) 512L else pmax(length(breaks), length(probs)) - 1L + npal = if (is.null(breaks) && is.null(probs)) { + 512L + } else { + pmax(length(breaks), length(probs)) - 1L + } palette = hcl.colors(npal, palette = palette) - if (is.null(breaks) && is.null(probs)) breaks = seq(from = xlim[1L], to = xlim[2L], length.out = npal + 1L) + if (is.null(breaks) && is.null(probs)) { + breaks = seq(from = xlim[1L], to = xlim[2L], length.out = npal + 1L) + } if (isTRUE(raster)) raster = npal > 20L } } else { @@ -393,15 +450,24 @@ data_ridge = function(bw = "nrd0", adjust = 1, kernel = "gaussian", n = 512, breaks[1L] = pmin(breaks[1L], xlim[1L]) breaks[length(breaks)] = pmax(breaks[length(breaks)], xlim[2L]) } - - if (is.null(col) && (!anyby || x_by)) col = "black" + + if (is.null(col) && (!anyby || x_by)) { + col = "black" + } # For ridge themes without groups, a numeric bg (e.g. bg = 0.2) should # produce transparent gray, not a transparent palette colour. (#547) - ridge_theme = identical(.tpar[["tinytheme"]], "ridge") || identical(.tpar[["tinytheme"]], "ridge2") + ridge_theme = identical(.tpar[["tinytheme"]], "ridge") || + identical(.tpar[["tinytheme"]], "ridge2") if (ridge_theme && !anyby) { ubg = settings[["bg"]] - if (!is.null(ubg) && length(ubg) == 1 && is.numeric(ubg) && ubg >= 0 && ubg <= 1) { + if ( + !is.null(ubg) && + length(ubg) == 1 && + is.numeric(ubg) && + ubg >= 0 && + ubg <= 1 + ) { settings[["bg"]] = adjustcolor("gray", alpha.f = ubg) } } @@ -425,21 +491,29 @@ data_ridge = function(bw = "nrd0", adjust = 1, kernel = "gaussian", n = 512, col = col, alpha = alpha ) - + # legend customizations settings$legend_args[["pch"]] = settings$legend_args[["pch"]] %||% 22 settings$legend_args[["pt.cex"]] = settings$legend_args[["pt.cex"]] %||% 3.5 - settings$legend_args[["y.intersp"]] = settings$legend_args[["y.intersp"]] %||% 1.25 - settings$legend_args[["seg.len"]] = settings$legend_args[["seg.len"]] %||% 1.25 - - env2env(environment(), settings, c( - "datapoints", - "yaxt", - "ylim", - "type_info", - "group_offsets", - "offsets_axis" - )) + settings$legend_args[["y.intersp"]] = settings$legend_args[[ + "y.intersp" + ]] %||% + 1.25 + settings$legend_args[["seg.len"]] = settings$legend_args[["seg.len"]] %||% + 1.25 + + env2env( + environment(), + settings, + c( + "datapoints", + "yaxt", + "ylim", + "type_info", + "group_offsets", + "offsets_axis" + ) + ) } return(fun) } @@ -452,7 +526,9 @@ draw_ridge = function() { ridge_theme = isTRUE(type_info[["ridge_theme"]]) d = data.frame(x = ix, y = iy, ymin = iymin, ymax = iymax) dsplit = split(d, d$y) - if (!is.null(type_info[["col"]])) icol = type_info[["col"]] + if (!is.null(type_info[["col"]])) { + icol = type_info[["col"]] + } if (is.null(ibg)) { pal_q = .tpar[["palette.qualitative"]] # For non-ridge themes with a palette, derive fill from the first palette @@ -463,7 +539,11 @@ draw_ridge = function() { } else { "gray" } - ibg = if (isTRUE(type_info[["fill_by"]])) seq_palette(icol, n = 2)[2] else default_bg + ibg = if (isTRUE(type_info[["fill_by"]])) { + seq_palette(icol, n = 2)[2] + } else { + default_bg + } } if (!is.null(type_info[["alpha"]]) && is.null(type_info[["palette"]])) { ibg = adjustcolor(ibg, alpha.f = type_info[["alpha"]]) @@ -478,35 +558,67 @@ draw_ridge = function() { } else { val = cumsum(rep(1, length(lab))) - 1 } - if (ridge_theme) abline(h = val, col = .tpar[["grid.col"]]) - draw_segments = if (type_info[["raster"]]) segmented_raster else segmented_polygon + if (ridge_theme) { + abline(h = val, col = .tpar[["grid.col"]]) + } + draw_segments = if (type_info[["raster"]]) { + segmented_raster + } else { + segmented_polygon + } for (i in rev(seq_along(dsplit))) { if (type_info[["gradient"]]) { with( dsplit[[i]], draw_segments( - x, ymax, ymin = ymin[1L], + x, + ymax, + ymin = ymin[1L], breaks = type_info[["breaks"]], probs = type_info[["probs"]], manbreaks = type_info[["manbreaks"]], - col = if (is.null(type_info[["palette"]])) ibg else type_info[["palette"]], + col = if (is.null(type_info[["palette"]])) { + ibg + } else { + type_info[["palette"]] + }, # border = if (is.null(type_info[["palette"]])) icol else "transparent", alpha = type_info[["alpha"]] ) ) } - with(dsplit[[i]], polygon(x, ymax, col = if (type_info[["gradient"]]) "transparent" else ibg, border = NA)) + with( + dsplit[[i]], + polygon( + x, + ymax, + col = if (type_info[["gradient"]]) "transparent" else ibg, + border = NA + ) + ) with(dsplit[[i]], lines(x, ymax, col = icol)) } # tinyAxis(x = d$y, side = 2, at = val, labels = lab, type = type_info[["yaxt"]], padj = padj) if (ridge_theme) { - tinyAxis(x = d$y, side = 2, at = val, labels = lab, type = type_info[["yaxt"]], - padj = 0, - mgp = c(3, 1, 0) - c(0.5, 0.5 + 0.3, 0), - tcl = 0) + tinyAxis( + x = d$y, + side = 2, + at = val, + labels = lab, + type = type_info[["yaxt"]], + padj = 0, + mgp = c(3, 1, 0) - c(0.5, 0.5 + 0.3, 0), + tcl = 0 + ) if (identical(.tpar[["tinytheme"]], "ridge2")) axis(1, labels = FALSE) } else { - tinyAxis(x = d$y, side = 2, at = val, labels = lab, type = type_info[["yaxt"]]) + tinyAxis( + x = d$y, + side = 2, + at = val, + labels = lab, + type = type_info[["yaxt"]] + ) } } return(fun) @@ -517,20 +629,33 @@ draw_ridge = function() { ## Auxiliary functions ## auxiliary function for drawing shaded segmented polygon -segmented_polygon = function(x, y, ymin = 0, breaks = range(x), probs = NULL, manbreaks = FALSE, col = "lightgray", border = "transparent", alpha = NULL) { - +segmented_polygon = function( + x, + y, + ymin = 0, + breaks = range(x), + probs = NULL, + manbreaks = FALSE, + col = "lightgray", + border = "transparent", + alpha = NULL +) { if (!is.null(probs)) { ## map quantiles to breaks - if (!(missing(breaks) || is.null(breaks))) stop("only one of 'breaks' and 'probs' must be specified") + if (!(missing(breaks) || is.null(breaks))) { + stop("only one of 'breaks' and 'probs' must be specified") + } breaks = quantile.density(list(x = x, y = y - ymin), probs = probs) } ## sanity check - if (breaks[1L] > x[1L] || breaks[length(breaks)] < x[length(x)]) stop("'breaks' do no span range of 'x'") + if (breaks[1L] > x[1L] || breaks[length(breaks)] < x[length(x)]) { + stop("'breaks' do no span range of 'x'") + } # ## recycle color (if necessary) rather use colorRampPalette below # col = rep_len(col, length(breaks) - 1L) - + # Create individual polygons if (isFALSE(manbreaks)) { # Special case for length(breaks)==length(x). We can take a fully vectorised @@ -540,83 +665,122 @@ segmented_polygon = function(x, y, ymin = 0, breaks = range(x), probs = NULL, ma } else { # For other cases, we'll do a bit more work to make sure that the polygons # overlap - bvals = do.call(c, sapply(seq_along(breaks[-1]), function(b) tail(x[x= xrange[1] & breaks < xrange[2]) - idx = c(idx, length(idx)+1) + idx = c(idx, length(idx) + 1) col = col[idx] col = colorRampPalette(col, alpha = TRUE)(length(x)) # support alpha? } - } else if (isFALSE(manbreaks) || length(col) > length(x) || length(x) %% length(col) != 0) { + } else if ( + isFALSE(manbreaks) || + length(col) > length(x) || + length(x) %% length(col) != 0 + ) { xrange = range(xx, na.rm = TRUE) idx = which(breaks >= xrange[1] & breaks < xrange[2]) - idx = c(idx, length(idx)+1) + idx = c(idx, length(idx) + 1) col = col[idx] col = colorRampPalette(col, alpha = TRUE)(length(x)) # support alpha? } } - border = if (is.null(alpha)) col else adjustcolor(col = col, alpha.f = alpha/2) - + border = if (is.null(alpha)) { + col + } else { + adjustcolor(col = col, alpha.f = alpha / 2) + } + ## draw all polygons polygon(xx, yy, col = col, border = border, lwd = 0.5) } #' @importFrom graphics rasterImage #' @importFrom grDevices as.raster -segmented_raster = function(x, y, ymin = 0, breaks = range(x), probs = NULL, manbreaks = FALSE, col = "lightgray", border = "transparent", alpha = NULL) { - ## set up raster matrix on x-grid and 500 y-pixels +segmented_raster = function( + x, + y, + ymin = 0, + breaks = range(x), + probs = NULL, + manbreaks = FALSE, + col = "lightgray", + border = "transparent", + alpha = NULL +) { + ## set up raster matrix on x-grid and 500 y-pixels n = length(x) - 1L m = 500L ## FIXME: hard-coded? r = matrix(1:n, ncol = n, nrow = m, byrow = TRUE) ## map quantiles to breaks if (!is.null(probs)) { - if (!(missing(breaks) || is.null(breaks))) stop("only one of 'breaks' and 'probs' must be specified") + if (!(missing(breaks) || is.null(breaks))) { + stop("only one of 'breaks' and 'probs' must be specified") + } breaks = quantile.density(list(x = x, y = y - ymin), probs = probs) } - if (!is.null(alpha)) col = adjustcolor(col, alpha.f = alpha) + if (!is.null(alpha)) { + col = adjustcolor(col, alpha.f = alpha) + } col = rev(col) ## uncomment to make extreme cols dark ## map colors to intervals and fill colors by column col = col[cut(x, breaks = breaks, include.lowest = TRUE)] @@ -625,11 +789,22 @@ segmented_raster = function(x, y, ymin = 0, breaks = range(x), probs = NULL, man ## clip raster pixels above density line ymax = max(y) ix = cbind(as.vector(row(r)), as.vector(col(r))) - ix = ix[seq(from = ymax, to = ymin, length.out = m)[row(r)] > y[col(r)], , drop = FALSE] + ix = ix[ + seq(from = ymax, to = ymin, length.out = m)[row(r)] > y[col(r)], + , + drop = FALSE + ] r[ix] = NA ## plot density and add raster gradient - rasterImage(as.raster(r), min(x), ymin, max(x), ymax, interpolate = length(breaks) >= 20L) ## FIXME: improve quality for "few" breaks? + rasterImage( + as.raster(r), + min(x), + ymin, + max(x), + ymax, + interpolate = length(breaks) >= 20L + ) ## FIXME: improve quality for "few" breaks? } ## auxiliary function for determining quantiles based on density function @@ -637,7 +812,9 @@ segmented_raster = function(x, y, ymin = 0, breaks = range(x), probs = NULL, man #' @importFrom stats median approx quantile.density = function(x, probs = seq(0, 1, 0.25), ...) { ## sanity check for probabilities - if (any(probs < 0 | probs > 1)) stop("'probs' outside [0,1]") + if (any(probs < 0 | probs > 1)) { + stop("'probs' outside [0,1]") + } ## probability density function, extrapolated to zero, use midpoints n = length(x$x) @@ -650,9 +827,9 @@ quantile.density = function(x, probs = seq(0, 1, 0.25), ...) { x = c(x[1L] - delta, x, x[n] + delta) ## numerical integration of density - cdf = c(0, cumsum(diff(x) * (pdf[-1L] + pdf[-(n + 2L)])/2)) - cdf = cdf/cdf[n + 2L] + cdf = c(0, cumsum(diff(x) * (pdf[-1L] + pdf[-(n + 2L)]) / 2)) + cdf = cdf / cdf[n + 2L] ## approximate quantiles - approx(cdf, x, xout = probs, rule = 2)$y + approx(cdf, x, xout = probs, rule = 2)$y } diff --git a/R/type_rug.R b/R/type_rug.R index 85d7ee93..36ec68a1 100644 --- a/R/type_rug.R +++ b/R/type_rug.R @@ -1,18 +1,18 @@ #' Add a rug to a plot -#' +#' #' @description #' Adds a rug representation (1-d plot) of the data to the plot. -#' +#' #' @details #' This function should only be used as part of [`tinyplot_add()`], i.e. adding #' to an existing plot. -#' +#' #' In most cases, determining which variable receives the rug representation #' will be based on the `side` argument (i.e., x-variable if side is 1 or 3, and #' y-variable if side is 2 or 4). An exception is if the preceding plot type was #' either `"density"` or `"histogram"`; for these latter cases, the x-variable #' will always be used. See Examples. -#' +#' #' @inheritParams graphics::rug #' @param jitter Logical. Add jittering to separate ties? Default is `FALSE`. #' @param amount Numeric. Amount of jittering (see \code{\link[base]{jitter}}). @@ -22,17 +22,23 @@ #' tinyplot_add(type = "rug") #' # use type_rug() to pass extra options #' tinyplot_add(type = type_rug(side = 3, ticksize = 0.05)) -#' +#' #' # For ties, use jittering #' tinyplot(eruptions ~ waiting, data = faithful, type = "lm") #' tinyplot_add(type = type_rug(jitter = TRUE, amount = 0.3)) #' tinyplot_add(type = type_rug(jitter = TRUE, amount = 0.1, side = 2)) #' # Add original points just for reference #' tinyplot_add(type = "p") -#' +#' #' @importFrom graphics rug #' @export -type_rug = function(ticksize = 0.03, side = 1, quiet = getOption("warn") < 0, jitter = FALSE, amount = NULL) { +type_rug = function( + ticksize = 0.03, + side = 1, + quiet = getOption("warn") < 0, + jitter = FALSE, + amount = NULL +) { data_rug = function(settings, ...) { env2env(settings, environment(), "datapoints") if (nrow(datapoints) == 0) { @@ -42,22 +48,37 @@ type_rug = function(ticksize = 0.03, side = 1, quiet = getOption("warn") < 0, ji env2env(environment(), settings, "datapoints") } - draw_rug = function(.ticksize = ticksize, .side = side, .quiet = quiet, .jitter = jitter, .amount = amount) { - fun = function(ix, iy, icol, ilwd, ...) { - lc = get_environment_variable(".last_call") - swapy = !is.null(lc$type) && lc$type %in% c("density", "hist", "histogram") - rugx = if (swapy) iy else if (side %in% c(1, 3)) ix else iy - if (isTRUE(jitter)) rugx = jitter(rugx, amount = .amount) - rug( - x = rugx, - col = icol, - lwd = ilwd, - ticksize = .ticksize, - side = .side, - quiet = .quiet - ) + draw_rug = function( + .ticksize = ticksize, + .side = side, + .quiet = quiet, + .jitter = jitter, + .amount = amount + ) { + fun = function(ix, iy, icol, ilwd, ...) { + lc = get_environment_variable(".last_call") + swapy = !is.null(lc$type) && + lc$type %in% c("density", "hist", "histogram") + rugx = if (swapy) { + iy + } else if (side %in% c(1, 3)) { + ix + } else { + iy } - return(fun) + if (isTRUE(jitter)) { + rugx = jitter(rugx, amount = .amount) + } + rug( + x = rugx, + col = icol, + lwd = ilwd, + ticksize = .ticksize, + side = .side, + quiet = .quiet + ) + } + return(fun) } out = list( diff --git a/R/type_segments.R b/R/type_segments.R index 3dc8d40f..c7b06c0a 100644 --- a/R/type_segments.R +++ b/R/type_segments.R @@ -1,24 +1,24 @@ #' Line segments plot type #' #' @description Type function for plotting line segments. -#' +#' #' @details Contrary to base \code{\link[graphics]{segments}}, line segments in #' [tinyplot] must be specified using the `xmin`, `ymin`,`xmax`, and `ymax` -#' arguments. -#' +#' arguments. +#' #' @examples #' # "segments" type convenience character string #' tinyplot( #' xmin = c(0,.1), ymin = c(.2,1), xmax = c(1,.9), ymax = c(.75,0), #' type = "segments" #' ) -#' +#' #' # Same result with type_segments() #' tinyplot( #' xmin = c(0,.1), ymin = c(.2,1), xmax = c(1,.9), ymax = c(.75,0), #' type = type_segments() #' ) -#' +#' #' @export type_segments = function() { out = list( @@ -32,13 +32,16 @@ type_segments = function() { draw_segments = function() { - fun = function(ixmin, iymin, ixmax, iymax, ilty, ilwd, icol, ...) { - segments( - x0 = ixmin, y0 = iymin, x1 = ixmax, y1 = iymax, - lty = ilty, - lwd = ilwd, - col = icol - ) - } - return(fun) + fun = function(ixmin, iymin, ixmax, iymax, ilty, ilwd, icol, ...) { + segments( + x0 = ixmin, + y0 = iymin, + x1 = ixmax, + y1 = iymax, + lty = ilty, + lwd = ilwd, + col = icol + ) + } + return(fun) } diff --git a/R/type_spineplot.R b/R/type_spineplot.R index 36ea2d78..cf0dac8a 100644 --- a/R/type_spineplot.R +++ b/R/type_spineplot.R @@ -11,39 +11,39 @@ #' @examples #' # "spineplot" type convenience string #' tinyplot(Species ~ Sepal.Width, data = iris, type = "spineplot") -#' +#' #' # Aside: specifying the type is redundant for this example, since tinyplot() #' # defaults to "spineplot" if y is a factor (just like base plot). #' tinyplot(Species ~ Sepal.Width, data = iris) -#' +#' #' # Use `type_spineplot()` to pass extra arguments for customization #' tinyplot(Species ~ Sepal.Width, data = iris, type = type_spineplot(breaks = 4)) -#' +#' #' p = palette.colors(3, "Pastel 1") #' tinyplot(Species ~ Sepal.Width, data = iris, type = type_spineplot(breaks = 4, col = p)) #' rm(p) -#' +#' #' # More idiomatic tinyplot way of drawing the previous plot: use y == by #' tinyplot( #' Species ~ Sepal.Width | Species, data = iris, type = type_spineplot(breaks = 4), #' palette = "Pastel 1", legend = FALSE #' ) -#' +#' #' # Grouped and faceted spineplots -#' +#' #' ttnc = as.data.frame(Titanic) -#' +#' #' tinyplot( #' Survived ~ Sex, facet = ~ Class, data = ttnc, #' type = type_spineplot(weights = ttnc$Freq) #' ) -#' +#' #' # For grouped "by" spineplots, it's better visually to facet as well #' tinyplot( #' Survived ~ Sex | Class, facet = "by", data = ttnc, #' type = type_spineplot(weights = ttnc$Freq) #' ) -#' +#' #' # Fancier version. Note the smart inheritance of spacing etc. #' tinyplot( #' Survived ~ Sex | Class, facet = "by", data = ttnc, @@ -63,13 +63,37 @@ #' tinyplot(Survived ~ Sex | Class, data = ttnc, #' type = type_spineplot(weights = ttnc$Freq), alpha = 0.3 #' ) -#' +#' #' @export -type_spineplot = function(breaks = NULL, tol.ylab = 0.05, off = NULL, xlevels = NULL, ylevels = NULL, col = NULL, xaxlabels = NULL, yaxlabels = NULL, weights = NULL) { +type_spineplot = function( + breaks = NULL, + tol.ylab = 0.05, + off = NULL, + xlevels = NULL, + ylevels = NULL, + col = NULL, + xaxlabels = NULL, + yaxlabels = NULL, + weights = NULL +) { col = col out = list( - data = data_spineplot(off = off, breaks = breaks, xlevels = xlevels, ylevels = ylevels, xaxlabels = xaxlabels, yaxlabels = yaxlabels, weights = weights), - draw = draw_spineplot(tol.ylab = tol.ylab, off = off, col = col, xaxlabels = xaxlabels, yaxlabels = yaxlabels), + data = data_spineplot( + off = off, + breaks = breaks, + xlevels = xlevels, + ylevels = ylevels, + xaxlabels = xaxlabels, + yaxlabels = yaxlabels, + weights = weights + ), + draw = draw_spineplot( + tol.ylab = tol.ylab, + off = off, + col = col, + xaxlabels = xaxlabels, + yaxlabels = yaxlabels + ), name = "spineplot" ) class(out) = "tinyplot_type" @@ -77,348 +101,522 @@ type_spineplot = function(breaks = NULL, tol.ylab = 0.05, off = NULL, xlevels = } #' @importFrom grDevices nclass.Sturges -data_spineplot = function(off = NULL, breaks = NULL, xlevels = xlevels, ylevels = ylevels, xaxlabels = NULL, yaxlabels = NULL, weights = NULL) { - fun = function(settings, ...) { - env2env(settings, environment(), c("datapoints", "xlim", "ylim", "facet", "facet.args", "by", "xaxb", "yaxb", "null_by", "null_facet", "null_palette", "col", "bg", "axes", "xaxt", "yaxt")) - - ## process weights - if (!is.null(weights)) { - ny = length(datapoints$y) - if (length(weights) != ny && length(weights) != 1L) { - stop(sprintf("'weights' must have either length 1 or %s", ny)) - } - } - datapoints$weights = weights - - ## process x variable - if (is.factor(datapoints$x)) { - breaks = NULL - off = if(is.null(off)) 0.02 else off/100 - if (is.null(xlim)) xlim = c(0, 1 + (nlevels(datapoints$x) - 1L) * off) - } else { - off = 0 - if (is.null(xlim)) xlim = c(0, 1) - x = as.numeric(datapoints$x) - if (is.null(breaks)) { - breaks = if (!is.null(xaxb)) xaxb else if (is.null(weights)) nclass.Sturges(x) else ceiling(log2(sum(weights)) + 1) - } - breaks = as.numeric(breaks) - if (length(breaks) == 1L) { - if (!is.numeric(breaks) || !is.finite(breaks) || breaks < 1L) stop("invalid number of 'breaks'") - if (breaks > 1e6) { - warning(gettextf("'breaks = %g' is too large and set to 1e6", breaks)) - breaks = 1000000L - } - rg = if (is.null(weights)) range(x, na.rm = TRUE) else range(x[weights > 0], na.rm = TRUE) - breaks = pretty(rg, n = breaks, min.n = 1L) - } - } +data_spineplot = function( + off = NULL, + breaks = NULL, + xlevels = xlevels, + ylevels = ylevels, + xaxlabels = NULL, + yaxlabels = NULL, + weights = NULL +) { + fun = function(settings, ...) { + env2env( + settings, + environment(), + c( + "datapoints", + "xlim", + "ylim", + "facet", + "facet.args", + "by", + "xaxb", + "yaxb", + "null_by", + "null_facet", + "null_palette", + "col", + "bg", + "axes", + "xaxt", + "yaxt" + ) + ) - ## process y variable - if (!is.factor(datapoints$y)) datapoints$y = factor(datapoints$y) - if (is.null(ylim)) ylim = c(0, 1) + ## process weights + if (!is.null(weights)) { + ny = length(datapoints$y) + if (length(weights) != ny && length(weights) != 1L) { + stop(sprintf("'weights' must have either length 1 or %s", ny)) + } + } + datapoints$weights = weights - ## adjust facet margins - if (!is.null(facet) && is.null(facet.args[["fmar"]])) { - facet.args[["fmar"]] = c(2, 2, 2, 2) + ## process x variable + if (is.factor(datapoints$x)) { + breaks = NULL + off = if (is.null(off)) 0.02 else off / 100 + if (is.null(xlim)) xlim = c(0, 1 + (nlevels(datapoints$x) - 1L) * off) + } else { + off = 0 + if (is.null(xlim)) { + xlim = c(0, 1) + } + x = as.numeric(datapoints$x) + if (is.null(breaks)) { + breaks = if (!is.null(xaxb)) { + xaxb + } else if (is.null(weights)) { + nclass.Sturges(x) + } else { + ceiling(log2(sum(weights)) + 1) } - - x_by = identical(datapoints$x, datapoints$by) - y_by = identical(datapoints$y, datapoints$by) - - x.categorical = is.factor(datapoints$x) - if (!is.null(xlevels) && x.categorical) { - xlevels = if(is.numeric(xlevels)) levels(datapoints$x)[xlevels] else xlevels - if (anyNA(xlevels) || !all(xlevels %in% levels(datapoints$x))) warning("not all 'xlevels' correspond to levels of 'x'") - datapoints$x = factor(datapoints$x, levels = xlevels) - if (x_by) datapoints$by = datapoints$x + } + breaks = as.numeric(breaks) + if (length(breaks) == 1L) { + if (!is.numeric(breaks) || !is.finite(breaks) || breaks < 1L) { + stop("invalid number of 'breaks'") } - if (!is.null(ylevels)) { - ylevels = if(is.numeric(ylevels)) levels(datapoints$y)[ylevels] else ylevels - if (anyNA(ylevels) || !all(ylevels %in% levels(datapoints$y))) warning("not all 'ylevels' correspond to levels of 'y'") - datapoints$y = factor(datapoints$y, levels = ylevels) - if (y_by) datapoints$by = datapoints$y + if (breaks > 1e6) { + warning(gettextf("'breaks = %g' is too large and set to 1e6", breaks)) + breaks = 1000000L } - - x = datapoints$x - y = datapoints$y - - # if either x_by or y_by are TRUE, we'll only split by facets and then - # use some simple logic to assign colouring on the backend - if (isTRUE(x_by) || isTRUE(y_by)) { - datapoints = split(datapoints, list(datapoints$facet)) - datapoints = Filter(function(k) nrow(k) > 0, datapoints) + rg = if (is.null(weights)) { + range(x, na.rm = TRUE) } else { - datapoints = split(datapoints, list(datapoints$by, datapoints$facet)) - datapoints = Filter(function(k) nrow(k) > 0, datapoints) + range(x[weights > 0], na.rm = TRUE) } - - # construct spineplot rectangles and breaks points for each by-facet combo - datapoints = Map(function(dat, x.categorical, off) { - ## set up frequency table - x = dat$x - if(!x.categorical) { - x = cut(as.numeric(x), breaks = breaks, include.lowest = TRUE) - } - ## TODO: process by grouping via: interaction + spacing + labeling - ## (for now just do interaction) - ## FIXME: data_facet only contains the first by group? - ## if (any(dat$by != "")) x = interaction(dat$by, x) - if(is.null(dat$weights)) { - tab = table(x, dat$y) - } else { - tab = as.table(tapply(dat$weights, list(x, dat$y), FUN = sum, na.rm = TRUE)) - tab[is.na(tab)] = 0 - } - nx = nrow(tab) - ny = ncol(tab) - - ## compute coordinates - ## cumulative proportions of x (plus off) vs. conditional cumulative proportions of y - yat = rbind(0, apply(proportions(tab[, ny:1L, drop = FALSE], 1L), 1L, cumsum)) - yat[is.na(yat)] = 1 - xat = c(0, cumsum(proportions(marginSums(tab, 1L)) + off)) - - ybottom = as.vector(yat[-(ny + 1L),]) - ytop = as.vector(yat[-1L,]) - xleft = rep(xat[1L:nx], rep(ny, nx)) - xright = rep(xat[2L:(nx+1L)] - off, rep(ny, nx)) - - out = data.frame( - by = dat$by[1], # already split - facet = dat$facet[1], # already split - ymin = ybottom, - ymax = ytop, - xmin = xleft, - xmax = xright - ) - - attr(out, "nx") = nx - attr(out, "ny") = ny - attr(out, "xat") = xat - attr(out, "yat") = yat - return(out) - }, - dat = datapoints, - x.categorical = x.categorical, - off = off - ) - - nx = attr(datapoints[[1]], "nx") ## should be the same for all by/facet groups - ny = attr(datapoints[[1]], "ny") ## ditto - xat = lapply(datapoints, attr, "xat") - yat = lapply(datapoints, attr, "yat") - datapoints = do.call(rbind, datapoints) - - if (is.null(yaxlabels)) yaxlabels = rev(levels(y)) - - ## axis labels - yaxlabels = if(is.null(yaxlabels)) levels(y) else rep_len(yaxlabels, ny) - if (!is.null(yaxb)) { - # yaxlabels = yaxlabels[yaxlabels %in% yaxb] - ## rather use the "" assignment workaround below, since otherwise we - ## get a mismatch between the label names and ticks - yaxlabels[!(yaxlabels %in% yaxb)] = "" + breaks = pretty(rg, n = breaks, min.n = 1L) + } + } + + ## process y variable + if (!is.factor(datapoints$y)) { + datapoints$y = factor(datapoints$y) + } + if (is.null(ylim)) { + ylim = c(0, 1) + } + + ## adjust facet margins + if (!is.null(facet) && is.null(facet.args[["fmar"]])) { + facet.args[["fmar"]] = c(2, 2, 2, 2) + } + + x_by = identical(datapoints$x, datapoints$by) + y_by = identical(datapoints$y, datapoints$by) + + x.categorical = is.factor(datapoints$x) + if (!is.null(xlevels) && x.categorical) { + xlevels = if (is.numeric(xlevels)) { + levels(datapoints$x)[xlevels] + } else { + xlevels + } + if (anyNA(xlevels) || !all(xlevels %in% levels(datapoints$x))) { + warning("not all 'xlevels' correspond to levels of 'x'") + } + datapoints$x = factor(datapoints$x, levels = xlevels) + if (x_by) datapoints$by = datapoints$x + } + if (!is.null(ylevels)) { + ylevels = if (is.numeric(ylevels)) { + levels(datapoints$y)[ylevels] + } else { + ylevels + } + if (anyNA(ylevels) || !all(ylevels %in% levels(datapoints$y))) { + warning("not all 'ylevels' correspond to levels of 'y'") + } + datapoints$y = factor(datapoints$y, levels = ylevels) + if (y_by) datapoints$by = datapoints$y + } + + x = datapoints$x + y = datapoints$y + + # if either x_by or y_by are TRUE, we'll only split by facets and then + # use some simple logic to assign colouring on the backend + if (isTRUE(x_by) || isTRUE(y_by)) { + datapoints = split(datapoints, list(datapoints$facet)) + datapoints = Filter(function(k) nrow(k) > 0, datapoints) + } else { + datapoints = split(datapoints, list(datapoints$by, datapoints$facet)) + datapoints = Filter(function(k) nrow(k) > 0, datapoints) + } + + # construct spineplot rectangles and breaks points for each by-facet combo + datapoints = Map( + function(dat, x.categorical, off) { + ## set up frequency table + x = dat$x + if (!x.categorical) { + x = cut(as.numeric(x), breaks = breaks, include.lowest = TRUE) } - if(x.categorical) { - xaxlabels = if(is.null(xaxlabels)) { - levels(x) - } else { - rep_len(xaxlabels, nx) - } + ## TODO: process by grouping via: interaction + spacing + labeling + ## (for now just do interaction) + ## FIXME: data_facet only contains the first by group? + ## if (any(dat$by != "")) x = interaction(dat$by, x) + if (is.null(dat$weights)) { + tab = table(x, dat$y) } else { - xaxlabels = if(is.null(xaxlabels)) { - if(is.numeric(x)) breaks else c(x[1L], x[c(diff(as.numeric(x)) > 0, TRUE)]) - } else { - rep_len(xaxlabels, nx + 1L) - } + tab = as.table(tapply( + dat$weights, + list(x, dat$y), + FUN = sum, + na.rm = TRUE + )) + tab[is.na(tab)] = 0 } - - # catch for x_by / y/by - if (isTRUE(x_by)) datapoints$by = factor(rep(xaxlabels, each = ny)) # each x label extends over ny rows - if (isTRUE(y_by)) datapoints$by = factor(rep_len(yaxlabels, nrow(datapoints))) - - ## grayscale flag - grayscale = null_by && null_palette && is.null(.tpar[["palette.qualitative"]]) - - x = c(datapoints$xmin, datapoints$xmax) - y = c(datapoints$ymin, datapoints$ymax) - ymin = datapoints$ymin - ymax = datapoints$ymax - xmin = datapoints$xmin - xmax = datapoints$xmax - by = if (null_by) by else datapoints$by - facet = if (null_facet) facet else datapoints$facet - - # Save original values for type_info before overwriting - axes_orig = axes - xaxt_orig = xaxt - yaxt_orig = yaxt - - axes = FALSE - frame.plot = FALSE - xaxt = "n" - yaxt = "n" - xaxs = "i" - yaxs = "i" - ylabs = yaxlabels - type_info = list( - off = off, - x.categorical = x.categorical, - nx = nx, - ny = ny, - xat = xat, - yat = yat, - xaxlabels = xaxlabels, - yaxlabels = yaxlabels, - breaks = breaks, - axes = axes_orig, - xaxt = xaxt_orig, - yaxt = yaxt_orig, - grayscale = grayscale, - x_by = x_by, - y_by = y_by + nx = nrow(tab) + ny = ncol(tab) + + ## compute coordinates + ## cumulative proportions of x (plus off) vs. conditional cumulative proportions of y + yat = rbind( + 0, + apply(proportions(tab[, ny:1L, drop = FALSE], 1L), 1L, cumsum) + ) + yat[is.na(yat)] = 1 + xat = c(0, cumsum(proportions(marginSums(tab, 1L)) + off)) + + ybottom = as.vector(yat[-(ny + 1L), ]) + ytop = as.vector(yat[-1L, ]) + xleft = rep(xat[1L:nx], rep(ny, nx)) + xright = rep(xat[2L:(nx + 1L)] - off, rep(ny, nx)) + + out = data.frame( + by = dat$by[1], # already split + facet = dat$facet[1], # already split + ymin = ybottom, + ymax = ytop, + xmin = xleft, + xmax = xright ) - - # legend customizations - settings$legend_args[["pch"]] = settings$legend_args[["pch"]] %||% 22 - settings$legend_args[["pt.cex"]] = settings$legend_args[["pt.cex"]] %||% 3.5 - settings$legend_args[["pt.lwd"]] = settings$legend_args[["pt.lwd"]] %||% 0 - settings$legend_args[["y.intersp"]] = settings$legend_args[["y.intersp"]] %||% 1.25 - settings$legend_args[["seg.len"]] = settings$legend_args[["seg.len"]] %||% 1.25 - - env2env(environment(), settings, c( - "x", "y", "ymin", "ymax", "xmin", "xmax", "col", "bg", "datapoints", - "by", "facet", "axes", "frame.plot", "xaxt", "yaxt", "xaxs", "yaxs", - "ylabs", "type_info", "facet.args" - )) - + + attr(out, "nx") = nx + attr(out, "ny") = ny + attr(out, "xat") = xat + attr(out, "yat") = yat + return(out) + }, + dat = datapoints, + x.categorical = x.categorical, + off = off + ) + + nx = attr(datapoints[[1]], "nx") ## should be the same for all by/facet groups + ny = attr(datapoints[[1]], "ny") ## ditto + xat = lapply(datapoints, attr, "xat") + yat = lapply(datapoints, attr, "yat") + datapoints = do.call(rbind, datapoints) + + if (is.null(yaxlabels)) { + yaxlabels = rev(levels(y)) } - return(fun) -} -#' @importFrom grDevices gray.colors -draw_spineplot = function(tol.ylab = 0.05, off = NULL, col = NULL, xaxlabels = NULL, yaxlabels = NULL) { - fun = function(ixmin, iymin, ixmax, iymax, ilty, ilwd, icol, ibg, - flip, - facet_window_args, - type_info, - ifacet, - ...) { - - if (is.null(off)) off = type_info[["off"]] - if (is.null(xaxlabels)) xaxlabels = type_info[["xaxlabels"]] - if (is.null(yaxlabels)) yaxlabels = type_info[["yaxlabels"]] - xat = type_info[["xat"]][[ifacet]] - yat = type_info[["yat"]][[ifacet]] - nx = type_info[["nx"]] - ny = type_info[["ny"]] - x.categorical = type_info[["x.categorical"]] - grayscale = type_info[["grayscale"]] - x_by = type_info[["x_by"]] - y_by = type_info[["y_by"]] - - ## graphical parameters - if (is.null(col)) { - if (is.null(ibg)) ibg = icol - if (isFALSE(y_by)) { - ibg = if (isTRUE(grayscale)) gray.colors(ny) else seq_palette(ibg, ny) + ## axis labels + yaxlabels = if (is.null(yaxlabels)) levels(y) else rep_len(yaxlabels, ny) + if (!is.null(yaxb)) { + # yaxlabels = yaxlabels[yaxlabels %in% yaxb] + ## rather use the "" assignment workaround below, since otherwise we + ## get a mismatch between the label names and ticks + yaxlabels[!(yaxlabels %in% yaxb)] = "" + } + if (x.categorical) { + xaxlabels = if (is.null(xaxlabels)) { + levels(x) + } else { + rep_len(xaxlabels, nx) + } + } else { + xaxlabels = if (is.null(xaxlabels)) { + if (is.numeric(x)) { + breaks + } else { + c(x[1L], x[c(diff(as.numeric(x)) > 0, TRUE)]) } - ibg = rep_len(ibg, ny) } else { - ibg = col + rep_len(xaxlabels, nx + 1L) } - - if (type_info[["xaxt"]] %in% c("l", "t", "n") && - type_info[["yaxt"]] %in% c("l", "t", "n") && - !all(c(type_info[["xaxt"]], type_info[["yaxt"]]) == "n")) ilwd = 0 - - rect( - xleft = ixmin, ybottom = iymin, xright = ixmax, ytop = iymax, - lty = ilty, - lwd = ilwd, - border = par("fg"), #icol, - col = ibg + } + + # catch for x_by / y/by + if (isTRUE(x_by)) { + datapoints$by = factor(rep(xaxlabels, each = ny)) + } # each x label extends over ny rows + if (isTRUE(y_by)) { + datapoints$by = factor(rep_len(yaxlabels, nrow(datapoints))) + } + + ## grayscale flag + grayscale = null_by && + null_palette && + is.null(.tpar[["palette.qualitative"]]) + + x = c(datapoints$xmin, datapoints$xmax) + y = c(datapoints$ymin, datapoints$ymax) + ymin = datapoints$ymin + ymax = datapoints$ymax + xmin = datapoints$xmin + xmax = datapoints$xmax + by = if (null_by) by else datapoints$by + facet = if (null_facet) facet else datapoints$facet + + # Save original values for type_info before overwriting + axes_orig = axes + xaxt_orig = xaxt + yaxt_orig = yaxt + + axes = FALSE + frame.plot = FALSE + xaxt = "n" + yaxt = "n" + xaxs = "i" + yaxs = "i" + ylabs = yaxlabels + type_info = list( + off = off, + x.categorical = x.categorical, + nx = nx, + ny = ny, + xat = xat, + yat = yat, + xaxlabels = xaxlabels, + yaxlabels = yaxlabels, + breaks = breaks, + axes = axes_orig, + xaxt = xaxt_orig, + yaxt = yaxt_orig, + grayscale = grayscale, + x_by = x_by, + y_by = y_by + ) + + # legend customizations + settings$legend_args[["pch"]] = settings$legend_args[["pch"]] %||% 22 + settings$legend_args[["pt.cex"]] = settings$legend_args[["pt.cex"]] %||% 3.5 + settings$legend_args[["pt.lwd"]] = settings$legend_args[["pt.lwd"]] %||% 0 + settings$legend_args[["y.intersp"]] = settings$legend_args[[ + "y.intersp" + ]] %||% + 1.25 + settings$legend_args[["seg.len"]] = settings$legend_args[["seg.len"]] %||% + 1.25 + + env2env( + environment(), + settings, + c( + "x", + "y", + "ymin", + "ymax", + "xmin", + "xmax", + "col", + "bg", + "datapoints", + "by", + "facet", + "axes", + "frame.plot", + "xaxt", + "yaxt", + "xaxs", + "yaxs", + "ylabs", + "type_info", + "facet.args" ) - - ## axes - ## - standard categorical axes (xaxt/yaxt == "s") _without_ ticks - ## - never draw additional axis lines, box always for spinogram - if(type_info[["axes"]]) { - if (x.categorical) { - spine_axis(if (flip) 2 else 1, at = (xat[1L:nx] + xat[2L:(nx+1L)] - off)/2, labels = xaxlabels, - type = type_info[["xaxt"]], categorical = TRUE) - } else { - spine_axis(if (flip) 2 else 1, at = xat, labels = xaxlabels, - type = type_info[["xaxt"]], categorical = FALSE) - } - yat = yat[, if(flip) ncol(yat) else 1L] - equidist = any(diff(yat) < tol.ylab) - yat = if(equidist) seq.int(1/(2*ny), 1-1/(2*ny), by = 1/ny) else (yat[-1L] + yat[-length(yat)])/2 - spine_axis(if (flip) 3 else 2, at = yat, labels = yaxlabels, - type = type_info[["yaxt"]], categorical = TRUE) - if (is_facet_position(if(flip) "bottom" else "right", ifacet, facet_window_args)) spine_axis(if (flip) 1 else 4, - type = type_info[["yaxt"]], categorical = FALSE) + ) + } + return(fun) +} + +#' @importFrom grDevices gray.colors +draw_spineplot = function( + tol.ylab = 0.05, + off = NULL, + col = NULL, + xaxlabels = NULL, + yaxlabels = NULL +) { + fun = function( + ixmin, + iymin, + ixmax, + iymax, + ilty, + ilwd, + icol, + ibg, + flip, + facet_window_args, + type_info, + ifacet, + ... + ) { + if (is.null(off)) { + off = type_info[["off"]] + } + if (is.null(xaxlabels)) { + xaxlabels = type_info[["xaxlabels"]] + } + if (is.null(yaxlabels)) { + yaxlabels = type_info[["yaxlabels"]] + } + xat = type_info[["xat"]][[ifacet]] + yat = type_info[["yat"]][[ifacet]] + nx = type_info[["nx"]] + ny = type_info[["ny"]] + x.categorical = type_info[["x.categorical"]] + grayscale = type_info[["grayscale"]] + x_by = type_info[["x_by"]] + y_by = type_info[["y_by"]] + + ## graphical parameters + if (is.null(col)) { + if (is.null(ibg)) { + ibg = icol } - if(!x.categorical && (is.null(ilwd) || ilwd > 0)) box() - + if (isFALSE(y_by)) { + ibg = if (isTRUE(grayscale)) gray.colors(ny) else seq_palette(ibg, ny) + } + ibg = rep_len(ibg, ny) + } else { + ibg = col } - return(fun) -} + if ( + type_info[["xaxt"]] %in% + c("l", "t", "n") && + type_info[["yaxt"]] %in% c("l", "t", "n") && + !all(c(type_info[["xaxt"]], type_info[["yaxt"]]) == "n") + ) { + ilwd = 0 + } + + rect( + xleft = ixmin, + ybottom = iymin, + xright = ixmax, + ytop = iymax, + lty = ilty, + lwd = ilwd, + border = par("fg"), #icol, + col = ibg + ) + ## axes + ## - standard categorical axes (xaxt/yaxt == "s") _without_ ticks + ## - never draw additional axis lines, box always for spinogram + if (type_info[["axes"]]) { + if (x.categorical) { + spine_axis( + if (flip) 2 else 1, + at = (xat[1L:nx] + xat[2L:(nx + 1L)] - off) / 2, + labels = xaxlabels, + type = type_info[["xaxt"]], + categorical = TRUE + ) + } else { + spine_axis( + if (flip) 2 else 1, + at = xat, + labels = xaxlabels, + type = type_info[["xaxt"]], + categorical = FALSE + ) + } + yat = yat[, if (flip) ncol(yat) else 1L] + equidist = any(diff(yat) < tol.ylab) + yat = if (equidist) { + seq.int(1 / (2 * ny), 1 - 1 / (2 * ny), by = 1 / ny) + } else { + (yat[-1L] + yat[-length(yat)]) / 2 + } + spine_axis( + if (flip) 3 else 2, + at = yat, + labels = yaxlabels, + type = type_info[["yaxt"]], + categorical = TRUE + ) + if ( + is_facet_position( + if (flip) "bottom" else "right", + ifacet, + facet_window_args + ) + ) { + spine_axis( + if (flip) 1 else 4, + type = type_info[["yaxt"]], + categorical = FALSE + ) + } + } + if (!x.categorical && (is.null(ilwd) || ilwd > 0)) box() + } + return(fun) +} spine_axis = function(side, ..., type = "standard", categorical = TRUE) { - type = match.arg(type, c("standard", "none", "labels", "ticks", "axis")) - ## standard: with axis, ticks (unless categorical), and labels - ## none: no axes - ## labels: only labels without ticks and axis line - ## ticks: only ticks and labels without axis line - ## axis: only axis line and labels but no ticks - - if (type == "none") { - invisible(numeric(0L)) + type = match.arg(type, c("standard", "none", "labels", "ticks", "axis")) + ## standard: with axis, ticks (unless categorical), and labels + ## none: no axes + ## labels: only labels without ticks and axis line + ## ticks: only ticks and labels without axis line + ## axis: only axis line and labels but no ticks + + if (type == "none") { + invisible(numeric(0L)) + } else { + args = list(side = side, ...) + if (type == "labels") { + args$tick = FALSE + } else if (type == "ticks") { + args$lwd = 0 + if (!("lwd.ticks" %in% names(args))) { + args$lwd.ticks = if (categorical) 0 else 1 + } + } else if (type == "axis") { + if (categorical) { + args$tick = FALSE + } else { + args$lwd.ticks = 0 + } } else { - args = list(side = side, ...) - if (type == "labels") { - args$tick = FALSE - } else if (type == "ticks") { - args$lwd = 0 - if (!("lwd.ticks" %in% names(args))) args$lwd.ticks = if (categorical) 0 else 1 - } else if (type == "axis") { - if (categorical) { - args$tick = FALSE - } else { - args$lwd.ticks = 0 - } - } else { - args$tick = !categorical - } - do.call("axis", args) + args$tick = !categorical } + do.call("axis", args) + } } #' @importFrom grDevices col2rgb convertColor hcl to_hcl = function(x) { - x = t(col2rgb(x, alpha = TRUE)/255) - alpha = x[, 4] - x = x[, 1:3] - x = convertColor(x, from = "sRGB", to = "Luv") - x = cbind(H = atan2(x[, 3L], x[, 2L]) * 180/pi, C = sqrt(x[, 2L]^2 + x[, 3L]^2), L = x[, 1L]) - x[is.na(x[, 1L]), 1L] = 0 - x[x[, 1L] < 0, 1L] = x[x[, 1L] < 0, 1L] + 360 - attr(x, "alpha") = alpha - return(x) + x = t(col2rgb(x, alpha = TRUE) / 255) + alpha = x[, 4] + x = x[, 1:3] + x = convertColor(x, from = "sRGB", to = "Luv") + x = cbind( + H = atan2(x[, 3L], x[, 2L]) * 180 / pi, + C = sqrt(x[, 2L]^2 + x[, 3L]^2), + L = x[, 1L] + ) + x[is.na(x[, 1L]), 1L] = 0 + x[x[, 1L] < 0, 1L] = x[x[, 1L] < 0, 1L] + 360 + attr(x, "alpha") = alpha + return(x) } seq_palette = function(x, n, power = 1.5) { - x = drop(to_hcl(x[1L])) - alpha = attr(x, "alpha") - hcl( - h = x[1L], - c = seq.int(from = x[2L]^(1/power), to = 0, length.out = n + 1)[1L:n]^power, - l = 100 - seq.int(from = (100 - x[3L])^(1/power), to = pmin(8, (100 - x[3L])/2)^(1/power), length.out = n)^power, - alpha = alpha - )[1L:n] + x = drop(to_hcl(x[1L])) + alpha = attr(x, "alpha") + hcl( + h = x[1L], + c = seq.int(from = x[2L]^(1 / power), to = 0, length.out = n + 1)[ + 1L:n + ]^power, + l = 100 - + seq.int( + from = (100 - x[3L])^(1 / power), + to = pmin(8, (100 - x[3L]) / 2)^(1 / power), + length.out = n + )^power, + alpha = alpha + )[1L:n] } diff --git a/R/type_spline.R b/R/type_spline.R index b1527ea0..ffbf35a5 100644 --- a/R/type_spline.R +++ b/R/type_spline.R @@ -16,44 +16,80 @@ #' data = cars, type = type_spline(method = "natural", n = 25), #' add = TRUE, lty = 2) #' @export -type_spline = function(n = NULL, - method = "fmm", - xmin = NULL, - xmax = NULL, - xout = NULL, - ties = mean) { - out = list( - draw = draw_lines(), - data = data_spline(method = method, ties = ties, n = n, xmin = xmin, xmax = xmax, xout = xout), - name = "l" - ) - class(out) = "tinyplot_type" - return(out) +type_spline = function( + n = NULL, + method = "fmm", + xmin = NULL, + xmax = NULL, + xout = NULL, + ties = mean +) { + out = list( + draw = draw_lines(), + data = data_spline( + method = method, + ties = ties, + n = n, + xmin = xmin, + xmax = xmax, + xout = xout + ), + name = "l" + ) + class(out) = "tinyplot_type" + return(out) } data_spline = function(n, method, xmin, xmax, xout, ties, ...) { - fun = function(settings, ...) { - env2env(settings, environment(), "datapoints") + fun = function(settings, ...) { + env2env(settings, environment(), "datapoints") - datapoints = split(datapoints, list(datapoints$facet, datapoints$by), drop = TRUE) - datapoints = lapply(datapoints, function(dat) { - if (is.null(n)) n = 3 * length(dat$x) - if (is.null(xmax)) xmax = max(dat$x) - if (is.null(xmin)) xmin = min(dat$x) - if (is.null(xout)) { - fit = spline(x = dat$x, y = dat$y, n = n, method = method, xmin = xmin, xmax = xmax, ties = ties) - } else { - fit = spline(x = dat$x, y = dat$y, n = n, method = method, xmin = xmin, xmax = xmax, xout = xout, ties = ties) - } - fit = as.data.frame(fit) - fit$facet = dat$facet[1] - fit$by = dat$by[1] - fit - return(fit) - }) - datapoints = do.call(rbind, datapoints) - env2env(environment(), settings, "datapoints") - } - return(fun) + datapoints = split( + datapoints, + list(datapoints$facet, datapoints$by), + drop = TRUE + ) + datapoints = lapply(datapoints, function(dat) { + if (is.null(n)) { + n = 3 * length(dat$x) + } + if (is.null(xmax)) { + xmax = max(dat$x) + } + if (is.null(xmin)) { + xmin = min(dat$x) + } + if (is.null(xout)) { + fit = spline( + x = dat$x, + y = dat$y, + n = n, + method = method, + xmin = xmin, + xmax = xmax, + ties = ties + ) + } else { + fit = spline( + x = dat$x, + y = dat$y, + n = n, + method = method, + xmin = xmin, + xmax = xmax, + xout = xout, + ties = ties + ) + } + fit = as.data.frame(fit) + fit$facet = dat$facet[1] + fit$by = dat$by[1] + fit + return(fit) + }) + datapoints = do.call(rbind, datapoints) + env2env(environment(), settings, "datapoints") + } + return(fun) } diff --git a/R/type_summary.R b/R/type_summary.R index 059609f9..3a03cb81 100644 --- a/R/type_summary.R +++ b/R/type_summary.R @@ -43,7 +43,11 @@ type_summary = function(fun = mean, ...) { funky = function(settings, ...) { env2env(settings, environment(), c("datapoints", "by", "facet")) - datapoints = split(datapoints, list(datapoints$facet, datapoints$by), drop = TRUE) + datapoints = split( + datapoints, + list(datapoints$facet, datapoints$by), + drop = TRUE + ) datapoints = lapply(datapoints, function(dat) { newy = ave(dat$y, dat$x, FUN = fun) dat$y = newy diff --git a/R/type_text.R b/R/type_text.R index f0774be9..96981e96 100644 --- a/R/type_text.R +++ b/R/type_text.R @@ -87,10 +87,10 @@ type_text = function( data_text = function(labels = NULL, clim = c(0.5, 2.5)) { fun = function(settings, ...) { env2env(settings, environment(), "datapoints") - + # Store clim for bubble() function settings$clim = clim - + if (is.null(labels)) { labels = datapoints$y } diff --git a/R/type_violin.R b/R/type_violin.R index 42eb2dd5..5108c98a 100644 --- a/R/type_violin.R +++ b/R/type_violin.R @@ -1,5 +1,5 @@ #' Violin plot type -#' +#' #' @md #' @description Type function for violin plots, which are an alternative to box #' plots for visualizing continuous distributions (by group) in the form of @@ -12,232 +12,311 @@ #' @inherit stats::density details #' @details See [`type_density`] for more details and considerations related to #' bandwidth selection and kernel types. -#' +#' #' @examples #' # "violin" type convenience string #' tinyplot(count ~ spray, data = InsectSprays, type = "violin") -#' +#' #' # aside: to match the defaults of `ggplot2::geom_violin()`, use `trim = TRUE` #' # and `joint.bw = FALSE` #' tinyplot(count ~ spray, data = InsectSprays, type = "violin", #' trim = TRUE, joint.bw = FALSE) -#' +#' #' # use flip = TRUE to reorient the axes #' tinyplot(count ~ spray, data = InsectSprays, type = "violin", flip = TRUE) -#' +#' #' # for flipped plots with long group labels, it's better to use a theme for #' # dynamic plot resizing #' tinytheme("clean") #' tinyplot(weight ~ feed, data = chickwts, type = "violin", flip = TRUE) -#' +#' #' # you can group by the x var to add colour (here with the original orientation) #' tinyplot(weight ~ feed | feed, data = chickwts, type = "violin", legend = FALSE) -#' +#' #' # dodged grouped violin plot example (different dataset) #' tinyplot(len ~ dose | supp, data = ToothGrowth, type = "violin", fill = 0.2) -#' +#' #' # note: above we relied on `...` argument passing alongside the "violin" #' # type convenience string. But this won't work for `width`, since it will #' # clash with the top-level `tinyplot(..., width = )` arg. To ensure #' # correct arg passing, it's safer to use the formal `type_violin()` option. #' tinyplot(len ~ dose | supp, data = ToothGrowth, fill = 0.2, #' type = type_violin(width = 0.8)) -#' +#' #' # reset theme #' tinytheme() -#' +#' #' @importFrom stats density weighted.mean -#' @importFrom stats bw.SJ bw.bcv bw.nrd bw.nrd0 bw.ucv +#' @importFrom stats bw.SJ bw.bcv bw.nrd bw.nrd0 bw.ucv #' @export type_violin = function( - bw = "nrd0", - joint.bw = c("mean", "full", "none"), - adjust = 1, - kernel = c("gaussian", "epanechnikov", "rectangular", "triangular", "biweight", "cosine", "optcosine"), - n = 512, - # more args from density here? - trim = FALSE, - width = 0.9 - ) { - kernel = match.arg(kernel, c("gaussian", "epanechnikov", "rectangular", "triangular", "biweight", "cosine", "optcosine")) - if (is.logical(joint.bw)) { - joint.bw = ifelse(joint.bw, "mean", "none") - } - joint.bw = match.arg(joint.bw, c("mean", "full", "none")) - out = list( - data = data_violin(bw = bw, adjust = adjust, kernel = kernel, n = n, - joint.bw = joint.bw, trim = trim, width = width), - # draw = NULL, - # name = "polygon" - draw = draw_polygon(density = NULL), - name = "violin" + bw = "nrd0", + joint.bw = c("mean", "full", "none"), + adjust = 1, + kernel = c( + "gaussian", + "epanechnikov", + "rectangular", + "triangular", + "biweight", + "cosine", + "optcosine" + ), + n = 512, + # more args from density here? + trim = FALSE, + width = 0.9 +) { + kernel = match.arg( + kernel, + c( + "gaussian", + "epanechnikov", + "rectangular", + "triangular", + "biweight", + "cosine", + "optcosine" ) - class(out) = "tinyplot_type" - return(out) + ) + if (is.logical(joint.bw)) { + joint.bw = ifelse(joint.bw, "mean", "none") + } + joint.bw = match.arg(joint.bw, c("mean", "full", "none")) + out = list( + data = data_violin( + bw = bw, + adjust = adjust, + kernel = kernel, + n = n, + joint.bw = joint.bw, + trim = trim, + width = width + ), + # draw = NULL, + # name = "polygon" + draw = draw_polygon(density = NULL), + name = "violin" + ) + class(out) = "tinyplot_type" + return(out) } -data_violin = function(bw = "nrd0", adjust = 1, kernel = "gaussian", n = 512, - joint.bw = "none", trim = FALSE, width = 0.9) { - fun = function(settings, ...) { - env2env(settings, environment(), c("datapoints", "by", "null_palette", "facet", "ylab", "col", "bg", "log", "null_by", "null_facet")) - - - # Handle ordering based on by and facet variables - ngrps = if (null_by) 1 else length(unique(datapoints$by)) - nfacets = if (null_facet) 1 else length(unique(datapoints$facet)) - - # catch for special cases - x_by = y_by = facet_by = FALSE - if (!null_by) { - x_by = identical(datapoints$x, datapoints$by) - y_by = identical(datapoints$y, datapoints$by) - if (!null_facet) facet_by = identical(datapoints$facet, datapoints$by) - } - - # FIXME (once we add support for gradient fill to draw_polygon) - if (y_by) { - warning("\n`y` == `by` is not currently supported for `type_violin`. We hope to support this in a future release, but for now `y` grouping will be turned off automatically.\n") - by = NULL - datapoints$by = "" - ngrps = 1 - null_by = TRUE - } - - # Convert x to factor if it's not already - datapoints$x = as.factor(datapoints$x) - if (x_by) datapoints$by = datapoints$x - - # Handle factor levels and maintain order - xlvls = levels(datapoints$x) - xlabs = seq_along(xlvls) - names(xlabs) = xlvls - # xlabs = levels(datapoints$x) - datapoints$x = as.integer(datapoints$x) - - if (null_by && null_facet) { - xord = order(datapoints$x) - } else if (null_facet) { - xord = order(datapoints$by, datapoints$x) - } else if (null_by) { - xord = order(datapoints$facet, datapoints$x) - } else { - xord = order(datapoints$by, datapoints$facet, datapoints$x) - } +data_violin = function( + bw = "nrd0", + adjust = 1, + kernel = "gaussian", + n = 512, + joint.bw = "none", + trim = FALSE, + width = 0.9 +) { + fun = function(settings, ...) { + env2env( + settings, + environment(), + c( + "datapoints", + "by", + "null_palette", + "facet", + "ylab", + "col", + "bg", + "log", + "null_by", + "null_facet" + ) + ) - if (length(unique(datapoints[["by"]])) == 1 && null_palette) { - if (is.null(col)) col = par("fg") - if (is.null(bg)) bg = "lightgray" - } else if (is.null(bg)) { - bg = "by" - } + # Handle ordering based on by and facet variables + ngrps = if (null_by) 1 else length(unique(datapoints$by)) + nfacets = if (null_facet) 1 else length(unique(datapoints$facet)) - # Reorder x, y, ymin, and ymax based on the order determined - datapoints = datapoints[xord,] - - - datapoints = split(datapoints, list(datapoints$x, datapoints$by, datapoints$facet)) - datapoints = Filter(function(k) nrow(k) > 0, datapoints) - - if (joint.bw == "none" || is.numeric(bw)) { - dens_bw = bw - } else { - if (joint.bw == "mean") { - # Use weighted mean of subgroup bandwidths - bws = sapply(datapoints, function(dat) bw_fun(kernel = bw, dat$y)) - ws = sapply(datapoints, nrow) - dens_bw = weighted.mean(bws, ws) - } else if (joint.bw == "full") { - dens_bw = bw_fun(kernel = bw, unlist(sapply(datapoints, `[[`, "x"))) - } - } - - # Compute group offsets for multi-group violins - if (ngrps > 1 && isFALSE(x_by) && isFALSE(facet_by)) { - xwidth_grp = width / ngrps - 0.01 - group_offsets = seq( - -((width - xwidth_grp) / 2), - ((width - xwidth_grp) / 2), - length.out = ngrps - ) - } else { - group_offsets = rep(0, max(ngrps, 1)) + # catch for special cases + x_by = y_by = facet_by = FALSE + if (!null_by) { + x_by = identical(datapoints$x, datapoints$by) + y_by = identical(datapoints$y, datapoints$by) + if (!null_facet) facet_by = identical(datapoints$facet, datapoints$by) + } + + # FIXME (once we add support for gradient fill to draw_polygon) + if (y_by) { + warning( + "\n`y` == `by` is not currently supported for `type_violin`. We hope to support this in a future release, but for now `y` grouping will be turned off automatically.\n" + ) + by = NULL + datapoints$by = "" + ngrps = 1 + null_by = TRUE + } + + # Convert x to factor if it's not already + datapoints$x = as.factor(datapoints$x) + if (x_by) { + datapoints$by = datapoints$x + } + + # Handle factor levels and maintain order + xlvls = levels(datapoints$x) + xlabs = seq_along(xlvls) + names(xlabs) = xlvls + # xlabs = levels(datapoints$x) + datapoints$x = as.integer(datapoints$x) + + if (null_by && null_facet) { + xord = order(datapoints$x) + } else if (null_facet) { + xord = order(datapoints$by, datapoints$x) + } else if (null_by) { + xord = order(datapoints$facet, datapoints$x) + } else { + xord = order(datapoints$by, datapoints$facet, datapoints$x) + } + + if (length(unique(datapoints[["by"]])) == 1 && null_palette) { + if (is.null(col)) { + col = par("fg") + } + if (is.null(bg)) bg = "lightgray" + } else if (is.null(bg)) { + bg = "by" + } + + # Reorder x, y, ymin, and ymax based on the order determined + datapoints = datapoints[xord, ] + + datapoints = split( + datapoints, + list(datapoints$x, datapoints$by, datapoints$facet) + ) + datapoints = Filter(function(k) nrow(k) > 0, datapoints) + + if (joint.bw == "none" || is.numeric(bw)) { + dens_bw = bw + } else { + if (joint.bw == "mean") { + # Use weighted mean of subgroup bandwidths + bws = sapply(datapoints, function(dat) bw_fun(kernel = bw, dat$y)) + ws = sapply(datapoints, nrow) + dens_bw = weighted.mean(bws, ws) + } else if (joint.bw == "full") { + dens_bw = bw_fun(kernel = bw, unlist(sapply(datapoints, `[[`, "x"))) + } + } + + # Compute group offsets for multi-group violins + if (ngrps > 1 && isFALSE(x_by) && isFALSE(facet_by)) { + xwidth_grp = width / ngrps - 0.01 + group_offsets = seq( + -((width - xwidth_grp) / 2), + ((width - xwidth_grp) / 2), + length.out = ngrps + ) + } else { + group_offsets = rep(0, max(ngrps, 1)) + } + offsets_axis = "x" + + datapoints = lapply(seq_along(datapoints), function(d) { + dat = datapoints[[d]] + if (trim) { + yrng = range(dat$y) + dens = density( + dat$y, + bw = dens_bw, + kernel = kernel, + n = n, + from = yrng[1], + to = yrng[2] + ) + } else { + dens = density(dat$y, bw = dens_bw, kernel = kernel, n = n) + } + + x = dens$y + y = dens$x + + if (log %in% c("y", "xy")) { + if (x[1] <= 0) { + warning( + "\nNon-positive density values have been trimmed as part of the logarthmic transformation.\n" + ) + xidx = x > 0 + x = x[xidx] + y = y[xidx] } - offsets_axis = "x" - - datapoints = lapply(seq_along(datapoints), function(d) { - dat = datapoints[[d]] - if (trim) { - yrng = range(dat$y) - dens = density(dat$y, bw = dens_bw, kernel = kernel, n = n, from = yrng[1], to = yrng[2]) - } else { - dens = density(dat$y, bw = dens_bw, kernel = kernel, n = n) - } - - x = dens$y - y = dens$x - - - if (log %in% c("y", "xy")) { - if (x[1] <= 0) { - warning("\nNon-positive density values have been trimmed as part of the logarthmic transformation.\n") - xidx = x > 0 - x = x[xidx] - y = y[xidx] - } - } - - x = c(x, rev(-x)) - y = c(y, rev(y)) - - xwidth = xwidth_orig = width - # dodge groups (if any) - if ((ngrps > 1) && isFALSE(x_by) && isFALSE(facet_by)) { - xwidth = xwidth_orig / ngrps - 0.01 - x = rescale_num(x, to = c(0, xwidth)) - x = x + as.numeric(sub("^([0-9]+)\\..*", "\\1", names(datapoints)[d])) - xwidth/2 - x = x + group_offsets[dat$by[1]] - } else if (nfacets > 1) { - x = rescale_num(x, to = c(0, xwidth)) - x = x + as.numeric(sub("^([0-9]+)\\..*", "\\1", names(datapoints)[d])) - xwidth/2 - } else { - x = rescale_num(x, to = c(0, xwidth)) - x = x + d - xwidth/2 - } - - x = c(x, NA) - y = c(y, NA) - - out = data.frame( - by = dat$by[1], # already split - facet = dat$facet[1], # already split - y = y, - x = x - ) - return(out) - }) - datapoints = do.call(rbind, datapoints) - datapoints = datapoints[1:(nrow(datapoints)-1), ] - - by = if (length(unique(datapoints$by)) == 1) by else datapoints$by - facet = if (length(unique(datapoints$facet)) == 1) facet else datapoints$facet - - # legend customizations - settings$legend_args[["pch"]] = settings$legend_args[["pch"]] %||% 22 - settings$legend_args[["pt.cex"]] = settings$legend_args[["pt.cex"]] %||% 3.5 - settings$legend_args[["y.intersp"]] = settings$legend_args[["y.intersp"]] %||% 1.25 - settings$legend_args[["seg.len"]] = settings$legend_args[["seg.len"]] %||% 1.25 - - env2env(environment(), settings, c( - "datapoints", - "by", - "facet", - "ylab", - "xlabs", - "col", - "bg", - "group_offsets", - "offsets_axis" - )) + } + + x = c(x, rev(-x)) + y = c(y, rev(y)) + + xwidth = xwidth_orig = width + # dodge groups (if any) + if ((ngrps > 1) && isFALSE(x_by) && isFALSE(facet_by)) { + xwidth = xwidth_orig / ngrps - 0.01 + x = rescale_num(x, to = c(0, xwidth)) + x = x + + as.numeric(sub("^([0-9]+)\\..*", "\\1", names(datapoints)[d])) - + xwidth / 2 + x = x + group_offsets[dat$by[1]] + } else if (nfacets > 1) { + x = rescale_num(x, to = c(0, xwidth)) + x = x + + as.numeric(sub("^([0-9]+)\\..*", "\\1", names(datapoints)[d])) - + xwidth / 2 + } else { + x = rescale_num(x, to = c(0, xwidth)) + x = x + d - xwidth / 2 + } + + x = c(x, NA) + y = c(y, NA) + + out = data.frame( + by = dat$by[1], # already split + facet = dat$facet[1], # already split + y = y, + x = x + ) + return(out) + }) + datapoints = do.call(rbind, datapoints) + datapoints = datapoints[1:(nrow(datapoints) - 1), ] + + by = if (length(unique(datapoints$by)) == 1) by else datapoints$by + facet = if (length(unique(datapoints$facet)) == 1) { + facet + } else { + datapoints$facet } - return(fun) + + # legend customizations + settings$legend_args[["pch"]] = settings$legend_args[["pch"]] %||% 22 + settings$legend_args[["pt.cex"]] = settings$legend_args[["pt.cex"]] %||% 3.5 + settings$legend_args[["y.intersp"]] = settings$legend_args[[ + "y.intersp" + ]] %||% + 1.25 + settings$legend_args[["seg.len"]] = settings$legend_args[["seg.len"]] %||% + 1.25 + + env2env( + environment(), + settings, + c( + "datapoints", + "by", + "facet", + "ylab", + "xlabs", + "col", + "bg", + "group_offsets", + "offsets_axis" + ) + ) + } + return(fun) } diff --git a/R/type_vline.R b/R/type_vline.R index 25748211..cd191a03 100644 --- a/R/type_vline.R +++ b/R/type_vline.R @@ -20,12 +20,24 @@ type_vline = function(v = 0) { env2env(environment(), settings, "type_info") } draw_vline = function() { - fun = function(ifacet, iby, data_facet, icol, ilty, ilwd, - ngrps, nfacets, by_continuous, facet_by, - type_info, - ...) { + fun = function( + ifacet, + iby, + data_facet, + icol, + ilty, + ilwd, + ngrps, + nfacets, + by_continuous, + facet_by, + type_info, + ... + ) { # flag for aesthetics by groups - grp_aes = type_info[["ul_col"]] == 1 || type_info[["ul_lty"]] == ngrps || type_info[["ul_lwd"]] == ngrps + grp_aes = type_info[["ul_col"]] == 1 || + type_info[["ul_lty"]] == ngrps || + type_info[["ul_lwd"]] == ngrps if (length(v) != 1) { if (!length(v) %in% c(ngrps, nfacets, ngrps * nfacets)) { diff --git a/R/utils.R b/R/utils.R index c680235d..ab9f134c 100644 --- a/R/utils.R +++ b/R/utils.R @@ -8,13 +8,16 @@ if (getRversion() <= "4.4.0") { ## input bw_fun = function(kernel, x) { kernel = tolower(kernel) - switch(kernel, + switch( + kernel, nrd0 = bw.nrd0(x), - nrd = bw.nrd(x), - ucv = bw.ucv(x), - bcv = bw.bcv(x), - sj = bw.SJ(x), - stop("Invalid `bw` string. Choose from 'nrd0', 'nrd', 'ucv', 'bcv', or 'SJ'.") + nrd = bw.nrd(x), + ucv = bw.ucv(x), + bcv = bw.bcv(x), + sj = bw.SJ(x), + stop( + "Invalid `bw` string. Choose from 'nrd0', 'nrd', 'ucv', 'bcv', or 'SJ'." + ) ) } @@ -57,8 +60,12 @@ more_than_n_unique = function(x, n, small_vec_len = 1e3L) { # Rescale numeric (used for continuous legends, etc.) rescale_num = function(x, from = NULL, to = NULL) { - if (is.null(from)) from = range(x) - if (is.null(to)) to = c(0, 1) + if (is.null(from)) { + from = range(x) + } + if (is.null(to)) { + to = c(0, 1) + } (x - from[1]) / diff(from) * diff(to) + to[1] } @@ -112,7 +119,9 @@ restore_margin_inner = function(ooma, topmar_epsilon = 0.1) { ooma = par("oma") omar = par("mar") - if (!any(ooma != 0)) return(invisible(NULL)) + if (!any(ooma != 0)) { + return(invisible(NULL)) + } # Restore inner margin defaults (in case affected by preceding tinyplot call) if (any(ooma != 0)) { From 0252c25038423c68fb0a4ea0844219e82e70cf97 Mon Sep 17 00:00:00 2001 From: Marc Bosch Date: Thu, 23 Apr 2026 13:39:41 +0200 Subject: [PATCH 2/7] added errorbar, documented --- NAMESPACE | 1 + R/type_meanse.R | 25 +++++++++++++++++++------ man/get_saved_par.Rd | 2 +- man/tinyplot.Rd | 2 ++ man/tinytheme.Rd | 4 ++-- man/type_lines.Rd | 5 ++--- man/type_mean_se.Rd | 40 ++++++++++++++++++++++++++++++++++++++++ man/type_ridge.Rd | 4 ++-- 8 files changed, 69 insertions(+), 14 deletions(-) create mode 100644 man/type_mean_se.Rd diff --git a/NAMESPACE b/NAMESPACE index 30d3736e..5b216916 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -27,6 +27,7 @@ export(type_jitter) export(type_lines) export(type_lm) export(type_loess) +export(type_mean_se) export(type_pointrange) export(type_points) export(type_polygon) diff --git a/R/type_meanse.R b/R/type_meanse.R index 3dec4e20..7b3ca0c5 100644 --- a/R/type_meanse.R +++ b/R/type_meanse.R @@ -10,6 +10,9 @@ #' @param conf.int confidence error to plot the standard error. Defaults to .95 #' @param na.rm a logical evaluating to TRUE or FALSE indicating whether NA #' values should be stripped before the computation proceeds Defaults to TRUE. +#' @param errorbar a logical evaluating to TRUE or FALSE indicating whether +#' errorbars should be drawn. If FALSE, it will draw a pointrange. Defaults to +#' TRUE #' @param ... Additional arguments are passed to the `lines()` function, #' ex: `col="pink"`. #' @examples @@ -26,7 +29,7 @@ #' #' #' @export -type_mean_se = function(conf.int = .95, na.rm = TRUE, ...) { +type_mean_se = function(conf.int = .95, na.rm = TRUE, errorbar = TRUE...) { pointrange_args = list(...) # function to get mean_se out of two vectors @@ -100,11 +103,21 @@ type_mean_se = function(conf.int = .95, na.rm = TRUE, ...) { } return(funky) } - out = list( - draw = draw_pointrange(...), - data = data_mean_se(fun = fun), - name = "l" - ) + if (errorbar) { + out = list( + draw = draw_errorbar(...), + data = data_mean_se(fun = fun), + name = "l" + ) + } + else { + out = list( + draw = draw_pointrange(...), + data = data_mean_se(fun = fun), + name = "l" + ) + } + class(out) = "tinyplot_type" return(out) } diff --git a/man/get_saved_par.Rd b/man/get_saved_par.Rd index 40e911af..d5f44468 100644 --- a/man/get_saved_par.Rd +++ b/man/get_saved_par.Rd @@ -38,7 +38,7 @@ Of course, users may prefer to manually capture and reset graphical parameters, as per the standard method described in the \code{\link[graphics]{par}} documentation. For example: -\if{html}{\out{
}}\preformatted{op = par(no.readonly = TRUE) # save current par settings +\if{html}{\out{
}}\preformatted{op = par(no.readonly = TRUE) # save current par settings # par(op) # reset original pars }\if{html}{\out{
}} diff --git a/man/tinyplot.Rd b/man/tinyplot.Rd index 503f1579..b4a9fd79 100644 --- a/man/tinyplot.Rd +++ b/man/tinyplot.Rd @@ -244,6 +244,8 @@ type of plot desired. \item \code{\link[=type_vline]{type_vline()}}: vertical line(s). \item \code{\link[=type_function]{type_function()}}: arbitrary function. \item \code{\link[=type_summary]{type_summary()}}: summarize \code{y} by unique values of \code{x}. +\item \code{\link[=type_meanse]{type_meanse()}}: return mean and standard error of \code{y} by +uniue values of \code{x} } } }} diff --git a/man/tinytheme.Rd b/man/tinytheme.Rd index a8906549..8aae669b 100644 --- a/man/tinytheme.Rd +++ b/man/tinytheme.Rd @@ -87,7 +87,7 @@ tinyplot(0:10) # Try a different theme tinytheme("dark") p() - + # Customize the theme by overriding default settings tinytheme("bw", fg = "green", font.main = 2, font.sub = 3, family = "Palatino") p() @@ -118,7 +118,7 @@ for (thm in thms) { tinytheme(thm) tinyplot( I(Sepal.Length*1e4) ~ Petal.Length | Species, facet = "by", data = iris, - yaxl = ",", + yaxl = ",", main = paste0('tinytheme("', thm, '")'), sub = "A subtitle" ) diff --git a/man/type_lines.Rd b/man/type_lines.Rd index e80592e6..bc816992 100644 --- a/man/type_lines.Rd +++ b/man/type_lines.Rd @@ -8,9 +8,8 @@ type_lines(type = "l", dodge = 0, fixed.dodge = FALSE) } \arguments{ \item{type}{1-character string giving the type of plot desired. The - following values are possible, for details, see \code{\link[base]{plot}}: - \code{"p"} for points, - \code{"l"} for lines, + following values are possible, for details, see \code{\link[graphics]{plot}}: + \code{"p"} for points, \code{"l"} for lines, \code{"b"} for both points and lines, \code{"c"} for empty points joined by lines, \code{"o"} for overplotted points and lines, diff --git a/man/type_mean_se.Rd b/man/type_mean_se.Rd new file mode 100644 index 00000000..a463c141 --- /dev/null +++ b/man/type_mean_se.Rd @@ -0,0 +1,40 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/type_meanse.R +\name{type_mean_se} +\alias{type_mean_se} +\title{Plot mean and standard error of \code{y} at unique values of \code{x}} +\usage{ +type_mean_se(conf.int = 0.95, na.rm = TRUE, errorbar = TRUE...) +} +\arguments{ +\item{conf.int}{confidence error to plot the standard error. Defaults to .95} + +\item{na.rm}{a logical evaluating to TRUE or FALSE indicating whether NA +values should be stripped before the computation proceeds Defaults to TRUE.} + +\item{errorbar}{a logical evaluating to TRUE or FALSE indicating whether +errorbars should be drawn. If FALSE, it will draw a pointrange. Defaults to +TRUE} + +\item{...}{Additional arguments are passed to the \code{lines()} function, +ex: \code{col="pink"}.} +} +\description{ +Applies a summary function to \code{y} along unique values of \code{x}. For example, +plot the mean \code{y} value for each \code{x} value. Internally, +\code{type_summary()} applies a thin wrapper around \code{\link[stats]{ave}} and +then passes the result to \code{\link{type_lines}} for drawing. +} +\examples{ +# Plot the mean and standard error of miles per gallon by cylinders +tinyplot(mpg ~ cyl, data = mtcars, data = mtcars, type = "mean_se") + + +# Use 99\% confidence intervals +tinyplot(mpg ~ cyl, data = mtcars, type = type_mean_se(conf.int = .99)) + +# Works with groups and/or facets too +tinyplot(mpg ~ cyl | gear, facet = "by", data = mtcars, type = "mean_se") + + +} diff --git a/man/type_ridge.Rd b/man/type_ridge.Rd index 1774c744..6c54cc11 100644 --- a/man/type_ridge.Rd +++ b/man/type_ridge.Rd @@ -189,7 +189,7 @@ tinyplot(Month2 ~ Temp, data = aq, type = "ridge") # further below) tinyplot(Month ~ Temp, data = aq, type = type_ridge(scale = 1)) - + ## by grouping is also supported. two special cases of interest: # 1) by == y (color by y groups) @@ -250,7 +250,7 @@ tinyplot(Month ~ Temp | Late, data = aq, type = type_ridge(scale = 1)) tinyplot(Month ~ Temp | Late, data = aq, type = type_ridge(scale = 1, joint.max = "by")) - + # restore the default theme tinytheme() From f490a0f65aa411bcda656df374ea25e318bcfa1c Mon Sep 17 00:00:00 2001 From: Marc Bosch Date: Thu, 23 Apr 2026 13:42:40 +0200 Subject: [PATCH 3/7] minor bug --- R/type_meanse.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/type_meanse.R b/R/type_meanse.R index 7b3ca0c5..b2302b08 100644 --- a/R/type_meanse.R +++ b/R/type_meanse.R @@ -29,7 +29,7 @@ #' #' #' @export -type_mean_se = function(conf.int = .95, na.rm = TRUE, errorbar = TRUE...) { +type_mean_se = function(conf.int = .95, na.rm = TRUE, errorbar = TRUE, ...) { pointrange_args = list(...) # function to get mean_se out of two vectors @@ -92,7 +92,7 @@ type_mean_se = function(conf.int = .95, na.rm = TRUE, errorbar = TRUE...) { datapoints = do.call(rbind, datapoints) xlvls <- levels(factor(datapoints$x)) - datapoints$x = as.integer(factor(datapoints$x, levels = xlvls)) + datapoints$x = factor(datapoints$x, levels = xlvls) xlabs <- seq_along(xlvls) names(xlabs) <- xlvls datapoints$x <- as.integer(datapoints$x) From 1027b8199506dd0631c2cac1a0dbeb061b3d2bb6 Mon Sep 17 00:00:00 2001 From: Marc Bosch Date: Thu, 23 Apr 2026 14:59:21 +0200 Subject: [PATCH 4/7] fixed x axis issue & dodge --- R/type_meanse.R | 70 ++++++++++++++++++++++++++++++++++++------------- 1 file changed, 52 insertions(+), 18 deletions(-) diff --git a/R/type_meanse.R b/R/type_meanse.R index b2302b08..0a3ec8c1 100644 --- a/R/type_meanse.R +++ b/R/type_meanse.R @@ -2,19 +2,16 @@ #' #' @md #' @description -#' Applies a summary function to `y` along unique values of `x`. For example, -#' plot the mean `y` value for each `x` value. Internally, -#' `type_summary()` applies a thin wrapper around \code{\link[stats]{ave}} and -#' then passes the result to [`type_lines`] for drawing. -#' +#' Plots the mean + standard error of a numeric variable by a grouping variable. + #' @param conf.int confidence error to plot the standard error. Defaults to .95 #' @param na.rm a logical evaluating to TRUE or FALSE indicating whether NA #' values should be stripped before the computation proceeds Defaults to TRUE. #' @param errorbar a logical evaluating to TRUE or FALSE indicating whether #' errorbars should be drawn. If FALSE, it will draw a pointrange. Defaults to #' TRUE -#' @param ... Additional arguments are passed to the `lines()` function, -#' ex: `col="pink"`. +#' @param ... Additional arguments are passed to the `draw_pointrange()` +#' or `draw_errorbar()` function, ex: `col="pink"`. #' @examples #' # Plot the mean and standard error of miles per gallon by cylinders #' tinyplot(mpg ~ cyl, data = mtcars, data = mtcars, type = "mean_se") @@ -29,7 +26,8 @@ #' #' #' @export -type_mean_se = function(conf.int = .95, na.rm = TRUE, errorbar = TRUE, ...) { +type_mean_se = function(conf.int = .95, na.rm = TRUE, errorbar = TRUE, + dodge = 0, fixed.dodge = FALSE, ...) { pointrange_args = list(...) # function to get mean_se out of two vectors @@ -91,30 +89,66 @@ type_mean_se = function(conf.int = .95, na.rm = TRUE, errorbar = TRUE, ...) { }) datapoints = do.call(rbind, datapoints) - xlvls <- levels(factor(datapoints$x)) - datapoints$x = factor(datapoints$x, levels = xlvls) - xlabs <- seq_along(xlvls) - names(xlabs) <- xlvls - datapoints$x <- as.integer(datapoints$x) - datapoints$xmin <- datapoints$x - datapoints$xmax <- datapoints$x - env2env(environment(), settings, c("datapoints", "xlabs")) + if (is.character(datapoints$x)) { + datapoints$x = as.factor(datapoints$x) + } + if (is.factor(datapoints$x)) { + ## original data (i.e., no new sorting by factor) + xlvls = unique(datapoints$x) + datapoints$x = factor(datapoints$x, levels = xlvls) + xlabs = seq_along(xlvls) + names(xlabs) = xlvls + datapoints$x = as.integer(datapoints$x) + } + datapoints$xmin = datapoints$x + datapoints$xmax = datapoints$x + + if (is.character(datapoints$x)) { + datapoints$x = as.factor(datapoints$x) + } + if (is.factor(datapoints$x)) { + ## original data (i.e., no new sorting by factor) + xlvls = unique(datapoints$x) + datapoints$x = factor(datapoints$x, levels = xlvls) + xlabs = seq_along(xlvls) + names(xlabs) = xlvls + datapoints$x = as.integer(datapoints$x) + } + datapoints$xmin = datapoints$x + datapoints$xmax = datapoints$x + + # dodge + if (dodge != 0) { + datapoints = dodge_positions(datapoints, dodge, fixed.dodge) + } + + + x = datapoints$x + + + env2env(environment(), settings, c( + "x", + "xlabs", + "datapoints" + )) } + + return(funky) } if (errorbar) { out = list( draw = draw_errorbar(...), data = data_mean_se(fun = fun), - name = "l" + name = "p" ) } else { out = list( draw = draw_pointrange(...), data = data_mean_se(fun = fun), - name = "l" + name = "p" ) } From 13c2dc03ae897be4d849a6fc5402e81da5f3696e Mon Sep 17 00:00:00 2001 From: Marc Bosch Date: Thu, 23 Apr 2026 15:02:58 +0200 Subject: [PATCH 5/7] update docs --- man/type_mean_se.Rd | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/man/type_mean_se.Rd b/man/type_mean_se.Rd index a463c141..76c0aac7 100644 --- a/man/type_mean_se.Rd +++ b/man/type_mean_se.Rd @@ -4,7 +4,14 @@ \alias{type_mean_se} \title{Plot mean and standard error of \code{y} at unique values of \code{x}} \usage{ -type_mean_se(conf.int = 0.95, na.rm = TRUE, errorbar = TRUE...) +type_mean_se( + conf.int = 0.95, + na.rm = TRUE, + errorbar = TRUE, + dodge = 0, + fixed.dodge = FALSE, + ... +) } \arguments{ \item{conf.int}{confidence error to plot the standard error. Defaults to .95} @@ -16,14 +23,11 @@ values should be stripped before the computation proceeds Defaults to TRUE.} errorbars should be drawn. If FALSE, it will draw a pointrange. Defaults to TRUE} -\item{...}{Additional arguments are passed to the \code{lines()} function, -ex: \code{col="pink"}.} +\item{...}{Additional arguments are passed to the \code{draw_pointrange()} +or \code{draw_errorbar()} function, ex: \code{col="pink"}.} } \description{ -Applies a summary function to \code{y} along unique values of \code{x}. For example, -plot the mean \code{y} value for each \code{x} value. Internally, -\code{type_summary()} applies a thin wrapper around \code{\link[stats]{ave}} and -then passes the result to \code{\link{type_lines}} for drawing. +Plots the mean + standard error of a numeric variable by a grouping variable. } \examples{ # Plot the mean and standard error of miles per gallon by cylinders From 96c444ecae57329aa83540f94910fb5491eb4ca3 Mon Sep 17 00:00:00 2001 From: Marc Bosch Date: Thu, 23 Apr 2026 15:14:55 +0200 Subject: [PATCH 6/7] update docs change name --- R/{type_meanse.R => type_mean_se.R} | 2 +- man/type_mean_se.Rd | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) rename R/{type_meanse.R => type_mean_se.R} (98%) diff --git a/R/type_meanse.R b/R/type_mean_se.R similarity index 98% rename from R/type_meanse.R rename to R/type_mean_se.R index 0a3ec8c1..13956255 100644 --- a/R/type_meanse.R +++ b/R/type_mean_se.R @@ -14,7 +14,7 @@ #' or `draw_errorbar()` function, ex: `col="pink"`. #' @examples #' # Plot the mean and standard error of miles per gallon by cylinders -#' tinyplot(mpg ~ cyl, data = mtcars, data = mtcars, type = "mean_se") +#' tinyplot(mpg ~ cyl, data = mtcars, type = "mean_se") #' #' diff --git a/man/type_mean_se.Rd b/man/type_mean_se.Rd index 76c0aac7..06d1f844 100644 --- a/man/type_mean_se.Rd +++ b/man/type_mean_se.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/type_meanse.R +% Please edit documentation in R/type_mean_se.R \name{type_mean_se} \alias{type_mean_se} \title{Plot mean and standard error of \code{y} at unique values of \code{x}} @@ -31,7 +31,7 @@ Plots the mean + standard error of a numeric variable by a grouping variable. } \examples{ # Plot the mean and standard error of miles per gallon by cylinders -tinyplot(mpg ~ cyl, data = mtcars, data = mtcars, type = "mean_se") +tinyplot(mpg ~ cyl, data = mtcars, type = "mean_se") # Use 99\% confidence intervals From f741bb3867a1167e3533ee28aae34b6d4e339b0a Mon Sep 17 00:00:00 2001 From: Marc Bosch Date: Thu, 23 Apr 2026 16:00:16 +0200 Subject: [PATCH 7/7] cleaning --- NAMESPACE | 1 + R/tinyplot.R | 2 +- R/type_meanse.R | 158 ++++++++++++++++++++++++++++++ inst/tinytest/test-type_mean_se.R | 38 +++++++ man/tinyplot.Rd | 2 +- man/type_mean_se.Rd | 45 ++++++++- 6 files changed, 243 insertions(+), 3 deletions(-) create mode 100644 R/type_meanse.R create mode 100644 inst/tinytest/test-type_mean_se.R diff --git a/NAMESPACE b/NAMESPACE index 5b216916..b317c0f0 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -120,6 +120,7 @@ importFrom(stats,predict) importFrom(stats,qnorm) importFrom(stats,qt) importFrom(stats,quantile) +importFrom(stats,sd) importFrom(stats,setNames) importFrom(stats,spline) importFrom(stats,terms) diff --git a/R/tinyplot.R b/R/tinyplot.R index 03eb8267..82f33c74 100644 --- a/R/tinyplot.R +++ b/R/tinyplot.R @@ -132,7 +132,7 @@ #' - [`type_vline()`]: vertical line(s). #' - [`type_function()`]: arbitrary function. #' - [`type_summary()`]: summarize `y` by unique values of `x`. -#' - [`type_meanse()`]: return mean and standard error of `y` by +#' - [`type_mean_se()`]: return mean and standard error of `y` by #' uniue values of `x` #' @param legend one of the following options: #' - NULL (default), in which case the legend will be determined by the diff --git a/R/type_meanse.R b/R/type_meanse.R new file mode 100644 index 00000000..d1e95357 --- /dev/null +++ b/R/type_meanse.R @@ -0,0 +1,158 @@ +#' Plot mean and standard error of `y` at unique values of `x` +#' +#' @md +#' @description +#' Plots the mean + standard error of a numeric variable by a grouping variable. + +#' @param conf.int confidence error to plot the standard error. Defaults to .95 +#' @param na.rm a logical evaluating to TRUE or FALSE indicating whether NA +#' values should be stripped before the computation proceeds Defaults to TRUE. +#' @param errorbar a logical evaluating to TRUE or FALSE indicating whether +#' errorbars should be drawn. If FALSE, it will draw a pointrange. Defaults to +#' TRUE +#' @inheritParams dodge_positions +#' @param ... Additional arguments are passed to the `draw_pointrange()` +#' or `draw_errorbar()` function, ex: `col="pink"`. +#' @examples +#' # Plot the mean and standard error of miles per gallon by cylinders +#' tinyplot(mpg ~ cyl, data = mtcars, type = "mean_se") +#' + +#' +#' # Use 99% confidence intervals +#' tinyplot(mpg ~ cyl, data = mtcars, type = type_mean_se(conf.int = .99)) +#' +#' # Works with groups and/or facets too +#' tinyplot(mpg ~ cyl | gear, facet = "by", data = mtcars, type = "mean_se") +#' +#' @importFrom stats sd +#' @export +type_mean_se = function(conf.int = .95, na.rm = TRUE, errorbar = TRUE, + dodge = 0, fixed.dodge = FALSE, ...) { + pointrange_args = list(...) + + # function to get mean_se out of two vectors + mean_se_internal <- function(var, group) { + # just one group + + mean_se_basic <- function(z) { + m <- mean(z, na.rm = na.rm) + se <- sd(z, na.rm = na.rm) / sqrt(length(z)) + + mult <- qnorm(1 - ((1 - conf.int) / 2)) + + conf.low <- m - se * mult + conf.high <- m + se * mult + + out <- data.frame(m = m, ymin = conf.low, ymax = conf.high) + + # pending - change colnames + + return(out) + } + + if (missing(group)) { + mean_se_basic(z = var) + } else { + out <- tapply(var, group, \(x) { + mean_se_basic(x) + }) + + out <- do.call("rbind", out) + + out$group <- row.names(out) + row.names(out) <- NULL + + out <- out[, c(4, 1, 2, 3)] + + return(out) + } + } + + data_mean_se = function(fun = mean_se_internal) { + funky = function(settings, ...) { + env2env(settings, environment(), c("datapoints", "by", "facet")) + + datapoints = split( + datapoints, + list(datapoints$facet, datapoints$by), + drop = TRUE + ) + datapoints = lapply(datapoints, function(dat) { + ms <- mean_se_internal(dat$y, dat$x) + colnames(ms) <- c("x", "y", "ymin", "ymax") + ms$xmin <- ms$x + ms$xmax <- ms$x + ms$by <- dat$by[1] + ms$facet <- dat$facet[1] + ms = ms[order(ms$x), ] + return(ms) + }) + datapoints = do.call(rbind, datapoints) + + + if (is.character(datapoints$x)) { + datapoints$x = as.factor(datapoints$x) + } + if (is.factor(datapoints$x)) { + ## original data (i.e., no new sorting by factor) + xlvls = unique(datapoints$x) + datapoints$x = factor(datapoints$x, levels = xlvls) + xlabs = seq_along(xlvls) + names(xlabs) = xlvls + datapoints$x = as.integer(datapoints$x) + } + datapoints$xmin = datapoints$x + datapoints$xmax = datapoints$x + + if (is.character(datapoints$x)) { + datapoints$x = as.factor(datapoints$x) + } + if (is.factor(datapoints$x)) { + ## original data (i.e., no new sorting by factor) + xlvls = unique(datapoints$x) + datapoints$x = factor(datapoints$x, levels = xlvls) + xlabs = seq_along(xlvls) + names(xlabs) = xlvls + datapoints$x = as.integer(datapoints$x) + } + datapoints$xmin = datapoints$x + datapoints$xmax = datapoints$x + + # dodge + if (dodge != 0) { + datapoints = dodge_positions(datapoints, dodge, fixed.dodge) + } + + + x = datapoints$x + + + env2env(environment(), settings, c( + "x", + "xlabs", + "datapoints" + )) + } + + + return(funky) + } + if (errorbar) { + out = list( + draw = draw_errorbar(...), + data = data_mean_se(fun = fun), + name = "p" + ) + } + else { + out = list( + draw = draw_pointrange(...), + data = data_mean_se(fun = fun), + name = "p" + ) + } + + class(out) = "tinyplot_type" + return(out) +} diff --git a/inst/tinytest/test-type_mean_se.R b/inst/tinytest/test-type_mean_se.R new file mode 100644 index 00000000..ed377ed7 --- /dev/null +++ b/inst/tinytest/test-type_mean_se.R @@ -0,0 +1,38 @@ +source("helpers.R") +using("tinysnapshot") + +# basic plot +f = function() { + plt(mpg ~ cyl, data = mtcars, type = "mean_se") +} +expect_snapshot_plot(f, label = "mean_se_simple") + + +# change colour +f = function() { + plt(mpg ~ cyl, data = mtcars, type = "mean_se", col = "red") +} +expect_snapshot_plot(f, label = "mean_se_simple_red") + + + +# custom confint + +f = function() { + plt(mpg ~ cyl, data = mtcars, type = type_mean_se(conf.int = .99)) +} +expect_snapshot_plot(f, label = "mean_se_confint99") + +# grouped + +f = function() { + plt(mpg ~ cyl | gear, data = mtcars, type = "mean_se", dodge = .1) +} +expect_snapshot_plot(f, label = "mean_se_grouped") + +# faceted + +f = function() { + plt(mpg ~ cyl, facet = ~gear, data = mtcars, type = "mean_se") +} +expect_snapshot_plot(f, label = "mean_se_faceted") diff --git a/man/tinyplot.Rd b/man/tinyplot.Rd index b4a9fd79..5926ffcd 100644 --- a/man/tinyplot.Rd +++ b/man/tinyplot.Rd @@ -244,7 +244,7 @@ type of plot desired. \item \code{\link[=type_vline]{type_vline()}}: vertical line(s). \item \code{\link[=type_function]{type_function()}}: arbitrary function. \item \code{\link[=type_summary]{type_summary()}}: summarize \code{y} by unique values of \code{x}. -\item \code{\link[=type_meanse]{type_meanse()}}: return mean and standard error of \code{y} by +\item \code{\link[=type_mean_se]{type_mean_se()}}: return mean and standard error of \code{y} by uniue values of \code{x} } } diff --git a/man/type_mean_se.Rd b/man/type_mean_se.Rd index 06d1f844..61c12fbc 100644 --- a/man/type_mean_se.Rd +++ b/man/type_mean_se.Rd @@ -1,9 +1,18 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/type_mean_se.R +% Please edit documentation in R/type_mean_se.R, R/type_meanse.R \name{type_mean_se} \alias{type_mean_se} \title{Plot mean and standard error of \code{y} at unique values of \code{x}} \usage{ +type_mean_se( + conf.int = 0.95, + na.rm = TRUE, + errorbar = TRUE, + dodge = 0, + fixed.dodge = FALSE, + ... +) + type_mean_se( conf.int = 0.95, na.rm = TRUE, @@ -23,10 +32,34 @@ values should be stripped before the computation proceeds Defaults to TRUE.} errorbars should be drawn. If FALSE, it will draw a pointrange. Defaults to TRUE} +\item{dodge}{Adjustment parameter for dodging overlapping points or ranges in +grouped plots along the x-axis (or y-axis for flipped plots). Either: +\itemize{ +\item numeric value in the range \verb{[0,1)}. Note that values are scaled +relative to the spacing of x-axis breaks, e.g. \code{dodge = 0.1} places the +outermost groups one-tenth of the way to adjacent breaks, \code{dodge = 0.5} +places them midway between breaks, etc. Values < 0.5 are recommended. +\item logical. If \code{TRUE}, the dodge width is calculated automatically based on +the number of groups (0.1 per group for 2-4 groups, 0.45 for 5+ groups). If +\code{FALSE} or 0, no dodging is performed. +} + +Default value is 0 (no dodging). While we do not check, it is \emph{strongly} +recommended that dodging only be used in cases where the x-axis comprises a +limited number of discrete breaks.} + +\item{fixed.dodge}{Logical. If \code{FALSE} (default), dodge positions are +calculated independently for each \code{x} value, based only on the groups +present at that position. If \code{TRUE}, dodge positions are based on all +groups, ensuring "fixed" spacing across x-axis breaks (i.e., even if some +groups are missing for a particular \code{x} value).} + \item{...}{Additional arguments are passed to the \code{draw_pointrange()} or \code{draw_errorbar()} function, ex: \code{col="pink"}.} } \description{ +Plots the mean + standard error of a numeric variable by a grouping variable. + Plots the mean + standard error of a numeric variable by a grouping variable. } \examples{ @@ -41,4 +74,14 @@ tinyplot(mpg ~ cyl, data = mtcars, type = type_mean_se(conf.int = .99)) tinyplot(mpg ~ cyl | gear, facet = "by", data = mtcars, type = "mean_se") +# Plot the mean and standard error of miles per gallon by cylinders +tinyplot(mpg ~ cyl, data = mtcars, type = "mean_se") + + +# Use 99\% confidence intervals +tinyplot(mpg ~ cyl, data = mtcars, type = type_mean_se(conf.int = .99)) + +# Works with groups and/or facets too +tinyplot(mpg ~ cyl | gear, facet = "by", data = mtcars, type = "mean_se") + }