R/ppt_classes.R

In officer: Manipulation of Microsoft Word and PowerPoint Documents

# presentation ------------------------------------------------------------

presentation <- R6Class(
  "presentation",
  inherit = openxml_document,

  public = list(
    initialize = function(package_dir) {
      super$initialize(character(0))
      presentation_filename <- file.path(package_dir, "ppt", "presentation.xml")
      self$feed(presentation_filename)

      slide_df <- private$get_slide_df()
      private$slide_id <- slide_df$id
      private$slide_rid <- slide_df$rid
    },

    add_slide = function(target) {
      private$rels_doc$add(
        id = paste0("rId", private$rels_doc$get_next_id()),
        type = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide",
        target = target
      )
      rels <- private$rels_doc$get_data()
      rid <- rels[rels$target %in% target, "id"]

      ids <- private$slide_id
      if (length(ids) < 1) {
        new_id <- 256
      } else {
        new_id <- max(ids) + 1
      }

      private$slide_id <- c(private$slide_id, new_id)
      private$slide_rid <- c(private$slide_rid, rid)

      private$update_xml()

      self
    },
    slide_data = function() {
      rel_df <- self$rel_df()
      rel_df <- select(
        .data = rel_df,
        all_of(setNames(c("id", "target"), c("slide_rid", "target")))
      )

      ref <- data.frame(
        slide_id = private$slide_id,
        slide_rid = private$slide_rid,
        stringsAsFactors = FALSE
      )

      left_join(ref, rel_df, by = "slide_rid")
    },

    move_slide = function(from, to) {
      slide_list <- self$slide_data()

      ord <- seq_len(nrow(slide_list))
      if (from < to) {
        to <- to + 1
      }
      ord[ord >= to] <- ord[ord >= to] + 1L
      ord[from] <- to
      slide_list <- slide_list[order(ord), , drop = FALSE]
      private$slide_id <- slide_list$slide_id
      private$slide_rid <- slide_list$slide_rid

      private$update_xml()

      self
    },

    remove_slide = function(target) {
      reldf <- self$rel_df()
      id <- which(basename(reldf$target) %in% basename(target))
      rid <- reldf$id[id]
      private$rels_doc$remove(target = target)

      dropid <- which(private$slide_rid %in% rid)

      private$slide_id <- private$slide_id[-dropid]
      private$slide_rid <- private$slide_rid[-dropid]

      private$update_xml()

      self
    }
  ),
  private = list(
    slide_id = NULL,
    slide_rid = NULL,

    get_slide_df = function() {
      nodes <- xml_find_all(private$doc, "//p:sldIdLst/p:sldId")
      id <- as.integer(xml_attr(nodes, "id", ns = xml_ns(private$doc)))
      rid <- xml_attr(nodes, "r:id", ns = xml_ns(private$doc))
      data.frame(id = id, rid = rid, stringsAsFactors = FALSE)
    },
    update_xml = function() {
      xml_list <- xml_find_first(private$doc, "//p:sldIdLst")
      xml_elt <- paste(
        sprintf(
          "<p:sldId id=\"%.0f\" r:id=\"%s\"/>",
          private$slide_id,
          private$slide_rid
        ),
        collapse = ""
      )

      xml_elt <- paste0(
        "<p:sldIdLst xmlns:a=\"http://schemas.openxmlformats.org/drawingml/2006/main\" xmlns:r=\"http://schemas.openxmlformats.org/officeDocument/2006/relationships\" xmlns:p=\"http://schemas.openxmlformats.org/presentationml/2006/main\">",
        xml_elt,
        "</p:sldIdLst>"
      )
      xml_elt <- as_xml_document(xml_elt)

      if (!inherits(xml_list, "xml_missing")) {
        xml_replace(xml_list, xml_elt)
      } else {
        ## needs to be after all MasterIdLst elements. placing it before sldSz seems to be the safest option.
        xml_add_sibling(
          xml_find_first(private$doc, "//p:sldSz"),
          xml_elt,
          .where = "before"
        )
      }

      self
    }
  )
)


# slide master ------------------------------------------------------------
slide_master <- R6Class(
  "slide_master",
  inherit = openxml_document,
  public = list(
    name = function() {
      theme_ <- private$theme_file()
      root <- gsub(paste0(self$dir_name(), "$"), "", dirname(private$filename))
      xml_attr(read_xml(file.path(root, theme_)), "name")
    },

    colors = function() {
      theme_ <- private$theme_file()
      root <- gsub(paste0(self$dir_name(), "$"), "", dirname(private$filename))

      doc <- read_xml(file.path(root, theme_))
      read_theme_colors(doc, self$name())
    },

    xfrm = function() {
      nodeset <- xml_find_all(
        self$get(),
        as_xpath_content_sel("p:cSld/p:spTree/")
      )
      read_xfrm(nodeset, self$file_name(), self$name())
    }
  ),
  private = list(
    theme_file = function() {
      data <- self$rel_df()
      theme_file <- data$target[basename(data$type) == "theme"]
      file.path("ppt/theme", basename(theme_file))
    }
  )
)

