R/read_docx_styles.R

In officer: Manipulation of Microsoft Word and PowerPoint Documents

get_all_attrs <- function(nodeset) {
    # extract all children per node
    children <- lapply(nodeset, xml_children)
    # extract all node names per child
    name <- lapply(children, xml_name)
    # extract all attributes per child
    attr <- lapply(children, xml_attrs)
    # set attribute names
    for (i in seq_along(attr)) {
      names(attr[[i]]) <- name[[i]]
    }
    attr
}

get_attr_val <- function(lst, node, attr = NULL) {
  if (is.null(attr)) attr <- "val"
  if (!length(lst)) return(NA_character_)

  vapply(lst, FUN.VALUE = "", function(node_attr) {
    a <- node_attr[[node]][attr]
    if (is.null(a)) NA_character_ else a
  })
}

# a faster way for constructing a data.frame
as_data_frame <- function(x, ...) {
  stopifnot(length(unique(lengths(x))) == 1L)
  structure(x, ..., row.names = seq_along(x[[1L]]), class = "data.frame")
}

read_rpr <- function(x) {
  node_rpr <- xml_child(x, "w:rPr")

  # check if empty
  not_empty <- lengths(node_rpr) > 0L

  # all elements to extract
  elem <- c(
    "font.size", "bold", "italic", "underlined", "color", "font.family",
    "vertical.align", "shading.color",
    "hansi.family", "eastasia.family", "cs.family", "bold.cs", "font.size.cs",
    "lang.val", "lang.eastasia", "lang.bidi"
  )

  # init results
  rpr <- replicate(length(elem), list(rep(NA_character_, length(node_rpr))))
  names(rpr) <- elem

  # directly return if all are empty
  if (!any(not_empty)) return(as_data_frame(rpr))

  # further reduce to only work on non-empty nodes and extract all attributes of
  # every child
  rpr_attr <- get_all_attrs(node_rpr[not_empty])

  # replace with actual attribute values
  rpr[["font.size"]][not_empty]       <- get_attr_val(rpr_attr, "sz")
  rpr[["bold"]][not_empty]            <- get_attr_val(rpr_attr, "b")
  rpr[["italic"]][not_empty]          <- get_attr_val(rpr_attr, "i")
  rpr[["underlined"]][not_empty]      <- get_attr_val(rpr_attr, "u")
  rpr[["color"]][not_empty]           <- get_attr_val(rpr_attr, "color")
  rpr[["font.family"]][not_empty]     <- get_attr_val(rpr_attr, "rFonts", "ascii")

  rpr[["vertical.align"]][not_empty]  <- get_attr_val(rpr_attr, "vertAlign")
  rpr[["shading.color"]][not_empty]   <- get_attr_val(rpr_attr, "shd", "fill")

  rpr[["hansi.family"]][not_empty]    <- get_attr_val(rpr_attr, "rFonts", "hAnsi")
  rpr[["eastasia.family"]][not_empty] <- get_attr_val(rpr_attr, "rFonts", "eastAsia")
  rpr[["cs.family"]][not_empty]       <- get_attr_val(rpr_attr, "rFonts", "cs")
  rpr[["bold.cs"]][not_empty]         <- get_attr_val(rpr_attr, "bCs")
  rpr[["font.size.cs"]][not_empty]    <- get_attr_val(rpr_attr, "szCs")

  rpr[["lang.val"]][not_empty]        <- get_attr_val(rpr_attr, "lang")
  rpr[["lang.eastasia"]][not_empty]   <- get_attr_val(rpr_attr, "lang", "eastAsia")
  rpr[["lang.bidi"]][not_empty]       <- get_attr_val(rpr_attr, "lang", "bidi")

  as_data_frame(rpr)
}

