R/ppt_ph_with_methods.R

In officer: Manipulation of Microsoft Word and PowerPoint Documents

# PH_WITH -------

#' @export
#' @title Add objects on the current slide
#' @description add object into a new shape in the current slide. This
#' function is able to add all supported outputs to a presentation. See
#' section **Methods (by class)** to see supported outputs.
#' @param x an rpptx object
#' @param value object to add as a new shape. Supported objects
#' are vectors, data.frame, graphics, block of formatted paragraphs,
#' unordered list of formatted paragraphs,
#' pretty tables with package flextable, editable graphics with
#' package rvg, 'Microsoft' charts with package mschart.
#' @param location a placeholder location object or a location short form. It will be used
#' to specify the location of the new shape. This location can be defined with a call to one
#' of the `ph_location_*` functions (see section `"see also"`). In `ph_with()`, several location
#' short forms can be used, as listed in section `"Short forms"`.
#' @param ... further arguments passed to or from other methods. When
#' adding a `ggplot` object or `plot_instr`, these arguments will be used
#' by png function.
#'
#' @section Short forms:
#' The `location` argument of `ph_with()` either expects a location object as returned by the
#' `ph_location_*` functions or a corresponding location *short form* (string or numeric):
#'
#' | **Location function**                       | **Short form**             | **Description**                                      |
#' |---------------------------------------------|----------------------------|------------------------------------------------------|
#' | `ph_location_left()`                        | `"left"`                   | Keyword string                                       |
#' | `ph_location_right()`                       | `"right"`                  | Keyword string                                       |
#' | `ph_location_fullsize()`                    | `"fullsize"`               | Keyword string                                       |
#' | `ph_location_type("body", 1)`               | `"body [1]"`               | String: type + index in brackets (`1` if omitted)    |
#' | `ph_location_label("my_label")`             | `"my_label"`               | Any string not matching a keyword or type            |
#' | `ph_location_id(1)`                         | `1`                        | Length 1 integer                                     |
#' | `ph_location(0, 0, 4, 5)`                   | `c(0,0,4,5)`               | Length 4 numeric, optionally named, `c(top=0, left=0, ...)` |
#'
#' @example inst/examples/example_ph_with.R
#' @seealso Specify placeholder locations with [ph_location_type], [ph_location],
#' [ph_location_label], [ph_location_left], [ph_location_right],
#' [ph_location_fullsize], [ph_location_template]. [phs_with] is a sibling of
#' `ph_with` that fills mutiple placeholders at once.
#' @section Illustrations:
#'
#' \if{html}{\figure{ph_with_doc_1.png}{options: width=80\%}}
ph_with <- function(x, value, location, ...) {
  location <- resolve_location(location)
  .ph_with(x, value, location, ...)
}


.ph_with <- function(x, value, location, ...) {
  UseMethod("ph_with", value)
}


#' @export
#' @describeIn ph_with add a character vector to a new shape on the
#' current slide, values will be added as paragraphs.
ph_with.character <- function(x, value, location, ...) {
  slide <- x$slide$get_slide(x$cursor)

  location <- fortify_location(location, doc = x)
  new_ph <- shape_properties_tags(
    left = location$left, top = location$top,
    width = location$width, height = location$height,
    label = location$ph_label, ph = location$ph,
    rot = location$rotation, bg = location$bg,
    ln = location$ln, geom = location$geom
  )

  pars <- paste0("<a:p><a:r><a:rPr/><a:t>", htmlEscapeCopy(value), "</a:t></a:r></a:p>", collapse = "")
  xml_elt <- paste0(
    psp_ns_yes, new_ph,
    "<p:txBody><a:bodyPr/><a:lstStyle/>",
    pars, "</p:txBody></p:sp>"
  )

  node <- as_xml_document(xml_elt)

  xml_add_child(xml_find_first(slide$get(), "//p:spTree"), node)
  x
}