# slide_layout ------------------------------------------------------------
slide_layout <- R6Class(
  "slide_layout",
  inherit = openxml_document,
  public = list(
    get_metadata = function() {
      rels <- self$rel_df()
      rels <- rels[basename(rels$type) == "slideMaster", ]
      data.frame(
        stringsAsFactors = FALSE,
        name = self$name(),
        filename = self$file_name(),
        master_file = rels$target
      )
    },
    xfrm = function() {
      rels <- self$rel_df()
      rels <- rels[basename(rels$type) == "slideMaster", ]

      nodeset <- xml_find_all(
        self$get(),
        as_xpath_content_sel("p:cSld/p:spTree/")
      )
      data <- read_xfrm(nodeset, self$file_name(), self$name())
      if (nrow(data)) {
        data$master_file <- basename(rels$target)
      } else {
        data$master_file <- character(0)
      }
      data
    },
    write_template = function(new_file) {
      path <- system.file(package = "officer", "template/slide.xml")

      rel_filename <- file.path(
        dirname(new_file),
        "_rels",
        paste0(basename(new_file), ".rels")
      )

      newrel <- relationship$new()$add(
        id = "rId1",
        type = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slideLayout",
        target = file.path("../slideLayouts", basename(self$file_name()))
      )
      newrel$write(path = rel_filename)
      file.copy(path, to = new_file, copy.mode = FALSE)
      self
    },

    name = function() {
      csld <- xml_find_first(self$get(), "//p:cSld")
      xml_attr(csld, "name")
    }
  )
)

# slide ------------------------------------------------------------
slide <- R6Class(
  "slide",
  inherit = openxml_document,
  public = list(
    feed = function(file) {
      super$feed(file)
      slide_info <- private$rels_doc$get_data()
      slide_info <- slide_info[basename(slide_info$type) == "slideLayout", ]
      private$layout_file <- basename(slide_info$target)
      self
    },

    set_layout_xfrm = function(xfrm_ref) {
      private$element_data <- xfrm_ref[xfrm_ref$file == private$layout_file, ]
      self
    },
    reference_img = function(src, dir_name) {
      src <- unique(src)
      private$rels_doc$add_img(src, root_target = "../media")
      dir.create(dir_name, recursive = TRUE, showWarnings = FALSE)
      file.copy(from = src, to = file.path(dir_name, basename(src)))
      self
    },

    reference_slide = function(slide_file) {
      rel_dat <- private$rels_doc$get_data()

      if (!slide_file %in% rel_dat$target) {
        next_id <- private$rels_doc$get_next_id()
        private$rels_doc$add(
          id = sprintf("rId%.0f", next_id),
          type = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide",
          target = slide_file
        )
      }
      self
    },

    reference_hyperlink = function(href) {
      rel_dat <- private$rels_doc$get_data()

      if (!href %in% rel_dat$target) {
        next_id <- private$rels_doc$get_next_id()
        private$rels_doc$add(
          id = sprintf("rId%.0f", next_id),
          type = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink",
          target = href,
          target_mode = "External"
        )
      }
      self
    },

    get_xfrm = function(type = NULL, index = 1) {
      out <- private$element_data
      if (!is.null(type)) {
        if (type %in% out$type) {
          type_matches <- which(out$type == type)
          if (index <= length(type_matches)) {
            id <- type_matches[index]
          } else {
            stop(
              type,
              " can only have ",
              length(type_matches),
              " element(s) but index is set to ",
              index
            )
          }
        } else {
          stop("type ", type, " is not available in the slide layout")
        }
        out <- out[id, ]
      }
      out
    },

    layout_name = function() {
      private$layout_file
    },

    get_metadata = function() {
      rels <- self$rel_df()
      rels <- rels[basename(rels$type) == "slideLayout", ]
      data.frame(
        stringsAsFactors = FALSE,
        name = self$name(),
        filename = self$file_name(),
        layout_file = rels$target
      )
    }
  ),
  private = list(
    layout_file = NULL,
    element_data = NULL
  )
)


# notesSlide ------------------------------------------------------------
notesSlide <- R6Class(
  "notesSlide",
  inherit = openxml_document,
  public = list(
    feed = function(file) {
      super$feed(file)
      self
    },

    fortify_id = function() {
      cnvpr <- xml_find_all(private$doc, "//p:cNvPr")
      for (i in seq_along(cnvpr)) {
        xml_attr(cnvpr[[i]], "id") <- i
      }
      self
    },

    get_metadata = function() {
      rels <- self$rel_df()
    }
  )
)