read_ppr <- function(x) {
  node_ppr <- xml_child(x, "w:pPr")

  # check if empty
  not_empty <- lengths(node_ppr) > 0L

  # all elements to extract
  elem <- c(
    "align", "keep_next", "line_spacing",
    "padding.bottom", "padding.top", "padding.left", "padding.right", "shading.color.par",
    "border.bottom.width", "border.bottom.color", "border.bottom.style",
    "border.top.width", "border.top.color", "border.top.style",
    "border.left.width", "border.left.color", "border.left.style",
    "border.right.width", "border.right.color", "border.right.style"
  )

  # init results
  ppr <- replicate(length(elem), list(rep(NA_character_, length(node_ppr))))
  names(ppr) <- elem

  # init values for non-character columns
  ppr[paste0("border.", c("bottom", "top", "left", "right"), ".width")] <- list(rep(NA_integer_, length(node_ppr)))
  ppr["line_spacing"] <- list(rep(NA_real_, length(node_ppr)))
  ppr["keep_next"] <- list(rep(FALSE, length(node_ppr)))

  # directly return if all are empty
  if (!any(not_empty)) return(as_data_frame(ppr))

  # further reduce to only work on non-empty nodes and extract all attributes of
  # every child
  ppr_attr <- get_all_attrs(node_ppr[not_empty])

  # NOTE: 'w:pBdr' has to be treated specially since it is nested inside 'w:pPr'
  bdr <- xml_child(node_ppr[not_empty], "w:pBdr")
  not_empty_bdr <- lengths(bdr) > 0L
  bdr_attr <- get_all_attrs(bdr[not_empty_bdr])

  # replace with actual attribute values
  ppr[["align"]][not_empty] <- get_attr_val(ppr_attr, "jc")
  ppr[["keep_next"]][not_empty] <- vapply(ppr_attr, function(attrs) "keepNext" %in% names(attrs), logical(1L))
  ppr[["line_spacing"]][not_empty] <- as.integer(get_attr_val(ppr_attr, "spacing", "line")) / 240L

  ppr[["padding.bottom"]][not_empty] <- get_attr_val(ppr_attr, "spacing", "after")
  ppr[["padding.top"]][not_empty] <- get_attr_val(ppr_attr, "spacing", "before")
  ppr[["padding.left"]][not_empty] <- get_attr_val(ppr_attr, "ind", "left")
  ppr[["padding.right"]][not_empty] <- get_attr_val(ppr_attr, "ind", "right")
  ppr[["shading.color.par"]][not_empty] <- get_attr_val(ppr_attr, "shd", "fill")

  ppr[["border.bottom.width"]][not_empty][not_empty_bdr] <- as.integer(get_attr_val(bdr_attr, "bottom", "sz")) / 8L
  ppr[["border.bottom.color"]][not_empty][not_empty_bdr] <- get_attr_val(bdr_attr, "bottom", "color")
  ppr[["border.bottom.style"]][not_empty][not_empty_bdr] <- get_attr_val(bdr_attr, "bottom", "val")

  ppr[["border.top.width"]][not_empty][not_empty_bdr] <- as.integer(get_attr_val(bdr_attr, "top", "sz")) / 8L
  ppr[["border.top.color"]][not_empty][not_empty_bdr] <- get_attr_val(bdr_attr, "top", "color")
  ppr[["border.top.style"]][not_empty][not_empty_bdr] <- get_attr_val(bdr_attr, "top", "val")

  ppr[["border.left.width"]][not_empty][not_empty_bdr] <- as.integer(get_attr_val(bdr_attr, "left", "sz")) / 8L
  ppr[["border.left.color"]][not_empty][not_empty_bdr] <- get_attr_val(bdr_attr, "left", "color")
  ppr[["border.left.style"]][not_empty][not_empty_bdr] <- get_attr_val(bdr_attr, "left", "val")

  ppr[["border.right.width"]][not_empty][not_empty_bdr] <- as.integer(get_attr_val(bdr_attr, "right", "sz")) / 8L
  ppr[["border.right.color"]][not_empty][not_empty_bdr] <- get_attr_val(bdr_attr, "right", "color")
  ppr[["border.right.style"]][not_empty][not_empty_bdr] <- get_attr_val(bdr_attr, "right", "val")

  as_data_frame(ppr)
}

read_docx_styles <- function(package_dir) {
  styles_file <- file.path(package_dir, "word/styles.xml")
  doc <- read_xml(styles_file)

  all_styles <- xml_find_all(doc, "/w:styles/w:style")

  ppr <- read_ppr(all_styles)
  rpr <- read_rpr(all_styles)

  main <- data.frame(stringsAsFactors = FALSE,
    style_type = xml_attr(all_styles, "type"),
    style_id = xml_attr(all_styles, "styleId"),
    style_name = xml_attr(xml_child(all_styles, "w:name"), "val"),
    base_on = xml_attr(xml_child(all_styles, "w:basedOn"), "val"),
    is_custom = xml_attr(all_styles, "customStyle") %in% "1",
    is_default = xml_attr(all_styles, "default") %in% "1"
  )
  out <- cbind(main, ppr, rpr)
  out
}

get_style_id <- function(data, style, type) {
  ref <- data[data$style_type == type, ]

  if (!style %in% ref$style_name) {
    t_ <- shQuote(ref$style_name, type = "sh")
    t_ <- paste(t_, collapse = ", ")
    t_ <- paste0("c(", t_, ")")
    stop("could not match any style named ", shQuote(style, type = "sh"), " in ", t_, call. = FALSE)
  }
  ref$style_id[ref$style_name == style]
}