R/pptx_slide_manip.R

In officer: Manipulation of Microsoft Word and PowerPoint Documents

#' @export
#' @title Add a slide
#' @description Add a slide into a pptx presentation.
#' @param x an `rpptx` object.
#' @param layout slide layout name to use. Can be ommited of a default layout is set via [layout_default()].
#' @param master master layout name where `layout` is located. Only required in case of several masters if layout is
#'   not unique.
#' @param ... Key-value pairs of the form `"short form location" = object` passed to [phs_with]. See section
#'   `"Short forms"` in [phs_with] for details, available short forms and examples.
#' @param .dots List of key-value pairs of the form `list("short form location" = object)`. Alternative to `...`. See
#'   [phs_with] for details.
#' @example inst/examples/example_add_slide.R
#' @seealso [print.rpptx()], [read_pptx()], [layout_summary()], [plot_layout_properties()], [ph_with()], [phs_with()], [layout_default()]
#' @family slide_manipulation
add_slide <- function(x, layout = NULL, master = NULL, ..., .dots = NULL) {
  if (is.null(layout) && !has_layout_default(x)) {
    # inform user. Passing no layout will be defunct in a future verion
    .Deprecated(
      "",
      package = "officer",
      msg = paste(
        "Calling `add_slide()` without specifying a `layout` is deprecated.\n",
        "Please pass a `layout` or use `layout_default()` to set a default.\n",
        '=> I will now continue with the former `layout` default "Title and Content" for backwards compatibility...'
      )
    )
    layout <- "Title and Content"
  }

  if (is.null(layout) && has_layout_default(x)) {
    ld <- get_layout_default(x)
    layout <- ld$layout
    master <- ld$master
  }

  la <- get_layout(x, layout, master, layout_by_id = FALSE)

  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 add_slide(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 add_slide(x, ..., .dots = list(title = 'My title', 'body[1]' = 'My body'))}"
      )
    )
  }

  new_slidename <- x$slide$get_new_slidename()

  xml_file <- file.path(x$package_dir, "ppt/slides", new_slidename)
  layout_obj <- x$slideLayouts$collection_get(la$layout_file)
  layout_obj$write_template(xml_file)

  # update presentation elements
  x$presentation$add_slide(target = file.path("slides", new_slidename))
  x$content_type$add_slide(partname = file.path("/ppt/slides", new_slidename))

  x$slide$add_slide(xml_file, x$slideLayouts$get_xfrm_data())
  x$cursor <- x$slide$length()

  # fill placeholders
  dots <- utils::modifyList(dots_list, .dots %||% list())
  if (length(dots) > 0) {
    x <- phs_with(x, .dots = dots)
  }
  x
}


#' @export
#' @title Change current slide
#' @description Change current slide index of an rpptx object.
#' @param x an rpptx object
#' @param index slide index
#' @example inst/examples/example_on_slide.R
#' @family slide_manipulation
#' @seealso [read_pptx()], [ph_with()]
on_slide <- function(x, index) {
  l_ <- length(x)
  if (l_ < 1) {
    cli::cli_abort("Presentation contains no slide.")
  }
  if (!between(index, 1, l_)) {
    cli::cli_abort(
      c(
        "Slide index {.val {index}} is out of range.",
        "x" = "Presentation has {cli::no(l_)} slide{?s}."
      )
    )
  }

  filename <- basename(x$presentation$slide_data()$target[index])
  location <- which(x$slide$get_metadata()$name %in% filename)

  x$cursor <- x$slide$slide_index(filename)
  x
}


