feat: layout_rename_ph_labels() to rename ph labels in layouts (#610)

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: officer
 Title: Manipulation of Microsoft Word and PowerPoint Documents
-Version: 0.6.7.013
+Version: 0.6.7.014
 Authors@R: c(
     person("David", "Gohel", , "david.gohel@ardata.fr", role = c("aut", "cre")),
     person("Stefan", "Moog", , "moogs@gmx.de", role = "aut"),

NAMESPACE

@@ -65,6 +65,7 @@ S3method(print,fp_cell)
 S3method(print,fp_par)
 S3method(print,fp_text)
 S3method(print,ftext)
+S3method(print,layout_info)
 S3method(print,rdocx)
 S3method(print,rpptx)
 S3method(print,rtf)
@@ -160,6 +161,7 @@ S3method(update,fp_text)
 S3method(update,fpar)
 S3method(update,sp_line)
 S3method(update,sp_lineend)
+export("layout_rename_ph_labels<-")
 export(add_sheet)
 export(add_slide)
 export(annotate_base)
@@ -241,6 +243,7 @@ export(hyperlink_ftext)
 export(image_to_base64)
 export(layout_dedupe_ph_labels)
 export(layout_properties)
+export(layout_rename_ph_labels)
 export(layout_summary)
 export(media_extract)
 export(move_slide)

NEWS.md

@@ -25,10 +25,11 @@ informative error message if the type is not present in layout (#601).
 
 ## Features
 
-- add `layout_dedupe_ph_labels()` to handle duplicate placholder labels (#589). 
+- `layout_rename_ph_labels()` to rename ph labels (#610).
+- add `layout_dedupe_ph_labels()` to handle duplicate placeholder labels (#589). 
 By default, it will only detect duplicate labels, but apply no changes. With 
 `action = "rename"`, it auto-renames duplicate labels and `action = "delete"` 
-deletes duplicates, only keeping their first occurence.
+deletes duplicates, only keeping their first occurrence.
 - new convenience functions `body_replace_gg_at_bkm()` and `body_replace_plot_at_bkm()`
 to replace text content enclosed in a bookmark with a ggplot or a base plot.
 - add `unit` (in, cm, mm) argument in function `page_size()`.

R/ph_location.R

@@ -15,7 +15,7 @@ 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(na.omit(as.numeric(props$id)))
+    ids <- sort(stats::na.omit(as.numeric(props$id)))
     if (length(ids) <= 20) {
       .all_ids_switch <- c("x" = "Available ids:  {.val {ids}}.") # only if few ids
     } else {

R/ppt_ph_rename_layout.R

@@ -0,0 +1,197 @@
+#' Change ph labels in a layout
+#'
+#' There are two versions of the function. The first takes a set of key-value pairs to rename the
+#' ph labels. The second uses a right hand side (rhs) assignment to specify the new ph labels.
+#' See section *Details*. \cr\cr
+#' _NB:_ You can also rename ph labels directly in PowerPoint. Open the master template view
+#' (`Alt` + `F10`) and go to `Home` > `Arrange` > `Selection Pane`.
+#'
+#' @details
+#' * Note the difference between the terms `id` and `index`. Both can be found in the output of
+#' [layout_properties()]. The unique ph `id` is found in column `id`. The `index` refers to the
+#' index of the data frame row.
+#' * In a right hand side (rhs) label assignment (`<- new_labels`), there are two ways to
+#' optionally specify a subset of phs to rename. In both cases, the length of the rhs vector
+#' (the new labels) must match the length of the id or index:
+#'   1. use the `id` argument to specify ph ids to rename: `layout_rename_ph_labels(..., id = 2:3) <- new_labels`
+#'   2. use an `index` in squared brackets: `layout_rename_ph_labels(...)[1:2] <- new_labels`
+#'
+#' @export
+#' @rdname layout_rename_ph_labels
+#' @param x An `rpptx` object.
+#' @param layout Layout name or index. Index is the row index of [layout_summary()].
+#' @param master Name of master. Only required if the layout name is not unique across masters.
+#' @param ... Comma separated list of key-value pairs to rename phs. Either reference a ph via its label
+#' (`"old label"` = `"new label"`) or its unique id (`"id"` = `"new label"`).
+#' @param .dots Provide a named list or vector of key-value pairs to rename phs
+#' (`list("old label"` = `"new label"`).
+#' @param id Unique placeholder id (see column `id` in [layout_properties()] or [plot_layout_properties()]).
+#' @param value Not relevant for user. A pure technical necessity for rhs assignments.
+#' @return Vector of renamed ph labels.
+#' @example inst/examples/example_layout_rename_ph_labels.R
+#'
+layout_rename_ph_labels <- function(x, layout, master = NULL, ..., .dots = NULL) {
+  stop_if_not_rpptx(x, "x")
+  dots <- list(...)
+  dots <- c(dots, .dots)
+  if (length(dots) > 0 && !is_named(dots)) {
+    cli::cli_abort(
+      c("Unnamed arguments are not allowed.",
+        "x" = "Arguments {.arg ...} and {.arg .dots} both require key value pairs."
+      ),
+      call = NULL
+    )
+  }
+
+  l <- get_layout(x, layout, master)
+  lp <- layout_properties(x, l$layout_name, l$master_name)
+  if (length(dots) == 0) {
+    return(lp$ph_label)
+  }
+  df_renames <- .rename_df_from_dots(lp, dots)
+  .set_ph_labels(l, df_renames)
+  reload_slidelayouts(x)
+
+  lp <- layout_properties(x, l$layout_name, l$master_name)
+  invisible(lp$ph_label)
+}
+
+
+#' @export
+#' @rdname layout_rename_ph_labels
+`layout_rename_ph_labels<-` <- function(x, layout, master = NULL, id = NULL, value) {
+  l <- get_layout(x, layout, master)
+  lp <- layout_properties(x, l$layout_name, l$master_name)
+
+  if (!is.null(id)) {
+    if (length(id) != length(value)) {
+      cli::cli_abort(
+        c("{.arg id} and rhs vector must have the same length",
+          "x" = "Number of ids ({.val {length(id)}}) and assigned values ({.val {length(value)}}) differ"
+        )
+      )
+    }
+    wrong_ids <- setdiff(id, lp$id)
+    n_wrong <- length(wrong_ids)
+    if (n_wrong > 0) {
+      cli::cli_abort(c(
+        "{cli::qty(n_wrong)} {?This/These} id{?s} {?does/do} not exist: {.val {wrong_ids}}",
+        "x" = "Choose one of: {.val {lp$id}}",
+        "i" = cli::col_grey("Also see {.code plot_layout_properties(..., '{l$layout_name}', '{l$master_nam}')}")
+      ))
+    }
+    .idx <- match(id, lp$id) # user might enter ids in arbitrary order
+    lp$ph_label[.idx] <- value
+    value <- lp$ph_label
+  }
+  names(value) <- lp$id
+  df_renames <- .rename_df_from_dots(lp, value)
+  .set_ph_labels(l, df_renames)
+  reload_slidelayouts(x)
+}
+
+
+# heuristic: if a number, then treat as ph_id
+.detect_ph_id <- function(x) {
+  suppressWarnings({ # avoid character to NA warning
+    !is.na(as.numeric(x)) # nchar(x) == 1 &
+  })
+}
+
+
+# create data frame with: ph_id, ph_label, ph_label_new as a
+# basis for subsequent renaming
+#
+# CAVEAT: the ph order in layout_properties() (i.e. get_xfrm_data()) is reference for the user.
+# Using the 'slide_layout' object's xfrm() method does not yield the same ph order!
+# We need to guarantee a proper match here.
+#
+.rename_df_from_dots <- function(lp, dots) {
+  lp <- lp[, c("id", "ph_label")]
+  label_old <- names(dots)
+  label_new <- as.character(dots)
+  is_id <- .detect_ph_id(label_old)
+  is_label <- !is_id
+
+  # warn if renaming a duplicate label
+  ii <- duplicated(lp$ph_label)
+  dupes <- lp$ph_label[ii]
+  dupes_used <- intersect(label_old, dupes)
+  n_dupes_used <- length(dupes_used)
+  if (n_dupes_used > 0) {
+    cli::cli_warn(c(
+      "When renaming a label with duplicates, only the first occurrence is renamed.",
+      "x" = "Renaming {n_dupes_used} ph label{?s} with duplicates: {.val {dupes_used}}"
+    ), call = NULL)
+  }
+
+  # check for duplicate renames
+  is_dupe <- duplicated(label_old)
+  if (any(is_dupe)) {
+    dupes <- unique(label_old[is_dupe])
+    n_dupes <- length(dupes)
+    cli::cli_abort(c(
+      "Each id or label must only have one rename entry only.",
+      "x" = "Found {n_dupes} duplicate id{?s}/label{?s} to rename: {.val {dupes}}"
+    ), call = NULL)
+  }
+
+  # match by label and check for unknown labels
+  label_old_ <- label_old[is_label]
+  row_idx_label <- match(label_old_, table = lp$ph_label)
+  i_wrong <- is.na(row_idx_label)
+  n_wrong <- sum(i_wrong)
+  if (n_wrong > 0) {
+    cli::cli_abort(c(
+      "Can't rename labels that don't exist.",
+      "x" = "{cli::qty(n_wrong)}{?This label does/These labels do} not exist: {.val {label_old_[i_wrong]}}"
+    ), call = NULL)
+  }
+
+  # match by id and check for unknown ids
+  id_old_ <- label_old[is_id]
+  row_idx_id <- match(id_old_, table = lp$id)
+  i_wrong <- is.na(row_idx_id)
+  n_wrong <- sum(i_wrong)
+  if (n_wrong > 0) {
+    cli::cli_abort(c(
+      "Can't rename ids that don't exist.",
+      "x" = "{cli::qty(n_wrong)}{?This id does/These ids do} not exist: {.val {id_old_[i_wrong]}}"
+    ), call = NULL)
+  }
+
+  # check for collision between label and id
+  idx_collision <- intersect(row_idx_label, row_idx_id)
+  n_collision <- length(idx_collision)
+  if (n_collision > 0) {
+    df <- lp[idx_collision, c("id", "ph_label")]
+    pairs <- paste(df$ph_label, "<-->", df$id)
+    cli::cli_abort(c(
+      "Either specify the label {.emph OR} the id of the ph to rename, not both.",
+      "x" = "These labels and ids collide: {.val {pairs}}"
+    ), call = NULL)
+  }
+
+  lp$ph_label_new <- NA
+  lp$ph_label_new[row_idx_label] <- label_new[is_label]
+  lp$ph_label_new[row_idx_id] <- label_new[is_id]
+  lp[!is.na(lp$ph_label_new), , drop = FALSE]
+}
+
+
+.set_ph_labels <- function(l, df_renames) {
+  if (!inherits(l, "layout_info")) {
+    cli::cli_abort(
+      c("{.arg l} must a a {.cls layout_info} object",
+        "x" = "Got {.cls {class(l)[1]}} instead"
+      ),
+      call = NULL
+    )
+  }
+  layout_xml <- l$slide_layout$get()
+  for (i in seq_len(nrow(df_renames))) {
+    cnvpr_node <- xml2::xml_find_first(layout_xml, sprintf("p:cSld/p:spTree/*/p:nvSpPr/p:cNvPr[@id='%s']", df_renames$id[i]))
+    xml2::xml_set_attr(cnvpr_node, "name", df_renames$ph_label_new[i])
+  }
+  l$slide_layout$save() # persist changes in slide layout xml file
+}

R/pptx_informations.R

@@ -95,6 +95,7 @@ layout_properties <- function(x, layout = NULL, master = NULL) {
   data[["cy"]] <- data[["cy"]] / 914400
   data[["rotation"]] <- data[["rotation"]] / 60000
 
+  rownames(data) <- NULL
   data
 }
 

R/pptx_layout_helper.R

@@ -0,0 +1,116 @@
+#' Layout selection helper
+#'
+#' Select a layout by name or index. The master name is inferred and only required
+#' for disambiguation in case the layout name is not unique across masters.
+#'
+#' @param x An `rpptx` object.
+#' @param layout Layout name or index. Index refers to the row index of the [layout_summary()]
+#' output.
+#' @param master Name of master. Only required if layout name is not unique across masters.
+#' @return A `<layout_info>` object, i.e. a list with the entries `index`, `layout_name`,
+#' `layout_file`, `master_name`, `master_file`, and `slide_layout`.
+#' @keywords internal
+get_layout <- function(x, layout, master = NULL) {
+  stop_if_not_rpptx(x, "x")
+  if (!(is.numeric(layout) || is.character(layout))) {
+    cli::cli_abort(
+      c("{.arg layout} must be {.cls numeric} or {.cls character}",
+        "x" = "Got class {.cls {class(layout)[1]}} instead"
+      )
+    )
+  }
+  if (length(layout) != 1) {
+    cli::cli_abort(
+      c("{.arg layout} is not length 1",
+        "x" = "{.arg layout} must be {.emph one} layout name or index."
+      )
+    )
+  }
+  df <- x$slideLayouts$get_metadata()
+  names(df)[2:3] <- c("layout_name", "layout_file") # consistent naming
+  n_layouts <- nrow(df)
+  df$index <- seq_len(n_layouts)
+
+  if (n_layouts == 0) {
+    cli::cli_alert_danger("No layouts available.")
+    return(NULL)
+  }
+
+  if (is.numeric(layout)) {
+    res <- get_row_by_index(df, layout)
+  } else {
+    res <- get_row_by_name(df, layout, master)
+  }
+  l <- as.list(res)
+  slide_layout <- x$slideLayouts$collection_get(l$layout_file)
+  l <- c(l, slide_layout = slide_layout)
+  l <- l[c("index", "layout_name", "layout_file", "master_name", "master_file", "slide_layout")] # nice order
+  class(l) <- c("layout_info", "list")
+  l
+}
+
+
+
+# else {
+#   # multiple layouts
+#   layout_exists(x, layout, must_exist = TRUE)
+#   layout_is_unique(x, layout, require_unique = TRUE)
+#   index <- which(df$layout_name == layout)
+# }
+# index <- which(df$layout_name == layout)
+# l <- df[index, ] |> as.list()
+# # l <- c(index = index, l, slide_layout = slide_layout)
+
+#' @export
+print.layout_info <- function(x, ...) {
+  cli::cli_h3("{.cls layout_info} object")
+  str(utils::head(x, -1), give.attr = FALSE, no.list = TRUE)
+  cat(" $ slide_layout: 'R6' <slide_layout>")
+}
+
+
+get_row_by_index <- function(df, layout) {
+  index <- layout
+  if (!index %in% df$index) {
+    cli::cli_abort(
+      c("Layout index out of bounds.",
+        "x" = "Index must be between {.val {1}} and {.val {nrow(df)}}.",
+        "i" = cli::col_grey("See row indexes in {.fn layout_summary}")
+      ),
+      call = NULL
+    )
+  }
+  df[index, ]
+}
+
+
+# select layout by name
+get_row_by_name <- function(df, layout, master) {
+  if (!is.null(master)) {
+    masters <- unique(df$master_name)
+    if (!master %in% masters) {
+      cli::cli_abort(c(
+        "master {.val {master}} does not exist.",
+        "i" = "See {.fn layout_summary} for available masters."
+      ), call = NULL)
+    }
+    df <- df[df$master_name == master, ]
+  }
+
+  df <- df[df$layout_name == layout, ]
+  if (nrow(df) == 0) {
+    msg <- ifelse(is.null(master),
+      "Layout {.val {layout}} does not exist",
+      "Layout {.val {layout}} does not exist in master {.val {master}}"
+    )
+    cli::cli_abort(c(msg, "i" = "See {.fn layout_summary} for available layouts."), call = NULL)
+    return(NULL)
+  }
+  if (nrow(df) > 1) {
+    cli::cli_abort(c(
+      "Layout exists in more than one master",
+      "x" = "Please specify the master name in arg {.arg master}"
+    ), call = NULL)
+  }
+  df
+}