R/ooxml.R

Defines functions tcpr_css css_px tcpr_wml tcpr_pml rpr_css rpr_wml rpr_pml ppr_wml ppr_css ppr_pml border_css border_wml border_pml solid_fill_pml solid_fill is_transparent colalpha hex_color css_color p_xfrm_str a_xfrm_str sh_props_pml runs_to_p_wml

# tags with namespaces ----

wp_ns_yes <- "<w:p xmlns:w=\"http://schemas.openxmlformats.org/wordprocessingml/2006/main\" xmlns:wp=\"http://schemas.openxmlformats.org/drawingml/2006/wordprocessingDrawing\" xmlns:r=\"http://schemas.openxmlformats.org/officeDocument/2006/relationships\" xmlns:w14=\"http://schemas.microsoft.com/office/word/2010/wordml\">"
wp_ns_no <- "<w:p>"

tbl_ns_yes <- "<w:tbl xmlns:w=\"http://schemas.openxmlformats.org/wordprocessingml/2006/main\" xmlns:wp=\"http://schemas.openxmlformats.org/drawingml/2006/wordprocessingDrawing\" xmlns:r=\"http://schemas.openxmlformats.org/officeDocument/2006/relationships\">"
tbl_ns_no <- "<w:tbl>"

wr_ns_yes <- "<w:r xmlns:w=\"http://schemas.openxmlformats.org/wordprocessingml/2006/main\" xmlns:wp=\"http://schemas.openxmlformats.org/drawingml/2006/wordprocessingDrawing\" xmlns:r=\"http://schemas.openxmlformats.org/officeDocument/2006/relationships\" xmlns:w14=\"http://schemas.microsoft.com/office/word/2010/wordml\">"
wr_ns_no <- "<w:r>"

ar_ns_yes <- "<a:r 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\">"
ar_ns_no <- "<a:r>"

ap_ns_yes <- "<a:p 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\">"
ap_ns_no <- "<a:p>"

psp_ns_yes <- "<p:sp 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\">"
psp_ns_no <- "<p:sp>"

# utils -----
runs_to_p_wml <- function(..., add_ns = FALSE, style_id = NULL){
  runs <- list(...)
  run_str <- lapply(runs, to_wml, add_ns = FALSE)
  run_str$collapse <- ""
  run_str <- do.call(paste0, run_str)
  open_tag <- wp_ns_no
  if (add_ns) {
    open_tag <- wp_ns_yes
  }

  if( !is.null(style_id) )
    ppr <- paste0("<w:pPr><w:pStyle w:val=\"", style_id, "\"/></w:pPr>")
  else ppr <- "<w:pPr/>"
  out <- paste0(open_tag, ppr, run_str, "</w:p>")
  out
}

sh_props_pml <- function( left = 0, top = 0, width = 3, height = 3,
                          bg = "transparent", rot = 0, label = "", ph = "<p:ph/>"){

  if( !is.null(bg) && !is.color( bg ) )
    stop("bg must be a valid color.", call. = FALSE )

  bg_str <- solid_fill_pml(bg)

  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/>"
  }

  str <- "<p:nvSpPr><p:cNvPr id=\"0\" name=\"%s\"/><p:cNvSpPr><a:spLocks noGrp=\"1\"/></p:cNvSpPr><p:nvPr>%s</p:nvPr></p:nvSpPr><p:spPr>%s%s</p:spPr>"
  sprintf(str, label, ph, xfrm_str, bg_str )

}

a_xfrm_str <- function( left = 0, top = 0, width = 3, height = 3, rot = 0){

  start_tag <- "<a:xfrm>"
  if( !is.null(rot) && rot != 0) start_tag <- sprintf("<a:xfrm rot=\"%.0f\">", -rot * 60000)

  xfrm_str <- paste0(start_tag, "<a:off x=\"%.0f\" y=\"%.0f\"/><a:ext cx=\"%.0f\" cy=\"%.0f\"/></a:xfrm>")
  sprintf(xfrm_str,
          left * 914400, top * 914400,
          width * 914400, height * 914400)
}

