diff --git a/R/by_aesthetics.R b/R/by_aesthetics.R index 7bbca0c6..400b9e87 100755 --- a/R/by_aesthetics.R +++ b/R/by_aesthetics.R @@ -274,7 +274,7 @@ gen_pal_fun = function(pal, gradient = FALSE, alpha = NULL, n = NULL) { by_pch = function(ngrps, type, pch = NULL) { no_pch = FALSE if (identical(type, "text")) { - pch <- rep(15, ngrps) + pch = rep(15, ngrps) } else if (!type %in% c("p", "b", "o", "pointrange", "errorbar", "boxplot", "qq")) { no_pch = TRUE pch = NULL diff --git a/R/hooks.R b/R/hooks.R index 1c4af278..e04fc085 100644 --- a/R/hooks.R +++ b/R/hooks.R @@ -12,10 +12,10 @@ #' a list of functions. #' @param action `"replace"`, `"append"` or `"prepend"` #' @keywords internal -set_hooks <- function(hooks, action = "append") { - old <- list() +set_hooks = function(hooks, action = "append") { + old = list() for (hook_name in names(hooks)) { - old[[hook_name]] <- getHook(hook_name) + old[[hook_name]] = getHook(hook_name) setHook(hook_name, hooks[[hook_name]], action = action) } invisible(old) @@ -23,12 +23,12 @@ set_hooks <- function(hooks, action = "append") { #' @rdname set_hooks #' @keywords internal -remove_hooks <- function(hooks) { +remove_hooks = function(hooks) { for (hook_name in names(hooks)) { - hook <- getHook(hook_name) + hook = getHook(hook_name) if (length(hook) > 0) { for (fun in unlist(hooks[hook_name])) { - hook[sapply(hook, identical, fun)] <- NULL + hook[sapply(hook, identical, fun)] = NULL } } setHook(hook_name, hook, "replace") diff --git a/R/sanitize.R b/R/sanitize.R index d51be159..5d4aa811 100644 --- a/R/sanitize.R +++ b/R/sanitize.R @@ -109,3 +109,31 @@ sanitize_type = function(type, x, y, dots) { out = list(draw = NULL, data = NULL, name = type) return(out) } + + + +sanitize_axes = function(axes, xaxt, yaxt, frame.plot) { + ## handle defaults of axes, xaxt, yaxt, frame.plot + ## - convert axes to character if necessary + ## - set defaults of xaxt/yaxt (if these are NULL) based on axes + ## - set logical axes based on xaxt/yaxt + ## - set frame.plot default based on xaxt/yaxt + if (isFALSE(axes)) { + axes = xaxt = yaxt = "none" + } else if (isTRUE(axes)) { + axes = "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 + } + axis_types = c("standard", "none", "labels", "ticks", "axis") + axes = match.arg(axes, axis_types) + xaxt = match.arg(xaxt, axis_types) + yaxt = match.arg(yaxt, axis_types) + 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")) + return(list(axes = axes, xaxt = xaxt, yaxt = yaxt, frame.plot = frame.plot)) +} diff --git a/R/sanitize_xylab.R b/R/sanitize_xylab.R new file mode 100644 index 00000000..f1d3600f --- /dev/null +++ b/R/sanitize_xylab.R @@ -0,0 +1,54 @@ +sanitize_xylab = function( + x, xlab = NULL, x_dep = NULL, xmin_dep = NULL, xmax_dep = NULL, + y, ylab = NULL, y_dep = NULL, ymin_dep = NULL, ymax_dep = NULL, + type = NULL) { + out_xlab = NULL + out_ylab = NULL + + is_boxplot = type %in% c("boxplot") + is_density = type %in% c("density") + is_frequency = type %in% c("histogram", "barplot", "function") + is_function = type %in% c("function") + is_range = type %in% c("rect", "segments", "pointrange") + is_ribbon = type %in% c("ribbon") + is_index = !is_frequency && !is_ribbon && !is_density + + ##### xlab + if (!is.null(xlab)) { + out_xlab = xlab + } else if (!is.null(xmin_dep) && !is.null(xmax_dep)) { + out_xlab = sprintf("[%s, %s]", xmin_dep, xmax_dep) + } else if (is_boxplot && is.null(y)) { + out_xlab = "" + } else if (is_index && is.null(y) && !is.null(x)) { + out_xlab = "Index" + } else { + out_xlab = x_dep + } + + ##### ylab + if (!is.null(ylab)) { + out_ylab = ylab + } else if (is_frequency && is.null(y) && !is.null(x)) { + out_ylab = "Frequency" + } else if (is_density && is.null(y) && !is.null(x)) { + out_ylab = "Density" + } else if (is_ribbon) { + if (!is.null(y_dep)) { + out_ylab = y_dep + } 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)) { + out_ylab = sprintf("[%s, %s]", ymin_dep, ymax_dep) + } else if (!is.null(y_dep)) { + out_ylab = y_dep + } else if (is.null(y) && !is.null(x_dep)) { + out_ylab = x_dep + } else { + out_ylab = NULL + } + + out = list(xlab = out_xlab, ylab = out_ylab) + return(out) +} diff --git a/R/tinyplot.R b/R/tinyplot.R index 19f9c7d8..bba3ff0d 100644 --- a/R/tinyplot.R +++ b/R/tinyplot.R @@ -695,28 +695,10 @@ tinyplot.default = function( # will be overwritten by some type_data() functions and ignored by others ribbon.alpha = sanitize_ribbon.alpha(NULL) - ## handle defaults of axes, xaxt, yaxt, frame.plot - ## - convert axes to character if necessary - ## - set defaults of xaxt/yaxt (if these are NULL) based on axes - ## - set logical axes based on xaxt/yaxt - ## - set frame.plot default based on xaxt/yaxt - if (isFALSE(axes)) { - axes = xaxt = yaxt = "none" - } else if (isTRUE(axes)) { - axes = "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 - } - axis_types = c("standard", "none", "labels", "ticks", "axis") - axes = match.arg(axes, axis_types) - xaxt = match.arg(xaxt, axis_types) - yaxt = match.arg(yaxt, axis_types) - 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")) + # axes + list2env( + sanitize_axes(axes, xaxt, yaxt, frame.plot), + environment()) # Write plot to output file or window with fixed dimensions setup_device(file = file, width = width, height = height) @@ -743,17 +725,14 @@ tinyplot.default = function( } # Capture deparsed expressions early, before x, y and by are evaluated - x_dep = if (!is.null(x)) { - deparse1(substitute(x)) - } else if (type %in% c("rect", "segments")) { - x = NULL - NULL - } - y_dep = if (is.null(y)) { - deparse1(substitute(x)) - } else { - deparse1(substitute(y)) - } + x_dep = if (is.null(x)) NULL else deparse1(substitute(x)) + xmin_dep = if (is.null(xmin)) NULL else deparse1(substitute(xmin)) + xmax_dep = if (is.null(xmax)) NULL else deparse1(substitute(xmax)) + + y_dep = if (is.null(y)) NULL else deparse1(substitute(y)) + ymin_dep = if (is.null(ymin)) NULL else deparse1(substitute(ymin)) + ymax_dep = if (is.null(ymax)) NULL else deparse1(substitute(ymax)) + by_dep = deparse1(substitute(by)) null_by = is.null(by) cex_dep = if (!is.null(cex)) deparse1(substitute(cex)) else NULL @@ -782,40 +761,33 @@ tinyplot.default = function( facet_attr = attributes(facet) ## TODO: better solution for restoring facet attributes? null_facet = is.null(facet) + # xlab & ylab + list2env( + sanitize_xylab( + x = x, xlab = xlab, x_dep = x_dep, xmin_dep = xmin_dep, xmax_dep = xmax_dep, + y = y, ylab = ylab, y_dep = y_dep, ymin_dep = ymin_dep, ymax_dep = ymax_dep, + type = type), + environment()) + if (is.null(x)) { ## Special catch for rect and segment plots without a specified y-var if (type %in% c("rect", "segments")) { - xmin_dep = deparse(substitute(xmin)) - xmax_dep = deparse(substitute(xmax)) - x_dep = paste0("[", xmin_dep, ", ", xmax_dep, "]") x = rep(NA, length(x)) } } if (is.null(y)) { ## Special catch for area and interval plots without a specified y-var if (type %in% c("rect", "segments", "pointrange", "errorbar", "ribbon")) { - ymin_dep = deparse(substitute(ymin)) - ymax_dep = deparse(substitute(ymax)) - y_dep = paste0("[", ymin_dep, ", ", ymax_dep, "]") y = rep(NA, length(x)) - } else if (type == "density") { - if (is.null(ylab)) ylab = "Density" - } else if (type == "function") { - if (is.null(ylab)) ylab = "Frequency" } else if (type == "boxplot") { y = x x = rep.int("", length(y)) - xlab = "" xaxt = "a" - } else if (!(type %in% c("histogram", "barplot"))) { + } else if (!(type %in% c("histogram", "barplot", "density", "function"))) { y = x x = seq_along(x) - if (is.null(xlab)) xlab = "Index" } } - - if (is.null(xlab)) xlab = x_dep - if (is.null(ylab) && type != "histogram") ylab = y_dep # flag(s) indicating whether x/ylim was set by the user (needed later for # special case where facets are free but still want to set x/ylim manually) diff --git a/R/type_barplot.R b/R/type_barplot.R index d6d01d96..cea11c0d 100644 --- a/R/type_barplot.R +++ b/R/type_barplot.R @@ -98,7 +98,7 @@ data_barplot = function(width = 5/6, beside = FALSE, center = FALSE, FUN = NULL, 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 + 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) diff --git a/R/type_qq.R b/R/type_qq.R index cbbbb5ae..7e13f656 100644 --- a/R/type_qq.R +++ b/R/type_qq.R @@ -38,10 +38,10 @@ type_qq = function(distribution = qnorm) { ) if (!is.null(ilty)) { - iy <- quantile(iy, c(0.25, 0.75)) - ix <- quantile(ix, c(0.25, 0.75)) - slope <- diff(iy) / diff(ix) - intercept <- iy[1] - slope * ix[1] + iy = quantile(iy, c(0.25, 0.75)) + ix = quantile(ix, c(0.25, 0.75)) + slope = diff(iy) / diff(ix) + intercept = iy[1] - slope * ix[1] abline(a = intercept, b = slope, lty = ilty, col = icol, lwd = ilwd) } } diff --git a/R/type_text.R b/R/type_text.R index 39a2d72c..3a129393 100644 --- a/R/type_text.R +++ b/R/type_text.R @@ -21,7 +21,7 @@ #' adj = 0 #' ) #' ) -#' +#' #' # to avoid clipping text at the plot region, we can use xpd = NA #' tinyplot(mpg ~ hp | factor(cyl), #' data = mtcars, @@ -47,23 +47,23 @@ type_text = function(labels, adj = NULL, pos = NULL, offset = 0.5, vfont = NULL, data_text = function(labels, clim = c(0.5, 2.5)) { fun = function(datapoints, legend_args, cex = NULL, ...) { if (length(labels) != 1 && length(labels) != nrow(datapoints)) { - msg <- sprintf("`labels` must be of length 1 or %s.", nrow(datapoints)) + msg = sprintf("`labels` must be of length 1 or %s.", nrow(datapoints)) stop(msg, call. = FALSE) } datapoints$labels = labels - + # browser() bubble = FALSE bubble_cex = 1 if (!is.null(cex) && length(cex) == nrow(datapoints)) { - bubble = TRUE + 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(c(bubble_labs, cex), to = clim) - cex = rescale_num(sqrt(c(bubble_labs, cex))/pi, to = clim) + 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)] names(bubble_cex) = format(bubble_labs) if (max(clim) > 2.5) { legend_args[["x.intersp"]] = max(clim) / 2.5