#' @export
#' @param format_fun format function for non character vectors
#' @describeIn ph_with add a numeric vector to a new shape on the
#' current slide, values will be be first formatted then
#' added as paragraphs.
ph_with.numeric <- function(x, value, location, format_fun = format, ...) {
  slide <- x$slide$get_slide(x$cursor)
  value <- format_fun(value, ...)
  location <- fortify_location(location, doc = x)

  new_ph <- shape_properties_tags(
    left = location$left, top = location$top,
    width = location$width, height = location$height,
    label = location$ph_label, ph = location$ph,
    rot = location$rotation, bg = location$bg,
    ln = location$ln, geom = location$geom
  )

  pars <- paste0("<a:p><a:r><a:rPr/><a:t>", htmlEscapeCopy(value), "</a:t></a:r></a:p>", collapse = "")
  xml_elt <- paste0(
    psp_ns_yes, new_ph,
    "<p:txBody><a:bodyPr/><a:lstStyle/>",
    pars, "</p:txBody></p:sp>"
  )
  node <- as_xml_document(xml_elt)

  xml_add_child(xml_find_first(slide$get(), "//p:spTree"), node)
  x
}

#' @export
#' @describeIn ph_with add a factor vector to a new shape on the
#' current slide, values will be be converted as character and then
#' added as paragraphs.
ph_with.factor <- function(x, value, location, ...) {
  slide <- x$slide$get_slide(x$cursor)
  value <- as.character(value)
  location <- fortify_location(location, doc = x)

  new_ph <- shape_properties_tags(
    left = location$left, top = location$top,
    width = location$width, height = location$height,
    label = location$ph_label, ph = location$ph,
    rot = location$rotation, bg = location$bg,
    ln = location$ln, geom = location$geom
  )

  pars <- paste0("<a:p><a:r><a:rPr/><a:t>", htmlEscapeCopy(value), "</a:t></a:r></a:p>", collapse = "")
  xml_elt <- paste0(
    psp_ns_yes, new_ph,
    "<p:txBody><a:bodyPr/><a:lstStyle/>",
    pars, "</p:txBody></p:sp>"
  )
  node <- as_xml_document(xml_elt)

  xml_add_child(xml_find_first(slide$get(), "//p:spTree"), node)
  x
}
#' @export
#' @rdname ph_with
ph_with.logical <- ph_with.numeric


#' @export
#' @param date_format A format string for dates (default `"%Y-%m-%d"`).
#' See `format` arg in [strftime()] for details.
#' Set a global default via `options(officer.date_format = ...)`.
#' @describeIn ph_with add a `Date` object vector to a new shape on the
#' current slide, values will be be first converted to character.
ph_with.Date <- function(x, value, location, date_format = NULL, ...) {
  opt <- options()$officer.date_format
  if (!is.null(opt) && is.na(opt)) { # catch NA
    opt <- NULL
  }
  format <- date_format %||% opt %||% "%Y-%m-%d" # fallback to format.Date() default
  value_str <- format(value, format = format)
  ph_with(x, value = value_str, location, ...)
}