p_xfrm_str <- function( left = 0, top = 0, width = 3, height = 3, rot = 0){

  if( is.null(rot)) rot <- 0

  xfrm_str <- "<p:xfrm rot=\"%.0f\"><a:off x=\"%.0f\" y=\"%.0f\"/><a:ext cx=\"%.0f\" cy=\"%.0f\"/></p:xfrm>"
  sprintf(xfrm_str, -rot * 60000,
          left * 914400, top * 914400,
          width * 914400, height * 914400)
}


# colors ----

css_color <- function(color){
  color <- as.vector(col2rgb(color, alpha = TRUE)) / c(1, 1, 1, 255)

  if( !(color[4] > 0) ) "transparent"
  else sprintf("rgba(%.0f,%.0f,%.0f,%.2f)",
               color[1], color[2], color[3], color[4])
}
hex_color <- function(color){
  color <- as.vector(col2rgb(color, alpha = TRUE)) / c(1, 1, 1, 255)
  sprintf("%02X%02X%02X",
          color[1], color[2], color[3])
}
colalpha <- function(x){
  if("transparent" %in% x) return(0)
  alpha <- as.vector(col2rgb(x, alpha = TRUE))[4] / 255
  alpha
}

is_transparent <- function(color){
  !(colalpha(color) > 0)
}

solid_fill <- function(color) {
  sprintf(
    paste0("<a:solidFill><a:srgbClr val=\"%s\">",
           "<a:alpha val=\"%.0f\"/>",
           "</a:srgbClr></a:solidFill>"),
    hex_color(color),
    colalpha(color) * 100000 )
}

solid_fill_pml <- function(bg){
  bg_str <- ""
  if( !is.null(bg)){
    bg_str <- solid_fill(bg)
  }
  bg_str
}

# border ----

border_pml <- function(x, side){
  tagname <- paste0("a:ln", side)

  width_ <- sprintf("w=\"%.0f\"", x$width * 12700)

  if(is_transparent(x$color) || x$width < .001){
    color_ <- "<a:noFill/>"
  } else {
    color_ <- solid_fill(x$color)
  }

  if( !x$style %in% c("dotted", "dashed", "solid") ){
    x$style <- "solid"
  }
  if( "dotted" %in% x$style ){
    x$style <- "sysDot"
  } else if( "dashed" %in% x$style ){
    x$style <- "sysDash"
  }

  style_ <- sprintf("<a:prstDash val=\"%s\"/>", x$style)

  paste0("<", tagname,
         " ", "algn=\"ctr\" cmpd=\"sng\" cap=\"flat\"",
         " ", width_,
         ">", color_, style_,
         "</", tagname, ">"
         )
}


border_wml <- function(x, side){
  tagname <- paste0("w:", side)
  x$style[x$style %in% "solid"] <- "single"
  if( !x$style %in% c("dotted", "dashed", "single") ){
    x$style <- "single"
  }
  if( x$width < 0.0001 || is_transparent(x$color) ){
    x$style <- "none"
  }


  style_ <- sprintf("w:val=\"%s\"", x$style)
  width_ <- sprintf("w:sz=\"%.0f\"", x$width*8)
  color_ <- sprintf("w:color=\"%s\"", hex_color(x$color))

  paste0("<", tagname,
         " ", style_,
         " ", width_,
         " ", "w:space=\"0\"",
         " ", color_,
         "/>")

}
border_css <- function(x, side){

  color_ <- css_color(x$color)
  if( !(x$width > 0 ) )
    color_ <- "transparent"

  width_ <- sprintf("%.02fpt", x$width)

  if( !x$style %in% c("dotted", "dashed", "solid") ){
    x$style <- "solid"
  }
  paste0("border-", side, ": ", width_, " ", x$style, " ", color_, ";")

}

# ppr ----
ppr_pml <- function(x){
  align  <- " algn=\"r\""
  if (x$text.align == "left" ){
    align  <- " algn=\"l\"";
  } else if(x$text.align == "center" ){
    align  <- " algn=\"ctr\"";
  } else if(x$text.align == "justify" ){
    align  <- " algn=\"just\"";
  }
  leftright_padding <- sprintf(" marL=\"%.0f\" marR=\"%.0f\"", x$padding.left*12700, x$padding.right*12700)
  top_padding <- sprintf("<a:spcBef><a:spcPts val=\"%.0f\" /></a:spcBef>", x$padding.top*100)
  bottom_padding <- sprintf("<a:spcAft><a:spcPts val=\"%.0f\" /></a:spcAft>", x$padding.bottom*100)

  line_spacing <- sprintf("<a:lnSpc><a:spcPct val=\"%.0f\"/></a:lnSpc>", x$line_spacing*100000)

  paste0("<a:pPr", align, leftright_padding, ">",
         line_spacing,
         top_padding, bottom_padding, "<a:buNone/>",
         "</a:pPr>")
}

