fix: ph_location_type() - throw error for out of range type id and mo…

…re info if ph type not present

`ph_location_type()` now throws an informative error if ...
- `id` for a `type` is our of range (#602)
- type exists but is not present in current layout

also: improved error message if type is unknown

close #601
close #603
fix #602

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: officer
 Title: Manipulation of Microsoft Word and PowerPoint Documents
-Version: 0.6.7.009
+Version: 0.6.7.010
 Authors@R: c(
     person("David", "Gohel", , "[email protected]", role = c("aut", "cre")),
     person("Stefan", "Moog", , "[email protected]", role = "aut"),

NEWS.md

@@ -15,6 +15,8 @@ For example, `slideLayout2.xml` will now preceed `slideLayout10.xml`. Before, al
 - `layout_properties()` now returns all placeholders in case of multiple master (#597). Also, the internal `xfrmize()` 
 now sorts the resulting data by placeholder position. This yields an intuitive order, with placeholders sorted from 
 top to bottom and left to right.
+- `ph_location_type()` now throws an error if the `id` for a `type` is out of range (#602) and a more 
+informative error message if the type is not present in layout (#601).
 
 ## Features
 

R/ph_location.R

@@ -1,35 +1,50 @@
-get_ph_loc <- function(x, layout, master, type, position_right, position_top, id = NULL){
-
-  props <- layout_properties( x, layout = layout, master = master )
+get_ph_loc <- function(x, layout, master, type, position_right, position_top, id = NULL) {
+  props <- layout_properties(x, layout = layout, master = master)
+  types_on_layout <- unique(props$type)
   props <- props[props$type %in% type, , drop = FALSE]
-
-  if( nrow(props) < 1) {
-    stop("no selected row")
+  nr <- nrow(props)
+  if (nr < 1) {
+    cli::cli_abort(c(
+      "Found no placeholder of type {.val {type}} on layout {.val {layout}}.",
+      "x" = "Available types are {.val {types_on_layout}}",
+      "i" = cli::col_grey("see {.code layout_properties(x, '{layout}', '{master}')}")
+    ), call = NULL)
   }
-  if( !is.null(id) ){
-    props <- props[id,, drop = FALSE]
+
+  if (!is.null(id)) {
+    if (!id %in% 1L:nr) {
+      cli::cli_abort(
+        c(
+          "{.arg id} is out of range.",
+          "x" = "Must be between {.val {1L}} and {.val {nr}} for ph type {.val {type}}.",
+          "i" = cli::col_grey("see {.code layout_properties(x, '{layout}', '{master}')} for all phs with type '{type}'")
+        ),
+        call = NULL
+      )
+    }
+    props <- props[id, , drop = FALSE]
   } else {
-    if(position_right){
-      props <- props[props$offx + 0.0001 > max(props$offx),]
+    if (position_right) {
+      props <- props[props$offx + 0.0001 > max(props$offx), ]
     } else {
-      props <- props[props$offx - 0.0001 < min(props$offx),]
+      props <- props[props$offx - 0.0001 < min(props$offx), ]
     }
-    if(position_top){
-      props <- props[props$offy - 0.0001 < min(props$offy),]
+    if (position_top) {
+      props <- props[props$offy - 0.0001 < min(props$offy), ]
     } else {
-      props <- props[props$offy + 0.0001 > max(props$offy),]
+      props <- props[props$offy + 0.0001 > max(props$offy), ]
     }
   }
 
-
-  if( nrow(props) > 1) {
-    warning("more than a row have been selected")
+  if (nrow(props) > 1) {
+    cli::cli_alert_warning("More than one placeholder selected.")
   }
   props <- props[, c("offx", "offy", "cx", "cy", "ph_label", "ph", "type", "fld_id", "fld_type", "rotation")]
   names(props) <- c("left", "top", "width", "height", "ph_label", "ph", "type", "fld_id", "fld_type", "rotation")
   as_ph_location(props)
 }
 
+
 as_ph_location <- function(x, ...){
   if( !is.data.frame(x) ){
     stop("x should be a data.frame")
@@ -229,18 +244,25 @@ fortify_location.location_template <- function( x, doc, ...){
 #'
 #' fileout <- tempfile(fileext = ".pptx")
 #' print(doc, target = fileout)
-ph_location_type <- function( type = "body", position_right = TRUE, position_top = TRUE, newlabel = NULL, id = NULL, ...){
-
-  ph_types <- c("ctrTitle", "subTitle", "dt", "ftr", "sldNum", "title", "body",
-                "pic", "chart", "tbl", "dgm", "media", "clipArt")
-  if(!type %in% ph_types){
-    stop("argument type ('", type, "') expected to be a value of ",
-         paste0(shQuote(ph_types), collapse = ", "), ".")
+ph_location_type <- function(type = "body", position_right = TRUE, position_top = TRUE, newlabel = NULL, id = NULL, ...) {
+  ph_types <- c(
+    "ctrTitle", "subTitle", "dt", "ftr", "sldNum", "title", "body",
+    "pic", "chart", "tbl", "dgm", "media", "clipArt"
+  )
+  if (!type %in% ph_types) {
+    cli::cli_abort(
+      c("type {.val {type}} is unknown.",
+        "x" = "Must be one of {.or {.val {ph_types}}}"
+      ),
+      call = NULL
+    )
   }
   x <- list(type = type, position_right = position_right, position_top = position_top, id = id, label = newlabel)
   class(x) <- c("location_type", "location_str")
   x
 }
+
+
 #' @export
 fortify_location.location_type <- function( x, doc, ...){
 
@@ -250,7 +272,6 @@ fortify_location.location_type <- function( x, doc, ...){
 
   layout <- ifelse(is.null(args$layout), unique( xfrm$name ), args$layout)
   master <- ifelse(is.null(args$master), unique( xfrm$master_name ), args$master)
-
   out <- get_ph_loc(doc, layout = layout, master = master,
              type = x$type, position_right = x$position_right,
              position_top = x$position_top, id = x$id)

tests/testthat/test-pptx-add.R

@@ -1,7 +1,7 @@
 test_that("add wrong arguments", {
   doc <- read_pptx()
-  expect_error(add_slide(doc, "Title and blah", "Office Theme"))
-  expect_error(add_slide(doc, "Title and Content", "Office Tddheme"))
+  expect_error(add_slide(doc, "Title and blah", "Office Theme"), fixed = TRUE)
+  expect_error(add_slide(doc, "Title and Content", "Office Tddheme"), fixed = TRUE)
 })
 
 test_that("add simple elements into placeholder", {
@@ -271,6 +271,7 @@ test_that("empty_content in pptx", {
   expect_equal(slide_summary(doc)$cx, 2)
 })
 
+
 test_that("pptx ph locations", {
   doc <- read_pptx()
   doc <- add_slide(doc, "Title and Content", "Office Theme")
@@ -334,6 +335,32 @@ test_that("pptx ph locations", {
   expect_equivalent(observed_xfrm, theorical_xfrm)
 })
 
+
+test_that("pptx ph_location_type", {
+  opts <- options(cli.num_colors = 1) # suppress colors to check error message
+  on.exit(options(opts))
+
+  x <- read_pptx()
+  x <- x |> add_slide("Two Content")
+
+  expect_no_error({
+    x |> ph_with("correct ph type id", ph_location_type("body", id = 1))
+  })
+
+  expect_error({
+    x |> ph_with("out of range type id", ph_location_type("body", id = 3)) # 3 does not exists => no error or warning
+  }, regexp = "`id` is out of range.", fixed = TRUE)
+
+  expect_error({
+    x |> ph_with("type okay but not available in layout", ph_location_type("tbl")) # tbl not on layout
+  }, regexp = "Found no placeholder of type", fixed = TRUE)
+
+  expect_error({
+    x |> ph_with("xxx is unknown type", ph_location_type("xxx"))
+  }, regexp = 'type "xxx" is unknown', fixed = TRUE)
+})
+
+
 test_that("pptx ph labels", {
   doc <- read_pptx()
   doc <- add_slide(doc, "Title and Content", "Office Theme")