tests/testthat/test-fp-text.R

In officer: Manipulation of Microsoft Word and PowerPoint Documents

source("utils.R")


wml_is_italic <- function(doc_) {
  !inherits(xml_find_first(doc_, "/w:document/w:rPr/w:i"), "xml_missing")
}
wml_is_bold <- function(doc_) {
  !inherits(xml_find_first(doc_, "/w:document/w:rPr/w:b"), "xml_missing")
}
wml_is_underline <- function(doc_) {
  !inherits(xml_find_first(doc_, "/w:document/w:rPr/w:u"), "xml_missing")
}

test_that("wml - font size", {
  fp <- fp_text(font.size = 10)
  xml_ <- format(fp, type = "wml")

  doc <- read_xml(wml_str(xml_))

  sz <- xml_find_first(doc, "/w:document/w:rPr/w:sz")
  szCs <- xml_find_first(doc, "/w:document/w:rPr/w:szCs")
  expect_false(inherits(szCs, "xml_missing"))
  expect_false(inherits(sz, "xml_missing"))

  expect_equal(xml_attr(sz, "val"), xml_attr(szCs, "val"))
  expect_equal(xml_attr(sz, "val"), expected = "20")
})

test_that("wml - bold italic underlined", {
  fp_bold <- fp_text(bold = TRUE)
  fp_italic <- update(fp_bold, bold = FALSE, italic = TRUE)
  fp_bold_italic <- update(fp_bold, italic = TRUE)
  fp_underline <- fp_text(underlined = TRUE)

  xml_bold_ <- format(fp_bold, type = "wml")
  xml_italic_ <- format(fp_italic, type = "wml")
  xml_bolditalic_ <- format(fp_bold_italic, type = "wml")
  xml_underline_ <- format(fp_underline, type = "wml")

  doc_bold_ <- read_xml(wml_str(xml_bold_))
  doc_italic_ <- read_xml(wml_str(xml_italic_))
  doc_bolditalic_ <- read_xml(wml_str(xml_bolditalic_))
  doc_underline_ <- read_xml(wml_str(xml_underline_))

  expect_equal(wml_is_bold(doc_bold_), TRUE)
  expect_equal(
    xml_attr(xml_find_first(doc_bold_, "/w:document/w:rPr/w:i"), "val"),
    "false"
  )
  expect_equal(
    xml_attr(xml_find_first(doc_italic_, "/w:document/w:rPr/w:b"), "val"),
    "false"
  )
  expect_equal(
    xml_attr(xml_find_first(doc_italic_, "/w:document/w:rPr/w:i"), "val"),
    "true"
  )

  expect_equal(
    xml_attr(xml_find_first(doc_italic_, "/w:document/w:rPr/w:b"), "val"),
    "false"
  )
  expect_equal(
    xml_attr(xml_find_first(doc_italic_, "/w:document/w:rPr/w:i"), "val"),
    "true"
  )
  expect_equal(wml_is_bold(doc_bolditalic_), TRUE)
  expect_equal(wml_is_italic(doc_bolditalic_), TRUE)

  expect_equal(
    xml_attr(xml_find_first(doc_bold_, "/w:document/w:rPr/w:u"), "val"),
    "none"
  )
  expect_equal(
    xml_attr(xml_find_first(doc_underline_, "/w:document/w:rPr/w:u"), "val"),
    "single"
  )
})


test_that("wml - font name", {
  fontname = "Arial"
  fp_ <- fp_text(font.family = fontname)

  xml_ <- format(fp_, type = "wml")
  doc_ <- read_xml(wml_str(xml_))

  node <- xml_find_first(doc_, "/w:document/w:rPr/w:rFonts")
  expect_false(inherits(node, "xml_missing"))

  expect_equal(xml_attr(node, "ascii"), fontname)
  expect_equal(xml_attr(node, "hAnsi"), fontname)
  expect_equal(xml_attr(node, "cs"), fontname)
})

test_that("wml - font color", {
  fp_ <- fp_text(color = grDevices::rgb(.8, .2, .1, .6))

  xml_ <- format(fp_, type = "wml")
  doc_ <- read_xml(wml_str(xml_))

  node <- xml_find_first(doc_, "/w:document/w:rPr/w:color")
  expect_false(inherits(node, "xml_missing"))

  expect_equal(xml_attr(node, "val"), "CC331A")

  node <- xml_find_first(doc_, "/w:document/w:rPr/w14:textFill")
  expect_false(inherits(node, "xml_missing"))
  expect_equal(
    xml_attr(xml_child(node, "w14:solidFill/w14:srgbClr"), "val"),
    "CC331A"
  )
  expect_equal(
    xml_attr(xml_child(node, "w14:solidFill/w14:srgbClr/w14:alpha"), "val"),
    "60000"
  )
})


test_that("wml - shading color", {
  fp_ <- fp_text(shading.color = rgb(1, 0, 1))

  xml_ <- format(fp_, type = "wml")
  doc_ <- read_xml(wml_str(xml_))

  node <- xml_find_first(doc_, "/w:document/w:rPr/w:shd")
  expect_false(inherits(node, "xml_missing"))

  expect_equal(xml_attr(node, "fill"), "FF00FF")
})


