tests for ph_location_id()

davidgohel · Sep 19, 2024 · 9a16b96 · 9a16b96
1 parent 1fdfde0
commit 9a16b96
Show file tree

Hide file tree

Showing 2 changed files with 75 additions and 11 deletions.
diff --git a/R/ph_location.R b/R/ph_location.R
@@ -15,13 +15,18 @@ get_ph_loc <- function(x, layout, master, type, type_idx = NULL, position_right,
   props <- layout_properties(x, layout = layout, master = master)
 
   if (!is.null(ph_id)) {
-    ids <- sort(props$id)
+    ids <- sort(na.omit(as.numeric(props$id)))
+    if (length(ids) <= 20) {
+      .all_ids_switch <- c("x" = "Available ids:  {.val {ids}}.") # only if few ids
+    } else {
+      .all_ids_switch <- NULL
+    }
     if (!ph_id %in% ids) {
       cli::cli_abort(
         c(
-          "{.arg id} does not exist.",
-          "x" = "Must be one of  {.val {ids}}.",
-          "i" = cli::col_grey("see column {.val id} in {.code layout_properties(x, '{layout}', '{master}')}")
+          "{.arg id} {.val {ph_id}} does not exist.",
+          .all_ids_switch,
+          "i" = cli::col_grey("see column {.val id} in {.code layout_properties(..., '{layout}', '{master}')}")
         ),
         call = NULL
       )
@@ -576,6 +581,13 @@ fortify_location.location_right <- function( x, doc, ...){
 ph_location_id <- function(id, newlabel = NULL, ...) {
   ph_id <- id # for disambiguation, store initial value
 
+  if (length(ph_id) > 1) {
+    cli::cli_abort(
+      c("{.arg id} must be {cli::style_underline('one')} number",
+        "x" = "Found more than one entry: {.val {ph_id}}"
+      )
+    )
+  }
   if (is.null(ph_id) || is.na(ph_id) || length(ph_id) == 0) {
     cli::cli_abort("{.arg id} must be a positive number")
   }
@@ -589,13 +601,6 @@ ph_location_id <- function(id, newlabel = NULL, ...) {
       )
     }
   }
-  if (length(ph_id) > 1) {
-    cli::cli_abort(
-      c("{.arg id} must be {cli::style_underline('one')} number",
-        "x" = "Found {.val {length(ph_id)}} numbers instead: {.val {ph_id}}"
-      )
-    )
-  }
   if (ph_id < 1) {
     cli::cli_abort(
       c("{.arg id} must be a {cli::style_underline('positive')} number",

diff --git a/tests/testthat/test-pptx-add.R b/tests/testthat/test-pptx-add.R
@@ -387,6 +387,64 @@ test_that("pptx ph_location_type", {
 })
 
 
+test_that("pptx ph_location_id", {
+  opts <- options(cli.num_colors = 1) # no colors for easier error message check
+  on.exit(options(opts))
+
+  # direct errors
+  error_exp <- "`id` must be one number"
+  expect_error(ph_location_id(id = 1:2), regex = error_exp, fixed = TRUE)
+  expect_error(ph_location_id(id = -1:1), regex = error_exp, fixed = TRUE)
+  expect_error(ph_location_id(id = c("A", "B")), regex = error_exp, fixed = TRUE)
+  expect_error(ph_location_id(id = c(NA, NA)), regex = error_exp, fixed = TRUE)
+
+  error_exp <- "`id` must be a positive number"
+  expect_error(ph_location_id(id = NULL), regex = error_exp, fixed = TRUE)
+  expect_error(ph_location_id(id = NA), regex = error_exp, fixed = TRUE)
+  expect_error(ph_location_id(id = NaN), regex = error_exp, fixed = TRUE)
+  expect_error(ph_location_id(id = character(0)), regex = error_exp, fixed = TRUE)
+  expect_error(ph_location_id(id = integer(0)), regex = error_exp, fixed = TRUE)
+
+  expect_error(ph_location_id(id = "A"), regex = 'Cannot convert "A" to integer', fixed = TRUE)
+  expect_error(ph_location_id(id = ""), regex = 'Cannot convert "" to integer', fixed = TRUE)
+  expect_error(ph_location_id(id = Inf), regex = "Cannot convert Inf to integer", fixed = TRUE)
+  expect_error(ph_location_id(id = -Inf), regex = "Cannot convert -Inf to integer", fixed = TRUE)
+
+  error_exp <- "`id` must be a positive number"
+  expect_error(ph_location_id(id = 0), regex = error_exp, fixed = TRUE)
+  expect_error(ph_location_id(id = -1), regex = error_exp, fixed = TRUE)
+
+  # downstream errors
+  x <- read_pptx()
+  x <- x |> add_slide("Comparison")
+
+  expect_error(
+    {
+      x |> ph_with("id does not exist", ph_location_id(id = 1000))
+    },
+    "`id` 1000 does not exist",
+    fixed = TRUE
+  )
+
+  # test for correct results
+  expect_no_error({
+    ids <- layout_properties(x, "Comparison")$id
+    for (id in ids) {
+      x |> ph_with(paste("text:", id), ph_location_id(id, newlabel = paste("newlabel:", id)))
+    }
+  })
+  nodes <- xml_find_all(
+    x = x$slide$get_slide(1)$get(),
+    xpath = "/p:sld/p:cSld/p:spTree/p:sp"
+  )
+  # text inside phs
+  expect_true(all(xml_text(nodes) == paste("text:", ids)))
+  # assigned shape names
+  all_nvpr <- xml_find_all(nodes, "./p:nvSpPr/p:cNvPr")
+  expect_true(all(xml_attr(all_nvpr, "name") == paste("newlabel:", ids)))
+})
+
+
 test_that("pptx ph labels", {
   doc <- read_pptx()
   doc <- add_slide(doc, "Title and Content", "Office Theme")
@@ -429,6 +487,7 @@ test_that("pptx ph labels", {
 })
 
 
+
 test_that("as_ph_location", {
   ref_names <- c("width", "height", "left", "top", "ph_label", "ph", "type", "rotation", "fld_id", "fld_type")
   l <- replicate(length(ref_names), "dummy", simplify = FALSE)