diff --git a/DESCRIPTION b/DESCRIPTION index 456b0ab..e6a024e 100644 --- a/DESCRIPTION +++ b/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", , "david.gohel@ardata.fr", role = c("aut", "cre")), person("Panagiotis", "Skintzos", , "sigmapi@posteo.net", role = "aut"), diff --git a/NAMESPACE b/NAMESPACE index d54c99e..76678a9 100644 --- a/NAMESPACE +++ b/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) diff --git a/NEWS.md b/NEWS.md index 647f2f8..a317128 100644 --- a/NEWS.md +++ b/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 diff --git a/R/geom_path_interactive.R b/R/geom_path_interactive.R index cb5fbe6..c90d61d 100644 --- a/R/geom_path_interactive.R +++ b/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) } diff --git a/R/utils_ggplot2.R b/R/utils_ggplot2.R index 526742b..eb13c6b 100644 --- a/R/utils_ggplot2.R +++ b/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) + } + ) +}