ppr_css <- function(x){

  text.align  <- sprintf("text-align:%s;", x$text.align)
  borders <- paste0(
    border_css(x$border.bottom, "bottom"),
    border_css(x$border.top, "top"),
    border_css(x$border.left, "left"),
    border_css(x$border.right, "right") )

  paddings <- sprintf("padding-top:%.0fpt;padding-bottom:%.0fpt;padding-left:%.0fpt;padding-right:%.0fpt;",
                      x$padding.top, x$padding.bottom, x$padding.left, x$padding.right)

  shading.color <- sprintf("background-color:%s;", css_color(x$shading.color))

  paste0("margin:0pt;", text.align, borders, paddings,
         shading.color)
}

ppr_wml <- function(x){

  if("justify" %in% x$text.align ){
    x$text.align  <- "both";
  }
  text_align_ <- sprintf("<w:jc w:val=\"%s\"/>", x$text.align)
  keep_with_next <- ""
  if(x$keep_with_next){
    keep_with_next <- "<w:keepNext/>"
  }
  borders_ <- paste0("<w:pBdr>",
    border_wml(x$border.bottom, "bottom"),
    border_wml(x$border.top, "top"),
    border_wml(x$border.left, "left"),
    border_wml(x$border.right, "right"), "</w:pBdr>" )

  leftright_padding <- sprintf("<w:ind w:firstLine=\"0\" w:left=\"%.0f\" w:right=\"%.0f\"/>",
                               x$padding.left*20, x$padding.right*20)
  topbot_spacing <- sprintf("<w:spacing w:after=\"%.0f\" w:before=\"%.0f\" w:line=\"%.0f\"/>",
                            x$padding.bottom*20, x$padding.top*20, x$line_spacing*240)
  shading_ <- ""
  if(!is_transparent(x$shading.color)){
    shading_ <- sprintf(
      "<w:shd w:val=\"clear\" w:color=\"auto\" w:fill=\"%s\"/>",
      hex_color(x$shading.color))
  }

  paste0("<w:pPr>",
         text_align_,
         keep_with_next,
         borders_,
         topbot_spacing,
         leftright_padding,
         shading_,
         "</w:pPr>")

}


# rpr ----

rpr_pml <- function(x){

  if(is_transparent(x$color) ) return("")

  out  <- "<a:rPr cap=\"none\""
  if( x$font.size > 0 ){
    out <- paste0(out, sprintf(" sz=\"%.0f\"", x$font.size * 100) )
  }

  if(x$italic){
    out <- paste0(out, " i=\"1\"")
  } else {
    out <- paste0(out, " i=\"0\"")
  }
  if(x$bold){
    out <- paste0(out, " b=\"1\"")
  } else {
    out <- paste0(out, " b=\"0\"")
  }
  if(x$underlined){
    out <- paste0(out, " u=\"sng\"")
  } else {
    out <- paste0(out, " u=\"none\"")
  }

  if( x$vertical.align == "superscript"){
    out <- paste0(out, " baseline=\"40000\"")
  } else if( x$vertical.align == "subscript"){
    out <- paste0(out, " baseline=\"-40000\"")
  }
  out <- paste0(out, ">")
  out <- paste0(out, solid_fill(x$color))

  if(!is_transparent(x$shading.color) ){
    shad <- sprintf(
      paste0("<a:highlight><a:srgbClr val=\"%s\">",
             "<a:alpha val=\"%.0f\"/>",
             "</a:srgbClr></a:highlight>"),
      hex_color(x$shading.color),
      colalpha(x$shading.color) * 100000 )
    out <- paste0(out, shad)
  }

  out <- paste0(out,
                sprintf("<a:latin typeface=\"%s\"/><a:cs typeface=\"%s\"/>",
                        x$font.family, x$font.family)
        )
  out <- paste0(out, "</a:rPr>")
  out
}