pml_has_true_attr <- function(doc_, what = "b") {
  rpr <- xml_find_first(doc_, "/a:document/a:rPr")
  val <- xml_attr(rpr, what)
  !is.na(val) && val == "1"
}
pml_attr <- function(doc_, what = "u") {
  rpr <- xml_find_first(doc_, "/a:document/a:rPr")
  xml_attr(rpr, what)
}


test_that("pml - font size", {
  fp <- fp_text(font.size = 10)
  xml_ <- format(fp, type = "pml")

  doc_ <- read_xml(pml_str(xml_))
  rpr <- xml_find_first(doc_, "/a:document/a:rPr")

  expect_equal(xml_attr(rpr, "sz"), "1000")
})

test_that("pml - bold italic underlined", {
  fp_bold <- fp_text(bold = TRUE)
  fp_italic <- update(fp_bold, bold = FALSE, italic = TRUE)
  fp_bold_italic <- update(fp_bold, italic = TRUE)
  fp_underline <- fp_text(underlined = TRUE)

  xml_bold_ <- format(fp_bold, type = "pml")
  xml_italic_ <- format(fp_italic, type = "pml")
  xml_bolditalic_ <- format(fp_bold_italic, type = "pml")
  xml_underline_ <- format(fp_underline, type = "pml")

  doc_bold_ <- read_xml(pml_str(xml_bold_))
  doc_italic_ <- read_xml(pml_str(xml_italic_))
  doc_bolditalic_ <- read_xml(pml_str(xml_bolditalic_))
  doc_underline_ <- read_xml(pml_str(xml_underline_))

  expect_equal(pml_has_true_attr(doc_bold_, "b"), TRUE)
  expect_equal(pml_has_true_attr(doc_bold_, "i"), FALSE)
  expect_equal(pml_has_true_attr(doc_bold_, "u"), FALSE)

  expect_equal(pml_has_true_attr(doc_italic_, "b"), FALSE)
  expect_equal(pml_has_true_attr(doc_italic_, "i"), TRUE)
  expect_equal(pml_has_true_attr(doc_italic_, "u"), FALSE)

  expect_equal(pml_has_true_attr(doc_bolditalic_, "b"), TRUE)
  expect_equal(pml_has_true_attr(doc_bolditalic_, "i"), TRUE)
  expect_equal(pml_has_true_attr(doc_bolditalic_, "u"), FALSE)

  expect_equal(pml_has_true_attr(doc_underline_, "b"), FALSE)
  expect_equal(pml_has_true_attr(doc_underline_, "i"), FALSE)
  expect_equal(pml_attr(doc_underline_, "u"), "sng")
})


test_that("pml - font name", {
  fontname = "Arial"
  fp_ <- fp_text(font.family = fontname)

  xml_ <- format(fp_, type = "pml")
  doc_ <- read_xml(pml_str(xml_))

  node <- xml_find_first(doc_, "/a:document/a:rPr/a:latin")
  expect_false(inherits(node, "xml_missing"))
  expect_equal(xml_attr(node, "typeface"), fontname)

  node <- xml_find_first(doc_, "/a:document/a:rPr/a:cs")
  expect_false(inherits(node, "xml_missing"))
  expect_equal(xml_attr(node, "typeface"), fontname)
})

test_that("pml - font color", {
  fp_ <- fp_text(color = rgb(1, 0, 0, .5))

  xml_ <- format(fp_, type = "pml")
  doc_ <- read_xml(pml_str(xml_))

  node <- xml_find_first(doc_, "/a:document/a:rPr/a:solidFill/a:srgbClr")
  expect_false(inherits(node, "xml_missing"))
  expect_equal(xml_attr(node, "val"), "FF0000")

  node <- xml_find_first(
    doc_,
    "/a:document/a:rPr/a:solidFill/a:srgbClr/a:alpha"
  )
  expect_equal(xml_attr(node, "val"), "50196")
})


test_that("css", {
  fp <- fp_text(
    font.size = 10,
    color = "#00FFFF34",
    shading.color = "#00FFFFCC"
  )
  expect_true(has_css_color(fp, "color", "rgba\\(0,255,255,0.20\\)"))
  expect_true(has_css_attr(fp, "font-family", "'Arial'"))
  expect_true(has_css_attr(fp, "font-size", "10.0pt"))
  expect_true(has_css_attr(fp, "font-style", "normal"))
  expect_true(has_css_attr(fp, "font-weight", "normal"))
  expect_true(has_css_attr(fp, "text-decoration", "none"))
  expect_true(has_css_color(fp, "background-color", "rgba\\(0,255,255,0.80\\)"))

  fp <- fp_text(bold = TRUE, italic = TRUE, underlined = TRUE)
  expect_true(has_css_attr(fp, "font-style", "italic"))
  expect_true(has_css_attr(fp, "font-weight", "bold"))
  expect_true(has_css_attr(fp, "text-decoration", "underline"))
})