diff --git a/NAMESPACE b/NAMESPACE
index 6ec919ad..c9c4a7da 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -7,10 +7,6 @@ S3method(create_layout,layout_ggraph)
S3method(create_layout,tbl_graph)
S3method(format,ggraph_geometry)
S3method(ggplot_build,ggraph)
-S3method(guide_gengrob,edge_direction)
-S3method(guide_geom,edge_direction)
-S3method(guide_merge,edge_direction)
-S3method(guide_train,edge_direction)
S3method(is.na,ggraph_geometry)
S3method(layout_to_table,"function")
S3method(layout_to_table,character)
@@ -251,7 +247,6 @@ import(vctrs)
importFrom(MASS,bandwidth.nrd)
importFrom(MASS,kde2d)
importFrom(Rcpp,sourceCpp)
-importFrom(digest,digest)
importFrom(dplyr,"%>%")
importFrom(dplyr,arrange)
importFrom(dplyr,do)
@@ -291,7 +286,6 @@ importFrom(graphlayouts,layout_with_focus)
importFrom(graphlayouts,layout_with_pmds)
importFrom(graphlayouts,layout_with_sparse_stress)
importFrom(graphlayouts,layout_with_stress)
-importFrom(grid,arrow)
importFrom(grid,convertHeight)
importFrom(grid,convertWidth)
importFrom(grid,convertX)
@@ -315,8 +309,6 @@ importFrom(grid,segmentsGrob)
importFrom(grid,setChildren)
importFrom(grid,textGrob)
importFrom(grid,unit)
-importFrom(gtable,gtable)
-importFrom(gtable,gtable_add_grob)
importFrom(igraph,"%--%")
importFrom(igraph,"vertex_attr<-")
importFrom(igraph,E)
@@ -374,7 +366,6 @@ importFrom(rlang,quo_is_symbol)
importFrom(rlang,quo_text)
importFrom(rlang,quos)
importFrom(rlang,sym)
-importFrom(scales,discard)
importFrom(scales,identity_pal)
importFrom(scales,muted)
importFrom(scales,rescale_pal)
diff --git a/NEWS.md b/NEWS.md
index a75530e2..69ac3c4f 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -10,6 +10,9 @@
* Allow `na.rm` in geoms (#301)
* If `check_overlap = TRUE` in `geom_node_text()` the rendering order is
reversed so that the top nodes are rendered, not the bottom ones
+* Updated guides to the new ggplot2 interface. For `guide_edge_direction()`,
+ this update adds the option to use labels instead of an arrow using the
+ `labels` argument.
# ggraph 2.1.0
diff --git a/R/edge_colourbar.R b/R/edge_colourbar.R
index 601f29c5..2a6dabfd 100644
--- a/R/edge_colourbar.R
+++ b/R/edge_colourbar.R
@@ -11,7 +11,7 @@
#' @export
guide_edge_colourbar <- function(..., available_aes = c("edge_colour", "edge_fill")) {
guide <- guide_colourbar(..., available_aes = available_aes)
- guide$name <- 'edge_colourbar'
+ guide$params$name <- 'edge_colourbar'
guide
}
#' @rdname guide_edge_colourbar
@@ -34,7 +34,7 @@ guide_edge_coloursteps <- function(even.steps = TRUE, show.limits = NULL, ticks
available_aes = c("edge_colour", "edge_fill")) {
guide <- guide_coloursteps(even.steps = even.steps, show.limits = show.limits,
ticks = ticks, ..., available_aes = available_aes)
- guide$name <- 'edge_coloursteps'
+ guide$params$name <- 'edge_coloursteps'
guide
}
#' @rdname guide_edge_coloursteps
diff --git a/R/edge_direction.R b/R/edge_direction.R
index aef8e566..bb550992 100644
--- a/R/edge_direction.R
+++ b/R/edge_direction.R
@@ -4,16 +4,20 @@
#' mapped to its progression, such as changing width, colour and opacity.
#'
#' @inheritParams ggplot2::guide_colourbar
+#' @inheritParams ggplot2::guide_legend
#'
#' @param arrow Logical. Should an arrow be drawn to illustrate the direction.
-#' Defaults to `TRUE`
+#' Defaults to `TRUE`. The arrow is styled with the `legend.axis.line` theme
+#' element. If `FALSE` the direction will be indicated by the text
+#' given in `labels`
#'
-#' @param arrow.position The position of the arrow relative to the example edge.
+#' @param labels A vector with two strings giving the labels to place at the
+#' start and the end of the legend to indicate direction if `arrow = FALSE`
#'
-#' @param override.aes A list specifying aesthetic parameters of legend key.
+#' @param arrow.position `r lifecycle::badge('deprecated')` The position of the
+#' arrow relative to the example edge. Use the `legend.text.position` argument
+#' in `theme()` instead.
#'
-#' @importFrom grid is.unit unit
-#' @importFrom digest digest
#' @export
#'
#' @examples
@@ -21,343 +25,242 @@
#' ggraph(gr, layout = 'kk') +
#' geom_edge_fan(aes(alpha = after_stat(index))) +
#' guides(edge_alpha = guide_edge_direction())
-guide_edge_direction <- function(title = waiver(), title.position = NULL,
- title.theme = NULL, title.hjust = NULL,
- title.vjust = NULL, arrow = TRUE,
- arrow.position = NULL,
- barwidth = NULL, barheight = NULL, nbin = 500,
- direction = NULL, default.unit = 'line',
- reverse = FALSE, order = 0,
- override.aes = list(), ...) {
- if (!is.null(barwidth) && !is.unit(barwidth)) {
- barwidth <- unit(barwidth, default.unit)
- }
- if (!is.null(barheight) && !is.unit(barheight)) {
- barheight <- unit(barheight, default.unit)
- }
- guide <- list(
- title = title, title.position = title.position,
- title.theme = title.theme, title.hjust = title.hjust,
- title.vjust = title.vjust, arrow = arrow,
- arrow.position = arrow.position, barwidth = barwidth,
- barheight = barheight, nbin = nbin, direction = direction,
- default.unit = default.unit, reverse = reverse, order = order,
- available_aes = c('edge_colour', 'edge_alpha', 'edge_width'),
- override.aes = expand_edge_aes(rename_aes(override.aes)), ...,
- name = 'edge_direction'
- )
- class(guide) <- c('guide', 'edge_direction')
- guide
-
-}
-#' Helper methods for guides
#'
-#' @importFrom scales discard
-#' @export
-#' @rdname guide-helpers
-#' @keywords internal
-guide_train.edge_direction <- function(guide, scale, aesthetic = NULL) {
- if (!any(c('edge_colour', 'edge_fill', 'edge_alpha') %in% scale$aesthetics)) {
- cli::cli_warn('{.fn guide_edge_direction} needs {.var edge_colour}, {.var edge_fill}, or {.var edge_alpha} scales.')
- return(NULL)
- }
- if (scale$is_discrete()) {
- cli::cli_warn('{.fn guide_edge_direction} guide needs continuous scales.')
- return(NULL)
+#' # Use text labels instead of an arrow
+#' ggraph(gr, layout = 'kk') +
+#' geom_edge_fan(aes(alpha = after_stat(index))) +
+#' guides(edge_alpha = guide_edge_direction(labels = c('start', 'end')))
+#'
+#' # Style the indicator arrow
+#' arrow_style <- element_line(linewidth = 3, arrow = grid::arrow(type = "closed"))
+#' ggraph(gr, layout = 'kk') +
+#' geom_edge_fan(aes(alpha = after_stat(index))) +
+#' guides(
+#' edge_alpha = guide_edge_direction(
+#' theme = theme(legend.axis.line = arrow_style)
+#' )
+#' )
+#'
+guide_edge_direction <- function(title = NULL, theme = NULL, arrow = NULL,
+ labels = NULL,
+ nbin = 500, position = NULL, direction = NULL,
+ reverse = FALSE, order = 0,
+ override.aes = list(), ...,
+ available_aes = c("edge_colour", "edge_alpha", "edge_width"),
+ arrow.position = deprecated()) {
+ # Piggyback on non-exported `deprecated_guide_args()`
+ theme <- guide_colourbar(theme = theme, ...)$params$theme
+
+ if (!is.null(arrow) && !is.null(labels)) {
+ cli::cli_abort("{.arg arrow} and {.arg labels} can't be used at the same time")
}
- breaks <- scale$get_breaks()
- if (length(breaks) == 0 || all(is.na(breaks))) {
- return()
+ if (is.null(arrow) && is.null(labels)) arrow <- TRUE
+ if (!is.null(labels)) arrow <- FALSE
+ if (!arrow && is.null(labels)) labels <- c("from", "to")
+
+
+ if (lifecycle::is_present(arrow.position)) {
+ lifecycle::deprecate_warn('2.2.0', 'guide_edge_direction(arrow.position)', 'guide_edge_direction(theme = "theme(legend.text.position)")')
+ if (!is.null(arrow.position)) {
+ if (is.null(theme)) theme <- theme()
+ theme$legend.text.position <- arrow.position
+ }
}
- ticks <- data_frame(scale$map(breaks), .name_repair = ~ aesthetic %||% scale$aesthetics[1])
- ticks$.value <- breaks
- ticks$.label <- scale$get_labels(breaks)
- guide$key <- ticks
- .limits <- scale$get_limits()
- .bar <- discard(pretty(.limits, n = guide$nbin), scale$get_limits())
- if (length(.bar) == 0) {
- .bar <- unique0(.limits)
+ if (!is.null(position)) {
+ position <- arg_match0(position, c("top", "right", "bottom", "left", "inside"))
}
- guide$bar <- data_frame(scale$map(.bar), .name_repair = ~ scale$aesthetics[1])
- guide$bar$.value <- .bar
- guide$bar <- guide$bar[order(.bar), ]
- if (guide$reverse) {
- guide$key <- guide$key[nrow(guide$key):1, ]
- guide$bar <- guide$bar[nrow(guide$bar):1, ]
+ if (!is.null(labels) && (length(labels) != 2 || !is.character(labels))) {
+ cli::cli_abort('{.arg label} must be a vector of two strings')
}
- guide$hash <- with(guide, digest::digest(list(
- title, bar$.value,
- direction, name
- )))
- guide
-}
-#' @rdname guide-helpers
-#' @export
-guide_merge.edge_direction <- function(guide, new_guide) {
- guide$bar <- merge(guide$bar, new_guide$bar, sort = FALSE)
- guide$override.aes <- c(guide$override.aes, new_guide$override.aes)
- if (any(duplicated(names(guide$override.aes)))) cli::cli_warn('Duplicated {.arg override.aes} is ignored.')
- guide$override.aes <- guide$override.aes[!duplicated(names(guide$override.aes))]
- guide
+ new_guide(
+ title = title,
+ theme = theme,
+ arrow = arrow,
+ labels = labels,
+ nbin = nbin,
+ position = position,
+ direction = direction,
+ override.aes = expand_edge_aes(rename_aes(override.aes)),
+ reverse = reverse,
+ order = order,
+ available_aes = available_aes,
+ name = 'direction',
+ super = GuideEdgeDirection
+ )
}
-#' @export
-#' @rdname guide-helpers
-guide_geom.edge_direction <- function(guide, layers, default_mapping) {
- guide$geoms <- lapply(layers, function(layer) {
- all <- names(c(
- layer$mapping, if (layer$inherit.aes) default_mapping,
- layer$stat$default_aes
- ))
- geom <- c(layer$geom$required_aes, names(layer$geom$default_aes))
- matched <- intersect(intersect(all, geom), names(guide$bar))
- matched <- setdiff(matched, names(layer$geom_params))
- matched <- setdiff(matched, names(layer$aes_params))
- if (length(matched) > 0) {
- if (is.na(layer$show.legend) || layer$show.legend) {
- data <- layer$geom$use_defaults(
- guide$bar[matched],
- layer$aes_params
- )
- }
- else {
- return(NULL)
- }
- }
- else {
- if (is.na(layer$show.legend) || !layer$show.legend) {
- return(NULL)
- }
- else {
- data <- layer$geom$use_defaults(
- NULL,
- layer$aes_params
- )[rep(1, nrow(guide$bar)), ]
- }
+GuideEdgeDirection <- ggproto(
+ "GuideEdgeDirection", GuideLegend,
+
+ params = list(
+ # title
+ title = NULL,
+
+ # theming
+ theme = NULL,
+
+ # bar
+ nbin = 300,
+ arrow = TRUE,
+ labels = c("from", "to"),
+
+ # general
+ direction = NULL,
+ override.aes = list(),
+ reverse = FALSE,
+ order = 0,
+
+ # parameter
+ name = "direction",
+ hash = character(),
+ position = NULL
+ ),
+
+ available_aes = c('edge_colour', 'edge_alpha', 'edge_width'),
+
+ hashables = exprs(title, decor$value, name),
+
+ elements = list(
+ background = "legend.background",
+ margin = "legend.margin",
+ key = "legend.key",
+ key_height = "legend.key.height",
+ key_width = "legend.key.width",
+ text = "legend.text",
+ theme.title = "legend.title",
+ text_position = "legend.text.position",
+ title_position = "legend.title.position",
+ arrow_line = "legend.axis.line"
+ ),
+
+ extract_key = function(scale, aesthetic, ...) {
+ if (scale$is_discrete()) {
+ cli::cli_warn("{.fn guide_edge_direction} needs continuous scales.")
+ return(NULL)
}
- data <- utils::modifyList(data, guide$override.aes)
- list(data = data, params = c(layer$geom_params, layer$stat_params))
- })
- guide$geoms <- guide$geoms[!vapply(guide$geoms, is.null, logical(1))]
- if (length(guide$geoms) == 0) {
- guide <- NULL
- }
- guide
-}
-#' @importFrom grid convertWidth convertHeight unit grobWidth grobHeight arrow grobName
-#' @importFrom gtable gtable gtable_add_grob
-#' @importFrom utils tail
-#' @importFrom stats setNames
-#' @rdname guide-helpers
-#' @export
-guide_gengrob.edge_direction <- function(guide, theme) {
- switch(guide$direction, horizontal = {
- arrow.position <- guide$arrow.position %||% 'bottom'
- if (!arrow.position %in% c('top', 'bottom')) {
- cli::cli_abort('{.arg arrow.position} {.val {arrow.position}} is invalid')
+ Guide$extract_key(scale, aesthetic, ...)
+ },
+
+ extract_decor = function(scale, aesthetic, nbin = 300, reverse = FALSE, ...) {
+ limits <- scale$get_limits()
+ bar <- seq(limits[1], limits[2], length.out = nbin)
+ if (length(bar) == 0) {
+ bar <- unique0(limits)
}
- }, vertical = {
- arrow.position <- guide$arrow.position %||% 'right'
- if (!arrow.position %in% c('left', 'right')) {
- cli::cli_abort('{.arg arrow.position} {.val {arrow.position}} is invalid')
+ aes <- scale$aesthetics[1]
+ bar <- data_frame0(
+ {{aes}} := scale$map(bar),
+ value = bar,
+ .size = length(bar)
+ )
+ if (reverse) {
+ bar <- bar[rev(seq_len(nrow(bar))), , drop = FALSE]
}
- })
- arrowlength <- convertWidth(guide$arrowlength %||%
- (theme$legend.key.width * 5), 'mm')
- arrowwidth <- convertWidth(unit(sin(30 / 360 * 2 * pi) * 0.25 * 2, 'in'), 'mm')
- edgewidth <- max(vapply(guide$geoms, function(g) {
- max(g$data$edge_width)
- }, numeric(1))) * .pt
- edgewidth <- convertWidth(unit(edgewidth, 'points'), 'mm')
- hgap <- c(convertWidth(unit(0.3, 'lines'), 'mm'))
- vgap <- hgap
- x <- rep(c(edgewidth) / 2, nrow(guide$bar))
- xend <- x
- y <- seq(0, 1, length.out = nrow(guide$bar) + 1) * c(arrowlength)
- yend <- y[-1]
- y <- y[-length(y)]
- grob.bar <- switch(
- guide$direction,
- horizontal = {
- lapply(guide$geoms, function(g) {
- segmentsGrob(
- x0 = y, y0 = x, x1 = yend, y1 = xend,
- default.units = 'mm',
- gp = gpar(
- col = alpha(
- g$data$edge_colour,
- g$data$edge_alpha
- ),
- lwd = g$data$edge_width * .pt,
- lty = g$data$edge_linetype,
- lineend = 'butt'
- )
- )
- })
- },
- vertical = {
- lapply(guide$geoms, function(g) {
- segmentsGrob(
- x0 = x, y0 = y, x1 = xend, y1 = yend,
- default.units = 'mm',
- gp = gpar(
- col = alpha(
- g$data$edge_colour,
- g$data$edge_alpha
- ),
- lwd = g$data$edge_width * .pt,
- lty = g$data$edge_linetype,
- lineend = 'butt'
- )
- )
- })
+ return(bar)
+ },
+
+ merge = function(self, params, new_guide, new_params) {
+ new_params$decor$value <- NULL
+ params$decor <- vec_cbind(params$decor, new_params$decor)
+ return(list(guide = self, params = params))
+ },
+
+ get_layer_key = function(params, layers, data = NULL) {
+ decor <- GuideLegend$get_layer_key(params, layers, data)$decor
+ extra_data <- lapply(decor, `[[`, 'data')
+ missing_aes <- setdiff(c("edge_colour", "edge_alpha", "edge_width"), names(params$decor))
+ for (d in extra_data) {
+ for (aes in missing_aes) {
+ if (!is.null(d[[aes]])) params$decor[[aes]] <- d[[aes]][1]
+ }
}
- )
- grob.bar <- inject(gList(!!!grob.bar))
- grob.title <- ggname(
- 'guide.title',
- element_grob(guide$title.theme %||%
- calc_element('legend.title', theme),
- label = guide$title,
- hjust = guide$title.hjust %||%
- theme$legend.title.align %||% 0,
- vjust = guide$title.vjust %||% 0.5
+ params
+ },
+
+ setup_params = function(params) {
+ params$direction <- arg_match0(
+ params$direction,
+ c("horizontal", "vertical"), arg_nm = "direction"
)
- )
- title_width <- convertWidth(grobWidth(grob.title), 'mm')
- title_width.c <- c(title_width)
- title_height <- convertHeight(grobHeight(grob.title), 'mm')
- title_height.c <- c(title_height)
- grob.arrow <- {
- if (!guide$arrow) {
- zeroGrob()
+ params
+ },
+
+ setup_elements = function(params, elements, theme) {
+ elements <- GuideColourbar$setup_elements(params, elements, theme)
+ if (is.logical(elements$arrow_line$arrow)) {
+ elements$arrow_line$arrow <- grid::arrow()
+ }
+ elements$arrow_line$arrow$ends <- if (params$reverse) 1L else 2L
+ elements
+ },
+
+ build_labels = function(key, elements, params) {
+ if (params$arrow) {
+ list(labels = flip_element_grob(
+ elements$arrow_line,
+ x = unit(c(0, 1), "npc"),
+ y = unit(c(0.5, 0.5), "npc"),
+ flip = params$direction == "vertical"
+ ))
} else {
- switch(
- guide$direction,
- horizontal = {
- segmentsGrob(
- x0 = y[1], y0 = c(arrowwidth) / 2, x1 = tail(yend, 1),
- y1 = c(arrowwidth) / 2, default.units = 'mm',
- gp = gpar(
- col = 'black', lwd = 0.5 * .pt,
- lty = 'solid', lineend = 'round'
- ),
- arrow = arrow(ends = if (guide$reverse) {
- 'first'
- } else {
- 'last'
- })
- )
- },
- vertical = {
- segmentsGrob(
- x0 = c(arrowwidth) / 2, y0 = y[1], x1 = c(arrowwidth) / 2,
- y1 = tail(yend, 1), default.units = 'mm',
- gp = gpar(
- col = 'black', lwd = 0.5 * .pt,
- lty = 'solid', lineend = 'round'
- ),
- arrow = arrow(ends = if (guide$reverse) {
- 'first'
- } else {
- 'last'
- })
- )
- }
+ list(labels = flip_element_grob(
+ elements$text,
+ label = params$labels,
+ x = unit(c(0, 1), "npc"),
+ margin_x = FALSE,
+ margin_y = TRUE,
+ flip = params$direction == "vertical"
+ ))
+ }
+ },
+
+ build_ticks = function(key, elements, params, position = params$position) {
+ zeroGrob()
+ },
+
+ build_decor = function(decor, grobs, elements, params) {
+ y <- seq(0, 1, length.out = nrow(decor) + 1)
+ yend <- y[-1]
+ y <- y[-length(y)]
+ x <- rep(0.5, length(y))
+ xend <- x
+ if (params$direction == "horizontal") {
+ tmp <- x
+ x <- y
+ y <- tmp
+ tmp <- xend
+ xend <- yend
+ yend <- tmp
+ }
+ grob <- segmentsGrob(
+ x0 = x, y0 = y, x1 = xend, y1 = yend,
+ default.units = "npc",
+ gp = gpar(
+ col = alpha(decor$edge_colour, decor$edge_alpha),
+ lwd = decor$edge_width * .pt,
+ lty = decor$edge_linetyoe,
+ lineend = "butt"
)
+ )
+
+ list(bar = grob)
+ },
+
+ measure_grobs = function(grobs, params, elements) {
+ params$sizes <- list(
+ widths = elements$width_cm,
+ heights = elements$height_cm
+ )
+ sizes <- GuideLegend$measure_grobs(grobs, params, elements)
+ if (params$arrow) {
+ l <- convertHeight(elements$arrow_line$arrow$length, "cm", valueOnly = TRUE)
+ a <- 2 * pi * elements$arrow_line$arrow$angle / 360
+ width <- sin(a) * l * 2 + elements$arrow_line$linewidth / 10
+ if (params$direction == "vertical") {
+ sizes$widths[sizes$widths == 0] <- width
+ } else {
+ sizes$heights[sizes$heights == 0] <- width
+ }
}
+ sizes
}
- switch(guide$direction, horizontal = {
- switch(arrow.position, top = {
- bl_widths <- c(arrowlength)
- bl_heights <- c(c(arrowwidth), vgap, c(edgewidth))
- vps <- list(
- bar.row = 3, bar.col = 1, label.row = 1,
- label.col = 1
- )
- }, bottom = {
- bl_widths <- c(arrowlength)
- bl_heights <- c(c(edgewidth), vgap, c(arrowwidth))
- vps <- list(
- bar.row = 1, bar.col = 1, label.row = 3,
- label.col = 1
- )
- })
- }, vertical = {
- switch(arrow.position, left = {
- bl_widths <- c(c(arrowwidth), vgap, c(edgewidth))
- bl_heights <- c(arrowlength)
- vps <- list(
- bar.row = 1, bar.col = 3, label.row = 1,
- label.col = 1
- )
- }, right = {
- bl_widths <- c(c(edgewidth), vgap, c(arrowwidth))
- bl_heights <- c(arrowlength)
- vps <- list(
- bar.row = 1, bar.col = 1, label.row = 1,
- label.col = 3
- )
- })
- })
- switch(guide$title.position, top = {
- widths <- c(bl_widths, max(0, title_width.c - sum(bl_widths)))
- heights <- c(title_height.c, vgap, bl_heights)
- vps <- with(vps, list(
- bar.row = bar.row + 2, bar.col = bar.col,
- label.row = label.row + 2, label.col = label.col,
- title.row = 1, title.col = 1:length(widths)
- ))
- }, bottom = {
- widths <- c(bl_widths, max(0, title_width.c - sum(bl_widths)))
- heights <- c(bl_heights, vgap, title_height.c)
- vps <- with(vps, list(
- bar.row = bar.row, bar.col = bar.col,
- label.row = label.row, label.col = label.col,
- title.row = length(heights),
- title.col = 1:length(widths)
- ))
- }, left = {
- widths <- c(title_width.c, hgap, bl_widths)
- heights <- c(bl_heights, max(0, title_height.c - sum(bl_heights)))
- vps <- with(vps, list(bar.row = bar.row, bar.col = bar.col +
- 2, label.row = label.row, label.col = label.col +
- 2, title.row = 1:length(heights), title.col = 1))
- }, right = {
- widths <- c(bl_widths, hgap, title_width.c)
- heights <- c(bl_heights, max(0, title_height.c - sum(bl_heights)))
- vps <- with(vps, list(
- bar.row = bar.row, bar.col = bar.col,
- label.row = label.row, label.col = label.col,
- title.row = 1:length(heights),
- title.col = length(widths)
- ))
- })
- grob.background <- element_render(theme, 'legend.background')
- padding <- unit(1.5, 'mm')
- widths <- c(padding, widths, padding)
- heights <- c(padding, heights, padding)
- gt <- gtable(widths = unit(widths, 'mm'), heights = unit(
- heights,
- 'mm'
- ))
- gt <- gtable_add_grob(gt, grob.background,
- name = 'background',
- clip = 'off', t = 1, r = -1, b = -1, l = 1
- )
- gt <- gtable_add_grob(gt, grob.bar,
- name = 'bar', clip = 'off',
- t = 1 + min(vps$bar.row), r = 1 + max(vps$bar.col), b = 1 +
- max(vps$bar.row), l = 1 + min(vps$bar.col)
- )
- gt <- gtable_add_grob(gt, grob.arrow,
- name = 'label', clip = 'off',
- t = 1 + min(vps$label.row), r = 1 + max(vps$label.col),
- b = 1 + max(vps$label.row), l = 1 + min(vps$label.col)
- )
- gt <- gtable_add_grob(gt, grob.title,
- name = 'title', clip = 'off',
- t = 1 + min(vps$title.row), r = 1 + max(vps$title.col),
- b = 1 + max(vps$title.row), l = 1 + min(vps$title.col)
- )
- gt
-}
+)
diff --git a/R/utils.R b/R/utils.R
index 28ad8da4..8944fdda 100644
--- a/R/utils.R
+++ b/R/utils.R
@@ -67,6 +67,26 @@ rename_aes <- function(x) {
}
x
}
+flip_names <- c(
+ x = "y",
+ y = "x",
+ width = "height",
+ height = "width",
+ hjust = "vjust",
+ vjust = "hjust",
+ margin_x = "margin_y",
+ margin_y = "margin_x"
+)
+flip_element_grob <- function(..., flip = FALSE) {
+ if (!flip) {
+ ans <- element_grob(...)
+ return(ans)
+ }
+ args <- list(...)
+ translate <- names(args) %in% names(flip_names)
+ names(args)[translate] <- flip_names[names(args)[translate]]
+ do.call(element_grob, args)
+}
#' @importFrom viridis scale_color_viridis
#' @export
diff --git a/man/figures/lifecycle-archived.svg b/man/figures/lifecycle-archived.svg
new file mode 100644
index 00000000..745ab0c7
--- /dev/null
+++ b/man/figures/lifecycle-archived.svg
@@ -0,0 +1,21 @@
+
diff --git a/man/figures/lifecycle-defunct.svg b/man/figures/lifecycle-defunct.svg
new file mode 100644
index 00000000..d5c9559e
--- /dev/null
+++ b/man/figures/lifecycle-defunct.svg
@@ -0,0 +1,21 @@
+
diff --git a/man/figures/lifecycle-deprecated.svg b/man/figures/lifecycle-deprecated.svg
new file mode 100644
index 00000000..b61c57c3
--- /dev/null
+++ b/man/figures/lifecycle-deprecated.svg
@@ -0,0 +1,21 @@
+
diff --git a/man/figures/lifecycle-experimental.svg b/man/figures/lifecycle-experimental.svg
new file mode 100644
index 00000000..5d88fc2c
--- /dev/null
+++ b/man/figures/lifecycle-experimental.svg
@@ -0,0 +1,21 @@
+
diff --git a/man/figures/lifecycle-maturing.svg b/man/figures/lifecycle-maturing.svg
new file mode 100644
index 00000000..897370ec
--- /dev/null
+++ b/man/figures/lifecycle-maturing.svg
@@ -0,0 +1,21 @@
+
diff --git a/man/figures/lifecycle-questioning.svg b/man/figures/lifecycle-questioning.svg
new file mode 100644
index 00000000..7c1721d0
--- /dev/null
+++ b/man/figures/lifecycle-questioning.svg
@@ -0,0 +1,21 @@
+
diff --git a/man/figures/lifecycle-soft-deprecated.svg b/man/figures/lifecycle-soft-deprecated.svg
new file mode 100644
index 00000000..9c166ff3
--- /dev/null
+++ b/man/figures/lifecycle-soft-deprecated.svg
@@ -0,0 +1,21 @@
+
diff --git a/man/figures/lifecycle-stable.svg b/man/figures/lifecycle-stable.svg
new file mode 100644
index 00000000..9bf21e76
--- /dev/null
+++ b/man/figures/lifecycle-stable.svg
@@ -0,0 +1,29 @@
+
diff --git a/man/figures/lifecycle-superseded.svg b/man/figures/lifecycle-superseded.svg
new file mode 100644
index 00000000..db8d757f
--- /dev/null
+++ b/man/figures/lifecycle-superseded.svg
@@ -0,0 +1,21 @@
+
diff --git a/man/guide-helpers.Rd b/man/guide-helpers.Rd
deleted file mode 100644
index 71bc8f6c..00000000
--- a/man/guide-helpers.Rd
+++ /dev/null
@@ -1,21 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/edge_direction.R
-\name{guide_train.edge_direction}
-\alias{guide_train.edge_direction}
-\alias{guide_merge.edge_direction}
-\alias{guide_geom.edge_direction}
-\alias{guide_gengrob.edge_direction}
-\title{Helper methods for guides}
-\usage{
-\method{guide_train}{edge_direction}(guide, scale, aesthetic = NULL)
-
-\method{guide_merge}{edge_direction}(guide, new_guide)
-
-\method{guide_geom}{edge_direction}(guide, layers, default_mapping)
-
-\method{guide_gengrob}{edge_direction}(guide, theme)
-}
-\description{
-Helper methods for guides
-}
-\keyword{internal}
diff --git a/man/guide_edge_direction.Rd b/man/guide_edge_direction.Rd
index eb70043c..8fd73770 100644
--- a/man/guide_edge_direction.Rd
+++ b/man/guide_edge_direction.Rd
@@ -5,22 +5,19 @@
\title{Edge direction guide}
\usage{
guide_edge_direction(
- title = waiver(),
- title.position = NULL,
- title.theme = NULL,
- title.hjust = NULL,
- title.vjust = NULL,
- arrow = TRUE,
- arrow.position = NULL,
- barwidth = NULL,
- barheight = NULL,
+ title = NULL,
+ theme = NULL,
+ arrow = NULL,
+ labels = NULL,
nbin = 500,
+ position = NULL,
direction = NULL,
- default.unit = "line",
reverse = FALSE,
order = 0,
override.aes = list(),
- ...
+ ...,
+ available_aes = c("edge_colour", "edge_alpha", "edge_width"),
+ arrow.position = deprecated()
)
}
\arguments{
@@ -29,14 +26,24 @@ If \code{NULL}, the title is not shown. By default
(\code{\link[ggplot2:waiver]{waiver()}}), the name of the scale object or the name
specified in \code{\link[ggplot2:labs]{labs()}} is used for the title.}
+\item{theme}{A \code{\link[ggplot2:theme]{theme}} object to style the guide individually or
+differently from the plot's theme settings. The \code{theme} argument in the
+guide overrides, and is combined with, the plot's theme.}
+
\item{arrow}{Logical. Should an arrow be drawn to illustrate the direction.
-Defaults to \code{TRUE}}
+Defaults to \code{TRUE}. The arrow is styled with the \code{legend.axis.line} theme
+element. If \code{FALSE} the direction will be indicated by the text
+given in \code{labels}}
-\item{arrow.position}{The position of the arrow relative to the example edge.}
+\item{labels}{A vector with two strings giving the labels to place at the
+start and the end of the legend to indicate direction if \code{arrow = FALSE}}
\item{nbin}{A numeric specifying the number of bins for drawing the
colourbar. A smoother colourbar results from a larger value.}
+\item{position}{A character string indicating where the legend should be
+placed relative to the plot panels.}
+
\item{direction}{A character string indicating the direction of the guide.
One of "horizontal" or "vertical."}
@@ -48,9 +55,17 @@ this guide among multiple guides. This controls the order in which
multiple guides are displayed, not the contents of the guide itself.
If 0 (default), the order is determined by a secret algorithm.}
-\item{override.aes}{A list specifying aesthetic parameters of legend key.}
+\item{override.aes}{A list specifying aesthetic parameters of legend key.
+See details and examples.}
\item{...}{ignored.}
+
+\item{available_aes}{A vector of character strings listing the aesthetics
+for which a colourbar can be drawn.}
+
+\item{arrow.position}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} The position of the
+arrow relative to the example edge. Use the \code{legend.text.position} argument
+in \code{theme()} instead.}
}
\description{
This guide is intended to show the direction of edges based on the aesthetics
@@ -61,4 +76,20 @@ gr <- tidygraph::as_tbl_graph(highschool)
ggraph(gr, layout = 'kk') +
geom_edge_fan(aes(alpha = after_stat(index))) +
guides(edge_alpha = guide_edge_direction())
+
+# Use text labels instead of an arrow
+ggraph(gr, layout = 'kk') +
+ geom_edge_fan(aes(alpha = after_stat(index))) +
+ guides(edge_alpha = guide_edge_direction(labels = c('start', 'end')))
+
+# Style the indicator arrow
+arrow_style <- element_line(linewidth = 3, arrow = grid::arrow(type = "closed"))
+ggraph(gr, layout = 'kk') +
+ geom_edge_fan(aes(alpha = after_stat(index))) +
+ guides(
+ edge_alpha = guide_edge_direction(
+ theme = theme(legend.axis.line = arrow_style)
+ )
+ )
+
}