Skip to content

Commit 202b80d

Browse files
teunbrandteunbrand
committed
convert element_grob to S7 generic
1 parent 8c199a1 commit 202b80d

File tree

3 files changed

+103
-115
lines changed

3 files changed

+103
-115
lines changed

‎NAMESPACE

Lines changed: 0 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -18,12 +18,6 @@ S3method(autolayer,default)
1818
S3method(autoplot,default)
1919
S3method(c,mapped_discrete)
2020
S3method(drawDetails,zeroGrob)
21-
S3method(element_grob,element_blank)
22-
S3method(element_grob,element_line)
23-
S3method(element_grob,element_point)
24-
S3method(element_grob,element_polygon)
25-
S3method(element_grob,element_rect)
26-
S3method(element_grob,element_text)
2721
S3method(format,ggproto)
2822
S3method(format,ggproto_method)
2923
S3method(fortify,"NULL")

‎R/theme-elements.R

Lines changed: 102 additions & 109 deletions
Original file line numberDiff line numberDiff line change
@@ -321,134 +321,127 @@ element_render <- function(theme, element, ..., name = NULL) {
321321
#' usually at least position. See the source code for individual methods.
322322
#' @keywords internal
323323
#' @export
324-
element_grob <- function(element, ...) {
325-
UseMethod("element_grob")
326-
}
324+
element_grob <- S7::new_generic("element_grob", "element")
327325

328-
#' @export
329-
element_grob.element_blank <- function(element, ...) zeroGrob()
326+
S7::method(element_grob, element_blank) <- function(element, ...) zeroGrob()
330327

331-
#' @export
332-
element_grob.element_rect <- function(element, x = 0.5, y = 0.5,
333-
width = 1, height = 1,
334-
fill = NULL, colour = NULL, linewidth = NULL, linetype = NULL, ..., size = deprecated()) {
328+
S7::method(element_grob, element_rect) <-
329+
function(element, x = 0.5, y = 0.5, width = 1, height = 1,
330+
fill = NULL, colour = NULL, linewidth = NULL, linetype = NULL,
331+
..., size = deprecated()) {
335332

336-
if (lifecycle::is_present(size)) {
337-
deprecate_soft0("3.4.0", "element_grob.element_rect(size)", "element_grob.element_rect(linewidth)")
338-
linewidth <- size
339-
}
333+
if (lifecycle::is_present(size)) {
334+
deprecate_soft0("3.4.0", "element_grob.element_rect(size)", "element_grob.element_rect(linewidth)")
335+
linewidth <- size
336+
}
340337

341-
# The gp settings can override element_gp
342-
gp <- gg_par(lwd = linewidth, col = colour, fill = fill, lty = linetype)
343-
element_gp <- gg_par(lwd = element$linewidth, col = element$colour,
344-
fill = element$fill, lty = element$linetype)
338+
gp <- gg_par(lwd = linewidth, col = colour, fill = fill, lty = linetype)
339+
element_gp <- gg_par(lwd = element@linewidth, col = element@colour,
340+
fill = element@fill, lty = element@linetype)
345341

346-
rectGrob(x, y, width, height, gp = modify_list(element_gp, gp), ...)
347-
}
342+
rectGrob(x, y, width, height, gp = modify_list(element_gp, gp), ...)
343+
}
348344

345+
S7::method(element_grob, element_text) <-
346+
function(element, label = "", x = NULL, y = NULL,
347+
family = NULL, face = NULL, colour = NULL, size = NULL,
348+
hjust = NULL, vjust = NULL, angle = NULL, lineheight = NULL,
349+
margin = NULL, margin_x = FALSE, margin_y = FALSE, ...) {
349350

350-
#' @export
351-
element_grob.element_text <- function(element, label = "", x = NULL, y = NULL,
352-
family = NULL, face = NULL, colour = NULL, size = NULL,
353-
hjust = NULL, vjust = NULL, angle = NULL, lineheight = NULL,
354-
margin = NULL, margin_x = FALSE, margin_y = FALSE, ...) {
351+
if (is.null(label))
352+
return(zeroGrob())
355353

356-
if (is.null(label))
357-
return(zeroGrob())
354+
vj <- vjust %||% element@vjust
355+
hj <- hjust %||% element@hjust
356+
margin <- margin %||% element@margin
358357

359-
vj <- vjust %||% element$vjust
360-
hj <- hjust %||% element$hjust
361-
margin <- margin %||% element$margin
358+
angle <- angle %||% element@angle %||% 0
362359

363-
angle <- angle %||% element$angle %||% 0
360+
# The gp settings can override element_gp
361+
gp <- gg_par(fontsize = size, col = colour,
362+
fontfamily = family, fontface = face,
363+
lineheight = lineheight)
364+
element_gp <- gg_par(fontsize = element@size, col = element@colour,
365+
fontfamily = element@family, fontface = element@face,
366+
lineheight = element@lineheight)
364367

365-
# The gp settings can override element_gp
366-
gp <- gg_par(fontsize = size, col = colour,
367-
fontfamily = family, fontface = face,
368-
lineheight = lineheight)
369-
element_gp <- gg_par(fontsize = element$size, col = element$colour,
370-
fontfamily = element$family, fontface = element$face,
371-
lineheight = element$lineheight)
368+
titleGrob(label, x, y, hjust = hj, vjust = vj, angle = angle,
369+
gp = modify_list(element_gp, gp), margin = margin,
370+
margin_x = margin_x, margin_y = margin_y, debug = element@debug, ...)
371+
}
372372

373-
titleGrob(label, x, y, hjust = hj, vjust = vj, angle = angle,
374-
gp = modify_list(element_gp, gp), margin = margin,
375-
margin_x = margin_x, margin_y = margin_y, debug = element$debug, ...)
376-
}
373+
S7::method(element_grob, element_line) <-
374+
function(element, x = 0:1, y = 0:1,
375+
colour = NULL, linewidth = NULL, linetype = NULL, lineend = NULL,
376+
arrow.fill = NULL,
377+
default.units = "npc", id.lengths = NULL, ..., size = deprecated()) {
377378

379+
if (lifecycle::is_present(size)) {
380+
deprecate_soft0("3.4.0", "element_grob.element_line(size)", "element_grob.element_line(linewidth)")
381+
linewidth <- size
382+
}
378383

384+
arrow <- if (is.logical(element@arrow) && !element@arrow) {
385+
NULL
386+
} else {
387+
element@arrow
388+
}
389+
if (is.null(arrow)) {
390+
arrow.fill <- colour
391+
element@arrow.fill <- element@colour
392+
}
379393

380-
#' @export
381-
element_grob.element_line <- function(element, x = 0:1, y = 0:1,
382-
colour = NULL, linewidth = NULL, linetype = NULL, lineend = NULL,
383-
arrow.fill = NULL,
384-
default.units = "npc", id.lengths = NULL, ..., size = deprecated()) {
385-
386-
if (lifecycle::is_present(size)) {
387-
deprecate_soft0("3.4.0", "element_grob.element_line(size)", "element_grob.element_line(linewidth)")
388-
linewidth <- size
389-
}
394+
# The gp settings can override element_gp
395+
gp <- gg_par(
396+
col = colour, fill = arrow.fill %||% colour,
397+
lwd = linewidth, lty = linetype, lineend = lineend
398+
)
399+
element_gp <- gg_par(
400+
col = element@colour, fill = element@arrow.fill %||% element@colour,
401+
lwd = element@linewidth, lty = element@linetype,
402+
lineend = element@lineend
403+
)
390404

391-
arrow <- if (is.logical(element$arrow) && !element$arrow) {
392-
NULL
393-
} else {
394-
element$arrow
395-
}
396-
if (is.null(arrow)) {
397-
arrow.fill <- colour
398-
element$arrow.fill <- element$colour
405+
polylineGrob(
406+
x, y, default.units = default.units,
407+
gp = modify_list(element_gp, gp),
408+
id.lengths = id.lengths, arrow = arrow, ...
409+
)
399410
}
400411

401-
# The gp settings can override element_gp
402-
gp <- gg_par(
403-
col = colour, fill = arrow.fill %||% colour,
404-
lwd = linewidth, lty = linetype, lineend = lineend
405-
)
406-
element_gp <- gg_par(
407-
col = element$colour, fill = element$arrow.fill %||% element$colour,
408-
lwd = element$linewidth, lty = element$linetype,
409-
lineend = element$lineend
410-
)
411-
412-
polylineGrob(
413-
x, y, default.units = default.units,
414-
gp = modify_list(element_gp, gp),
415-
id.lengths = id.lengths, arrow = arrow, ...
416-
)
417-
}
418-
419-
#' @export
420-
element_grob.element_polygon <- function(element, x = c(0, 0.5, 1, 0.5),
421-
y = c(0.5, 1, 0.5, 0), fill = NULL,
422-
colour = NULL, linewidth = NULL,
423-
linetype = NULL, ...,
424-
id = NULL, id.lengths = NULL,
425-
pathId = NULL, pathId.lengths = NULL) {
426-
427-
gp <- gg_par(lwd = linewidth, col = colour, fill = fill, lty = linetype)
428-
element_gp <- gg_par(lwd = element$linewidth, col = element$colour,
429-
fill = element$fill, lty = element$linetype)
430-
pathGrob(
431-
x = x, y = y, gp = modify_list(element_gp, gp), ...,
432-
# We swap the id logic so that `id` is always the (super)group id
433-
# (consistent with `polygonGrob()`) and `pathId` always the subgroup id.
434-
pathId = id, pathId.lengths = id.lengths,
435-
id = pathId, id.lengths = pathId.lengths
436-
)
437-
}
412+
S7::method(element_grob, element_polygon) <-
413+
function(element, x = c(0, 0.5, 1, 0.5),
414+
y = c(0.5, 1, 0.5, 0), fill = NULL,
415+
colour = NULL, linewidth = NULL,
416+
linetype = NULL, ...,
417+
id = NULL, id.lengths = NULL,
418+
pathId = NULL, pathId.lengths = NULL) {
419+
420+
gp <- gg_par(lwd = linewidth, col = colour, fill = fill, lty = linetype)
421+
element_gp <- gg_par(lwd = element@linewidth, col = element@colour,
422+
fill = element@fill, lty = element@linetype)
423+
pathGrob(
424+
x = x, y = y, gp = modify_list(element_gp, gp), ...,
425+
# We swap the id logic so that `id` is always the (super)group id
426+
# (consistent with `polygonGrob()`) and `pathId` always the subgroup id.
427+
pathId = id, pathId.lengths = id.lengths,
428+
id = pathId, id.lengths = pathId.lengths
429+
)
430+
}
438431

439-
#' @export
440-
element_grob.element_point <- function(element, x = 0.5, y = 0.5, colour = NULL,
441-
shape = NULL, fill = NULL, size = NULL,
442-
stroke = NULL, ...,
443-
default.units = "npc") {
444-
445-
gp <- gg_par(col = colour, fill = fill, pointsize = size, stroke = stroke)
446-
element_gp <- gg_par(col = element$colour, fill = element$fill,
447-
pointsize = element$size, stroke = element$stroke)
448-
shape <- translate_shape_string(shape %||% element$shape %||% 19)
449-
pointsGrob(x = x, y = y, pch = shape, gp = modify_list(element_gp, gp),
450-
default.units = default.units, ...)
451-
}
432+
S7::method(element_grob, element_point) <-
433+
function(element, x = 0.5, y = 0.5, colour = NULL,
434+
shape = NULL, fill = NULL, size = NULL,
435+
stroke = NULL, ...,
436+
default.units = "npc") {
437+
438+
gp <- gg_par(col = colour, fill = fill, pointsize = size, stroke = stroke)
439+
element_gp <- gg_par(col = element@colour, fill = element@fill,
440+
pointsize = element@size, stroke = element@stroke)
441+
shape <- translate_shape_string(shape %||% element@shape %||% 19)
442+
pointsGrob(x = x, y = y, pch = shape, gp = modify_list(element_gp, gp),
443+
default.units = default.units, ...)
444+
}
452445

453446
#' Define and register new theme elements
454447
#'

‎R/zzz.R

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -30,6 +30,7 @@ on_load(
3030
vars <- dplyr::vars
3131
}
3232
)
33+
on_load(S7::methods_register())
3334
.onLoad <- function(...) {
3435
run_on_load()
3536
}

0 commit comments

Comments
 (0)