Shapes provided via strings instead of integers (#2338)

* Add shape string translate function

* Call translate_shape_string from geom_point if shape is a character

* Call translate_shape_string from scale_shape_manual if character

* Tidy-up/changing pch strings

* Updated NEWS.md

* Sryle fixes

* Style fixes

* Remove paste() from stop()

* Update translate_shape_string() function

* Remove shape string translation from manual scales (is superfluous)

* Add shape string translation to draw_key_point()

* Strip names from translated shape integer vector

* translate_shape_string() tests

* Rename shape translate test file

* Fix style

* Adhere to error message guidelines

* Remove superfluous tests and merge two tests for invalidity

* Adjust geom-point tests

* Remove merge remnants

* Add "triangle square" as an alias for "square triangle" shape

* Add shape name example in aesthetic vignette

* Quick formatting adjustments

* Replace startsWith for <= 3.2 compatibility

Author: daniel-barnett

NEWS.md

@@ -172,6 +172,9 @@ up correct aspect ratio, and draws a graticule.
 * `guide_train()`, `guide_merge()`, `guide_geom()`, and `guide_gengrob()`
   are now exported as they are needed if you want to design your own guide.
   They are not currently documented; use at your own risk (#2528).
+  
+* Shapes can now be provided using strings instead of integers (i.e.
+  `geom_point(shape = "diamond")`) (@daniel-barnett, #2075). 
 
 ## Breaking changes
 

R/geom-point.r

@@ -126,6 +126,10 @@ GeomPoint <- ggproto("GeomPoint", Geom,
   ),
 
   draw_panel = function(data, panel_params, coord, na.rm = FALSE) {
+    if (is.character(data$shape)) {
+      data$shape <- translate_shape_string(data$shape)
+    }
+
     coords <- coord$transform(data, panel_params)
     ggname("geom_point",
       pointsGrob(
@@ -144,3 +148,91 @@ GeomPoint <- ggproto("GeomPoint", Geom,
 
   draw_key = draw_key_point
 )
+
+translate_shape_string <- function(shape_string) {
+  if (nchar(shape_string[1]) == 1) {
+    return(shape_string)
+  }
+
+  pch_table <- c(
+    "square open"           = 0,
+    "circle open"           = 1,
+    "triangle open"         = 2,
+    "plus"                  = 3,
+    "cross"                 = 4,
+    "diamond open"          = 5,
+    "triangle down open"    = 6,
+    "square cross"          = 7,
+    "asterisk"              = 8,
+    "diamond plus"          = 9,
+    "circle plus"           = 10,
+    "star"                  = 11,
+    "square plus"           = 12,
+    "circle cross"          = 13,
+    "square triangle"       = 14,
+    "triangle square"       = 14,
+    "square"                = 15,
+    "circle small"          = 16,
+    "triangle"              = 17,
+    "diamond"               = 18,
+    "circle"                = 19,
+    "bullet"                = 20,
+    "circle filled"         = 21,
+    "square filled"         = 22,
+    "diamond filled"        = 23,
+    "triangle filled"       = 24,
+    "triangle down filled"  = 25
+  )
+
+  shape_match <- charmatch(shape_string, names(pch_table))
+
+  invalid_strings <- is.na(shape_match)
+  nonunique_strings <- shape_match == 0
+
+  if (any(invalid_strings)) {
+    bad_string <- unique(shape_string[invalid_strings])
+    n_bad <- length(bad_string)
+
+    collapsed_names <- sprintf("\n* '%s'", bad_string[1:min(5, n_bad)])
+
+    more_problems <- if (n_bad > 5) {
+      sprintf("\n* ... and %d more problem%s", n_bad - 5, ifelse(n_bad > 6, "s", ""))
+    }
+
+    stop(
+      "Can't find shape name:",
+      collapsed_names,
+      more_problems,
+      call. = FALSE
+    )
+  }
+
+  if (any(nonunique_strings)) {
+    bad_string <- unique(shape_string[nonunique_strings])
+    n_bad <- length(bad_string)
+
+    n_matches <- vapply(
+      bad_string[1:min(5, n_bad)],
+      function(shape_string) sum(grepl(paste0("^", shape_string), names(pch_table))),
+      integer(1)
+    )
+
+    collapsed_names <- sprintf(
+      "\n* '%s' partially matches %d shape names",
+      bad_string[1:min(5, n_bad)], n_matches
+    )
+
+    more_problems <- if (n_bad > 5) {
+      sprintf("\n* ... and %d more problem%s", n_bad - 5, ifelse(n_bad > 6, "s", ""))
+    }
+
+    stop(
+      "Shape names must be unambiguous:",
+      collapsed_names,
+      more_problems,
+      call. = FALSE
+    )
+  }
+
+  unname(pch_table[shape_match])
+}

R/legend-draw.r

@@ -15,6 +15,10 @@ NULL
 #' @export
 #' @rdname draw_key
 draw_key_point <- function(data, params, size) {
+  if (is.character(data$shape)) {
+    data$shape <- translate_shape_string(data$shape)
+  }
+
   pointsGrob(0.5, 0.5,
     pch = data$shape,
     gp = gpar(

tests/testthat/test-geom-point.R

@@ -0,0 +1,26 @@
+context("geom-point")
+
+test_that("single strings translate to their corresponding integers", {
+  expect_equal(translate_shape_string("square open"), 0)
+})
+
+test_that("vectors of strings translate to corresponding integers", {
+  shape_strings <- c(
+    "square open",
+    "circle open",
+    "square open",
+    "triangle open"
+  )
+
+  expect_equal(translate_shape_string(shape_strings), c(0, 1, 0, 2))
+})
+
+test_that("single characters are not translated to integers", {
+  expect_equal(translate_shape_string(letters), letters)
+  expect_equal(translate_shape_string(as.character(0:9)), as.character(0:9))
+})
+
+test_that("invalid shape names raise an error", {
+  expect_error(translate_shape_string("void"), "Can't find shape name")
+  expect_error(translate_shape_string("tri"), "Shape names must be unambiguous")
+})

vignettes/ggplot2-specs.Rmd

@@ -143,7 +143,7 @@ The border of the polygon is controlled by the `colour`, `linetype`, and `size`
 
 ### Shape {#sec:shape-spec}
 
-Shapes take four types of values:
+Shapes take five types of values:
 
 *   An __integer__ in $[0, 25]$:
 
@@ -161,6 +161,32 @@ Shapes take four types of values:
       scale_x_continuous(NULL, breaks = NULL) + 
       scale_y_continuous(NULL, breaks = NULL)
     ```
+   
+*   The __name__ of the shape:
+     
+```{r out.width = "90%", fig.asp = 0.4, fig.width = 8}
+shape_names <- c(
+  "circle", paste("circle", c("open", "filled", "cross", "plus", "small")), "bullet",
+  "square", paste("square", c("open", "filled", "cross", "plus", "triangle")),
+  "diamond", paste("diamond", c("open", "filled", "plus")),
+  "triangle", paste("triangle", c("open", "filled", "square")),
+  paste("triangle down", c("open", "filled")),
+  "plus", "cross", "asterisk"
+)
+
+shapes <- data.frame(
+  shape_names = shape_names,
+  x = c(1:7, 1:6, 1:3, 5, 1:3, 6, 2:3, 1:3),
+  y = -rep(1:6, c(7, 6, 4, 4, 2, 3))
+)
+
+ggplot(shapes, aes(x, y)) +
+  geom_point(aes(shape = shape_names), fill = "red", size = 5) +
+  geom_text(aes(label = shape_names), nudge_y = -0.3, size = 3.5) +
+  scale_shape_identity() +
+  scale_x_continuous(NULL, breaks = NULL) +
+  scale_y_continuous(NULL, breaks = NULL)
+```
 
 *   A __single character__, to use that character as a plotting symbol.