R/ppt_ph_manipulate.R

In officer: Manipulation of Microsoft Word and PowerPoint Documents

get_shape_id <- function(x, type = NULL, id = NULL, ph_label = NULL) {
  slsmry <- slide_summary(x)

  if (is.null(ph_label)) {
    sel <- which(slsmry$type %in% type)
    if (length(sel) < 1) {
      stop("no shape of type ", shQuote(type), " has been found")
    }
    sel <- sel[id]
    if (sum(is.finite(sel)) != 1) {
      stop(
        "no shape of type ",
        shQuote(type),
        " and with id ",
        id,
        " has been found"
      )
    }
  } else {
    sel <- which(slsmry$ph_label %in% ph_label)
    if (length(sel) < 1) {
      stop("no shape with label ", shQuote(ph_label), " has been found")
    }
    sel <- sel[id]
    if (sum(is.finite(sel)) != 1) {
      stop(
        "no shape with label ",
        shQuote(ph_label),
        "and with id ",
        id,
        " has been found"
      )
    }
  }
  slsmry$id[sel]
}


#' @export
#' @title Remove a shape
#' @description Remove a shape in a slide.
#' @param x an rpptx object
#' @param type placeholder type
#' @param id placeholder index (integer) for a duplicated type. This is to be used when a placeholder
#' type is not unique in the layout of the current slide, e.g. two placeholders with type 'body'. To
#' add onto the first, use `id = 1` and `id = 2` for the second one.
#' Values can be read from [slide_summary()].
#' @param ph_label label associated to the placeholder. Use column
#' `ph_label` of result returned by [slide_summary()].
#' If used, `type` and `id` are ignored.
#' @param id_chr deprecated.
#' @examples
#' fileout <- tempfile(fileext = ".pptx")
#' dummy_fun <- function(doc) {
#'   doc <- add_slide(doc,
#'     layout = "Two Content",
#'     master = "Office Theme"
#'   )
#'   doc <- ph_with(
#'     x = doc, value = "Un titre",
#'     location = ph_location_type(type = "title")
#'   )
#'   doc <- ph_with(
#'     x = doc, value = "Un corps 1",
#'     location = ph_location_type(type = "body", id = 1)
#'   )
#'   doc <- ph_with(
#'     x = doc, value = "Un corps 2",
#'     location = ph_location_type(type = "body", id = 2)
#'   )
#'   doc
#' }
#' doc <- read_pptx()
#' for (i in 1:3) {
#'   doc <- dummy_fun(doc)
#' }
#'
#' doc <- on_slide(doc, index = 1)
#' doc <- ph_remove(x = doc, type = "title")
#'
#' doc <- on_slide(doc, index = 2)
#' doc <- ph_remove(x = doc, type = "body", id = 2)
#'
#' doc <- on_slide(doc, index = 3)
#' doc <- ph_remove(x = doc, type = "body", id = 1)
#'
#' print(doc, target = fileout)
#' @family functions for placeholders manipulation
#' @seealso [ph_with()]
ph_remove <- function(
  x,
  type = "body",
  id = 1,
  ph_label = NULL,
  id_chr = NULL
) {
  slide <- x$slide$get_slide(x$cursor)
  office_id <- get_shape_id(x, type = type, id = id, ph_label = ph_label)
  current_elt <- xml_find_first(
    slide$get(),
    sprintf("p:cSld/p:spTree/*[*/p:cNvPr[@id='%s']]", office_id)
  )
  xml_remove(current_elt)

  x
}


