tests: new tests

- pptx hyperlink image - slide remove with rm_images
davidgohel · May 5, 2024 · ed2fb57 · ed2fb57
1 parent 2b9499e
commit ed2fb57
Show file tree

Hide file tree

Showing 3 changed files with 118 additions and 60 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Package: officer
 Type: Package
 Title: Manipulation of Microsoft Word and PowerPoint Documents
-Version: 0.6.6.005
+Version: 0.6.6.006
 Authors@R: c(
     person("David", "Gohel", role = c("aut", "cre"), email = "david.gohel@ardata.fr"),
     person("Stefan", "Moog", role = "aut", email = 'moogs@gmx.de'),

diff --git a/tests/testthat/test-pptx-add.R b/tests/testthat/test-pptx-add.R
@@ -14,10 +14,9 @@ test_that("add simple elements into placeholder", {
   doc <- ph_with(doc, c(1L, 2L), location = ph_location_left())
   doc <- ph_with(doc, as.factor(c("rhhh", "vvvlllooo")), location = ph_location_right())
   doc <- add_slide(doc, layout = "Two Content", master = "Office Theme")
-  doc <- ph_with(doc, c(pi, pi/2), location = ph_location_left())
+  doc <- ph_with(doc, c(pi, pi / 2), location = ph_location_left())
   doc <- ph_with(doc, c(TRUE, FALSE), location = ph_location_right())
   expect_snapshot_doc(x = doc, name = "pptx-add-simple", engine = "testthat")
-
 })
 
 test_that("add ggplot into placeholder", {
@@ -29,17 +28,22 @@ test_that("add ggplot into placeholder", {
   local_edition(3L)
   doc <- read_pptx()
   doc <- add_slide(doc)
-  gg_plot <- ggplot(data = iris ) +
-    geom_point(mapping = aes(Sepal.Length, Petal.Length),
-               size = 3) +
+  gg_plot <- ggplot(data = iris) +
+    geom_point(
+      mapping = aes(Sepal.Length, Petal.Length),
+      size = 3
+    ) +
     theme_minimal()
-  doc <- ph_with(x = doc, value = gg_plot,
-                   location = ph_location_type(type = "body"),
-                   bg = "transparent" )
-  doc <- ph_with(x = doc, value = "graphic title",
-                   location = ph_location_type(type="title") )
+  doc <- ph_with(
+    x = doc, value = gg_plot,
+    location = ph_location_type(type = "body"),
+    bg = "transparent"
+  )
+  doc <- ph_with(
+    x = doc, value = "graphic title",
+    location = ph_location_type(type = "title")
+  )
   expect_snapshot_doc(x = doc, name = "pptx-add-ggplot2", engine = "testthat")
-
 })
 test_that("add base plot into placeholder", {
   skip_if_not_installed("doconv")
@@ -54,7 +58,8 @@ test_that("add base plot into placeholder", {
   doc <- ph_with(
     doc, anyplot,
     location = ph_location_fullsize(),
-    bg = "#00000066", pointsize = 12)
+    bg = "#00000066", pointsize = 12
+  )
   expect_snapshot_doc(x = doc, name = "pptx-add-barplot", engine = "testthat")
 })
 
@@ -64,13 +69,15 @@ test_that("add unordered_list into placeholder", {
   require(doconv)
   local_edition(3L)
   ul1 <- unordered_list(
-    level_list = c(0,1,1,0,0,1,1),
-    str_list = c("List1", "Item 1", "Item 2", "" ,"List 2", "Option A", "Option B"))
+    level_list = c(0, 1, 1, 0, 0, 1, 1),
+    str_list = c("List1", "Item 1", "Item 2", "", "List 2", "Option A", "Option B")
+  )
 
   ul2 <- unordered_list(
-    level_list = c(0,1,2,0,0,1,2)+1,
-    str_list = c("List1", "Item 1", "Item 2", "" ,"List 2", "Option A", "Option B"),
-    style = fp_text_lite(color = "gray25") )
+    level_list = c(0, 1, 2, 0, 0, 1, 2) + 1,
+    str_list = c("List1", "Item 1", "Item 2", "", "List 2", "Option A", "Option B"),
+    style = fp_text_lite(color = "gray25")
+  )
 
   doc <- read_pptx()
   doc <- add_slide(doc)
@@ -89,25 +96,33 @@ test_that("add block_list into placeholder", {
   fpt_red_italic <- fp_text_lite(color = "#C32900", italic = TRUE)
   value <- block_list(
     fpar(ftext("hello world", fpt_blue_bold)),
-    fpar(ftext("hello", fpt_blue_bold), " ",
-         ftext("world", fpt_red_italic)),
     fpar(
-      ftext("hello world", fpt_red_italic)))
+      ftext("hello", fpt_blue_bold), " ",
+      ftext("world", fpt_red_italic)
+    ),
+    fpar(
+      ftext("hello world", fpt_red_italic)
+    )
+  )
 
   doc <- read_pptx()
   doc <- add_slide(doc)
-  doc <- ph_with(doc, value = value, location = ph_location_type(),
-                 level_list = c(1, 2, 3))
+  doc <- ph_with(doc,
+    value = value, location = ph_location_type(),
+    level_list = c(1, 2, 3)
+  )
   expect_snapshot_doc(x = doc, name = "pptx-add-blocklist", engine = "testthat")
 })
 
 test_that("add formatted par into placeholder", {
   bold_face <- shortcuts$fp_bold(font.size = 30)
   bold_redface <- update(bold_face, color = "red")
 
-  fpar_ <- fpar(ftext("Hello ", prop = bold_face),
-                ftext("World", prop = bold_redface ),
-                ftext(", how are you?", prop = bold_face ) )
+  fpar_ <- fpar(
+    ftext("Hello ", prop = bold_face),
+    ftext("World", prop = bold_redface),
+    ftext(", how are you?", prop = bold_face)
+  )
 
   doc <- read_pptx()
   doc <- add_slide(doc, layout = "Title and Content", master = "Office Theme")
@@ -119,8 +134,8 @@ test_that("add formatted par into placeholder", {
 
   xmldoc <- doc$slide$get_slide(id = 1)$get()
   cols <- xml_attr(xml_find_all(xmldoc, "//a:rPr/a:solidFill/a:srgbClr"), "val")
-  expect_equal(cols, c("000000", "FF0000", "000000") )
-  expect_equal( xml_attr(xml_find_all(xmldoc, "//a:rPr") ,"b"), rep("1",3))
+  expect_equal(cols, c("000000", "FF0000", "000000"))
+  expect_equal(xml_attr(xml_find_all(xmldoc, "//a:rPr"), "b"), rep("1", 3))
 })
 
 
@@ -133,12 +148,11 @@ test_that("add xml into placeholder", {
   doc <- ph_with(doc, value = as_xml_document(xml_str), location = ph_location(left = 1, top = 1, width = 3, height = 3))
   sm <- slide_summary(doc)
   expect_equal(nrow(sm), 2)
-  expect_equal(sm[1,]$text, "Hello world 1")
-  expect_equal(sm[2,]$text, "Hello world 1")
+  expect_equal(sm[1, ]$text, "Hello world 1")
+  expect_equal(sm[2, ]$text, "Hello world 1")
 })
 
 test_that("slidelink shape", {
-
   doc <- read_pptx()
   doc <- add_slide(doc, layout = "Title and Content", master = "Office Theme")
   doc <- ph_with(doc, "Un titre 1", location = ph_location_type(type = "title"))
@@ -147,23 +161,22 @@ test_that("slidelink shape", {
   doc <- ph_with(doc, "Un titre 2", location = ph_location_type(type = "title"))
   doc <- on_slide(doc, index = 1)
 
-  doc <- ph_slidelink(doc, type = "body", slide_index = 2 )
+  doc <- ph_slidelink(doc, type = "body", slide_index = 2)
 
   rel_df <- doc$slide$get_slide(1)$rel_df()
 
   slide_filename <- doc$slide$get_metadata()$name[2]
 
-  expect_true( slide_filename %in% rel_df$target )
-  row_num_ <- which( is.na(rel_df$target_mode) & rel_df$target %in% slide_filename )
+  expect_true(slide_filename %in% rel_df$target)
+  row_num_ <- which(is.na(rel_df$target_mode) & rel_df$target %in% slide_filename)
 
   rid <- rel_df[row_num_, "id"]
   xpath_ <- sprintf("//p:sp[p:nvSpPr/p:cNvPr/a:hlinkClick/@r:id='%s']", rid)
-  node_ <- xml_find_first(doc$slide$get_slide(1)$get(), xpath_ )
-  expect_false( inherits(node_, "xml_missing") )
+  node_ <- xml_find_first(doc$slide$get_slide(1)$get(), xpath_)
+  expect_false(inherits(node_, "xml_missing"))
 })
 
 test_that("hyperlink shape", {
-
   doc <- read_pptx()
   doc <- add_slide(doc, layout = "Title and Content", master = "Office Theme")
   doc <- ph_with(x = doc, location = ph_location_type(type = "title"), value = "Un titre 1")
@@ -177,24 +190,43 @@ test_that("hyperlink shape", {
   doc <- read_pptx(outputfile)
   rel_df <- doc$slide$get_slide(1)$rel_df()
 
-  expect_true( "https://cran.r-project.org" %in% rel_df$target )
-  row_num_ <- which( !is.na(rel_df$target_mode) & rel_df$target %in% "https://cran.r-project.org" )
+  expect_true("https://cran.r-project.org" %in% rel_df$target)
+  row_num_ <- which(!is.na(rel_df$target_mode) & rel_df$target %in% "https://cran.r-project.org")
 
   rid <- rel_df[row_num_, "id"]
   xpath_ <- sprintf("//p:sp[p:nvSpPr/p:cNvPr/a:hlinkClick/@r:id='%s']", rid)
-  node_ <- xml_find_first(doc$slide$get_slide(1)$get(), xpath_ )
-  expect_false( inherits(node_, "xml_missing") )
+  node_ <- xml_find_first(doc$slide$get_slide(1)$get(), xpath_)
+  expect_false(inherits(node_, "xml_missing"))
+})
+
+test_that("hyperlink image", {
+  img.file <- file.path(R.home(component = "doc"), "html", "logo.jpg")
+
+  x <- read_pptx()
+  x <- add_slide(x)
+  x <- ph_with(x, value = external_img(img.file), location = ph_location(newlabel = "logo"))
+  x <- ph_hyperlink(x = x, ph_label = "logo", href = "https://cran.r-project.org")
+  outputfile <- tempfile(fileext = ".pptx")
+  print(x, target = outputfile)
+
+  doc <- read_pptx(outputfile)
+  rel_df <- doc$slide$get_slide(1)$rel_df()
+
+  expect_true("https://cran.r-project.org" %in% rel_df$target)
 })
 
 test_that("img dims in pptx", {
   skip_on_os("windows")
-  img.file <- file.path( R.home("doc"), "html", "logo.jpg" )
+  img.file <- file.path(R.home("doc"), "html", "logo.jpg")
   doc <- read_pptx()
   doc <- add_slide(doc, "Title and Content", "Office Theme")
   doc <- ph_with(doc,
-                 value = external_img(img.file),
-                 location = ph_location(left = 1, top = 1,
-                                        height = 1.06, width = 1.39) )
+    value = external_img(img.file),
+    location = ph_location(
+      left = 1, top = 1,
+      height = 1.06, width = 1.39
+    )
+  )
   sm <- slide_summary(doc)
 
   expect_equal(nrow(sm), 1)
@@ -206,10 +238,13 @@ test_that("img dims in pptx", {
   doc <- read_pptx()
   doc <- add_slide(doc, "Title and Content", "Office Theme")
   doc <- ph_with(doc,
-                 value = external_img(img.file),
-                 location = ph_location(left = 1, top = 1,
-                                        height = 1.06, width = 1.39),
-                 use_loc_size = TRUE)
+    value = external_img(img.file),
+    location = ph_location(
+      left = 1, top = 1,
+      height = 1.06, width = 1.39
+    ),
+    use_loc_size = TRUE
+  )
   sm <- slide_summary(doc)
 
   expect_equal(nrow(sm), 1)
@@ -226,7 +261,9 @@ test_that("empty_content in pptx", {
     x = doc, value = empty_content(),
     location = ph_location(
       left = 0, top = 0,
-      width = 2, height = 3, bg = "black"))
+      width = 2, height = 3, bg = "black"
+    )
+  )
 
   expect_equal(slide_summary(doc)$offy, 0)
   expect_equal(slide_summary(doc)$offx, 0)
@@ -258,16 +295,17 @@ test_that("pptx ph locations", {
     x = doc, value = "from title",
     location = ph_location_template(
       left = 1, width = 2, height = 1, top = 4,
-      type = "title", newlabel = "newlabel")
+      type = "title", newlabel = "newlabel"
+    )
   )
 
   layouts_info <- layout_properties(doc)
 
 
   title_xfrm <- layouts_info[layouts_info$name %in% "Two Content" &
-                 layouts_info$type %in% "title", c("offx", "offy", "cx", "cy")]
+    layouts_info$type %in% "title", c("offx", "offy", "cx", "cy")]
   side_xfrm <- layouts_info[layouts_info$name %in% "Two Content" &
-                 layouts_info$type %in% "body", c("offx", "offy", "cx", "cy")]
+    layouts_info$type %in% "body", c("offx", "offy", "cx", "cy")]
   full_xfrm <- as.data.frame(slide_size(doc))
   names(full_xfrm) <- c("cx", "cy")
   full_xfrm <- cbind(data.frame(offx = 0L, offy = 0L), full_xfrm)
@@ -276,11 +314,13 @@ test_that("pptx ph locations", {
     side_xfrm,
     title_xfrm,
     full_xfrm,
-    from_title_xfrm)
+    from_title_xfrm
+  )
 
   all_xfrm <- xml_find_all(
     x = doc$slide$get_slide(1)$get(),
-    xpath = "/p:sld/p:cSld/p:spTree/p:sp/p:spPr/a:xfrm")
+    xpath = "/p:sld/p:cSld/p:spTree/p:sp/p:spPr/a:xfrm"
+  )
   offx <- xml_attr(xml_child(all_xfrm, "a:off"), "x")
   offx <- as.integer(offx) / 914400
   offy <- xml_attr(xml_child(all_xfrm, "a:off"), "y")
@@ -292,7 +332,6 @@ test_that("pptx ph locations", {
 
   observed_xfrm <- data.frame(offx = offx, offy = offy, cx = cx, cy = cy)
   expect_equivalent(observed_xfrm, theorical_xfrm)
-
 })
 
 test_that("pptx ph labels", {
@@ -305,8 +344,10 @@ test_that("pptx ph labels", {
   )
   doc <- ph_with(
     x = doc, value = "elephant",
-    location = ph_location_label(ph_label = "Date Placeholder 3",
-                                 newlabel = "label2")
+    location = ph_location_label(
+      ph_label = "Date Placeholder 3",
+      newlabel = "label2"
+    )
   )
   doc <- ph_with(
     x = doc, value = "elephant",
@@ -319,12 +360,12 @@ test_that("pptx ph labels", {
 
   all_nvpr <- xml_find_all(
     x = doc$slide$get_slide(1)$get(),
-    xpath = "/p:sld/p:cSld/p:spTree/p:sp/p:nvSpPr/p:cNvPr")
+    xpath = "/p:sld/p:cSld/p:spTree/p:sp/p:nvSpPr/p:cNvPr"
+  )
   expect_equal(
     xml_attr(all_nvpr, "name"),
     paste0("label", 1:4)
   )
-
 })
 
 

diff --git a/tests/testthat/test-pptx-misc.R b/tests/testthat/test-pptx-misc.R
@@ -58,7 +58,24 @@ test_that("slide remove", {
   expect_equal(sm[1,]$text, "Hello world 2")
 })
 
+test_that("slide remove with rm_images", {
+  img.file <- file.path(R.home(component = "doc"), "html", "logo.jpg")
+  ext_img <- external_img(img.file)
 
+  x <- read_pptx()
+  x <- add_slide(x)
+  x <- ph_with(x, ext_img, location = ph_location_type())
+  filename <- print(x, target = tempfile(fileext = ".pptx"))
+
+  z <- read_pptx(filename)
+  z <- remove_slide(z, index = 1)
+  file1 <- print(z, target = tempfile(fileext = ".pptx"))
+  z <- read_pptx(filename)
+  z <- remove_slide(z, index = 1, rm_images = TRUE)
+  file2 <- print(z, target = tempfile(fileext = ".pptx"))
+
+  expect_gt(file.size(file1), file.size(file2))
+})
 
 test_that("ph remove", {
   x <- read_pptx()