Skip failed calculations

NEWS.md

@@ -7,6 +7,9 @@
 * If the mapping has `group`, use it as grouping variable, which is consistent
   with the logic of ggplot2 (#77).
 
+* `gghighlight()` now ignores if the calculation fails over some layers. This
+  is useful to combine with such layers as `annotate()` (#78).
+
 # gghighlight 0.1.0
 
 * Add `gghighlight()`, which replaces the current `gghighlight_line()` and `gghighlight_point()`; these functions are now deprecated.

R/gghighlight.R

@@ -130,7 +130,7 @@ ggplot_add.gg_highlighter <- function(object, plot, object_name) {
   )
 
   # Sieve the upper layer.
-  purrr::walk2(
+  success <- purrr::map2_lgl(
     layers_sieved,
     group_infos,
     sieve_layer,
@@ -139,10 +139,23 @@ ggplot_add.gg_highlighter <- function(object, plot, object_name) {
     use_group_by = object$use_group_by
   )
 
+  if (!any(success)) {
+    rlang::abort("All calculations failed! Please provide a valid predicate.")
+  }
+  if (!all(success)) {
+    rlang::warn(
+      sprintf("Could not calculate the predicate for %s; ignored",
+              paste("layer", which(!success), collapse = ", "))
+    )
+    # remove failed layers
+    layers_sieved[!success] <- list(NULL)
+  }
+
   # The plot data should also be sieved to deleting facets for unhighlighted levels
   plot$data <- layers_sieved[[1]]$data
 
-  plot$layers[idx_layers] <- layers_bleached
+  # skip failed layers
+  plot$layers[idx_layers][success] <- layers_bleached[success]
   plot <- plot %+% layers_sieved
 
   if (!object$use_direct_label) {
@@ -302,7 +315,7 @@ sieve_layer <- function(layer, group_info, predicates,
                         max_highlight = 5L,
                         use_group_by = NULL) {
   # If there are no predicates, do nothing.
-  if (length(predicates) == 0) return(layer)
+  if (length(predicates) == 0) return(TRUE)
 
   # If use_group_by is NULL, infer it from whether group_key is NULL or not.
   use_group_by <- use_group_by %||% !is.null(group_info$id)
@@ -312,7 +325,7 @@ sieve_layer <- function(layer, group_info, predicates,
   # 3) If use_group_by is TRUE but group IDs exist, show a warning and do not use group_by().
   if (use_group_by) {
     if (is.null(group_info$id)) {
-      warning("You set use_group_by = TRUE, but there seems no groups.\n",
+      warning("Tried to calculate with group_by(), but there seems no groups.\n",
               "Please provide group, colour or fill aes.\n",
               "Falling back to ungrouped filter operation...", call. = FALSE)
       use_group_by <- FALSE
@@ -323,20 +336,32 @@ sieve_layer <- function(layer, group_info, predicates,
 
   # If use_group_by is TRUE, try to calculate grouped
   if (use_group_by) {
-    tryCatch({
-      layer$data <- calculate_grouped(layer$data, predicates, max_highlight, group_info$id)
-      # if this succeeds, return the layer
-      return(layer)
-    },
-    error = function(e) {
-      warning("You set use_group_by = TRUE, but grouped calculation failed.\n",
-              "Falling back to ungrouped filter operation...", call. = FALSE)
-    })
+    tryCatch(
+      {
+        layer$data <- calculate_grouped(layer$data, predicates, max_highlight, group_info$id)
+        # if this succeeds, return TRUE
+        return(TRUE)
+      },
+      error = function(e) {
+        warning("Tried to calculate with group_by(), but the calculation failed.\n",
+                "Falling back to ungrouped filter operation...", call. = FALSE)
+      }
+    )
   }
 
   # the grouped calculation failed or skipped, try ungrouped one.
-  layer$data <- calculate_ungrouped(layer$data, predicates, max_highlight)
-  layer
+  tryCatch(
+    {
+      layer$data <- calculate_ungrouped(layer$data, predicates, max_highlight)
+      return(TRUE)
+    },
+    error = function(e) {
+      # do not warn here, but in ggplot_add.gg_highlighter()
+      return(FALSE)
+    }
+  )
+
+  FALSE
 }
 
 calculate_grouped <- function(data, predicates, max_highlight, group_ids) {

tests/testthat/test-gghighlight.R

@@ -146,7 +146,11 @@ test_that("sieve_layer() works with simple cases", {
   d_sieved_grouped <- d[d$type != "a", ]
 
   # Ungrouped.
-  f <- function(...) sieve_layer(geom_bar(aes(x = x), d), NULL, pred_ungrouped, ...)
+  f <- function(...) {
+    l <- geom_bar(aes(x = x), d)
+    expect_true(sieve_layer(l, NULL, pred_ungrouped, ...))
+    l
+  }
   # Basic usage.
   expect_equal(f(), geom_bar(aes(x = x), d_sieved_ungrouped))
   # Large number of max_highlights doesn't affect the result.
@@ -155,11 +159,16 @@ test_that("sieve_layer() works with simple cases", {
   # the result is not sliced down to the number.
   expect_equal(f(max_highlight = 2L), geom_bar(aes(x = x), d_sieved_ungrouped))
   # When predicate is numerical, the result is sliced.
-  expect_equal(sieve_layer(geom_bar(aes(x = x), d), NULL, list(rlang::quo(value)), max_highlight = 2L),
-               geom_bar(aes(x = x), d[6:7, ]))
+  l <- geom_bar(aes(x = x), d)
+  expect_true(sieve_layer(l, NULL, list(rlang::quo(value)), max_highlight = 2L))
+  expect_equal(l, geom_bar(aes(x = x), d[6:7, ]))
 
   # Grouped.
-  f <- function(...) sieve_layer(geom_bar(aes(colour = type), d), g_info, pred_grouped, ...)
+  f <- function(...) {
+    l <- geom_bar(aes(colour = type), d)
+    expect_true(sieve_layer(l, g_info, pred_grouped, ...))
+    l
+  }
   # Basic usage.
   expect_equal(f(), geom_bar(aes(colour = type), d_sieved_grouped))
   # Large number of max_highlights doesn't affect the result.
@@ -168,16 +177,18 @@ test_that("sieve_layer() works with simple cases", {
   # the result is not sliced down to the number.
   expect_equal(f(max_highlight = 1L), geom_bar(aes(colour = type), d[d$type != "a", ]))
   # When predicate is numerical, the result is sliced.
-  expect_equal(sieve_layer(geom_bar(aes(colour = type), d), g_info,
-                           list(rlang::quo(mean(value))), max_highlight = 1L),
-               geom_bar(aes(colour = type), d[6:7, ]))
+  l <- geom_bar(aes(colour = type), d)
+  expect_true(sieve_layer(l, g_info, list(rlang::quo(mean(value))), max_highlight = 1L))
+  expect_equal(l, geom_bar(aes(colour = type), d[6:7, ]))
 
   # can be grouped, but intentionally avoid group_by;
   # the result is same no matter group_key is provided or not
   f <- function (key, use_group_by) {
     info <- g_info
     info$key <- key
-    sieve_layer(geom_bar(aes(colour = type), d), info, pred_ungrouped, use_group_by = use_group_by)
+    l <- geom_bar(aes(colour = type), d)
+    expect_true(sieve_layer(l, info, pred_ungrouped, use_group_by = use_group_by))
+    l
   }
   expect_equal(f(rlang::quo(type), use_group_by = FALSE), geom_bar(aes(colour = type), d_sieved_ungrouped))
   expect_equal(f(NULL, FALSE), geom_bar(aes(colour = type), d_sieved_ungrouped))
@@ -186,19 +197,26 @@ test_that("sieve_layer() works with simple cases", {
   expect_equal(l, geom_bar(aes(colour = type), d_sieved_ungrouped))
 
   # use_group_by=TRUE without group_key generates a warning, and do sieving in ungrouped-manner.
-  expect_warning(l <- sieve_layer(geom_bar(aes(x = x), d), NULL, pred_ungrouped, use_group_by = TRUE))
+  l <- geom_bar(aes(x = x), d)
+  expect_warning(sieve_layer(l, NULL, pred_ungrouped, use_group_by = TRUE))
   expect_equal(l, geom_bar(aes(x = x), d_sieved_ungrouped))
 
   # predicate can contain group key (c.f. #27)
   m <- c(a = 1, b = 100, c = 10)
   pred_use_group_var <- list(rlang::quo(max(value * m[type]) >= 100))
-  l <- sieve_layer(geom_bar(aes(colour = type), d), g_info, pred_use_group_var)
+  l <- geom_bar(aes(colour = type), d)
+  expect_true(sieve_layer(l, g_info, pred_use_group_var))
   expect_equal(l, geom_bar(aes(colour = type), d[d$type != "a", ]))
 })
 
+test_that("sieve_layer() returns false if all calculation is failed", {
+  expect_false(sieve_layer(geom_bar(aes(x = x), d), NULL, list(rlang::quo(no_such_column > 1))))
+})
+
 test_that("sieve_layer() works with zero predicate", {
-  expect_equal(sieve_layer(geom_bar(aes(x = x), d), NULL, list()),
-               geom_bar(aes(x = x), d))
+  l <- geom_bar(aes(x = x), d)
+  expect_true(sieve_layer(l, NULL, list()))
+  expect_equal(l, geom_bar(aes(x = x), d))
 })
 
 test_that("sieve_layer() works with more than two predicates", {
@@ -227,13 +245,13 @@ test_that("sieve_layer() works with more than two predicates", {
 
 
   # logical predicates only; max_highlight is ignored.
-  expect_equal(sieve_layer(geom_line(aes(colour = type), d2), g_info2,
-                           pred_grouped[1:2], max_highlight = 2),
-               geom_line(aes(colour = type), d2[!d2$type %in% c("a", "d"), ]))
+  l <- geom_line(aes(colour = type), d2)
+  expect_true(sieve_layer(l, g_info2, pred_grouped[1:2], max_highlight = 2))
+  expect_equal(l, geom_line(aes(colour = type), d2[!d2$type %in% c("a", "d"), ]))
 
-  expect_equal(sieve_layer(geom_line(aes(colour = type), d2), g_info2,
-                           pred_grouped, max_highlight = 2),
-               geom_line(aes(colour = type), d2[c(3,4,9,10), ]))
+  l <- geom_line(aes(colour = type), d2)
+  expect_true(sieve_layer(l, g_info2, pred_grouped, max_highlight = 2))
+  expect_equal(l, geom_line(aes(colour = type), d2[c(3,4,9,10), ]))
 })
 
 test_that("sieve_layer() works with list columns", {
@@ -250,16 +268,19 @@ test_that("sieve_layer() works with list columns", {
   )
 
   # ungrouped
-  sl <- sieve_layer(geom_bar(aes(x), d3), NULL, rlang::quos(p1 = l, p2 = v), max_highlight = 2)
+  sl <- geom_bar(aes(x), d3)
+  expect_true(sieve_layer(sl, NULL, rlang::quos(p1 = l, p2 = v), max_highlight = 2))
   expect_identical(sl$mapping, aes(x))
   expect_identical(sl$data, d3[3:4, ])
 
   # grouped
   d3_ <- setNames(d3[3], c("colour"))
   ids3 <- c(1, 1, 2, 2)
   group_info3 <- list(data = d3_, id = ids3, key = aes(colour = z))
-  sl <- sieve_layer(geom_line(aes(x, v, colour = z), d3), group_info3,
-                    rlang::quos(p1 = list(l), p2 = sum(v)), max_highlight = 1, use_group_by = TRUE)
+  sl <- geom_line(aes(x, v, colour = z), d3)
+  expect_true(
+    sieve_layer(sl, group_info3, rlang::quos(p1 = list(l), p2 = sum(v)), max_highlight = 1, use_group_by = TRUE)
+  )
   expect_identical(sl$mapping, aes(x, v, colour = z))
   expect_identical(sl$data, d3[3:4, ])
 })
@@ -398,3 +419,25 @@ test_that("gghighlight() works with two layers, ungrouped", {
   # If n is larger than the number of layers, it throws error.
   expect_error(p1 + gghighlight(mean(value) > 1, n = 3))
 })
+
+test_that("gghighlight() works with annotations", {
+  l_bleached <- geom_point(aes_bleached, d_bleached, colour = grey07, fill = NA)
+  l_sieved <- geom_point(aes(x, y, colour = type), d[d$value > 1, ])
+  l_annotate <- annotate("text", x = 1, y = 1, label = "foo")
+
+  p <- ggplot(d, aes(x, y, colour = type)) +
+    geom_point() +
+    l_annotate
+
+  # ignore annotation
+  expect_warning(p1 <- p + gghighlight(value > 1, use_group_by = FALSE, use_direct_label = FALSE))
+  expect_equal_layers(p1$layers,
+                      list(l_bleached, l_annotate, l_sieved))
+
+  # raise error
+  expect_error(
+    suppressWarnings(
+      p + gghighlight(no_such_column > 1, use_group_by = FALSE, use_direct_label = FALSE)
+    )
+  )
+})