fix: geom_line_interactive() now correctly assigns data_id and tool…

…tip values

see #310 #299

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: ggiraph
 Title: Make 'ggplot2' Graphics Interactive
-Version: 0.9.0.002
+Version: 0.9.0.003
 Authors@R: c(
     person("David", "Gohel", , "[email protected]", role = c("aut", "cre")),
     person("Panagiotis", "Skintzos", , "[email protected]", role = "aut"),

NAMESPACE

@@ -288,25 +288,34 @@ importFrom(purrr,transpose)
 importFrom(rlang,abort)
 importFrom(rlang,arg_match)
 importFrom(rlang,caller_env)
+importFrom(rlang,current_env)
 importFrom(rlang,env_get_list)
 importFrom(rlang,eval_tidy)
+importFrom(rlang,format_error_call)
 importFrom(rlang,inherits_any)
+importFrom(rlang,inject)
 importFrom(rlang,is_named)
+importFrom(rlang,is_null)
 importFrom(rlang,is_scalar_character)
 importFrom(rlang,is_scalar_double)
 importFrom(rlang,is_scalar_integer)
 importFrom(rlang,is_scalar_logical)
 importFrom(rlang,is_string)
 importFrom(rlang,list2)
+importFrom(rlang,zap)
 importFrom(stats,ave)
 importFrom(stats,complete.cases)
+importFrom(stats,setNames)
 importFrom(systemfonts,match_font)
 importFrom(systemfonts,registry_fonts)
 importFrom(systemfonts,system_fonts)
 importFrom(uuid,UUIDgenerate)
 importFrom(vctrs,data_frame)
+importFrom(vctrs,vec_cast)
 importFrom(vctrs,vec_cbind)
 importFrom(vctrs,vec_interleave)
+importFrom(vctrs,vec_ptype2)
 importFrom(vctrs,vec_rbind)
+importFrom(vctrs,vec_slice)
 importFrom(vctrs,vec_unique)
 useDynLib(ggiraph,.registration = TRUE)

NEWS.md

@@ -3,6 +3,7 @@
 ## Issues
 
 - enable build in Alpine linux, thanks to Sebastian Meyer.
+- geom_line_interactive now correctly assigns data_id and tooltip values
 
 ## Changes
 

R/geom_path_interactive.R

@@ -32,6 +32,7 @@ GeomInteractivePath <- ggproto(
                         panel_params,
                         coord,
                         arrow = NULL,
+                        arrow.fill = NULL,
                         lineend = "butt",
                         linejoin = "round",
                         linemitre = 10,
@@ -57,15 +58,33 @@ GeomInteractivePath <- ggproto(
     rows <-
       stats::ave(seq_len(nrow(munched)), munched$group, FUN = length)
     munched <- munched[rows >= 2, ]
+    if (nrow(munched) < 2) return(zeroGrob())
+
+    # Work out whether we should use lines or segments
+    attr <- dapply(munched, "group", function(df) {
+      linetype <- unique0(df$linetype)
+      data_frame0(
+        solid = length(linetype) == 1 && (identical(linetype, "solid") || linetype == 1),
+        constant = nrow(unique0(df[, names(df) %in% c("alpha", "colour", "linewidth", "linetype")])) == 1,
+        .size = 1
+      )
+    })
+    solid_lines <- all(attr$solid)
+    constant <- all(attr$constant)
+    if (!solid_lines && !constant) {
+      cli::cli_abort("{.fn {snake_class(self)}} can't have varying {.field colour}, {.field linewidth}, and/or {.field alpha} along the line when {.field linetype} isn't solid.")
+    }
 
     # Work out grouping variables for grobs
     n <- nrow(munched)
-    constant <- length(gr$x0) == n
+    group_diff <- munched$group[-1] != munched$group[-n]
+    start <- c(TRUE, group_diff)
+    end <-   c(group_diff, TRUE)
+
+    munched$fill <- arrow.fill %||% munched$colour
 
     if (!constant) {
-      group_diff <- munched$group[-1] != munched$group[-n]
-      end <- c(group_diff, TRUE)
-      add_interactive_attrs(gr, munched, rows = !end, ipar = .ipar)
+      add_interactive_attrs(gr, munched, rows = rows[!end], ipar = .ipar)
     } else {
       add_interactive_attrs(gr, munched, ipar = .ipar)
     }

R/utils_ggplot2.R

@@ -126,3 +126,243 @@ unique0 <- function(x, ...) {
 
 #' @importFrom vctrs data_frame
 data_frame0 <- function(...) data_frame(..., .name_repair = "minimal")
+
+#' Apply function to unique subsets of a data.frame
+#'
+#' This function is akin to `plyr::ddply`. It takes a single data.frame,
+#' splits it by the unique combinations of the columns given in `by`, apply a
+#' function to each split, and then reassembles the results into a sigle
+#' data.frame again.
+#'
+#' @param df A data.frame
+#' @param by A character vector of column names to split by
+#' @param fun A function to apply to each split
+#' @param ... Further arguments to `fun`
+#' @param drop Should unused factor levels in the columns given in `by` be
+#' dropped.
+#'
+#' @return A data.frame if the result of `fun` does not include the columns
+#' given in `by` these will be prepended to the result.
+#'
+#' @keywords internal
+#' @noRd
+#' @importFrom vctrs vec_slice
+#' @importFrom stats setNames
+dapply <- function(df, by, fun, ..., drop = TRUE) {
+  grouping_cols <- .subset(df, by)
+  fallback_order <- unique0(c(by, names(df)))
+  apply_fun <- function(x) {
+    res <- fun(x, ...)
+    if (is.null(res)) return(res)
+    if (length(res) == 0) return(data_frame0())
+    vars <- lapply(setNames(by, by), function(col) .subset2(x, col)[1])
+    if (is.matrix(res)) res <- split_matrix(res)
+    if (is.null(names(res))) names(res) <- paste0("V", seq_along(res))
+    if (all(by %in% names(res))) return(data_frame0(!!!unclass(res)))
+    res <- modify_list(unclass(vars), unclass(res))
+    res <- res[intersect(c(fallback_order, names(res)), names(res))]
+    data_frame0(!!!res)
+  }
+
+  # Shortcut when only one group
+  has_single_group <- all(vapply(
+    grouping_cols,
+    function(x) identical(as.character(levels(x) %||% attr(x, "n")), "1"),
+    logical(1)
+  ))
+  if (has_single_group) {
+    return(apply_fun(df))
+  }
+
+  ids <- id(grouping_cols, drop = drop)
+  group_rows <- split_with_index(seq_len(nrow(df)), ids)
+  result <- lapply(seq_along(group_rows), function(i) {
+    cur_data <- vec_slice(df, group_rows[[i]])
+    apply_fun(cur_data)
+  })
+  vec_rbind0(!!!result)
+}
+
+split_with_index <- function(x, f, n = max(f)) {
+  if (n == 1) return(list(x))
+  f <- as.integer(f)
+  attributes(f) <- list(levels = as.character(seq_len(n)), class = "factor")
+  unname(split(x, f))
+}
+
+# Adapted from plyr:::id_vars
+# Create a unique id for elements in a single vector
+id_var <- function(x, drop = FALSE) {
+  if (length(x) == 0) {
+    id <- integer()
+    n <- 0L
+  } else if (!is.null(attr(x, "n")) && !drop) {
+    return(x)
+  } else if (is.factor(x) && !drop) {
+    x <- addNA(x, ifany = TRUE)
+    id <- as.integer(x)
+    n <- nlevels(x)
+  } else {
+    levels <- sort(unique0(x), na.last = TRUE)
+    id <- match(x, levels)
+    n <- max(id)
+  }
+  attr(id, "n") <- n
+  id
+}
+#' Create an unique integer id for each unique row in a data.frame
+#'
+#' Properties:
+#' - `order(id)` is equivalent to `do.call(order, df)`
+#' - rows containing the same data have the same value
+#' - if `drop = FALSE` then room for all possibilities
+#'
+#' @param .variables list of variables
+#' @param drop Should unused factor levels be dropped?
+#'
+#' @return An integer vector with attribute `n` giving the total number of
+#' possible unique rows
+#'
+#' @keywords internal
+#' @noRd
+#' @importFrom rlang inject
+id <- function(.variables, drop = FALSE) {
+  nrows <- NULL
+  if (is.data.frame(.variables)) {
+    nrows <- nrow(.variables)
+    .variables <- unclass(.variables)
+  }
+  lengths <- lengths(.variables)
+  .variables <- .variables[lengths != 0]
+  if (length(.variables) == 0) {
+    n <- nrows %||% 0L
+    id <- seq_len(n)
+    attr(id, "n") <- n
+    return(id)
+  }
+  if (length(.variables) == 1) {
+    return(id_var(.variables[[1]], drop = drop))
+  }
+  ids <- rev(lapply(.variables, id_var, drop = drop))
+  p <- length(ids)
+  ndistinct <- vapply(ids, attr, "n", FUN.VALUE = numeric(1), USE.NAMES = FALSE)
+  n <- prod(ndistinct)
+  if (n > 2^31) {
+    char_id <- inject(paste(!!!ids, sep = "\r"))
+    res <- match(char_id, unique0(char_id))
+  }
+  else {
+    combs <- c(1, cumprod(ndistinct[-p]))
+    mat <- inject(cbind(!!!ids))
+    res <- c((mat - 1L) %*% combs + 1L)
+  }
+  if (drop) {
+    id_var(res, drop = TRUE)
+  }
+  else {
+    res <- as.integer(res)
+    attr(res, "n") <- n
+    res
+  }
+}
+
+#' @importFrom rlang current_env
+vec_rbind0 <- function(..., .error_call = current_env(), .call = caller_env()) {
+  with_ordered_restart(
+    vec_rbind(..., .error_call = .error_call),
+    .call
+  )
+}
+split_matrix <- function(x, col_names = colnames(x)) {
+  force(col_names)
+  x <- lapply(seq_len(ncol(x)), function(i) x[, i])
+  if (!is.null(col_names)) names(x) <- col_names
+  x
+}
+
+#' @importFrom rlang zap format_error_call is_null
+#' @importFrom vctrs vec_ptype2 vec_cast
+# Restart handler for using vec_rbind with mix of types
+# Ordered is coerced to factor
+# If a character vector is present the other is converted to character
+with_ordered_restart <- function(expr, .call) {
+  withCallingHandlers(
+    expr,
+    vctrs_error_incompatible_type = function(cnd) {
+      x <- cnd[["x"]]
+      y <- cnd[["y"]]
+
+      class_x <- class(x)[1]
+      class_y <- class(y)[1]
+
+      restart <- FALSE
+
+      if (is.ordered(x) || is.ordered(y)) {
+        restart <- TRUE
+        if (is.ordered(x)) {
+          x <- factor(as.character(x), levels = levels(x))
+        }
+        if (is.ordered(y)) {
+          y <- factor(as.character(y), levels = levels(y))
+        }
+      } else if (is.character(x) || is.character(y)) {
+        restart <- TRUE
+        if (is.character(x)) {
+          y <- as.character(y)
+        } else {
+          x <- as.character(x)
+        }
+      } else if (is.factor(x) || is.factor(y)) {
+        restart <- TRUE
+        lev <- c()
+        if (is.factor(x)) {
+          lev <- c(lev, levels(x))
+        }
+        if (is.factor(y)) {
+          lev <- c(lev, levels(y))
+        }
+        x <- factor(as.character(x), levels = unique(lev))
+        y <- factor(as.character(y), levels = unique(lev))
+      }
+
+      # Don't recurse and let ptype2 error keep its course
+      if (!restart) {
+        return(zap())
+      }
+
+      msg <- paste0("Combining variables of class <", class_x, "> and <", class_y, ">")
+      desc <- paste0(
+        "Please ensure your variables are compatible before plotting (location: ",
+        format_error_call(.call),
+        ")"
+      )
+
+      cli::cli_warn(
+        I(paste(msg, "was deprecated in ggplot2 3.4.0.", desc))
+      )
+
+      x_arg <- cnd[["x_arg"]]
+      y_arg <- cnd[["y_arg"]]
+      call <- cnd[["call"]]
+
+      # Recurse with factor methods and restart with the result
+      if (inherits(cnd, "vctrs_error_ptype2")) {
+        out <- vec_ptype2(x, y, x_arg = x_arg, y_arg = y_arg, call = call)
+        restart <- "vctrs_restart_ptype2"
+      } else if (inherits(cnd, "vctrs_error_cast")) {
+        out <- vec_cast(x, y, x_arg = x_arg, to_arg = y_arg, call = call)
+        restart <- "vctrs_restart_cast"
+      } else {
+        return(zap())
+      }
+
+      # Old-R compat for `tryInvokeRestart()`
+      try_restart <- function(restart, ...) {
+        if (!is_null(findRestart(restart))) {
+          invokeRestart(restart, ...)
+        }
+      }
+      try_restart(restart, out)
+    }
+  )
+}