#' @export
#' @param level_list The list of levels for hierarchy structure as integer values.
#' If used the object is formated as an unordered list. If 1 and 2,
#' item 1 level will be 1, item 2 level will be 2.
#' @describeIn ph_with add a [block_list()] made
#' of [fpar()] to a new shape on the current slide.
ph_with.block_list <- function(x, value, location, level_list = integer(0), ...) {
  slide <- x$slide$get_slide(x$cursor)

  location <- fortify_location(location, doc = x)

  pars <- sapply(value, to_pml)

  if (length(level_list) > 0) {
    pars <- gsub("<a:buNone/>", "", pars, fixed = TRUE)

    level_values <- rep(1L, length(pars))
    level_values[] <- level_list
    level_values <- level_values - 1L

    lvl <- sprintf(" lvl=\"%.0f\"", level_values)
    lvl <- paste0("<a:pPr", ifelse(level_values > 0, lvl, ""), "/>")

    pars <- mapply(
      function(par, lvl) {
        paste0(par[1], lvl, par[2])
      }, strsplit(pars, split = "<a:pPr(.*)</a:pPr>"), lvl,
      SIMPLIFY = FALSE
    )
    pars <- unlist(pars)
  }

  pars <- paste0(pars, collapse = "")

  new_ph <- shape_properties_tags(
    left = location$left, top = location$top,
    width = location$width, height = location$height,
    label = location$ph_label, ph = location$ph,
    rot = location$rotation, bg = location$bg,
    ln = location$ln, geom = location$geom
  )

  xml_elt <- paste0(
    psp_ns_yes, new_ph,
    "<p:txBody><a:bodyPr/><a:lstStyle/>",
    pars, "</p:txBody></p:sp>"
  )

  node <- as_xml_document(xml_elt)

  xml_add_child(xml_find_first(slide$get(), "//p:spTree"), node)
  x
}


#' @export
#' @describeIn ph_with add a [unordered_list()] made
#' of [fpar()] to a new shape on the current slide.
ph_with.unordered_list <- function(x, value, location, ...) {
  slide <- x$slide$get_slide(x$cursor)
  location <- fortify_location(location, doc = x)

  p <- to_pml(value)

  new_ph <- shape_properties_tags(
    left = location$left, top = location$top,
    width = location$width, height = location$height,
    label = location$ph_label, ph = location$ph,
    rot = location$rotation, bg = location$bg,
    ln = location$ln, geom = location$geom
  )

  xml_elt <- paste0(
    psp_ns_yes, new_ph,
    "<p:txBody><a:bodyPr/><a:lstStyle/>", p, "</p:txBody></p:sp>"
  )
  node <- as_xml_document(xml_elt)
  xml_add_child(xml_find_first(slide$get(), "//p:spTree"), node)
  x
}


#' @export
#' @param header display header if TRUE
#' @param tcf conditional formatting settings defined by [table_conditional_formatting()]
#' @param alignment alignment for each columns, 'l' for left, 'r' for right
#' and 'c' for center. Default to NULL.
#' @describeIn ph_with add a data.frame to a new shape on the current slide with
#' function [block_table()]. Use package 'flextable' instead for more
#' advanced formattings.
ph_with.data.frame <- function(x, value, location, header = TRUE,
                               tcf = table_conditional_formatting(),
                               alignment = NULL,
                               ...) {
  location <- fortify_location(location, doc = x)

  slide <- x$slide$get_slide(x$cursor)
  style_id <- x$table_styles$def[1]

  pt <- prop_table(
    style = style_id, layout = table_layout(),
    width = table_width(),
    tcf = tcf
  )

  bt <- block_table(x = value, header = header, properties = pt, alignment = alignment)

  xml_elt <- to_pml(
    bt,
    left = location$left, top = location$top,
    width = location$width, height = location$height,
    label = location$ph_label, ph = location$ph,
    rot = location$rotation, bg = location$bg,
    ln = location$ln, geom = location$geom
  )

  value <- as_xml_document(xml_elt)
  xml_add_child(xml_find_first(slide$get(), "//p:spTree"), value)
  x
}


#' @export
#' @describeIn ph_with add a ggplot object to a new shape on the
#' current slide. Use package 'rvg' for more advanced graphical features.
#' @param res resolution of the png image in ppi
#' @param alt_text Alt-text for screen-readers. Defaults to `""`. If `""` or `NULL`
#'    an alt text added with `ggplot2::labs(alt = ...)` will be used if any.
#' @param scale Multiplicative scaling factor, same as in ggsave
ph_with.gg <- function(x, value, location, res = 300, alt_text = "", scale = 1, ...) {
  location_ <- fortify_location(location, doc = x)
  slide <- x$slide$get_slide(x$cursor)
  if (!requireNamespace("ggplot2")) {
    stop("package ggplot2 is required to use this function")
  }

  slide <- x$slide$get_slide(x$cursor)
  width <- location_$width
  height <- location_$height

  stopifnot(inherits(value, "gg"))
  file <- tempfile(fileext = ".png")
  agg_png(filename = file, width = width, height = height, units = "in", res = res, scaling = scale, background = "transparent", ...)
  print(value)
  dev.off()
  on.exit(unlink(file))

  if (is.null(alt_text) || alt_text == "") {
    alt_text <- ggplot2::get_alt_text(value)
    if (is.null(alt_text)) alt_text <- ""
  }

  ext_img <- external_img(file, width = width, height = height, alt = alt_text)

  ph_with(x, ext_img, location = location)
}

