Feat: plot_layout_properties(): accept index, new legend arg, plot …

…current slide by default

- `plot_layout_properties()`: Now prints the current slide's layout
   by default, if not layout name is provided explicitly (#595).
-  Accept the layout index (see `layout_summary()`) as alternative to
   the layout name (suggestion 2 in #595).
- `plot_layout_properties()`: Gains arg `legend` to add a legend to plot

NEWS.md

@@ -22,7 +22,10 @@ informative error message if the type is not present in layout (#601).
 - `plot_layout_properties()` plots more information by default now: layout name, ph label, ph id, ph type + index by default (#606).
 - `ph_location_type()`: new `type_idx` arg replaces the deprecated `id` arg (#606).
 - Add `ph_location_id()` as a new member to the `ph_location_*` family. It references a placeholder via its unique id (#606).
-
+- `plot_layout_properties()`: Now accepts the layout index (see `layout_summary()`) as an alternative to the layout name.
+  Gains an argument `legend` to add a legend to the plot. Also prints the current slide's layout by 
+  default now, if not layout name is provided explicitly (#595).
+
 ## Features
 
 - `layout_rename_ph_labels()` to rename ph labels (#610).

R/pptx_informations.R

@@ -12,6 +12,7 @@ length.rpptx <- function( x ){
   x$slide$length()
 }
 
+
 #' @export
 #' @title Slides width and height
 #' @description Get the width and height of slides in inches as
@@ -32,7 +33,6 @@ slide_size <- function(x) {
 }
 
 
-
 #' @export
 #' @title Presentation layouts summary
 #' @description Get information about slide layouts and
@@ -118,8 +118,8 @@ layout_properties <- function(x, layout = NULL, master = NULL) {
 #'    _NB_: The id is set by PowerPoint automatically and lack a meaningful order.
 #'
 #' @param x an `rpptx` object
-#' @param layout slide layout name.
-#' @param master master layout name where `layout` is located.
+#' @param layout slide layout name or numeric index (row index from [layout_summary()).
+#' @param master master layout name where `layout` is located. Can be omitted if layout is unambiguous.
 #' @param title if `TRUE` (default), adds a title with the layout name at the top.
 #' @param labels if `TRUE` (default), adds placeholder labels (centered in *red*).
 #' @param type if `TRUE` (default), adds the placeholder type and its index (in square brackets)
@@ -128,21 +128,16 @@ layout_properties <- function(x, layout = NULL, master = NULL) {
 #'  [layout_properties()]) in the upper right corner (in *green*).
 #' @param cex named list or vector to specify font size for `labels`, `type`, and `id`. Default is
 #'   `c(labels = .5, type = .5, id = .5)`. See [graphics::text()] for details on how `cex` works.
+#' @param legend Add a legend to the plot (default `FALSE`).
 #' @importFrom graphics plot rect text box
-#' @examples
-#' x <- read_pptx()
-#' plot_layout_properties(x = x, layout = "Title Slide", master = "Office Theme")
-#' plot_layout_properties(x = x, layout = "Two Content")
-#' plot_layout_properties(x = x, layout = "Two Content", title = FALSE, type = FALSE, id = FALSE)
-#'
-#' # change font size
-#' plot_layout_properties(x = x, layout = "Two Content", cex = c(labels = 1, id = .7, type = .7))
-#'
 #' @family functions for reading presentation information
+#' @example inst/examples/example_plot_layout_properties.R
 #'
 plot_layout_properties <- function(x, layout = NULL, master = NULL, labels = TRUE, title = TRUE,
-                                   type = TRUE, id = TRUE, cex = NULL) {
-  old_par <- par(mar = c(2, 2, 1.5, 0))
+                                   type = TRUE, id = TRUE, cex = NULL, legend = FALSE) {
+  stop_if_not_rpptx(x, "x")
+  loffset <- ifelse(legend, 1, 0) # make space for legend at top
+  old_par <- par(mar = c(2, 2, 1.5 + loffset, 0))
   on.exit(par(old_par))
 
   cex_default <- list(labels = .5, type = .5, id = .5)
@@ -155,7 +150,21 @@ plot_layout_properties <- function(x, layout = NULL, master = NULL, labels = TRU
   }
   .cex <- utils::modifyList(x = cex_default, val = as.list(cex), keep.null = TRUE)
 
-  dat <- layout_properties(x, layout = layout, master = master)
+  # use current slides layout as default (if layout and master = NULL)
+  if (is.null(layout) && is.null(master)) {
+    if (length(x) == 0) {
+      cli::cli_abort(
+        c("No {.arg layout} selected and no slides in presentation.",
+        "x" = "Pass a layout name or index (see {.fn layout_summary})")
+      )
+    }
+    la <- get_layout_for_current_slide(x)
+    cli::cli_inform(c("i"="Showing current slide's layout: {.val {la$layout_name}}"))
+  } else {
+    la <- get_layout(x, layout, master)
+  }
+
+  dat <- layout_properties(x, layout = la$layout_name, master = la$master_name)
   if (length(unique(dat$name)) > 1) {
     cli::cli_abort(c("One single layout must be chosen",
       "x" = "Did you supply a master?"
@@ -166,9 +175,6 @@ plot_layout_properties <- function(x, layout = NULL, master = NULL, labels = TRU
                      "x" = "Did you misspell the layout name?"
     ), call = NULL)
   }
-  # # order and type_idx now in xfrmize()
-  # dat <- dat[order(dat$type, as.integer(dat$id)), ] # set order for type idx. Removing the line would result in the default layout properties order, i.e., top->bottom left->right.
-  # dat$type_idx <- stats::ave(dat$type, dat$type, FUN = seq_along) # NB: returns character index
 
   s <- slide_size(x)
   h <- s$height
@@ -179,11 +185,11 @@ plot_layout_properties <- function(x, layout = NULL, master = NULL, labels = TRU
   plot(x = c(0, w), y = -c(0, h), asp = 1, type = "n", axes = FALSE, xlab = NA, ylab = NA)
   rect(xleft = 0, xright = w, ybottom = 0, ytop = -h, border = "darkgrey")
   rect(xleft = offx, xright = offx + cx, ybottom = -offy, ytop = -(offy + cy))
-  mtext("y [inch]", side = 2, line = 0, cex = 1.2, col = "darkgrey")
-  mtext("x [inch]", side = 1, line = 0, cex = 1.2, col = "darkgrey")
+  mtext("y [inch]", side = 2, line = 0, cex = .9, col = "darkgrey")
+  mtext("x [inch]", side = 1, line = 0, cex = .9, col = "darkgrey")
 
   if (title) {
-    title(main = paste("Layout:", layout))
+    title(main = paste("Layout:", la$layout_name), line = 0 + loffset)
   }
   if (labels) { # centered
     text(x = offx + cx / 2, y = -(offy + cy / 2), labels = dat$ph_label, cex = .cex$labels, col = "red", adj = c(.5, 1)) # adj-vert: avoid interference with type/id in small phs
@@ -195,6 +201,16 @@ plot_layout_properties <- function(x, layout = NULL, master = NULL, labels = TRU
   if (id) { # upper right corner
     text(x = offx + cx, y = -offy, labels = dat$id, cex = .cex$id, col = "darkgreen", adj = c(1.3, 1.2))
   }
+  if (legend) {
+    legend(x = w / 2, y = 0, x.intersp = 0.4, xjust = .5, yjust = 0,
+      legend = c("type [type_idx]", "ph_label", "id"), fill = c("blue", "red", "darkgreen"),
+      bty = "n", pt.cex = 1.2, cex = .7, text.width = NA,
+      text.col = c("blue", "red", "darkgreen"), horiz = TRUE, xpd = TRUE
+    )
+  }
+
+
+
 }
 
 
@@ -265,6 +281,7 @@ annotate_base <- function(path = NULL, output_file = 'annotated_layout.pptx' ){
   ppt
 }
 
+
 #' @export
 #' @title Slide content in a data.frame
 #' @description Get content and positions of current slide
@@ -319,10 +336,6 @@ slide_summary <- function( x, index = NULL ){
 }
 
 
-
-
-
-
 #' @export
 #' @title Color scheme of a PowerPoint file
 #' @description Get the color scheme of a

R/pptx_layout_helper.R

@@ -103,3 +103,27 @@ get_row_by_name <- function(df, layout, master) {
   }
   df
 }
+
+
+# get <layout_info> object for slide layout
+get_slide_layout <- function(x, slide_idx) {
+  stop_if_not_rpptx(x)
+  if (length(x) == 0) {
+    cli::cli_abort(
+      c("Presentation does not have any slides yet",
+        "x" = "Can only get the layout for an existing slides",
+        "i" = "You can add a slide using {.fn add_slide}")
+      , call = NULL)
+  }
+  ensure_slide_index_exists(x, slide_idx)
+  df <- x$slide$get_xfrm()[[slide_idx]]
+  layout <- unique(df$name)
+  master <- unique(df$master_name)
+  get_layout(x, layout, master)
+}
+
+
+# get <layout_info> object for layout of current slide
+get_layout_for_current_slide <- function(x) {
+  get_slide_layout(x, x$cursor)
+}

R/pptx_slide_manip.R

@@ -234,3 +234,24 @@ shape_properties_tags <- function(left = 0, top = 0, width = 3, height = 3,
 
   sprintf(str, randomid, label, ph, xfrm_str, geom_str, bg_str, ln_str)
 }
+
+
+# check if slide index exists
+ensure_slide_index_exists <- function(x, slide_idx) {
+  stop_if_not_rpptx(x)
+  if (!is.numeric(slide_idx)) {
+    cli::cli_abort(
+      c("{.arg slide_idx} must be {.cls numeric}",
+        "x" = "You provided {.cls {class(slide_idx)[1]}} instead.")
+      , call = NULL)
+  }
+  n <- length(x) # no of slides
+  check <- slide_idx %in% seq_len(n)
+  if (!check) {
+    cli::cli_abort(
+      c("Slide index {.val {slide_idx}} is out of range.",
+        "x" = "Presentation has {cli::no(n)} slide{?s}."
+      ), call = NULL
+    )
+  }
+}

inst/examples/example_plot_layout_properties.R

@@ -0,0 +1,17 @@
+x <- read_pptx()
+
+# select layout explicitly
+plot_layout_properties(x = x, layout = "Title Slide", master = "Office Theme")
+plot_layout_properties(x = x, layout = "Title Slide") # no master needed if layout name unique
+plot_layout_properties(x = x, layout = 1) # use layout index instead of name
+
+# plot current slide's layout (default if no layout is passed)
+x <- read_pptx()
+x <- add_slide(x, "Title Slide")
+plot_layout_properties(x)
+
+# change appearance: what to show, font size, legend etc.
+plot_layout_properties(x, layout = "Two Content", title = FALSE, type = FALSE, id = FALSE)
+plot_layout_properties(x, layout = 4, cex = c(labels = .8, id = .7, type = .7))
+plot_layout_properties(x, 1, legend = TRUE)
+

tests/testthat/test-get-layout-helper.R

@@ -84,3 +84,44 @@ test_that("<layout_info> prints correctly", {
   out <- capture.output(print(l))
   expect_equal(length(out), length(l))
 })
+
+
+test_that("get layout from slide", {
+  opts <- options(cli.num_colors = 1) # suppress colors for error message check
+  on.exit(options(opts))
+
+  x <- read_pptx()
+
+  # fails if no slides exist
+  expect_error(get_slide_layout(x, 0), "Presentation does not have any slides yet")
+  expect_error(get_layout_for_current_slide(x), "Presentation does not have any slides yet")
+
+  # detect correct slide layout
+  layout <- "Comparison"
+  x <- add_slide(x, layout)
+
+  expect_error(get_slide_layout(x, 0), "Slide index 0 is out of range")
+  expect_error(get_slide_layout(x, 2), "Slide index 2 is out of range")
+
+  error_msg <- "`slide_idx` must be <numeric>"
+  expect_error(get_slide_layout(x, "1"), error_msg)
+  expect_error(get_slide_layout(x, NA), error_msg)
+  expect_error(get_slide_layout(x, NULL), error_msg)
+
+  expect_no_error(get_slide_layout(x, 1))
+  expect_no_error(get_layout_for_current_slide(x))
+
+  la_slide <- get_slide_layout(x, 1)
+  la_current <- get_layout_for_current_slide(x)
+  la_reference <- get_layout(x, layout)
+  expect_identical(la_current, la_reference)
+  expect_identical(la_slide, la_reference)
+
+  layout <- "Title Slide"
+  x <- add_slide(x, layout)
+  la_slide <- get_slide_layout(x, 2)
+  la_current <- get_layout_for_current_slide(x)
+  la_reference <- get_layout(x, layout)
+  expect_identical(la_current, la_reference)
+  expect_identical(la_slide, la_reference)
+})

tests/testthat/test-pptx-info.R

@@ -99,30 +99,38 @@ test_that("plot layout properties", {
   )
   dev.off()
 
+  png3 <- tempfile(fileext = ".png")
+  png(png3, width = 7, height = 6, res = 150, units = "in")
+  plot_layout_properties(
+    x = x, layout = "Title Slide", master = "Office Theme", legend = TRUE
+  )
+  dev.off()
+
   expect_snapshot_doc(name = "plot-titleslide-layout-default", x = png1, engine = "testthat")
   expect_snapshot_doc(name = "plot-titleslide-layout-labels-only", x = png2, engine = "testthat")
+  expect_snapshot_doc(name = "plot-titleslide-layout-default-with-legend", x = png3, engine = "testthat")
 
   # issue #604
   p <- test_path("docs_dir/test-content-order.pptx")
   x <- read_pptx(p)
 
-  png3 <- tempfile(fileext = ".png")
-  png(png3, width = 7, height = 6, res = 150, units = "in")
+  png4 <- tempfile(fileext = ".png")
+  png(png4, width = 7, height = 6, res = 150, units = "in")
   plot_layout_properties(
     x = x, layout = "Many Contents", master = "Office Theme"
   )
   dev.off()
 
-  png4 <- tempfile(fileext = ".png")
-  png(png4, width = 7, height = 6, res = 150, units = "in")
+  png5 <- tempfile(fileext = ".png")
+  png(png5, width = 7, height = 6, res = 150, units = "in")
   plot_layout_properties(
     x = x, layout = "Many Contents", master = "Office Theme",
     labels = TRUE, type = FALSE, id = FALSE, title = FALSE
   )
   dev.off()
 
-  expect_snapshot_doc(name = "plot-content-order-default", x = png3, engine = "testthat")
-  expect_snapshot_doc(name = "plot-content-order-labels-only", x = png4, engine = "testthat")
+  expect_snapshot_doc(name = "plot-content-order-default", x = png4, engine = "testthat")
+  expect_snapshot_doc(name = "plot-content-order-labels-only", x = png5, engine = "testthat")
 })
 
 
@@ -146,6 +154,26 @@ test_that("slide summary", {
 })
 
 
+
+test_that("plot layout properties: layout arg takes numeric index", {
+  x <- read_pptx()
+  las <- layout_summary(x)
+  ii <- as.numeric(rownames(las))
+
+  discarded_plot <- function(x, layout = NULL, master = NULL) { # avoid Rplots.pdf creation
+    file <- tempfile(fileext = ".png")
+    png(file, width = 7, height = 6, res = 150, units = "in")
+      plot_layout_properties(x, layout, master)
+    dev.off()
+  }
+
+  for (idx in ii) {
+    expect_no_error(discarded_plot(x, idx))
+  }
+  expect_no_error(discarded_plot(x, 1, "Office Theme"))
+})
+
+
 test_that("color scheme", {
   x <- read_pptx()
   cs <- color_scheme(x)