rpr_wml <- function(x){

  out <- paste0("<w:rPr><w:rFonts",
    " w:ascii=\"", x$font.family, "\"",
    " w:hAnsi=\"", x$font.family, "\"",
    " w:eastAsia=\"", x$font.family, "\"",
    " w:cs=\"", x$font.family, "\"",
    "/>")

  if(x$italic){
    out <- paste0(out, "<w:i w:val=\"true\"/>")
  } else {
    out <- paste0(out, "<w:i w:val=\"false\"/>")
  }
  if(x$bold){
    out <- paste0(out, "<w:b w:val=\"true\"/>")
  } else {
    out <- paste0(out, "<w:b w:val=\"false\"/>")
  }
  if(x$underlined){
    out <- paste0(out, "<w:u w:val=\"single\"/>")
  } else {
    out <- paste0(out, "<w:u w:val=\"none\"/>")
  }

  if( x$vertical.align == "superscript"){
    out <- paste0(out, "<w:vertAlign w:val=\"superscript\"/>")
  } else if( x$vertical.align == "subscript"){
    out <- paste0(out, "<w:vertAlign w:val=\"subscript\"/>")
  }

  out <- paste0(
    out,
    sprintf("<w:sz w:val=\"%.0f\"/><w:szCs w:val=\"%.0f\"/>",
            x$font.size * 2, x$font.size * 2)
  )

  out <- paste0(
    out,
    sprintf("<w:color w:val=\"%s\"/>", hex_color(x$color))
  )

  if(!is_transparent(x$shading.color) ){
    out <- paste0(
      out,
      sprintf("<w:shd w:val=\"clear\" w:color=\"auto\" w:fill=\"%s\"/>", hex_color(x$shading.color))
    )
  }

  if(colalpha(x$color) < 1){
    out <- paste0(
      out,
      sprintf(
        paste0("<w14:textFill><w14:solidFill><w14:srgbClr val=\"%s\">",
               "<w14:alpha val=\"%.0f\"/>",
               "</w14:srgbClr></w14:solidFill></w14:textFill>"),
        hex_color(x$color),
        colalpha(x$color) * 100000 )
    )
  }
  out <- paste0(out, "</w:rPr>")
  out
}

rpr_css <- function(x){

  out <- sprintf("font-family:'%s';", x$font.family)
  out <- paste0(out, sprintf("color:%s;", css_color(x$color)))
  out <- paste0(out, sprintf("font-size:%0.1fpt;", x$font.size))

  if(x$italic){
    out <- paste0(out, "font-style:italic;")
  } else {
    out <- paste0(out, "font-style:normal;")
  }

  if(x$bold){
    out <- paste0(out, "font-weight:bold;")
  } else {
    out <- paste0(out, "font-weight:normal;")
  }

  if(x$underlined){
    out <- paste0(out, "text-decoration:underline;")
  } else {
    out <- paste0(out, "text-decoration:none;")
  }

  if(!is_transparent(x$shading.color) ){
    out <- paste0(
      out,
      sprintf("background-color:%s;", css_color(x$shading.color))
    )
  } else out <- paste0(out, "background-color:transparent;")

  if( x$vertical.align == "superscript"){
    out <- paste0(out, "vertical-align: super;")
  } else if( x$vertical.align == "subscript"){
    out <- paste0(out, "vertical-align: sub;")
  }

  out
}
# tcpr ----

tcpr_pml <- function(x){

  text.direction <-
    if(x$text.direction %in% "btlr")
      " vert=\"vert270\""
    else if(x$text.direction %in% "tbrl")
      " vert=\"vert\""
    else ""

  vertical.align <-
    if(x$vertical.align %in% "center"){
      " anchor=\"ctr\""
    } else if( x$vertical.align %in% "top"){
      " anchor=\"t\""
    } else " anchor=\"b\""

  margins <- sprintf(" marB=\"%.0f\" marT=\"%.0f\" marR=\"%.0f\" marL=\"%.0f\"",
                     x$margin.bottom * 12700, x$margin.top * 12700,
                     x$margin.right * 12700, x$margin.left * 12700)

  background.color <- paste0(
    sprintf("<a:solidFill><a:srgbClr val=\"%s\">", hex_color(x$background.color) ),
    sprintf("<a:alpha val=\"%.0f\"/>", colalpha(x$background.color)*100000 ),
    "</a:srgbClr></a:solidFill>" )

  bb <- border_pml(x$border.bottom, side = "B")
  bt <- border_pml(x$border.top, side = "T")
  bl <- border_pml(x$border.left, side = "L")
  br <- border_pml(x$border.right, side = "R")
  pml_attrs <- paste0(text.direction, vertical.align, margins)
  paste0("<a:tcPr ", pml_attrs, ">", bl, br, bt, bb,
         background.color, "</a:tcPr>" )
}

