From f16a15b64d9cb7c6ddd016a4f5def80e2ed49a6f Mon Sep 17 00:00:00 2001 From: Jan Netik Date: Thu, 3 Sep 2020 17:38:06 +0200 Subject: [PATCH 1/6] #4173 lambda functions in discrete scales & facets --- R/labeller.r | 9 +++++++++ R/scale-.r | 2 ++ 2 files changed, 11 insertions(+) diff --git a/R/labeller.r b/R/labeller.r index 26d2263557..9e079ff0a8 100644 --- a/R/labeller.r +++ b/R/labeller.r @@ -297,6 +297,7 @@ resolve_labeller <- function(rows, cols, labels) { #' # your labeller to the right variable with labeller() #' p + facet_grid(cyl ~ am, labeller = labeller(am = to_string)) as_labeller <- function(x, default = label_value, multi_line = TRUE) { + if(is.formula(x)) x <- as_function(x) force(x) fun <- function(labels) { labels <- lapply(labels, as.character) @@ -426,7 +427,15 @@ labeller <- function(..., .rows = NULL, .cols = NULL, if (!is.null(keep.as.numeric)) { .Deprecated(old = "keep.as.numeric") } + dots <- list(...) + + first_dot <- dots[[1]] + + if (is.formula(first_dot) || is.function(first_dot)) { + return(as_labeller(first_dot)) + } + .default <- as_labeller(.default) function(labels) { diff --git a/R/scale-.r b/R/scale-.r index 801b839109..928d194dde 100644 --- a/R/scale-.r +++ b/R/scale-.r @@ -168,6 +168,8 @@ discrete_scale <- function(aesthetics, scale_name, palette, name = waiver(), check_breaks_labels(breaks, labels) + if (is.formula(labels)) labels <- as_function(labels) + if (!is.function(limits) && (length(limits) > 0) && !is.discrete(limits)) { warn( glue( From 533107267121816fce7a282e0cee311df365479b Mon Sep 17 00:00:00 2001 From: Jan Netik Date: Thu, 3 Sep 2020 20:12:42 +0200 Subject: [PATCH 2/6] #4173 lambda functions in discrete scales & facets --- R/labeller.r | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/R/labeller.r b/R/labeller.r index 9e079ff0a8..1815e39265 100644 --- a/R/labeller.r +++ b/R/labeller.r @@ -430,10 +430,10 @@ labeller <- function(..., .rows = NULL, .cols = NULL, dots <- list(...) - first_dot <- dots[[1]] - - if (is.formula(first_dot) || is.function(first_dot)) { - return(as_labeller(first_dot)) + if (length(dots) == 1) { + if (is.formula(dots[[1]]) || is.function(dots[[1]]) && !is_labeller(dots[[1]])) { + return(as_labeller(dots[[1]])) + } } .default <- as_labeller(.default) From ce15ec10cbf617eb507e9f99b726b20f16ff2721 Mon Sep 17 00:00:00 2001 From: Jan Netik Date: Fri, 26 Mar 2021 21:13:10 +0100 Subject: [PATCH 3/6] more concise as_labeller --- R/labeller.r | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/R/labeller.r b/R/labeller.r index 1815e39265..d8cd04dd81 100644 --- a/R/labeller.r +++ b/R/labeller.r @@ -297,7 +297,6 @@ resolve_labeller <- function(rows, cols, labels) { #' # your labeller to the right variable with labeller() #' p + facet_grid(cyl ~ am, labeller = labeller(am = to_string)) as_labeller <- function(x, default = label_value, multi_line = TRUE) { - if(is.formula(x)) x <- as_function(x) force(x) fun <- function(labels) { labels <- lapply(labels, as.character) @@ -312,6 +311,8 @@ as_labeller <- function(x, default = label_value, multi_line = TRUE) { x(labels) } else if (is.function(x)) { default(lapply(labels, x)) + } else if (is.formula(x)) { + default(lapply(labels, as_function(x))) } else if (is.character(x)) { default(lapply(labels, function(label) x[label])) } else { @@ -430,11 +431,6 @@ labeller <- function(..., .rows = NULL, .cols = NULL, dots <- list(...) - if (length(dots) == 1) { - if (is.formula(dots[[1]]) || is.function(dots[[1]]) && !is_labeller(dots[[1]])) { - return(as_labeller(dots[[1]])) - } - } .default <- as_labeller(.default) @@ -562,7 +558,11 @@ build_strip <- function(label_df, labeller, theme, horizontal) { #' #' @noRd assemble_strips <- function(grobs, theme, horizontal = TRUE, clip) { - if (length(grobs) == 0 || is.zero(grobs[[1]])) return(grobs) + if (length(grobs) == 0 || is.zero(grobs[[1]])) { + # Subsets matrix of zeroGrobs to correct length (#4050) + grobs <- grobs[seq_len(NROW(grobs))] + return(grobs) + } # Add margins to non-titleGrobs so they behave eqivalently grobs[] <- lapply(grobs, function(g) { From 019c43d4e8072f3a963b1704c867461e4df4cef1 Mon Sep 17 00:00:00 2001 From: Jan Netik Date: Thu, 6 May 2021 17:57:24 +0200 Subject: [PATCH 4/6] incorporate changes from master scale part was resolved by https://github.com/tidyverse/ggplot2/pull/4427 --- R/scale-.r | 1 - 1 file changed, 1 deletion(-) diff --git a/R/scale-.r b/R/scale-.r index 6f4b917dc2..3fa2f6cbde 100644 --- a/R/scale-.r +++ b/R/scale-.r @@ -184,7 +184,6 @@ discrete_scale <- function(aesthetics, scale_name, palette, name = waiver(), check_breaks_labels(breaks, labels) - if (is.formula(labels)) labels <- as_function(labels) # Convert formula input to function if appropriate limits <- allow_lambda(limits) breaks <- allow_lambda(breaks) From 6d488b6716c5228bc68f9fc1841888abbffa1565 Mon Sep 17 00:00:00 2001 From: Jan Netik Date: Thu, 6 May 2021 20:20:11 +0200 Subject: [PATCH 5/6] revert added blank lines --- R/labeller.r | 3 --- 1 file changed, 3 deletions(-) diff --git a/R/labeller.r b/R/labeller.r index 3c9dedb535..447bcc07f7 100644 --- a/R/labeller.r +++ b/R/labeller.r @@ -435,10 +435,7 @@ labeller <- function(..., .rows = NULL, .cols = NULL, if (!is.null(keep.as.numeric)) { .Deprecated(old = "keep.as.numeric") } - dots <- list(...) - - .default <- as_labeller(.default) function(labels) { From 7cf02ae2d6d851f7f685dc9a83d98e595f145c95 Mon Sep 17 00:00:00 2001 From: Jan Netik Date: Thu, 6 May 2021 21:19:40 +0200 Subject: [PATCH 6/6] NEWS updated --- NEWS.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/NEWS.md b/NEWS.md index 03caddc347..5820554735 100644 --- a/NEWS.md +++ b/NEWS.md @@ -126,6 +126,9 @@ * The scale arguments `limits`, `breaks`, `minor_breaks`, `labels`, `rescaler` and `oob` now accept purrr style lambda notation (@teunbrand, #4427). + +* `as_labeller()` (and therefore also `labeller()`) now handles functions in + purrr-style lambda notation (@netique, #4188). # ggplot2 3.3.3 This is a small patch release mainly intended to address changes in R and CRAN.