R/ppt_ph_dedupe_layout.R

In officer: Manipulation of Microsoft Word and PowerPoint Documents

#' Detect and handle duplicate placeholder labels
#'
#' PowerPoint does not enforce unique placeholder labels in a layout.
#' Selecting a placeholder via its label using [ph_location_label] will throw
#' an error, if the label is not unique. [layout_dedupe_ph_labels] helps to detect,
#' rename, or delete duplicate placholder labels.
#'
#' @param x An `rpptx` object.
#' @param action Action to perform on duplicate placeholder labels. One of:
#' * `detect` (default) = show info on dupes only, make no changes
#' * `rename` = create unique labels. Labels are renamed by appending a sequential number
#'    separated by dot to duplicate labels. For example, `c("title", "title")` becomes `c("title.1", "title.2")`.
#' * `delete` = only keep one of the placeholders with a duplicate label
#' @param print_info Print action information (e.g. renamed placeholders) to console?
#'  Default is `FALSE`. Always `TRUE` for action `detect`.
#' @return A `rpptx` object (with modified placeholder labels).
#' @export
#' @examples
#' x <- read_pptx()
#' layout_dedupe_ph_labels(x)
#'
#' file <- system.file("doc_examples", "ph_dupes.pptx", package = "officer")
#' x <- read_pptx(file)
#' layout_dedupe_ph_labels(x)
#' layout_dedupe_ph_labels(x, "rename", print_info = TRUE)
#'
layout_dedupe_ph_labels <- function(x, action = "detect", print_info = FALSE) {
  if (!inherits(x, "rpptx")) {
    stop("'x' must be an 'rpptx' object", call. = FALSE)
  }
  action <- match.arg(action, c("detect", "rename", "delete"))
  layout_names <- x$slideLayouts$get_metadata()$filename
  xfrm_list <- lapply(layout_names, .dedupe_phs_in_layout, x = x, action = action)
  x <- reload_slidelayouts(x) # reinit slideLayouts to get processed ph labels [e.g. when calling x$slideLayouts$get_xfrm_data()]
  if (print_info | action == "detect") {
    .print_dedupe_info(x = x, xfrm_list = xfrm_list, action = action)
  }
  invisible(x)
}


# handle placeholder labels in a single layout
#
# layout_file: layout filename (e.g. "slideLayout1.xml").
# x: An `rpptx` object
#
# returns: Dataframe with placeholder info. Only needed for .print_dedupe_info()
.dedupe_phs_in_layout <- function(layout_file, x, action = "rename") {
  ph_label <- NULL
  if (!grepl("\\.xml$", layout_file, ignore.case = TRUE)) {
    stop("'layout_file' must be an .xml file", call. = FALSE)
  }
  action <- match.arg(action, c("detect", "rename", "delete"))
  layout <- x$slideLayouts$collection_get(layout_file)
  xfrm <- layout$xfrm()
  xfrm <- subset(xfrm, duplicated(ph_label) | duplicated(ph_label, fromLast = TRUE))
  if (nrow(xfrm) == 0) {
    return()
  }
  xfrm <- transform(xfrm, ph_label_new = make_strings_unique(ph_label), delete_flag = duplicated(ph_label)) # prepare once for all action types
  if (action == "detect") {
    return(xfrm) # no further action required
  } else if (action == "rename") {
    xfrm$delete_flag <- FALSE
  } else if (action == "delete") {
    xfrm$ph_label_new <- xfrm$ph_label
  }

  # rename label or delete ph shape
  layout_xml <- layout$get()
  for (i in 1L:nrow(xfrm)) {
    shape <- xml2::xml_find_first(layout_xml, sprintf("p:cSld/p:spTree/*[p:nvSpPr/p:cNvPr[@id='%s']]", xfrm$id[i]))
    if (xfrm$delete_flag[i]) {
      xml2::xml_remove(shape)
    } else {
      nodes <- xml2::xml_find_first(shape, ".//p:cNvPr")
      xml2::xml_set_attr(nodes, "name", xfrm$ph_label_new[i])
    }
  }
  layout$save() # persist changes in slideout xml file
  xfrm
}


# reload slideLayouts (if layout XML in package_dir has changed)
reload_slidelayouts <- function(x) {
  x$slideLayouts$initialize(x$package_dir,
    master_metadata = x$masterLayouts$get_metadata(),
    master_xfrm = x$masterLayouts$xfrm()
  )
  x
}


# Create unique string by appending a sepatator and a number
# make_strings_unique(c("A", "B", "B", "C", "A"))
make_strings_unique <- function(x, sep = ".") {
  ii <- stats::ave(x, x, FUN = seq_along)
  paste0(x, sep, ii)
}


# helper mostly for testing
has_ph_dupes <- function(x) {
  if (!inherits(x, "rpptx")) {
    stop("'x' must be an 'rpptx' object", call. = FALSE)
  }
  xfrm <- x$slideLayouts$get_xfrm_data()
  dupes <- stats::aggregate(ph_label ~ master_name + name, data = xfrm, FUN = function(x) sum(duplicated(x)) > 0)
  any(dupes$ph_label)
}


# print info on what was done (if print_info = TRUE)
.print_dedupe_info <- function(x, xfrm_list, action) {
  .df_1 <- do.call(rbind, xfrm_list)
  if (is.null(.df_1)) {
    cat("No duplicate placeholder labels detected.")
    return(invisible(NULL))
  }
  .df_2 <- x$slideLayouts$get_xfrm_data()
  .df_2 <- unique(.df_2[, c("master_file", "master_name"), drop = FALSE])
  df <- merge(.df_1, .df_2, sort = FALSE)
  rownames(df) <- NULL
  df <- df[, c("master_name", "name", "ph_label", "ph_label_new", "delete_flag"), drop = FALSE]
  colnames(df)[2] <- "layout_name"
  if (action == "detect") {
    cat("Placeholders with duplicate labels:\n")
    cat(cli::col_grey("* 'ph_label_new' = new placeholder label for action = 'rename'\n"))
    cat(cli::col_grey("* 'delete_flag' = deleted placeholders for action = 'delete'\n"))
  } else if (action == "rename") {
    df$delete_flag <- NULL
    cat("Renamed duplicate placeholder labels:\n")
    cat(cli::col_grey("* 'ph_label_new' = new placeholder label\n"))
  } else if (action == "delete") {
    df <- df[df$delete_flag, , drop = FALSE]
    df$ph_label_new <- NULL
    cat("Removed placeholders with duplicate labels:\n")
  }
  print(df)
}