From 1ea1c9580fea3c56ff1d09b00266c1a889d447e8 Mon Sep 17 00:00:00 2001
From: Mark Heckmann <heckmann.mark@gmail.com>
Date: Mon, 23 Sep 2024 13:22:18 +0200
Subject: [PATCH] Feat: Add `ph_location_id()` as a new member to the
 `ph_location_*` family

`ph_location_id()`is a new member in the `ph_location_*`
family. It references a placeholder via its unique id (#606)
---
 NAMESPACE                      |   2 +
 NEWS.md                        |   4 +-
 R/ph_location.R                | 151 +++++++++++++++++++++++++++++----
 man/officer.Rd                 |   2 +-
 man/ph_location.Rd             |   1 +
 man/ph_location_fullsize.Rd    |   1 +
 man/ph_location_id.Rd          |  67 +++++++++++++++
 man/ph_location_label.Rd       |   1 +
 man/ph_location_left.Rd        |   1 +
 man/ph_location_right.Rd       |   1 +
 man/ph_location_template.Rd    |   1 +
 man/ph_location_type.Rd        |   1 +
 tests/testthat/test-pptx-add.R |  59 +++++++++++++
 13 files changed, 272 insertions(+), 20 deletions(-)
 create mode 100644 man/ph_location_id.Rd

diff --git a/NAMESPACE b/NAMESPACE
index 9c71694e..ceda3b5b 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -30,6 +30,7 @@ S3method(format,fp_cell)
 S3method(format,fp_par)
 S3method(format,fp_text)
 S3method(fortify_location,location_fullsize)
+S3method(fortify_location,location_id)
 S3method(fortify_location,location_label)
 S3method(fortify_location,location_left)
 S3method(fortify_location,location_manual)
@@ -254,6 +255,7 @@ export(page_size)
 export(ph_hyperlink)
 export(ph_location)
 export(ph_location_fullsize)
+export(ph_location_id)
 export(ph_location_label)
 export(ph_location_left)
 export(ph_location_right)
diff --git a/NEWS.md b/NEWS.md
index ed6f897b..0102a41d 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -18,10 +18,10 @@ 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).
 - `plot_layout_properties()` assignment order fixed for `labels= FALSE` (#604)
-- `layout_properties()` gains a `type_idx` column to index phs of the same type on a layout. Indexing is performed based on ph position, following a top-to-bottom, left-to-right order. (#606).
+- `layout_properties()` gains a `type_idx` column to index phs of the same type on a layout. Indexing is performed based on ph position, following a top-to-bottom, left-to-right order (#606).
 - `plot_layout_properties()` plots more information by default now: layout name, ph label, ph id, ph type + index by default (#606).
 - `ph_location_type()`: new `type_idx` arg replaces the deprecated `id` arg (#606).
-
+- Add `ph_location_id()` as a new member to the `ph_location_*` family. It references a placeholder via its unique id (#606).
 
 ## Features
 
diff --git a/R/ph_location.R b/R/ph_location.R
index 0e5ca94a..8e7ca423 100644
--- a/R/ph_location.R
+++ b/R/ph_location.R
@@ -1,8 +1,40 @@
 
+props_to_ph_location <- function(props) {
+  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)
+}
+
+
 # id is deprecated and replaced by type_idx. Will be removed soon
 get_ph_loc <- function(x, layout, master, type, type_idx = NULL, position_right, position_top,
                        id = NULL, ph_id = NULL) {
   props <- layout_properties(x, layout = layout, master = master)
+
+  if (!is.null(ph_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} {.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
+      )
+    }
+    props <- props[props$id == ph_id, , drop = FALSE]
+    return(props_to_ph_location(props))
+  }
+
   types_on_layout <- unique(props$type)
   props <- props[props$type %in% type, , drop = FALSE]
   nr <- nrow(props)
@@ -13,6 +45,7 @@ get_ph_loc <- function(x, layout, master, type, type_idx = NULL, position_right,
       "i" = cli::col_grey("see {.code layout_properties(x, '{layout}', '{master}')}")
     ), call = NULL)
   }
+
   # id and type_idx are both used for now. 'id' is deprecated. The following code block can be removed in the future.
   if (!is.null(id)) {
     if (!id %in% 1L:nr) {
@@ -30,7 +63,10 @@ get_ph_loc <- function(x, layout, master, type, type_idx = NULL, position_right,
     props <- props[order(props$type, as.integer(props$id)), ] # set order for type idx. Removing the line would result in the default layout properties order, i.e., top->bottom left->right.
     props$.id <- stats::ave(props$type, props$master_name, props$name, props$type, FUN = seq_along)
     props <- props[props$.id == id, , drop = FALSE]
-  } else if (!is.null(type_idx)) {
+    return(props_to_ph_location(props))
+  }
+
+  if (!is.null(type_idx)) {
     if (!type_idx %in% props$type_idx) {
       cli::cli_abort(
         c(
@@ -42,25 +78,20 @@ get_ph_loc <- function(x, layout, master, type, type_idx = NULL, position_right,
       )
     }
     props <- props[props$type_idx == type_idx, , drop = FALSE]
-  } else {
-    if (position_right) {
-      props <- props[props$offx + 0.0001 > max(props$offx), ]
-    } else {
-      props <- props[props$offx - 0.0001 < min(props$offx), ]
-    }
-    if (position_top) {
-      props <- props[props$offy - 0.0001 < min(props$offy), ]
-    } else {
-      props <- props[props$offy + 0.0001 > max(props$offy), ]
-    }
+    return(props_to_ph_location(props))
   }
 
-  if (nrow(props) > 1) {
-    cli::cli_alert_warning("More than one placeholder selected.")
+  if (position_right) {
+    props <- props[props$offx + 0.0001 > max(props$offx), ]
+  } else {
+    props <- props[props$offx - 0.0001 < min(props$offx), ]
   }
-  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)
+  if (position_top) {
+    props <- props[props$offy - 0.0001 < min(props$offy), ]
+  } else {
+    props <- props[props$offy + 0.0001 > max(props$offy), ]
+  }
+  props_to_ph_location(props)
 }
 
 
@@ -477,6 +508,7 @@ fortify_location.location_left <- function( x, doc, ...){
   out
 }
 
+
 #' @export
 #' @title Location of a right body element
 #' @description The function will return the location corresponding
@@ -500,6 +532,7 @@ ph_location_right <- function( newlabel = NULL, ... ){
   x
 }
 
+
 #' @export
 fortify_location.location_right <- function( x, doc, ...){
 
@@ -516,3 +549,87 @@ fortify_location.location_right <- function( x, doc, ...){
   out
 }
 
+
+#' @export
+#' @title Location of a placeholder based on its id
+#' @description Each placeholder has an id (a low integer value). The ids are unique across a single
+#' layout. The function uses the placeholder's id to reference it. Different from a ph label,
+#' the id is auto-assigned by PowerPoint and cannot be modified by the user.
+#' Use [layout_properties()] (column `id`) and [plot_layout_properties()] (upper right
+#' corner, in green) to find a placeholder's id.
+#'
+#' @param id placeholder id.
+#' @param newlabel a new label to associate with the placeholder.
+#' @param ... not used.
+#' @family functions for placeholder location
+#' @inherit ph_location details
+#' @examples
+#' doc <- read_pptx()
+#' doc <- add_slide(doc, "Comparison")
+#' plot_layout_properties(doc, "Comparison")
+#'
+#' doc <- ph_with(doc, "The Title", location = ph_location_id(id = 2)) # title
+#' doc <- ph_with(doc, "Left Header", location = ph_location_id(id = 3)) # left header
+#' doc <- ph_with(doc, "Left Content", location = ph_location_id(id = 4)) # left content
+#' doc <- ph_with(doc, "The Footer", location = ph_location_id(id = 8)) # footer
+#'
+#' file <- tempfile(fileext = ".pptx")
+#' print(doc, file)
+#' \dontrun{
+#' file.show(file) # may not work on your system
+#' }
+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")
+  }
+  if (!is.integer(ph_id)) {
+    ph_id <- suppressWarnings(as.integer(ph_id))
+    if (is.na(ph_id)) {
+      cli::cli_abort(
+        c("Cannot convert {.val {id}} to integer",
+          "x" = "{.arg id} must be a number, you provided class {.cls {class(id)[1]}}"
+        )
+      )
+    }
+  }
+  if (ph_id < 1) {
+    cli::cli_abort(
+      c("{.arg id} must be a {cli::style_underline('positive')} number",
+        "x" = "Found {.val {ph_id}}"
+      )
+    )
+  }
+  x <- list(
+    type = NULL, type_idx = NULL, position_right = NULL, position_right = NULL,
+    position_top = NULL, id = NULL, ph_id = ph_id, label = newlabel
+  )
+  class(x) <- c("location_id", "location_num")
+  x
+}
+
+
+#' @export
+fortify_location.location_id <- function(x, doc, ...) {
+  slide <- doc$slide$get_slide(doc$cursor)
+  xfrm <- slide$get_xfrm()
+  args <- list(...)
+
+  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, ph_id = x$ph_id)
+  if (!is.null(x$label)) {
+    out$ph_label <- x$label
+  }
+  out
+}
+
+
diff --git a/man/officer.Rd b/man/officer.Rd
index ad4bedb5..8f296390 100644
--- a/man/officer.Rd
+++ b/man/officer.Rd
@@ -36,6 +36,7 @@ manuals \url{https://davidgohel.github.io/officer/}
 Authors:
 \itemize{
   \item Stefan Moog \email{moogs@gmx.de}
+  \item Mark Heckmann \email{heckmann.mark@gmail.com} (\href{https://orcid.org/0000-0002-0736-7417}{ORCID})
 }
 
 Other contributors:
@@ -51,7 +52,6 @@ Other contributors:
   \item Nikolai Beck \email{beck.nikolai@gmail.com} (set speaker notes for .pptx documents) [contributor]
   \item Greg Leleu \email{gregoire.leleu@gmail.com} (fields functionality in ppt) [contributor]
   \item Majid Eismann [contributor]
-  \item Mark Heckmann \email{heckmann.mark@gmail.com} (\href{https://orcid.org/0000-0002-0736-7417}{ORCID}) [contributor]
   \item Hongyuan Jia \email{hongyuanjia@cqust.edu.cn} (\href{https://orcid.org/0000-0002-0075-8183}{ORCID}) [contributor]
 }
 
diff --git a/man/ph_location.Rd b/man/ph_location.Rd
index 6d4b1ac5..09879114 100644
--- a/man/ph_location.Rd
+++ b/man/ph_location.Rd
@@ -74,6 +74,7 @@ print(doc, target = tempfile(fileext = ".pptx") )
 \seealso{
 Other functions for placeholder location: 
 \code{\link{ph_location_fullsize}()},
+\code{\link{ph_location_id}()},
 \code{\link{ph_location_label}()},
 \code{\link{ph_location_left}()},
 \code{\link{ph_location_right}()},
diff --git a/man/ph_location_fullsize.Rd b/man/ph_location_fullsize.Rd
index 0d4cb5fd..1d50797f 100644
--- a/man/ph_location_fullsize.Rd
+++ b/man/ph_location_fullsize.Rd
@@ -24,6 +24,7 @@ print(doc, target = tempfile(fileext = ".pptx") )
 \seealso{
 Other functions for placeholder location: 
 \code{\link{ph_location}()},
+\code{\link{ph_location_id}()},
 \code{\link{ph_location_label}()},
 \code{\link{ph_location_left}()},
 \code{\link{ph_location_right}()},
diff --git a/man/ph_location_id.Rd b/man/ph_location_id.Rd
new file mode 100644
index 00000000..7589230f
--- /dev/null
+++ b/man/ph_location_id.Rd
@@ -0,0 +1,67 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/ph_location.R
+\name{ph_location_id}
+\alias{ph_location_id}
+\title{Location of a placeholder based on its id}
+\usage{
+ph_location_id(id, newlabel = NULL, ...)
+}
+\arguments{
+\item{id}{placeholder id.}
+
+\item{newlabel}{a new label to associate with the placeholder.}
+
+\item{...}{not used.}
+}
+\description{
+Each placeholder has an id (a low integer value). The ids are unique across a single
+layout. The function uses the placeholder's id to reference it. Different from a ph label,
+the id is auto-assigned by PowerPoint and cannot be modified by the user.
+Use \code{\link[=layout_properties]{layout_properties()}} (column \code{id}) and \code{\link[=plot_layout_properties]{plot_layout_properties()}} (upper right
+corner, in green) to find a placeholder's id.
+}
+\details{
+The location of the bounding box associated to a placeholder
+within a slide is specified with the left top coordinate,
+the width and the height. These are defined in inches:
+
+\describe{
+\item{left}{left coordinate of the bounding box}
+\item{top}{top coordinate of the bounding box}
+\item{width}{width of the bounding box}
+\item{height}{height of the bounding box}
+}
+
+In addition to these attributes, a label can be
+associated with the shape. Shapes, text boxes, images and other objects
+will be identified with that label in the Selection Pane of PowerPoint.
+This label can then be reused by other functions such as \code{ph_location_label()}.
+It can be set with argument \code{newlabel}.
+}
+\examples{
+doc <- read_pptx()
+doc <- add_slide(doc, "Comparison")
+plot_layout_properties(doc, "Comparison")
+
+doc <- ph_with(doc, "The Title", location = ph_location_id(id = 2)) # title
+doc <- ph_with(doc, "Left Header", location = ph_location_id(id = 3)) # left header
+doc <- ph_with(doc, "Left Content", location = ph_location_id(id = 4)) # left content
+doc <- ph_with(doc, "The Footer", location = ph_location_id(id = 8)) # footer
+
+file <- tempfile(fileext = ".pptx")
+print(doc, file)
+\dontrun{
+file.show(file) # may not work on your system
+}
+}
+\seealso{
+Other functions for placeholder location: 
+\code{\link{ph_location}()},
+\code{\link{ph_location_fullsize}()},
+\code{\link{ph_location_label}()},
+\code{\link{ph_location_left}()},
+\code{\link{ph_location_right}()},
+\code{\link{ph_location_template}()},
+\code{\link{ph_location_type}()}
+}
+\concept{functions for placeholder location}
diff --git a/man/ph_location_label.Rd b/man/ph_location_label.Rd
index 3f103ca0..5d2e40f5 100644
--- a/man/ph_location_label.Rd
+++ b/man/ph_location_label.Rd
@@ -58,6 +58,7 @@ print(doc, target = tempfile(fileext = ".pptx"))
 Other functions for placeholder location: 
 \code{\link{ph_location}()},
 \code{\link{ph_location_fullsize}()},
+\code{\link{ph_location_id}()},
 \code{\link{ph_location_left}()},
 \code{\link{ph_location_right}()},
 \code{\link{ph_location_template}()},
diff --git a/man/ph_location_left.Rd b/man/ph_location_left.Rd
index d626b4d8..1d3f4d1f 100644
--- a/man/ph_location_left.Rd
+++ b/man/ph_location_left.Rd
@@ -29,6 +29,7 @@ print(doc, target = tempfile(fileext = ".pptx") )
 Other functions for placeholder location: 
 \code{\link{ph_location}()},
 \code{\link{ph_location_fullsize}()},
+\code{\link{ph_location_id}()},
 \code{\link{ph_location_label}()},
 \code{\link{ph_location_right}()},
 \code{\link{ph_location_template}()},
diff --git a/man/ph_location_right.Rd b/man/ph_location_right.Rd
index 2be82abc..c94e3f0c 100644
--- a/man/ph_location_right.Rd
+++ b/man/ph_location_right.Rd
@@ -29,6 +29,7 @@ print(doc, target = tempfile(fileext = ".pptx") )
 Other functions for placeholder location: 
 \code{\link{ph_location}()},
 \code{\link{ph_location_fullsize}()},
+\code{\link{ph_location_id}()},
 \code{\link{ph_location_label}()},
 \code{\link{ph_location_left}()},
 \code{\link{ph_location_template}()},
diff --git a/man/ph_location_template.Rd b/man/ph_location_template.Rd
index 7a742f2e..ee79250d 100644
--- a/man/ph_location_template.Rd
+++ b/man/ph_location_template.Rd
@@ -68,6 +68,7 @@ print(doc, target = tempfile(fileext = ".pptx") )
 Other functions for placeholder location: 
 \code{\link{ph_location}()},
 \code{\link{ph_location_fullsize}()},
+\code{\link{ph_location_id}()},
 \code{\link{ph_location_label}()},
 \code{\link{ph_location_left}()},
 \code{\link{ph_location_right}()},
diff --git a/man/ph_location_type.Rd b/man/ph_location_type.Rd
index 49b7394c..13c8ec4b 100644
--- a/man/ph_location_type.Rd
+++ b/man/ph_location_type.Rd
@@ -97,6 +97,7 @@ print(doc, target = fileout)
 Other functions for placeholder location: 
 \code{\link{ph_location}()},
 \code{\link{ph_location_fullsize}()},
+\code{\link{ph_location_id}()},
 \code{\link{ph_location_label}()},
 \code{\link{ph_location_left}()},
 \code{\link{ph_location_right}()},
diff --git a/tests/testthat/test-pptx-add.R b/tests/testthat/test-pptx-add.R
index a99a6b8a..79bbc63b 100644
--- 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)