#' @export
#' @describeIn ph_with add an R plot to a new shape on the
#' current slide. Use package 'rvg' for more advanced graphical features.
ph_with.plot_instr <- function(x, value, location, res = 300, ...) {
  location_ <- fortify_location(location, doc = x)
  slide <- x$slide$get_slide(x$cursor)
  slide <- x$slide$get_slide(x$cursor)
  width <- location_$width
  height <- location_$height

  file <- tempfile(fileext = ".png")

  dirname <- tempfile()
  dir.create(dirname)
  filename <- paste(dirname, "/plot%03d.png", sep = "")
  agg_png(filename = filename, width = width, height = height, units = "in", res = res, scaling = 1, background = "transparent", ...)

  tryCatch(
    {
      eval(value$code)
    },
    finally = {
      dev.off()
    }
  )
  file <- list.files(dirname, full.names = TRUE)
  on.exit(unlink(dirname, recursive = TRUE, force = TRUE))

  if (length(file) > 1) {
    stop(length(file), " files have been produced. Multiple plot are not supported")
  }

  ext_img <- external_img(file, width = width, height = height)
  ph_with(x, ext_img, location = location)
}


#' @export
#' @param use_loc_size if set to FALSE, external_img width and height will
#' be used.
#' @describeIn ph_with add a [external_img()] to a new shape
#' on the current slide.
#'
#' When value is a external_img object, image will be copied
#' into the PowerPoint presentation. The width and height
#' specified in call to [external_img()] will be
#' ignored, their values will be those of the location,
#' unless use_loc_size is set to FALSE.
ph_with.external_img <- function(x, value, location, use_loc_size = TRUE, ...) {
  location <- fortify_location(location, doc = x)

  slide <- x$slide$get_slide(x$cursor)

  if (!use_loc_size) {
    location$width <- attr(value, "dims")$width
    location$height <- attr(value, "dims")$height
  }
  width <- location$width
  height <- location$height


  xml_str <- to_pml(
    x = value,
    left = location$left, top = location$top,
    width = width, height = height,
    label = location$ph_label, ph = location$ph,
    rot = location$rotation, bg = location$bg,
    ln = location$ln
  )

  value <- as_xml_document(xml_str)
  xml_add_child(xml_find_first(slide$get(), "//p:spTree"), value)
  x
}




#' @export
#' @describeIn ph_with add an [fpar()] to a new shape
#' on the current slide as a single paragraph in a [block_list()].
ph_with.fpar <- function(x, value, location, ...) {
  ph_with.block_list(x, value = block_list(value), location = location)

  x
}

#' @export
#' @describeIn ph_with add an [empty_content()] to a new shape
#' on the current slide.
ph_with.empty_content <- function(x, value, location, ...) {
  slide <- x$slide$get_slide(x$cursor)

  location <- fortify_location(location, doc = x)
  new_ph <- shape_properties_tags(
    left = location$left, top = location$top,
    width = location$width, height = location$height,
    label = location$ph_label, ph = location$ph,
    rot = location$rotation, bg = location$bg,
    ln = location$ln, geom = location$geom
  )

  if (is.na(location$fld_id)) {
    xml_elt <- paste0(psp_ns_yes, new_ph, "</p:sp>")
  } else {
    pars <- paste0("<a:p><a:fld id=\"", location$fld_id, "\" type = \"", location$fld_type, "\"><a:rPr/><a:t>", x$cursor, "</a:t></a:fld></a:p>", collapse = "")
    xml_elt <- sprintf(paste0(
      psp_ns_yes, new_ph,
      "<p:txBody><a:bodyPr/><a:lstStyle/>",
      pars, "</p:txBody></p:sp>"
    ))
  }
  node <- as_xml_document(xml_elt)

  xml_add_child(xml_find_first(slide$get(), "//p:spTree"), node)
  x
}