#' @export
#' @title Remove slide(s)
#' @description Remove one or more slides from a pptx presentation.
#' @param x an rpptx object
#' @param index slide index or a vector of slide indices to remove,
#' default to current slide position.
#' @param rm_images unused anymore.
#' @note cursor is set on the last slide.
#' @example inst/examples/example_remove_slide.R
#' @family slide_manipulation
#' @seealso [read_pptx()], [ph_with()], [ph_remove()]
remove_slide <- function(x, index = NULL, rm_images = FALSE) {
  stop_if_not_rpptx(x)

  l_ <- length(x)
  if (l_ < 1) {
    cli::cli_abort("Presentation contains no slide to delete.")
  }

  if (is.null(index)) {
    index <- x$cursor
  }

  if (length(index) == 0) {
    return(x)
  }

  # Validate all indices
  indices <- unique(as.integer(index))
  invalid_indices <- indices[!between(indices, 1, l_)]
  if (length(invalid_indices) > 0) {
    n_invalid <- length(invalid_indices)
    cli::cli_abort(
      c(
        "{cli::qty(n_invalid)}Slide index{?es} {.val {invalid_indices}} {cli::qty(n_invalid)}{?is/are} out of range.",
        "x" = "Presentation has {cli::no(l_)} slide{?s}."
      )
    )
  }

  # Get slide mapping information using existing slide_data method
  slide_map <- x$presentation$slide_data()
  slide_map$filename <- basename(slide_map$target)

  indices_to_remove <- sort(unique(indices), decreasing = TRUE)
  slides_to_remove_df <- slide_map[indices_to_remove, , drop = FALSE]

  # Build file paths for deletion
  files_to_delete <- file.path(
    x$package_dir,
    "ppt",
    "slides",
    slides_to_remove_df$filename
  )
  rels_to_delete <- file.path(
    x$package_dir,
    "ppt",
    "slides",
    "_rels",
    paste0(slides_to_remove_df$filename, ".rels")
  )

  # Delete slide XML files if they exist
  unlink(files_to_delete[file.exists(files_to_delete)], force = TRUE)
  # Delete slide relationship files if they exist
  unlink(rels_to_delete[file.exists(rels_to_delete)], force = TRUE)

  # Remove slides from internal collections
  for (filename in slides_to_remove_df$filename) {
    slide_idx <- x$slide$slide_index(filename)
    x$slide$remove_slide(slide_idx)
    x$presentation$remove_slide(filename)
    x$content_type$remove_slide(partname = filename)
  }

  # Set cursor to last slide
  x$cursor <- x$slide$length()
  x
}


#' @export
#' @title Move a slide
#' @description Move a slide in a pptx presentation.
#' @inheritParams remove_slide
#' @param to new slide index.
#' @note cursor is set on the last slide.
#' @example inst/examples/example_move_slide.R
#' @family slide_manipulation
#' @seealso [read_pptx()]
move_slide <- function(x, index = NULL, to) {
  x$presentation$slide_data()

  if (is.null(index)) {
    index <- x$cursor
  }

  l_ <- length(x)

  if (l_ < 1) {
    cli::cli_abort("Presentation contains no slide.")
  }
  if (!between(index, 1, l_)) {
    cli::cli_abort(
      c(
        "Slide index {.val {index}} is out of range.",
        "x" = "Presentation has {cli::no(l_)} slide{?s}."
      )
    )
  }
  if (!between(to, 1, l_)) {
    cli::cli_abort(
      c(
        "Target position {.val {to}} is out of range.",
        "x" = "Presentation has {cli::no(l_)} slide{?s}."
      )
    )
  }

  x$presentation$move_slide(from = index, to = to)
  x$cursor <- to
  x
}


#' @title Correct pptx content references
#' @description Content references are not managed directly
#' but computed after the content is added. This function
#' loop over each slide and fix references (links and images)
#' if necessary.
#' @param x an rpptx object
#' @return an rpptx object
#' @noRd
pptx_fortify_slides <- function(x) {
  for (cursor_index in seq_len(x$slide$length())) {
    slide <- x$slide$get_slide(cursor_index)

    process_images(
      slide,
      slide$relationship(),
      x$package_dir,
      media_dir = "ppt/media",
      media_rel_dir = "../media"
    )

    process_links(slide, type = "pml")

    cnvpr <- xml_find_all(slide$get(), "//p:cNvPr")
    for (i in seq_along(cnvpr)) {
      xml_attr(cnvpr[[i]], "id") <- i
    }
  }

  x
}


#' @export
#' @title pptx tags for visual and non visual properties
#' @description Visual and non visual properties of a
#' shape can be returned by this function.
#' @param left,top,width,height place holder coordinates
#' in inches.
#' @param bg background color
#' @param rot rotation angle
#' @param label a label for the placeholder.
#' @param ph string containing xml code for ph tag
#' @param ln a [sp_line()] object specifying the outline style.
#' @param geom shape geometry, see http://www.datypic.com/sc/ooxml/t-a_ST_ShapeType.html
#' @return a character value
#' @family functions for officer extensions
#' @keywords internal
shape_properties_tags <- function(
  left = 0,
  top = 0,
  width = 3,
  height = 3,
  bg = "transparent",
  rot = 0,
  label = "",
  ph = "<p:ph/>",
  ln = sp_line(lwd = 0, linecmpd = "solid", lineend = "rnd"),
  geom = NULL
) {
  if (!is.null(bg) && !is.color(bg)) {
    cli::cli_abort("{.arg bg} must be a valid color, not {.val {bg}}.")
  }

  bg_str <- solid_fill_pml(bg)
  ln_str <- ln_pml(ln)
  geom_str <- prst_geom_pml(geom)

  xfrm_str <- a_xfrm_str(
    left = left,
    top = top,
    width = width,
    height = height,
    rot = rot
  )
  if (is.null(ph) || is.na(ph)) {
    ph <- "<p:ph/>"
  }

  randomid <- officer::uuid_generate()

  str <- "<p:nvSpPr><p:cNvPr id=\"%s\" name=\"%s\"/><p:cNvSpPr><a:spLocks noGrp=\"1\"/></p:cNvSpPr><p:nvPr>%s</p:nvPr></p:nvSpPr><p:spPr>%s%s%s%s</p:spPr>"

  sprintf(str, randomid, label, ph, xfrm_str, geom_str, bg_str, ln_str)
}


