Fix for position = "inside" (#51)

* customise `check_position()` * resolve `position = "inside"` as right-positioned * include inside where appropriate * add news bullet
teunbrand · Feb 15, 2025 · 073ae43 · 073ae43
1 parent 3dc2b3a
commit 073ae43
Show file tree

Hide file tree

Showing 9 changed files with 42 additions and 14 deletions.
diff --git a/NEWS.md b/NEWS.md
@@ -1,5 +1,7 @@
 # legendry (development version)
 
+* Fixed bug hindering `position = "inside"` placement (#42)
+
 # legendry 0.2.0
 
 This is a small feature release introducing dendrogram scales and a size guide.

diff --git a/R/compose-.R b/R/compose-.R
@@ -77,7 +77,7 @@ Compose <- ggproto(
     title <- scale$make_title(params$title %|W|% scale$name %|W|% title)
     position  <- params$position  <- params$position %|W|% NULL
     aesthetic <- params$aesthetic <- aesthetic %||% scale$aesthetics[1]
-    check_position(position, allow_null = TRUE)
+    check_position(position, inside = TRUE, allow_null = TRUE)
 
     key <- resolve_key(params$key, allow_null = TRUE)
     if (is.function(key)) {

diff --git a/R/compose-crux.R b/R/compose-crux.R
@@ -126,7 +126,7 @@ ComposeCrux <- ggproto(
     elements$text_position <- elements$text_position %||%
       switch(params$direction, horizontal = "bottom", vertical = "right")
 
-    check_position(elements$title_position, .trbl, arg = "legend.title.position")
+    check_position(elements$title_position, theta = FALSE, arg = "legend.title.position")
     elements
   },
 
@@ -139,9 +139,10 @@ ComposeCrux <- ggproto(
       return(zeroGrob())
     }
 
-    position  <- params$position  <- params$position  %||% position
     direction <- params$direction <- params$direction %||% direction
-    check_position(position, .trbl)
+    position  <- params$position  <- params$position  %||% position
+    position  <- switch(position, inside = "right", position)
+    check_position(position)
     check_argmatch(direction, c("horizontal", "vertical"))
 
     theme <- theme + params$theme

diff --git a/R/compose-stack.R b/R/compose-stack.R
@@ -147,6 +147,7 @@ ComposeStack <- ggproto(
 
     theme <- theme + params$theme
     position <- params$position <- params$position  %||% position
+    position <- switch(position, inside = "right", position)
     check_position(position)
     params$guide_params <-
       set_list_element(params$guide_params, "position", position)

diff --git a/R/guide-colring.R b/R/guide-colring.R
@@ -239,7 +239,7 @@ GuideColring <- ggproto(
   override_elements = function(params, elements, theme) {
     elements$title_position <- elements$title_position %||%
       switch(params$direction, horizontal = "left", vertical = "top")
-    check_position(elements$title_position, .trbl, arg = "legend.title.position")
+    check_position(elements$title_position, theta = FALSE, arg = "legend.title.position")
     elements$width <- cm(elements$width)
     elements$size  <- cm(elements$size) * 5
     elements$margin <- elements$margin %||% margin()
@@ -252,7 +252,8 @@ GuideColring <- ggproto(
 
     position  <- params$position  <- params$position  %||% position
     direction <- params$direction <- params$direction %||% direction
-    check_position(position, .trbl)
+    position  <- switch(position, inside = "right", position)
+    check_position(position, theta = FALSE)
     check_argmatch(direction, c("horizontal", "vertical"))
 
     theme <- theme + params$theme

diff --git a/R/guide-legend-base.R b/R/guide-legend-base.R
@@ -72,7 +72,7 @@ guide_legend_base <- function(
   order = 0
 ) {
 
-  check_position(position, allow_null = TRUE)
+  check_position(position, theta = FALSE, inside = TRUE, allow_null = TRUE)
   check_argmatch(direction, c("horizontal", "vertical"), allow_null = TRUE)
   check_bool(reverse)
   check_number_whole(nrow, min = 1, allow_null = TRUE)

diff --git a/R/guide-legend-cross.R b/R/guide-legend-cross.R
@@ -73,7 +73,7 @@ guide_legend_cross <- function(
   order = 0
 ) {
 
-  check_position(position, allow_null = TRUE)
+  check_position(position, theta = FALSE, inside = TRUE, allow_null = TRUE)
   check_argmatch(direction, c("horizontal", "vertical"), allow_null = TRUE)
   check_bool(swap)
 

diff --git a/R/guide-legend-group.R b/R/guide-legend-group.R
@@ -67,7 +67,7 @@ guide_legend_group <- function(
   order = 0
 ) {
 
-  check_position(position, allow_null = TRUE)
+  check_position(position, theta = FALSE, inside = TRUE, allow_null = TRUE)
   check_argmatch(direction, c("horizontal", "vertical"), allow_null = TRUE)
   check_number_whole(nrow, min = 1, allow_null = TRUE)
   check_number_whole(ncol, min = 1, allow_null = TRUE)

diff --git a/R/utils-checks.R b/R/utils-checks.R
@@ -215,11 +215,34 @@ check_argmatch <- function(
   )
 }
 
-check_position <- new_function(
-  `[[<-`(fn_fmls(check_argmatch), "options", .trblt),
-  body(check_argmatch),
-  fn_env(check_argmatch)
-)
+check_position <- function(
+    x, options = .trbl, theta = TRUE, inside = FALSE,
+    ...,
+    allow_null = FALSE,
+    arg = caller_arg(x), call = caller_env()
+) {
+  if (!missing(x)) {
+    if (allow_null && is_null(x)) {
+      return(invisible(NULL))
+    }
+    if (is.character(x)) {
+      if (theta) {
+        options <- c(options, "theta", "theta.sec")
+      }
+      if (inside) {
+        options <- c(options, "inside")
+      }
+      arg_match0(x, options, arg_nm = arg, error_call = call)
+      return(invisible(NULL))
+    }
+  }
+
+  stop_input_type(
+    x, "a single string", ...,
+    allow_na = FALSE, allow_null = allow_null,
+    arg = arg, call = call
+  )
+}
 
 check_unique <- function(x, arg = caller_arg(x), call = caller_env()) {
   if (!vec_duplicate_any(x)) {