tcpr_wml <- function(x){

  background.color <- sprintf("<w:shd w:val=\"clear\" w:color=\"auto\" w:fill=\"%s\"/>", hex_color(x$background.color) )
  vertical.align <- ifelse( x$vertical.align %in% c("center", "top"), sprintf("<w:vAlign w:val=\"%s\"/>", x$vertical.align), "<w:vAlign w:val=\"bottom\"/>" )
  text.direction <- ifelse(
    x$text.direction %in% "btlr", "<w:textDirection w:val=\"btLr\"/>",
    ifelse(x$text.direction %in% "tbrl", "<w:textDirection w:val=\"tbRl\"/>", "") )

  bb <- border_wml(x$border.bottom, side = "bottom")
  bt <- border_wml(x$border.top, side = "top")
  bl <- border_wml(x$border.left, side = "left")
  br <- border_wml(x$border.right, side = "right")


  margin.bottom <- sprintf("<w:bottom w:w=\"%.0f\" w:type=\"dxa\"/>", x$margin.bottom * 20 )
  margin.top <- sprintf("<w:top w:w=\"%.0f\" w:type=\"dxa\"/>", x$margin.top * 20 )
  margin.left <- sprintf("<w:left w:w=\"%.0f\" w:type=\"dxa\"/>", x$margin.left * 20 )
  margin.right <- sprintf("<w:right w:w=\"%.0f\" w:type=\"dxa\"/>", x$margin.right * 20 )
  paste0("<w:tcPr><w:tcBorders>", bb, bt, bl, br, "</w:tcBorders>",
                         background.color,
                         "<w:tcMar>", margin.top, margin.bottom, margin.left, margin.right, "</w:tcMar>",
                         text.direction, vertical.align, "</w:tcPr>" )

}

css_px <- function(x, format = "%.0fpx"){
  ifelse( is.na(x), "inherit",
          ifelse( x < 0.001, "0", sprintf(format, x)) )
}

tcpr_css <- function(x){

  background.color <- ifelse( colalpha(x$background.color) > 0,
                              sprintf("background-clip: padding-box;background-color:%s;", css_color(x$background.color) ),
                              "background-color:transparent;")

  width <- ifelse( is.null(x$width) || is.na(x$width), "", sprintf("width:%s;", css_px(x$width * 72) ) )
  height <- ifelse( is.null(x$height) || is.na(x$height), "", sprintf("height:%s;", css_px(x$height * 72 ) ) )
  vertical.align <- ifelse(
    x$vertical.align %in% "center", "vertical-align:middle;",
    ifelse(x$vertical.align %in% "top", "vertical-align:top;", "vertical-align:bottom;") )

  bb <- border_css(x$border.bottom, side = "bottom")
  bt <- border_css(x$border.top, side = "top")
  bl <- border_css(x$border.left, side = "left")
  br <- border_css(x$border.right, side = "right")

  margin.bottom <- sprintf("margin-bottom:%s;", sprintf("%.0fpt", x$margin.bottom) )
  margin.top <- sprintf("margin-top:%s;", sprintf("%.0fpt", x$margin.top) )
  margin.left <- sprintf("margin-left:%s;", sprintf("%.0fpt", x$margin.left) )
  margin.right <- sprintf("margin-right:%s;", sprintf("%.0fpt", x$margin.right) )

  paste0(width, height, background.color, vertical.align, bb, bt, bl, br,
                         margin.bottom, margin.top, margin.left, margin.right)

}

Try the officer package in your browser

Any scripts or data that you put into this service are public.

officer documentation built on Sept. 7, 2020, 5:09 p.m.