#' @export
#' @title Slide link to a placeholder
#' @description Add slide link to a placeholder in the current slide.
#' @inheritParams ph_remove
#' @param slide_index slide index to reach
#' @examples
#' fileout <- tempfile(fileext = ".pptx")
#' loc_title <- ph_location_type(type = "title")
#' doc <- read_pptx()
#' doc <- add_slide(doc, "Title and Content")
#' doc <- ph_with(x = doc, "Un titre 1", location = loc_title)
#' doc <- add_slide(doc, "Title and Content")
#' doc <- ph_with(x = doc, "Un titre 2", location = loc_title)
#' doc <- on_slide(doc, 1)
#' slide_summary(doc) # read column ph_label here
#' doc <- ph_slidelink(x = doc, ph_label = "Title 1", slide_index = 2)
#'
#' print(doc, target = fileout)
#' @family functions for placeholders manipulation
#' @seealso [ph_with()]
ph_slidelink <- function(
  x,
  type = "body",
  id = 1,
  id_chr = NULL,
  ph_label = NULL,
  slide_index
) {
  slide <- x$slide$get_slide(x$cursor)
  office_id <- get_shape_id(x, type = type, id = id, ph_label = ph_label)
  current_elt <- xml_find_first(
    slide$get(),
    sprintf("p:cSld/p:spTree/*[p:nvSpPr/p:cNvPr[@id='%s']]", office_id)
  )

  # declare slide ref in relationships
  slide_name <- x$slide$names()[slide_index]
  slide$reference_slide(slide_name)
  rel_df <- slide$rel_df()
  id <- rel_df[rel_df$target == slide_name, "id"]

  # add hlinkClick
  cnvpr <- xml_child(current_elt, "p:nvSpPr/p:cNvPr")
  str_ <- "<a:hlinkClick xmlns:a=\"http://schemas.openxmlformats.org/drawingml/2006/main\" xmlns:r=\"http://schemas.openxmlformats.org/officeDocument/2006/relationships\" r:id=\"%s\" action=\"ppaction://hlinksldjump\"/>"
  str_ <- sprintf(str_, id)
  xml_add_child(cnvpr, as_xml_document(str_))

  x
}


#' @export
#' @title Hyperlink a placeholder
#' @description Add hyperlink to a placeholder in the current slide.
#' @inheritParams ph_remove
#' @param href hyperlink (do not forget http or https prefix)
#' @examples
#' fileout <- tempfile(fileext = ".pptx")
#' loc_manual <- ph_location(bg = "red", newlabel = "mytitle")
#' doc <- read_pptx()
#' doc <- add_slide(doc, "Title and Content")
#' doc <- ph_with(x = doc, "Un titre 1", location = loc_manual)
#' slide_summary(doc) # read column ph_label here
#' doc <- ph_hyperlink(
#'   x = doc, ph_label = "mytitle",
#'   href = "https://cran.r-project.org"
#' )
#'
#' print(doc, target = fileout)
#' @family functions for placeholders manipulation
#' @seealso [ph_with()]
ph_hyperlink <- function(
  x,
  type = "body",
  id = 1,
  id_chr = NULL,
  ph_label = NULL,
  href
) {
  slide <- x$slide$get_slide(x$cursor)
  office_id <- get_shape_id(x, type = type, id = id, ph_label = ph_label)
  current_elt <- xml_find_first(
    slide$get(),
    sprintf(
      "p:cSld/p:spTree/*[p:nvSpPr/p:cNvPr[@id='%s']]|p:cSld/p:spTree/*[p:nvPicPr/p:cNvPr[@id='%s']]",
      office_id,
      office_id
    )
  )

  # add hlinkClick
  if (xml_name(current_elt) %in% "pic") {
    cnvpr <- xml_child(current_elt, "p:nvPicPr/p:cNvPr")
  } else {
    cnvpr <- xml_child(current_elt, "p:nvSpPr/p:cNvPr")
  }
  str_ <- "<a:hlinkClick xmlns:a=\"http://schemas.openxmlformats.org/drawingml/2006/main\" xmlns:r=\"http://schemas.openxmlformats.org/officeDocument/2006/relationships\" r:id=\"%s\"/>"
  str_ <- sprintf(str_, href)
  xml_add_child(cnvpr, as_xml_document(str_))
  x
}