R/ppt_ph_manipulate.R

In davidgohel/oxbase: 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 \code{id = 1} and \code{id = 2} for the second one.
#' Values can be read from \code{\link{slide_summary}}.
#' @param ph_label label associated to the placeholder. Use column
#' \code{ph_label} of result returned by \code{\link{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 \code{\link{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:nvSpPr/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)
#' doc <- ph_with(x = doc, "Un titre 1", location = loc_title)
#' doc <- add_slide(doc)
#' 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 \code{\link{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)
#' 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 \code{\link{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']]", office_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\"/>"
  str_ <- sprintf(str_, href)
  xml_add_child(cnvpr, as_xml_document(str_))
  x
}