xml_to_slide <- function(slide, location, value, package_dir) {
  node <- xml_find_first(value, as_xpath_content_sel("//"))
  if (xml_name(node) == "grpSp") {
    node_sppr <- xml_child(node, "p:grpSpPr")
    node_xfrm <- xml_child(node, "p:grpSpPr/a:xfrm")
    node_name <- xml_child(node, "p:nvGrpSpPr/p:cNvPr")
  } else if (xml_name(node) == "graphicFrame") {
    node_xfrm <- xml_child(node, "p:xfrm")
    node_name <- xml_child(node, "p:nvGraphicFramePr/p:cNvPr")
    node_sppr <- xml_missing()
  } else if (xml_name(node) == "pic") {
    node_sppr <- xml_child(node, "p:spPr")
    node_xfrm <- xml_child(node, "p:spPr/a:xfrm")
    node_name <- xml_child(node, "p:nvPicPr/p:cNvPr")
  } else if (xml_name(node) == "sp") {
    node_sppr <- xml_child(node, "p:spPr")
    node_xfrm <- xml_child(node, "p:spPr/a:xfrm")
    node_name <- xml_child(node, "p:nvSpPr/p:cNvPr")
  } else {
    node_xfrm <- xml_missing()
    node_name <- xml_missing()
    node_sppr <- xml_missing()
  }


  if (!inherits(node_name, "xml_missing")) {
    xml_attr(node_name, "name") <- location$ph_label
  }

  if (!inherits(node_xfrm, "xml_missing")) {
    off <- xml_child(node_xfrm, "a:off")
    ext <- xml_child(node_xfrm, "a:ext")
    chOff <- xml_child(node_xfrm, "a:chOff")
    chExt <- xml_child(node_xfrm, "a:chExt")
    xml_attr(off, "x") <- sprintf("%.0f", location$left * 914400)
    xml_attr(off, "y") <- sprintf("%.0f", location$top * 914400)
    xml_attr(ext, "cx") <- sprintf("%.0f", location$width * 914400)
    xml_attr(ext, "cy") <- sprintf("%.0f", location$height * 914400)
    xml_attr(chOff, "x") <- sprintf("%.0f", location$left * 914400)
    xml_attr(chOff, "y") <- sprintf("%.0f", location$top * 914400)
    xml_attr(chExt, "cx") <- sprintf("%.0f", location$width * 914400)
    xml_attr(chExt, "cy") <- sprintf("%.0f", location$height * 914400)

    # add location$rotation to cNvPr:name
    if (!is.null(location$rotation) &&
      is.finite(location$rotation) &&
      is.numeric(location$rotation)) {
      xml_attr(node_xfrm, "rot") <- sprintf("%.0f", -location$rotation * 60000)
    }
  }

  if (!inherits(node_sppr, "xml_missing")) {
    # add location$bg to SpPr
    if (!is.null(location$bg)) {
      bg_str <- solid_fill_pml(location$bg)
      xml_add_child(node_sppr, as_xml_document(bg_str))
    }
  }
  value
}

#' @export
#' @describeIn ph_with add an xml_document object to a new shape on the
#' current slide. This function is to be used to add custom openxml code.
ph_with.xml_document <- function(x, value, location, ...) {
  slide <- x$slide$get_slide(x$cursor)

  location <- fortify_location(location, doc = x)

  xml_to_slide(slide, location, value, x$package_dir)

  xml_add_child(xml_find_first(slide$get(), "//p:spTree"), value)
  x
}


