diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index 8863865c..f89019d5 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -5,6 +5,7 @@ on: pull_request: branches: - master + workflow_dispatch: name: R-CMD-check diff --git a/DESCRIPTION b/DESCRIPTION index b0ef3858..bc9320fe 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Type: Package Package: officer Title: Manipulation of Microsoft Word and PowerPoint Documents -Version: 0.6.8.003 +Version: 0.6.8.004 Authors@R: c( person("David", "Gohel", , "david.gohel@ardata.fr", role = c("aut", "cre")), person("Stefan", "Moog", , "moogs@gmx.de", role = "aut"), @@ -65,3 +65,49 @@ Suggests: Encoding: UTF-8 Roxygen: list(markdown = TRUE) RoxygenNote: 7.3.2 +Collate: + 'core_properties.R' + 'custom_properties.R' + 'defunct.R' + 'dev-utils.R' + 'docx_add.R' + 'docx_comments.R' + 'docx_cursor.R' + 'docx_part.R' + 'docx_replace.R' + 'docx_section.R' + 'docx_settings.R' + 'empty_content.R' + 'formatting_properties.R' + 'fortify_docx.R' + 'fortify_pptx.R' + 'knitr_utils.R' + 'officer.R' + 'ooxml.R' + 'ooxml_block_objects.R' + 'ooxml_run_objects.R' + 'openxml_content_type.R' + 'openxml_document.R' + 'pack_folder.R' + 'ph_location.R' + 'post-proc.R' + 'ppt_class_dir_collection.R' + 'ppt_classes.R' + 'ppt_notes.R' + 'ppt_ph_dedupe_layout.R' + 'ppt_ph_manipulate.R' + 'ppt_ph_rename_layout.R' + 'ppt_ph_with_methods.R' + 'pptx_informations.R' + 'pptx_layout_helper.R' + 'pptx_matrix.R' + 'utils.R' + 'pptx_slide_manip.R' + 'read_docx.R' + 'read_docx_styles.R' + 'read_pptx.R' + 'read_xlsx.R' + 'relationship.R' + 'rtf.R' + 'shape_properties.R' + 'shorcuts.R' diff --git a/NAMESPACE b/NAMESPACE index 89f0a329..4338c78b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -162,6 +162,7 @@ S3method(update,fpar) S3method(update,sp_line) S3method(update,sp_lineend) export("layout_rename_ph_labels<-") +export("slide_visible<-") export(add_sheet) export(add_slide) export(annotate_base) @@ -301,6 +302,7 @@ export(sheet_select) export(shortcuts) export(slide_size) export(slide_summary) +export(slide_visible) export(slip_in_column_break) export(slip_in_footnote) export(slip_in_seqfield) diff --git a/NEWS.md b/NEWS.md index a1f74bc7..a69691bc 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,6 +2,7 @@ ## Issues +- Add `slide_visible()` to get and set the visibility of slides (#622). - debug selector for `ph_remove()` (see #625) that was not working for rvg outputs. diff --git a/R/pptx_slide_manip.R b/R/pptx_slide_manip.R index 22c6a298..416b5e76 100644 --- a/R/pptx_slide_manip.R +++ b/R/pptx_slide_manip.R @@ -1,3 +1,4 @@ + #' @export #' @title Add a slide #' @description Add a slide into a pptx presentation. @@ -255,3 +256,84 @@ ensure_slide_index_exists <- function(x, slide_idx) { ) } } + + +# internal workhorse get/set slide visibility +# x : rpptx object +# slide_idx: id of slide +# value: Use TRUE / FALSE to set visibility. +.slide_visible <- function(x, slide_idx, value = NULL) { + stop_if_not_rpptx(x) + slide <- x$slide$get_slide(slide_idx) + slide_xml <- slide$get() + node <- xml2::xml_find_first(slide_xml, "/p:sld") + if (is.null(value)) { + value <- xml2::xml_attr(node, "show") + value <- as.logical(as.numeric(value)) + ifelse(is.na(value), TRUE, value) # if show is not set, the slide is shown + } else { + stop_if_not_class(value, "logical", arg = "value") + xml2::xml_set_attr(node, "show", value = as.numeric(value)) + slide$save() + invisible(x) + } +} + + +#' Get or set slide visibility +#' +#' PPTX slides can be visible or hidden. This function gets or sets the visibility of slides. +#' @param x An `rpptx` object. +#' @param value Boolean vector with slide visibilities. +#' @rdname slide-visible +#' @export +#' @example inst/examples/example_slide_visible.R +#' @return Boolean vector with slide visibilities or `rpptx` object if changes are made to the object. +`slide_visible<-` <- function(x, value) { + stop_if_not_rpptx(x) + stop_if_not_class(value, "logical", arg = "value") + n_vals <- length(value) + n_slides <- length(x) + if (n_vals > n_slides) { + cli::cli_abort("More values ({.val {n_vals}}) than slides ({.val {n_slides}})") + } + if (n_vals != 1 && n_vals != n_slides) { + cli::cli_warn("Value is not length 1 or same length as number of slides ({.val {n_slides}}). Recycling values.") + } + value <- rep(value, length.out = n_slides) + for (i in seq_along(value)) { + .slide_visible(x, i, value[i]) + } + invisible(x) +} + + +#' @param hide,show Indexes of slides to hide or show. +#' @rdname slide-visible +#' @export +slide_visible <- function(x, hide = NULL, show = NULL) { + stop_if_not_rpptx(x) + idx_in_both <- intersect(as.integer(hide), as.integer(show)) + if (length(idx_in_both) > 1) { + cli::cli_abort( + "Overlap between indexes in {.arg hide} and {.arg show}: {.val {idx_in_both}}", + "x" = "Indexes must be mutually exclusive.") + } + if (!is.null(hide)) { + stop_if_not_integerish(hide, "hide") + stop_if_not_in_slide_range(x, hide, arg = "hide") + slide_visible(x)[hide] <- FALSE + } + if (!is.null(show)) { + stop_if_not_integerish(show, "show") + stop_if_not_in_slide_range(x, show, arg = "show") + slide_visible(x)[show] <- TRUE + } + n_slides <- length(x) + res <- vapply(seq_len(n_slides), function(idx) .slide_visible(x, idx), logical(1)) + if (is.null(hide) && is.null(show)) { + res + } else { + x + } +} diff --git a/R/utils.R b/R/utils.R index 0200f5c2..2b328a9a 100644 --- a/R/utils.R +++ b/R/utils.R @@ -334,6 +334,49 @@ stop_if_not_rpptx <- function(x, arg = NULL) { stop_if_not_class(x, "rpptx", arg) } + +stop_if_not_integerish <- function(x, arg = NULL) { + check <- is_integerish(x) + if (!check) { + msg_arg <- ifelse(is.null(arg), "Incorrect input.", "Incorrect input for {.arg {arg}}") + cli::cli_abort(c( + msg_arg, + "x" = "Expected integerish values but got {.cls {class(x)[1]}}" + ), call = NULL) + } +} + + +#' Ensure valid slide indexes +#' +#' @param x An `rpptx` object. +#' @param idx Slide indexes. +#' @param arg Name of argument to use in error message (optional). +#' @param call Environment to display in error message. Defaults to caller env. +#' Set `NULL` to suppress (see [cli::cli_abort]). +#' @keywords internal +stop_if_not_in_slide_range <- function(x, idx, arg = NULL, call = parent.frame()) { + stop_if_not_rpptx(x) + stop_if_not_integerish(idx) + + n_slides <- length(x) + idx_available <- seq_len(n_slides) + idx_outside <- setdiff(idx, idx_available) + n_outside <- length(idx_outside) + + if (n_outside == 0) { + return(invisible(NULL)) + } + argname <- ifelse(is.null(arg), "", "of {.arg {arg}} ") + part_1 <- paste0("{n_outside} index{?es} ", argname, "outside slide range: {.val {idx_outside}}") + part_2 <- ifelse(n_slides == 0, + "Presentation has no slides!", + "Slide indexes must be in the range [{min(idx_available)}..{max(idx_available)}]" + ) + cli::cli_abort(c(part_1, "x" = part_2), call = call) +} + + check_unit <- function(unit, choices, several.ok = FALSE) { if (!several.ok && length(unit) != 1) { cli::cli_abort( @@ -429,3 +472,13 @@ is_named <- function(x) { detect_void_name <- function(x) { x == "" | is.na(x) } + + +# is_integerish(1) +# is_integerish(1.0) +# is_integerish(c(1.0, 2.0)) +is_integerish <- function(x) { + ii <- all(is.numeric(x) | is.integer(x)) + jj <- all(x == as.integer(x)) + ii && jj +} diff --git a/inst/examples/example_slide_visible.R b/inst/examples/example_slide_visible.R new file mode 100644 index 00000000..1dbd3e47 --- /dev/null +++ b/inst/examples/example_slide_visible.R @@ -0,0 +1,17 @@ +path <- system.file("doc_examples/example.pptx", package = "officer") +x <- read_pptx(path) + +slide_visible(x) # get slide visibilities + +x <- slide_visible(x, hide = 1:2) # hide slides 1 and 2 +x <- slide_visible(x, show = 1:2) # make slides 1 and 2 visible +x <- slide_visible(x, show = 1:2, hide = 3) + +slide_visible(x) <- FALSE # hide all slides +slide_visible(x) <- c(TRUE, FALSE, TRUE) # set each slide separately +slide_visible(x) <- c(TRUE, FALSE) # warns that rhs values are recycled + +slide_visible(x)[2] <- TRUE # set 2nd slide to visible +slide_visible(x)[c(1, 3)] <- FALSE # 1st and 3rd slide +slide_visible(x)[c(1, 3)] <- c(FALSE, FALSE) # identical + diff --git a/man/slide-visible.Rd b/man/slide-visible.Rd new file mode 100644 index 00000000..5d1ae6d3 --- /dev/null +++ b/man/slide-visible.Rd @@ -0,0 +1,43 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pptx_slide_manip.R +\name{slide_visible<-} +\alias{slide_visible<-} +\alias{slide_visible} +\title{Get or set slide visibility} +\usage{ +slide_visible(x) <- value + +slide_visible(x, hide = NULL, show = NULL) +} +\arguments{ +\item{x}{An \code{rpptx} object.} + +\item{value}{Boolean vector with slide visibilities.} + +\item{hide, show}{Indexes of slides to hide or show.} +} +\value{ +Boolean vector with slide visibilities or \code{rpptx} object if changes are made to the object. +} +\description{ +PPTX slides can be visible or hidden. This function gets or sets the visibility of slides. +} +\examples{ +path <- system.file("doc_examples/example.pptx", package = "officer") +x <- read_pptx(path) + +slide_visible(x) # get slide visibilities + +x <- slide_visible(x, hide = 1:2) # hide slides 1 and 2 +x <- slide_visible(x, show = 1:2) # make slides 1 and 2 visible +x <- slide_visible(x, show = 1:2, hide = 3) + +slide_visible(x) <- FALSE # hide all slides +slide_visible(x) <- c(TRUE, FALSE, TRUE) # set each slide separately +slide_visible(x) <- c(TRUE, FALSE) # warns that rhs values are recycled + +slide_visible(x)[2] <- TRUE # set 2nd slide to visible +slide_visible(x)[c(1, 3)] <- FALSE # 1st and 3rd slide +slide_visible(x)[c(1, 3)] <- c(FALSE, FALSE) # identical + +} diff --git a/man/stop_if_not_in_slide_range.Rd b/man/stop_if_not_in_slide_range.Rd new file mode 100644 index 00000000..4079eeed --- /dev/null +++ b/man/stop_if_not_in_slide_range.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{stop_if_not_in_slide_range} +\alias{stop_if_not_in_slide_range} +\title{Ensure valid slide indexes} +\usage{ +stop_if_not_in_slide_range(x, idx, arg = NULL, call = parent.frame()) +} +\arguments{ +\item{x}{An \code{rpptx} object.} + +\item{idx}{Slide indexes.} + +\item{arg}{Name of argument to use in error message (optional).} + +\item{call}{Environment to display in error message. Defaults to caller env. +Set \code{NULL} to suppress (see \link[cli:cli_abort]{cli::cli_abort}).} +} +\description{ +Ensure valid slide indexes +} +\keyword{internal} diff --git a/officer.Rproj b/officer.Rproj index cba1b6b7..7f266a65 100644 --- a/officer.Rproj +++ b/officer.Rproj @@ -1,8 +1,9 @@ Version: 1.0 +ProjectId: cf684f77-79cc-4641-8f83-6d6abc3f30bd RestoreWorkspace: No SaveWorkspace: No -AlwaysSaveHistory: Default +AlwaysSaveHistory: No EnableCodeIndexing: Yes UseSpacesForTab: Yes diff --git a/tests/testthat/docs_dir/test-slides-visible.pptx b/tests/testthat/docs_dir/test-slides-visible.pptx new file mode 100644 index 00000000..b8702a32 Binary files /dev/null and b/tests/testthat/docs_dir/test-slides-visible.pptx differ diff --git a/tests/testthat/test-pptx-misc.R b/tests/testthat/test-pptx-misc.R index 45840fba..44c14aac 100644 --- a/tests/testthat/test-pptx-misc.R +++ b/tests/testthat/test-pptx-misc.R @@ -118,7 +118,86 @@ test_that("no master do not generate an error", { }) - unlink("*.pptx") unlink("*.emf") + +test_that("slide_visible", { + opts <- options(cli.num_colors = 1) # suppress colors for error message check + on.exit(options(opts)) + + x <- read_pptx() + expect_equal(slide_visible(x), logical(0)) # works with 0 slides + + path <- testthat::test_path("docs_dir", "test-slides-visible.pptx") + x <- read_pptx(path) + + expect_equal(slide_visible(x), c(FALSE, TRUE, FALSE)) + x <- slide_visible(x, hide = 1:2) + expect_s3_class(x, "rpptx") + expect_equal(slide_visible(x), c(FALSE, FALSE, FALSE)) + x <- slide_visible(x, show = 1:2) + expect_s3_class(x, "rpptx") + expect_equal(slide_visible(x), c(TRUE, TRUE, FALSE)) + x <- slide_visible(x, hide = 1:2, show = 3) + expect_s3_class(x, "rpptx") + expect_equal(slide_visible(x), c(FALSE, FALSE, TRUE)) + + expect_error( + regex = "Overlap between indexes in `hide` and `show`", + slide_visible(x, hide = 1:2, show = 1:2) + ) + expect_error( + regex = "2 indexes of `hide` outside slide range", + slide_visible(x, hide = 1:5) + ) + expect_error( + regex = "1 index of `show` outside slide range", + slide_visible(x, show = -1) + ) + + slide_visible(x) <- FALSE # hide all slides + expect_false(any(slide_visible(x))) + slide_visible(x) <- c(TRUE, FALSE, TRUE) + expect_equal(slide_visible(x), c(TRUE, FALSE, TRUE)) + expect_warning( + regexp = "Value is not length 1 or same length as number of slides", + slide_visible(x) <- c(TRUE, FALSE) # warns that rhs values are recycled + ) + expect_equal(slide_visible(x), c(TRUE, FALSE, TRUE)) + + slide_visible(x)[2] <- TRUE + expect_equal(slide_visible(x), c(TRUE, TRUE, TRUE)) + slide_visible(x)[c(1, 3)] <- FALSE + expect_equal(slide_visible(x), c(FALSE, TRUE, FALSE)) + + slide_visible(x) <- TRUE + expect_warning( + regexp = "number of items to replace is not a multiple of replacement length", + slide_visible(x)[c(1, 2)] <- rep(FALSE, 4) + ) + expect_equal(slide_visible(x), c(FALSE, FALSE, TRUE)) + + expect_error( + { + slide_visible(x) <- rep(FALSE, 4) + }, + regexp = "More values \\(4\\) than slides \\(3\\)" + ) + + # test that changes are written to file + path <- testthat::test_path("docs_dir", "test-slides-visible.pptx") + x <- read_pptx(path) + + slide_visible(x) <- FALSE + path <- tempfile(fileext = ".pptx") + print(x, path) + x <- read_pptx(path) + expect_equal(slide_visible(x), c(FALSE, FALSE, FALSE)) + + slide_visible(x)[c(1, 3)] <- TRUE + path <- tempfile(fileext = ".pptx") + print(x, path) + x <- read_pptx(path) + expect_equal(slide_visible(x), c(TRUE, FALSE, TRUE)) +}) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index 02511776..efb70879 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -13,6 +13,66 @@ test_that("trailing file index extraction / sorting", { test_that("misc", { + opts <- options(cli.num_colors = 1) # suppress colors for error message check + on.exit(options(opts)) + df <- df_rename(mtcars, c("mpg", "cyl"), c("A", "B")) expect_true(all(names(df)[1:2] == c("A", "B"))) + + expect_true(is_integerish(1)) + expect_true(is_integerish(1:3)) + expect_true(is_integerish(1.0)) + expect_true(is_integerish(c(1.0, 2.0))) + expect_false(is_integerish(1.00001)) + expect_false(is_integerish(c(1.1, 2.0))) + expect_false(is_integerish(TRUE)) + expect_false(is_integerish(FALSE)) + expect_error( + expect_warning(stop_if_not_integerish(LETTERS)), + regex = "Expected integerish values but got " + ) + expect_error( + stop_if_not_integerish(c(1.1, 1.2)), + regex = "Expected integerish values but got " + ) +}) + + +test_that("stop_if_not_in_slide_range", { + opts <- options(cli.num_colors = 1) # suppress colors for error message check + on.exit(options(opts)) + + x <- read_pptx() + expect_error( + regex = "Presentation has no slides", + stop_if_not_in_slide_range(x, 1) + ) + + x <- add_slide(x) + x <- add_slide(x) + expect_no_error(stop_if_not_in_slide_range(x, 1:2)) + expect_error( + regex = "1 index outside slide range", + stop_if_not_in_slide_range(x, -1) + ) + expect_error( + regex = "2 indexes of `my_arg` outside slide range", + stop_if_not_in_slide_range(x, 3:4, arg = "my_arg") + ) + expect_error( + regex = "Expected integerish values but got ", + stop_if_not_in_slide_range(x, 3.1) + ) + + foo <- function() { + stop_if_not_in_slide_range(x, 3:4) + } + error_text <- tryCatch(foo(), error = paste) + grepl("^Error in `foo()`:", error_text, fixed = TRUE) + + foo <- function() { + stop_if_not_in_slide_range(x, 3:4, call = NULL) + } + error_text <- tryCatch(foo(), error = paste) + grepl("^Error:", error_text, fixed = TRUE) })