tests/testthat/test-pptx-add-geom-ln.R

In officer: Manipulation of Microsoft Word and PowerPoint Documents

test_that("add outline to placeholder", {
  sp_line_ <- list(
    sp_line(color = "#FFFF00", lwd = 4.5, lty = "solid", linecmpd = "sng"),
    sp_line(color = "black", lwd = 9, lty = "dash", linecmpd = "dbl")
  )
  width <- 4
  height <- 3
  top <- 7.5 / 2 - height / 2
  left <- c(1, 10 - width - 1)

  loc_ <- lapply(
    seq_along(sp_line_),
    function(x)
      ph_location(
        left = left[x],
        top = top,
        width = width,
        height = height,
        bg = "orange",
        ln = sp_line_[[x]]
      )
  )

  doc <- read_pptx()
  doc <- add_slide(doc, layout = "Title and Content", master = "Office Theme")
  doc <- ph_with(doc, "Box with solid outline", location = loc_[[1]])
  doc <- ph_with(doc, "Box with dashed double outline", location = loc_[[2]])

  sm <- slide_summary(doc)
  expect_equal(nrow(sm), 2)
  expect_equal(
    sm$text,
    c("Box with solid outline", "Box with dashed double outline")
  )

  xmldoc <- doc$slide$get_slide(id = 1)$get()
  cols <- xml_attr(xml_find_all(xmldoc, "//a:ln/a:solidFill/a:srgbClr"), "val")
  expect_equal(cols, c("FFFF00", "000000"))
  expect_equal(
    xml_attr(xml_find_all(xmldoc, "//a:ln"), "w"),
    as.character(c(4.5, 9) * 12700)
  )
  expect_equal(
    xml_attr(xml_find_all(xmldoc, "//a:ln"), "cmpd"),
    c("sng", "dbl")
  )
  expect_equal(
    xml_attr(xml_find_all(xmldoc, "//a:ln/a:prstDash"), "val"),
    c("solid", "dash")
  )
})

test_that("add geometry to placeholder", {
  sp_line_ <- sp_line(
    color = "#FFFF00",
    lwd = 4.5,
    lty = "solid",
    linecmpd = "sng"
  )

  width <- 4
  height <- 3
  top <- 7.5 / 2 - height / 2
  left <- c(1, 10 - width - 1)

  loc_ <- list(
    ph_location(
      left = left[1],
      top = top,
      width = width,
      height = height,
      bg = "orange",
      ln = sp_line_,
      geom = "roundRect"
    ),
    ph_location(
      left = left[2],
      top = top,
      width = width,
      height = height,
      bg = "steelblue",
      ln = sp_line_,
      geom = "trapezoid"
    )
  )

  doc <- read_pptx()
  doc <- add_slide(doc, layout = "Title and Content", master = "Office Theme")
  doc <- ph_with(doc, "Round Rectangle", location = loc_[[1]])
  doc <- ph_with(doc, "Trapezoid", location = loc_[[2]])

  sm <- slide_summary(doc)
  expect_equal(nrow(sm), 2)
  expect_equal(sm$text, c("Round Rectangle", "Trapezoid"))

  xmldoc <- doc$slide$get_slide(id = 1)$get()
  cols <- xml_attr(
    xml_find_all(xmldoc, "//p:spPr/a:solidFill/a:srgbClr"),
    "val"
  )
  expect_equal(cols, c("FFA500", "4682B4"))
  expect_equal(
    xml_attr(xml_find_all(xmldoc, "//a:prstGeom"), "prst"),
    c("roundRect", "trapezoid")
  )
  cols <- xml_attr(xml_find_all(xmldoc, "//a:ln/a:solidFill/a:srgbClr"), "val")
  expect_equal(cols, c("FFFF00", "FFFF00"))
  expect_equal(
    xml_attr(xml_find_all(xmldoc, "//a:ln"), "w"),
    as.character(c(4.5, 4.5) * 12700)
  )
  expect_equal(
    xml_attr(xml_find_all(xmldoc, "//a:ln/a:prstDash"), "val"),
    c("solid", "solid")
  )
})

test_that("add line geometry with lineends", {
  headend <- sp_lineend(type = "oval", width = "sm", length = "sm")
  tailend <- sp_lineend(type = "triangle", width = "lg", length = "lg")

  sp_line1 <- sp_line(
    color = "steelblue",
    lwd = 4.5,
    lty = "solid",
    linecmpd = "sng",
    headend = headend,
    tailend = tailend
  )
  sp_line2 <- update(
    sp_line1,
    linecmpd = "dbl",
    headend = tailend,
    tailend = headend
  )

  width <- 4
  height <- 3
  top <- 7.5 / 2 - height / 2
  left <- c(1, 10 - width - 1)

  loc_ <- list(
    ph_location(
      left = left[1],
      top = top,
      width = width,
      height = height,
      ln = sp_line1,
      geom = "line"
    ),
    ph_location(
      left = left[2],
      top = top,
      width = width,
      height = height,
      ln = sp_line2,
      rotation = 180,
      geom = "line"
    )
  )

  doc <- read_pptx()
  doc <- add_slide(doc, layout = "Title and Content", master = "Office Theme")
  doc <- ph_with(doc, "", location = loc_[[1]])
  doc <- ph_with(doc, "", location = loc_[[2]])

  sm <- slide_summary(doc)
  expect_equal(nrow(sm), 2)

  xmldoc <- doc$slide$get_slide(id = 1)$get()
  expect_equal(
    xml_attr(xml_find_all(xmldoc, "//a:prstGeom"), "prst"),
    c("line", "line")
  )
  cols <- xml_attr(xml_find_all(xmldoc, "//a:ln/a:solidFill/a:srgbClr"), "val")
  expect_equal(cols, c("4682B4", "4682B4"))
  expect_equal(
    xml_attr(xml_find_all(xmldoc, "//a:ln"), "cmpd"),
    c("sng", "dbl")
  )
  expect_equal(
    xml_attr(xml_find_all(xmldoc, "//a:headEnd"), "type"),
    c("oval", "triangle")
  )
  expect_equal(
    xml_attr(xml_find_all(xmldoc, "//a:tailEnd"), "type"),
    c("triangle", "oval")
  )
  expect_equal(
    xml_attr(xml_find_all(xmldoc, "//a:headEnd"), "w"),
    c("sm", "lg")
  )
  expect_equal(
    xml_attr(xml_find_all(xmldoc, "//a:tailEnd"), "len"),
    c("lg", "sm")
  )
})