From 07fa418b5f85335b43ee272bd895293d7f84f78c Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Sat, 13 Jan 2024 17:41:50 +0100 Subject: [PATCH 1/5] First working version --- NAMESPACE | 5 ++ R/element-text-repel.R | 196 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 201 insertions(+) create mode 100644 R/element-text-repel.R diff --git a/NAMESPACE b/NAMESPACE index 41e3ec4..643d49a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,7 +1,10 @@ # Generated by roxygen2: do not edit by hand +S3method(element_grob,element_text_repel) +S3method(heightDetails,element_textrepeltree) S3method(makeContent,labelrepeltree) S3method(makeContent,textrepeltree) +S3method(widthDetails,element_textrepeltree) export(GeomLabelRepel) export(GeomTextRepel) export(PositionNudgeRepel) @@ -22,6 +25,7 @@ importFrom(grid,grobTree) importFrom(grid,grobWidth) importFrom(grid,grobX) importFrom(grid,grobY) +importFrom(grid,heightDetails) importFrom(grid,is.grob) importFrom(grid,is.unit) importFrom(grid,makeContent) @@ -34,5 +38,6 @@ importFrom(grid,stringHeight) importFrom(grid,stringWidth) importFrom(grid,textGrob) importFrom(grid,unit) +importFrom(grid,widthDetails) importFrom(rlang,warn) useDynLib(ggrepel) diff --git a/R/element-text-repel.R b/R/element-text-repel.R new file mode 100644 index 0000000..f251539 --- /dev/null +++ b/R/element-text-repel.R @@ -0,0 +1,196 @@ + +element_text_repel <- function( + # Generic text settings + family = NULL, + face = NULL, + colour = NULL, + size = NULL, + hjust = NULL, + vjust = NULL, + angle = NULL, + lineheight = NULL, + color = NULL, + + # Spacings + margin = NULL, + box.padding = NULL, + + # Repel settings + force = NULL, + force_pull = NULL, + max.time = NULL, + max.iter = NULL, + max.overlaps = NULL, + + # Segment settings + min.segment.length = NULL, + segment.colour = NULL, + segment.linetype = NULL, + segment.size = NULL, + segment.curvature = NULL, + segment.angle = NULL, + segment.ncp = NULL, + segment.shape = NULL, + segment.square = NULL, + segment.squareShape = NULL, + segment.inflect = NULL, + arrow = NULL, + + # General settings + position = c("bottom", "top", "left", "right"), + inherit.blank = FALSE +) { + # Capture arguments in list + args <- setdiff(rlang::fn_fmls_names(element_text_repel), c("color", "colour")) + vals <- mget(args, envir = rlang::current_env()) + vals["colour"] <- list(color %||% colour) + + structure( + vals, + class = c("element_text_repel", "element_text", "element") + ) +} + +#' @export +#' @method element_grob element_text_repel +element_grob.element_text_repel <- function( + element, label = "", x = NULL, y = NULL, + family = NULL, face = NULL, colour = NULL, size = NULL, + hjust = NULL, vjust = NULL, angle = NULL, lineheight = NULL, + margin = NULL, margin_x = FALSE, margin_y = FALSE, + position = c("bottom", "top", "left", "right"), ... +) { + if (is.null(x %||% y)) { + # Nothing to repel from, might be a legend or title + out <- NextMethod() + return(out) + } + if (is.null(label) || sum(nzchar(label) & !is.na(label)) < 1) { + # No labels to render + return(zeroGrob()) + } + + # Resolve position. + # Axes often have only x *or* y defined but not both. + # So if we have `x` but not `y`, we're probably in a top or bottom axis. + # Likewise, if we have `y` but not `x`, we're a left or right axis. + # In some rare cases we might have both, which will get the `"none"` position. + position <- element$position + if (is.null(x)) { + position <- intersect(position, c("left", "right")) + } + if (is.null(y)) { + position <- intersect(position, c("top", "bottom")) + } + if (length(position) < 1 || (!is.null(x) && !is.null(y))) { + position <- "none" + } else { + position <- position[1] + } + + vjust <- vjust %||% element$vjust + hjust <- hjust %||% element$hjust + + # Setup text-related graphical paramters + gp <- gpar( + fontsize = size, fontfamily = family, + fontface = face, lineheight = lineheight + ) + element_gp <- gpar( + fontsize = element$size, fontfamily = element$family, + fontface = element$face, lineheight = element$lineheight + ) + for (i in names(gp)) element_gp[i] <- gp[i] + gp <- element_gp + + # We set a temporary viewport so that text-related sizes are calculated + # correctly relative to the font size + grid::pushViewport(grid::viewport(gp = gp), recording = FALSE) + on.exit(grid::popViewport(recording = FALSE)) + + margin <- margin %||% element$margin + x_margin <- if (margin_x) width_cm(margin[c(2, 4)]) else c(0, 0) + y_margin <- if (margin_y) height_cm(margin[c(1, 3)]) else c(0, 0) + + box.padding <- height_cm(element$box.padding %||% to_unit(0.25)) + max_width <- max(width_cm(stringWidth(label))) + sum(x_margin) + box.padding + max_height <- max(height_cm(stringHeight(label))) + sum(y_margin) + box.padding + + # Set position dependent defaults + direction <- switch(position, left = , right = "y", top = , bottom = "x", "both") + vp <- switch( + direction, + x = grid::viewport(width = unit(1, "npc"), height = unit(max_height, "cm")), + y = grid::viewport(width = unit(max_width, "cm"), height = unit(1, "npc")), + both = grid::viewport(width = unit(1, "npc"), height = unit(1, "npc")) + ) + + x <- x %||% switch(position, right = 0, left = 1, hjust) + y <- y %||% switch(position, bottom = 1, top = 0, vjust) + x_nudge <- switch(position, left = -x_margin[1], right = x_margin[2], 0) + y_nudge <- switch(position, top = y_margin[2], bottom = -y_margin[1], 0) + x_nudge <- x_nudge / max_width + y_nudge <- y_nudge / max_height + + # Set defaults + arg_names <- rlang::fn_fmls_names(element_grob.element_text_repel) + defaults <- GeomTextRepel$use_defaults(NULL) + defaults <- defaults[setdiff(names(defaults), c(arg_names, "fontface"))] + both <- intersect(names(defaults), names(element)[lengths(element) > 0]) + + data <- rlang::inject(data.frame( + label = label, + colour = colour %||% element$colour, + angle = angle %||% element$angle, + size = gp$fontsize / .pt, + family = gp$fontfamily, + fontface = names(gp$font), + lineheight = gp$lineheight, + hjust = hjust, + vjust = vjust, + point.size = 0, + !!!defaults, + nudge_x = x_nudge, + nudge_y = y_nudge + )) + + # We cannot declare x/y in the data.frame directly because if they are units, + # data.frame might because of the lack of an as.data.frame.unit method. + data$x <- x + data$y <- y + + gTree( + limits = data.frame(x = c(0, 1), y = c(0, 1)), + data = data, + lab = label, + direction = direction, + box.padding = unit(box.padding, "cm"), + point.padding = to_unit(0), + min.segment.length = to_unit(0), + arrow = element$arrow, + force = element$force %||% 1, + force_pull = element$force_pull %||% 1, + max.time = element$max.time %||% 0.5, + max.iter = element$max.iter %||% 1000, + max.overlaps = element$max.overlaps %||% getOption("ggrepel.max.overlaps", default = 10), + seed = element$seed %||% NA, + verbose = FALSE, + width = unit(max_width, "cm"), + height = unit(max_height, "cm"), + vp = vp, + cl = c("element_textrepeltree", "textrepeltree") + ) +} + +# Helper funcions +width_cm <- function(x) convertWidth(x, "cm", valueOnly = TRUE) +height_cm <- function(x) convertHeight(x, "cm", valueOnly = TRUE) + +#' @export +#' @importFrom grid widthDetails +#' @method widthDetails element_textrepeltree +widthDetails.element_textrepeltree <- function(x) x$width +#' @export +#' @importFrom grid heightDetails +#' @method heightDetails element_textrepeltree +heightDetails.element_textrepeltree <- function(x) x$height From c5960e3684dd023b29a7d24d4ba35b14251bc66e Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 2 Dec 2024 22:07:02 +0100 Subject: [PATCH 2/5] fix lines not drawn properly --- R/element-text-repel.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/element-text-repel.R b/R/element-text-repel.R index f251539..f7b9d9b 100644 --- a/R/element-text-repel.R +++ b/R/element-text-repel.R @@ -165,7 +165,7 @@ element_grob.element_text_repel <- function( lab = label, direction = direction, box.padding = unit(box.padding, "cm"), - point.padding = to_unit(0), + point.padding = to_unit(sqrt(.Machine$double.eps)), min.segment.length = to_unit(0), arrow = element$arrow, force = element$force %||% 1, From c99ce24228de9b572c7df1b7e9769c8623e2fd6a Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 2 Dec 2024 22:59:06 +0100 Subject: [PATCH 3/5] pass segment settings better --- R/element-text-repel.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/R/element-text-repel.R b/R/element-text-repel.R index f7b9d9b..b5742f4 100644 --- a/R/element-text-repel.R +++ b/R/element-text-repel.R @@ -37,6 +37,7 @@ element_text_repel <- function( arrow = NULL, # General settings + seed = NA, position = c("bottom", "top", "left", "right"), inherit.blank = FALSE ) { @@ -112,7 +113,7 @@ element_grob.element_text_repel <- function( x_margin <- if (margin_x) width_cm(margin[c(2, 4)]) else c(0, 0) y_margin <- if (margin_y) height_cm(margin[c(1, 3)]) else c(0, 0) - box.padding <- height_cm(element$box.padding %||% to_unit(0.25)) + box.padding <- height_cm(to_unit(element$box.padding %||% 0.25)) max_width <- max(width_cm(stringWidth(label))) + sum(x_margin) + box.padding max_height <- max(height_cm(stringHeight(label))) + sum(y_margin) + box.padding @@ -137,6 +138,7 @@ element_grob.element_text_repel <- function( defaults <- GeomTextRepel$use_defaults(NULL) defaults <- defaults[setdiff(names(defaults), c(arg_names, "fontface"))] both <- intersect(names(defaults), names(element)[lengths(element) > 0]) + defaults[both] <- element[both] data <- rlang::inject(data.frame( label = label, @@ -148,6 +150,7 @@ element_grob.element_text_repel <- function( lineheight = gp$lineheight, hjust = hjust, vjust = vjust, + segment.colour = element$segment.colour %||% colour %||% element$colour, point.size = 0, !!!defaults, nudge_x = x_nudge, From da2e37cfd1732bcce0d67a612abe0e54250d2135 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 2 Dec 2024 23:34:43 +0100 Subject: [PATCH 4/5] document --- NAMESPACE | 1 + R/element-text-repel.R | 51 ++++++++++++- man/element_text_repel.Rd | 146 ++++++++++++++++++++++++++++++++++++++ 3 files changed, 197 insertions(+), 1 deletion(-) create mode 100644 man/element_text_repel.Rd diff --git a/NAMESPACE b/NAMESPACE index 643d49a..93701a1 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -8,6 +8,7 @@ S3method(widthDetails,element_textrepeltree) export(GeomLabelRepel) export(GeomTextRepel) export(PositionNudgeRepel) +export(element_text_repel) export(geom_label_repel) export(geom_text_repel) export(position_nudge_repel) diff --git a/R/element-text-repel.R b/R/element-text-repel.R index b5742f4..7fdcac0 100644 --- a/R/element-text-repel.R +++ b/R/element-text-repel.R @@ -1,4 +1,53 @@ - +#' Repulsive text element +#' +#' This text element is a replacement for \code{\link[ggplot2]{element_text}} +#' that repulses labels. +#' +#' @inheritParams ggplot2::element_text +#' @inheritParams geom_text_repel +#' @param segment.colour,segment.linetype,segment.size Graphical parameters for +#' the line connecting the text to points of origin. +#' @param segment.curvature,segment.angle,segment.ncp,segment.shape,segment.square,segment.squareShape,segment.inflect +#' Settings for curving the connecting line. See \code{\link[grid]{curveGrob}} +#' for descriptions of these parameters. +#' @param position One of \code{"top"}, \code{"right"}, \code{"bottom"}, +#' \code{"left"} setting where the text labels should be relative to points +#' of origin. +#' +#' @return An object of class \code{}. +#' @export +#' +#' @examples +#' # A plot with a crowded y-axis +#' p <- ggplot(mtcars, aes(mpg, rownames(mtcars))) + +#' geom_col() + +#' coord_cartesian(ylim = c(-32, 64)) + +#' theme(axis.text.y = element_text_repel()) +#' +#' # By default there isn't enough space to draw distinctive lines +#' p +#' +#' # The available space can be increased by setting the margin +#' p + theme(axis.text.y.left = element_text_repel(margin = margin(r = 20))) +#' +#' # For secondary axis positions at the top and right, the `position` argument +#' # should be set accordingly +#' p + scale_y_discrete(position = "right") + +#' theme(axis.text.y.right = element_text_repel( +#' margin = margin(l = 20), +#' position = "right" +#' )) +#' +#' # Using segment settings and matching tick colour +#' p + theme( +#' axis.text.y.left = element_text_repel( +#' margin = margin(r = 20), +#' segment.curvature = -0.1, +#' segment.inflect = TRUE, +#' segment.colour = "red" +#' ), +#' axis.ticks.y.left = element_line(colour = "red") +#' ) element_text_repel <- function( # Generic text settings family = NULL, diff --git a/man/element_text_repel.Rd b/man/element_text_repel.Rd new file mode 100644 index 0000000..545425c --- /dev/null +++ b/man/element_text_repel.Rd @@ -0,0 +1,146 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/element-text-repel.R +\name{element_text_repel} +\alias{element_text_repel} +\title{Repulsive text element} +\usage{ +element_text_repel( + family = NULL, + face = NULL, + colour = NULL, + size = NULL, + hjust = NULL, + vjust = NULL, + angle = NULL, + lineheight = NULL, + color = NULL, + margin = NULL, + box.padding = NULL, + force = NULL, + force_pull = NULL, + max.time = NULL, + max.iter = NULL, + max.overlaps = NULL, + min.segment.length = NULL, + segment.colour = NULL, + segment.linetype = NULL, + segment.size = NULL, + segment.curvature = NULL, + segment.angle = NULL, + segment.ncp = NULL, + segment.shape = NULL, + segment.square = NULL, + segment.squareShape = NULL, + segment.inflect = NULL, + arrow = NULL, + seed = NA, + position = c("bottom", "top", "left", "right"), + inherit.blank = FALSE +) +} +\arguments{ +\item{family}{Font family} + +\item{face}{Font face ("plain", "italic", "bold", "bold.italic")} + +\item{colour, color}{Line/border colour. Color is an alias for colour.} + +\item{size}{text size in pts.} + +\item{hjust}{Horizontal justification (in \eqn{[0, 1]})} + +\item{vjust}{Vertical justification (in \eqn{[0, 1]})} + +\item{angle}{Angle (in \eqn{[0, 360]})} + +\item{lineheight}{Line height} + +\item{margin}{Margins around the text. See \code{\link[ggplot2:margin]{margin()}} for more +details. When creating a theme, the margins should be placed on the +side of the text facing towards the center of the plot.} + +\item{box.padding}{Amount of padding around bounding box, as unit or number. +Defaults to 0.25. (Default unit is lines, but other units can be specified +by passing \code{unit(x, "units")}).} + +\item{force}{Force of repulsion between overlapping text labels. Defaults +to 1.} + +\item{force_pull}{Force of attraction between a text label and its +corresponding data point. Defaults to 1.} + +\item{max.time}{Maximum number of seconds to try to resolve overlaps. +Defaults to 0.5.} + +\item{max.iter}{Maximum number of iterations to try to resolve overlaps. +Defaults to 10000.} + +\item{max.overlaps}{Exclude text labels when they overlap too many other +things. For each text label, we count how many other text labels or other +data points it overlaps, and exclude the text label if it has too many overlaps. +Defaults to 10.} + +\item{min.segment.length}{Skip drawing segments shorter than this, as unit or +number. Defaults to 0.5. (Default unit is lines, but other units can be +specified by passing \code{unit(x, "units")}).} + +\item{segment.colour, segment.linetype, segment.size}{Graphical parameters for +the line connecting the text to points of origin.} + +\item{segment.curvature, segment.angle, segment.ncp, segment.shape, segment.square, segment.squareShape, segment.inflect}{Settings for curving the connecting line. See \code{\link[grid]{curveGrob}} +for descriptions of these parameters.} + +\item{arrow}{Arrow specification, as created by \code{\link[grid:arrow]{grid::arrow()}}} + +\item{seed}{Random seed passed to \code{\link[base]{set.seed}}. Defaults to +\code{NA}, which means that \code{set.seed} will not be called.} + +\item{position}{One of \code{"top"}, \code{"right"}, \code{"bottom"}, +\code{"left"} setting where the text labels should be relative to points +of origin.} + +\item{inherit.blank}{Should this element inherit the existence of an +\code{element_blank} among its parents? If \code{TRUE} the existence of +a blank element among its parents will cause this element to be blank as +well. If \code{FALSE} any blank parent element will be ignored when +calculating final element state.} +} +\value{ +An object of class \code{}. +} +\description{ +This text element is a replacement for \code{\link[ggplot2]{element_text}} +that repulses labels. +} +\examples{ +# A plot with a crowded y-axis +p <- ggplot(mtcars, aes(mpg, rownames(mtcars))) + + geom_col() + + coord_cartesian(ylim = c(-32, 64)) + + theme(axis.text.y = element_text_repel()) + +# By default there isn't enough space to draw distinctive lines +p + +# The available space can be increased by setting the margin +p + theme(axis.text.y.left = element_text_repel(margin = margin(r = 20))) + +# For secondary axis positions at the top and right, the `position` argument +# should be set accordingly +p + scale_y_discrete(position = "right") + + theme(axis.text.y.right = element_text_repel( + margin = margin(l = 20), + position = "right" + )) + +# Using segment settings and matching tick colour +p + theme( + axis.text.y.left = element_text_repel( + margin = margin(r = 20), + segment.curvature = -0.1, + segment.inflect = TRUE, + segment.colour = "red" + ), + axis.ticks.y.left = element_line(colour = "red") +) +} From 3d1b03b0952c589eabfb815b6c551655b42e6f46 Mon Sep 17 00:00:00 2001 From: Teun van den Brand Date: Mon, 2 Dec 2024 23:39:19 +0100 Subject: [PATCH 5/5] add test --- .../element-text-repel/element-text-repel.svg | 170 ++++++++++++++++++ tests/testthat/test-element-text-repel.R | 81 +++++++++ 2 files changed, 251 insertions(+) create mode 100644 tests/testthat/_snaps/element-text-repel/element-text-repel.svg create mode 100644 tests/testthat/test-element-text-repel.R diff --git a/tests/testthat/_snaps/element-text-repel/element-text-repel.svg b/tests/testthat/_snaps/element-text-repel/element-text-repel.svg new file mode 100644 index 0000000..131ef2d --- /dev/null +++ b/tests/testthat/_snaps/element-text-repel/element-text-repel.svg @@ -0,0 +1,170 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Lorem ipsum +dolor amet +consectetur +adipiscing +elit + + + + + +Lorem ipsum +dolor amet +consectetur +adipiscing +elit + + + + + + + + + + + + + + + +Lorem ipsum +dolor amet +consectetur +adipiscing +elit + + + + + + + + + + +Lorem ipsum +dolor amet +consectetur +adipiscing +elit +x +x + +x + + + + + + + + + + + + + + + + +Lorem ipsum +dolor amet +consectetur +adipiscing +elit + +labels + + + + + + + + + + + + + +adipiscing +consectetur +dolor amet +elit +Lorem ipsum +element_text_repel + + diff --git a/tests/testthat/test-element-text-repel.R b/tests/testthat/test-element-text-repel.R new file mode 100644 index 0000000..f49c8ad --- /dev/null +++ b/tests/testthat/test-element-text-repel.R @@ -0,0 +1,81 @@ +test_that("element_text_repel positions are interpreted correctly", { + + # Unit calculations require an active device + tmp <- tempfile(fileext = ".pdf") + pdf(tmp) + withr::defer({ + dev.off() + unlink(tmp) + }) + + columns <- c("x", "y", "nudge_x", "nudge_y") + + examplar <- calc_element("text", theme_get()) + element <- element_text_repel(margin = margin(1, 1, 1, 1, "cm")) + el <- merge_element(element, examplar) + + grob <- element_grob(el, label = "foo") + expect_s3_class(grob, "titleGrob") + + grob <- element_grob(el, label = "foo", x = 0.25) + expect_s3_class(grob, "element_textrepeltree") + data <- unlist(grob$data[columns], use.names = FALSE) + expect_equal(data, c(0.25, 1, 0, 0)) + + grob <- element_grob(el, label = "foo", y = 0.25) + data <- unlist(grob$data[columns], use.names = FALSE) + expect_equal(data, c(1, 0.25, 0, 0)) + + el$position <- "right" + grob <- element_grob(el, label = "foo", y = 0.25) + data <- unlist(grob$data[columns], use.names = FALSE) + expect_equal(data, c(0, 0.25, 0, 0)) + + el$position <- "top" + grob <- element_grob(el, label = "foo", x = 0.25) + data <- unlist(grob$data[columns], use.names = FALSE) + expect_equal(data, c(0.25, 0, 0, 0)) + +}) + +test_that("element_text_repel renders as expected", { + + x <- c(0, 4.9, 5, 5.1, 10) + labels <- c("Lorem ipsum", "dolor amet", "consectetur", "adipiscing", "elit") + + p <- ggplot(mapping = aes(x, x, colour = x, shape = labels)) + + geom_point() + + scale_x_continuous(breaks = x, labels = labels) + + scale_y_continuous(breaks = x, labels = labels) + + scale_colour_viridis_c(breaks = x, labels = labels) + + guides(x.sec = "axis", y.sec = "axis") + + theme( + axis.text.x.bottom = element_text_repel( + margin = margin(t = 10), + colour = "dodgerblue", + seed = 42 + ), + axis.text.y.left = element_text_repel( + margin = margin(r = 10), + segment.colour = "dodgerblue", + seed = 42 + ), + axis.text.x.top = element_text_repel( + margin = margin(b = 10), position = "top", + arrow = arrow(length = unit(2, "mm")), + seed = 42 + ), + axis.text.y.right = element_text_repel( + margin = margin(l = 10), position = "right", + segment.curvature = 0.1, segment.inflect = TRUE, + seed = 42 + ), + legend.text = element_text_repel( + margin = margin(l = 10), position = "right", + segment.linetype = "dotted", colour = "dodgerblue", + seed = 42 + ) + ) + + vdiffr::expect_doppelganger("element_text_repel", p) +})