# PHS_WITH -------

#' @title Fill multiple placeholders using key value syntax
#' @description A sibling of [officer::ph_with] that fills mutiple placeholders at once. Placeholder locations are
#'   specfied using the short form syntax. The location and corresponding object are passed as key value pairs
#'   (`phs_with("short form location" = object)`). Under the hood, [officer::ph_with] is called for each pair. Note
#'   that `phs_with` does not cover all options from the `ph_location_*` family and is also less customization. It is a
#'   covenience wrapper for the most common use cases. The implemented short forms are listed in section
#'   `"Short forms"`.
#' @param x A `rpptx` object.
#' @param ... Key-value pairs of the form `"short form location" = object`. If the short form is an integer or a string
#'   with blanks, you must wrap it in quotes or backticks.
#' @param .dots List of key-value pairs `"short form location" = object`. Alternative to `...`.
#' @param .slide_idx Numeric indexes of slides to process. `NULL` (default) processes the current slide only. Use
#'   keyword `all` for all slides.
#' @section Short forms: The following short forms are implemented and can be used as the parameter in the function
#'   call. The corresponding function from the `ph_location_*` family (called under the hood) is displayed on the
#'   right.
#'
#' | **Short form** | **Description**                                   | **Location function**           |
#' |----------------|---------------------------------------------------|---------------------------------|
#' | `"left"`       | Keyword string                                    | `ph_location_left()`            |
#' | `"right"`      | Keyword string                                    | `ph_location_right()`           |
#' | `"fullsize"`   | Keyword string                                    | `ph_location_fullsize()`        |
#' | `"body [1]"`   | String: type + index in brackets (`1` if omitted) | `ph_location_type("body", 1)`   |
#' | `"my_label"`   | Any string not matching a keyword or type         | `ph_location_label("my_label")` |
#' | `1`            | Length 1 integer                                  | `ph_location_id(1)`             |
#'
#' @export
#' @seealso [ph_with()], [add_slide()]
#' @example inst/examples/example_phs_with.R
phs_with <- function(x, ..., .dots = NULL, .slide_idx = NULL) {
  dots_list <- list(...)
  if (length(dots_list) > 0 && !is_named(dots_list)) {
    cli::cli_abort(
      c("Missing key in {.arg ...}",
        "x" = "{.arg ...} requires a key-value syntax, with a ph short-form location as the key",
        "i" = "Example: {.code phs_with(x, title = 'My title', 'body[1]' = 'My body')}"
      )
    )
  }
  if (length(.dots) > 0 && !is_named(.dots)) {
    cli::cli_abort(
      c("Missing names in {.arg .dots}",
        "x" = "{.arg .dots} must be a named list, with ph short-form locations as names",
        "i" = "Example: {.code phs_with(x, .dots = list(title = 'My title', 'body[1]' = 'My body'))}"
      )
    )
  }
  dots <- utils::modifyList(dots_list, .dots %||% list())
  if (length(dots) == 0) {
    return(x)
  }
  .slide_idx <- .slide_idx %||% x$cursor # default is current slide
  if (is.character(.slide_idx) && .slide_idx == "all") {
    .slide_idx <- seq_len(length(x))
  }
  stop_if_not_in_slide_range(x, .slide_idx)

  loc_strings <- as.list(names(dots))
  ii <- grepl("^\\d+$", loc_strings) # find integer short-forms
  loc_strings[ii] <- as.integer(loc_strings[ii])
  locations <- lapply(loc_strings, resolve_location)

  .old_cursor <- x$cursor
  for (slide_idx in .slide_idx) {
    x$cursor <- slide_idx # pw_with always uses the current slide
    for (i in seq_along(dots)) {
      x <- ph_with(x, dots[[i]], locations[[i]])
    }
  }
  x$cursor <- .old_cursor
  x
}