# check if slide index exists
ensure_slide_index_exists <- function(x, slide_idx) {
  stop_if_not_rpptx(x)
  if (!is.numeric(slide_idx)) {
    cli::cli_abort(
      c(
        "{.arg slide_idx} must be {.cls numeric}",
        "x" = "You provided {.cls {class(slide_idx)[1]}} instead."
      ),
      call = NULL
    )
  }
  n <- length(x) # no of slides
  check <- slide_idx %in% seq_len(n)
  if (!check) {
    cli::cli_abort(
      c(
        "Slide index {.val {slide_idx}} is out of range.",
        "x" = "Presentation has {cli::no(n)} slide{?s}."
      ),
      call = NULL
    )
  }
}


# internal workhorse get/set slide visibility
# x : rpptx object
# slide_idx: id of slide
# value: Use TRUE / FALSE to set visibility.
.slide_visible <- function(x, slide_idx, value = NULL) {
  stop_if_not_rpptx(x)
  slide <- x$slide$get_slide(slide_idx)
  slide_xml <- slide$get()
  node <- xml2::xml_find_first(slide_xml, "/p:sld")
  if (is.null(value)) {
    value <- xml2::xml_attr(node, "show")
    value <- as.logical(as.numeric(value))
    ifelse(is.na(value), TRUE, value) # if show is not set, the slide is shown
  } else {
    stop_if_not_class(value, "logical", arg = "value")
    xml2::xml_set_attr(node, "show", value = as.numeric(value))
    slide$save()
    invisible(x)
  }
}


#' Get or set slide visibility
#'
#' PPTX slides can be visible or hidden. This function gets or sets the visibility of slides.
#' @param x An `rpptx` object.
#' @param value Boolean vector with slide visibilities.
#' @rdname slide-visible
#' @export
#' @example inst/examples/example_slide_visible.R
#' @return Boolean vector with slide visibilities or `rpptx` object if changes are made to the object.
`slide_visible<-` <- function(x, value) {
  stop_if_not_rpptx(x)
  stop_if_not_class(value, "logical", arg = "value")
  n_vals <- length(value)
  n_slides <- length(x)
  if (n_vals > n_slides) {
    cli::cli_abort(
      "More values ({.val {n_vals}}) than slides ({.val {n_slides}})"
    )
  }
  if (n_vals != 1 && n_vals != n_slides) {
    cli::cli_warn(
      "Value is not length 1 or same length as number of slides ({.val {n_slides}}). Recycling values."
    )
  }
  value <- rep(value, length.out = n_slides)
  for (i in seq_along(value)) {
    .slide_visible(x, i, value[i])
  }
  invisible(x)
}


#' @param hide,show Indexes of slides to hide or show.
#' @rdname slide-visible
#' @export
slide_visible <- function(x, hide = NULL, show = NULL) {
  stop_if_not_rpptx(x)
  idx_in_both <- intersect(as.integer(hide), as.integer(show))
  if (length(idx_in_both) > 1) {
    cli::cli_abort(
      "Overlap between indexes in {.arg hide} and {.arg show}: {.val {idx_in_both}}",
      "x" = "Indexes must be mutually exclusive."
    )
  }
  if (!is.null(hide)) {
    stop_if_not_integerish(hide, "hide")
    stop_if_not_in_slide_range(x, hide, arg = "hide")
    slide_visible(x)[hide] <- FALSE
  }
  if (!is.null(show)) {
    stop_if_not_integerish(show, "show")
    stop_if_not_in_slide_range(x, show, arg = "show")
    slide_visible(x)[show] <- TRUE
  }
  n_slides <- length(x)
  res <- vapply(
    seq_len(n_slides),
    function(idx) .slide_visible(x, idx),
    logical(1)
  )
  if (is.null(hide) && is.null(show)) {
    res
  } else {
    x
  }
}