feat: adds internal function to change dimensions of chunk_outputs

Author: averissimo

R/tm_a_pca.R

@@ -1080,6 +1080,15 @@ srv_a_pca <- function(id, data, dat, plot_height, plot_width, ggplot2_args, deco
       graph_align = "center"
     )
 
+    decorated_output_dims_q <- reactive({
+      dims <- req(pws$dim())
+      q <- req(decorated_output_q())
+      teal.reporter::teal_card(q) <- modify_last_chunk_outputs_attributes(
+        teal.reporter::teal_card(q), list(dev.width = dims[[1]], dev.height = dims[[2]])
+      )
+      q
+    })
+
     # tables ----
     output$tbl_importance <- renderTable(
       expr = {
@@ -1141,6 +1150,6 @@ srv_a_pca <- function(id, data, dat, plot_height, plot_width, ggplot2_args, deco
       verbatim_content = source_code_r,
       title = "R Code for PCA"
     )
-    decorated_output_q
+    decorated_output_dims_q
   })
 }

R/utils.R

@@ -363,3 +363,54 @@ select_decorators <- function(decorators, scope) {
     list()
   }
 }
+
+#' Set the attributes of the last chunk outputs
+#' @param data (`teal_card`) object to modify.
+#' @param attributes (`list`) of attributes to set on the last chunk outputs.
+#' @param n (`integer(1)`) number of the last element of `teal_card` to modify.
+#' it will only change `chunk_output` objects.
+#' @param inner_classes (`character`) classes within `chunk_output` that should be modified.
+#' This can be used to only change `recordedplot`, `ggplot2` or other type of objects.
+#' @keywords internal
+modify_last_chunk_outputs_attributes <- function(teal_card,
+                                                 attributes,
+                                                 n = 1,
+                                                 inner_classes = NULL,
+                                                 quiet = FALSE) {
+  checkmate::assert_class(teal_card, "teal_card")
+  checkmate::assert_list(attributes, names = "unique")
+  checkmate::assert_int(n, lower = 1)
+  checkmate::assert_character(inner_classes, null.ok = TRUE)
+  checkmate::assert_flag(quiet)
+
+  if (!inherits(teal_card[[length(teal_card)]], "chunk_output")) {
+    if (!quiet) {
+      warning("The last element of the `teal_card` is not a `chunk_output` object. No attributes were modified.")
+    }
+    return(teal_card)
+  }
+
+  for (ix in seq_len(length(teal_card))) {
+    if (ix > n) {
+      break
+    }
+    current_ix <- length(teal_card) + 1 - ix
+    if (!inherits(teal_card[[current_ix]], "chunk_output")) {
+      if (!quiet) {
+        warning("The ", ix, " to last element of the `teal_card` is not a `chunk_output` object. Skipping any further modifications.")
+      }
+      return(teal_card)
+    }
+
+    if (length(inner_classes) > 0 && !checkmate::test_multi_class(teal_card[[current_ix]][[1]], inner_classes)) {
+      next
+    }
+
+    attributes(teal_card[[current_ix]]) <- modifyList(
+      attributes(teal_card[[current_ix]]),
+      attributes
+    )
+  }
+
+  teal_card
+}

man/modify_last_chunk_outputs_attributes.Rd

@@ -0,0 +1,49 @@
+testthat::describe("modify_last_chunk_outputs_attributes", {
+  card <- teal.reporter::teal_card(
+    "# Header",
+    "Some text",
+    structure(list(2), class = "chunk_output"),
+    structure(list("1"), class = "chunk_output")
+  )
+
+  it("changes last chunk output with default parameters", {
+    new_card <- modify_last_chunk_outputs_attributes(teal_card, list(dev.height = 200))
+    testthat::expect_equal(attributes(new_card[[4]]), list(class = "chunk_output", dev.height = 200))
+    testthat::expect_equal(attributes(new_card[[3]]), list(class = "chunk_output"))
+  })
+
+  it("changes last 2 chunks", {
+    new_card <- modify_last_chunk_outputs_attributes(card, list(dev.height = 200), n = 2)
+    testthat::expect_equal(attributes(new_card[[4]]), list(class = "chunk_output", dev.height = 200))
+    testthat::expect_equal(attributes(new_card[[3]]), list(class = "chunk_output", dev.height = 200))
+  })
+
+  it("only changes the numeric chunk_outputs", {
+    new_card <- modify_last_chunk_outputs_attributes(card, list(dev.height = 200), n = 2, inner_classes = "numeric")
+    testthat::expect_equal(attributes(new_card[[3]]), list(class = "chunk_output", dev.height = 200))
+    testthat::expect_equal(attributes(new_card[[4]]), list(class = "chunk_output"))
+  })
+
+  it("throws warning when last chunk is not chunk_output", {
+    testthat::expect_warning(
+      modify_last_chunk_outputs_attributes(c(card, "yada"), list(new_attr = TRUE)),
+      "The last element of the `teal_card` is not a `chunk_output` object. No attributes were modified."
+    )
+  })
+
+  it("throws warning when second to last chunk is not chunk_output", {
+    card_modified <- c(card[c(1, 2, 3)], "bla", card[[4]])
+    testthat::expect_warning(
+      modify_last_chunk_outputs_attributes(card_modified, n = 3, list(new_attr = TRUE)),
+      "The 2 to last element of the `teal_card` is not a `chunk_output` object. Skipping any further modifications."
+    )
+  })
+
+  it("modifies all elements up until the first non-chunk output", {
+    card_modified <- c(card[c(1, 2, 3)], "bla", card[[4]])
+    new_card <- modify_last_chunk_outputs_attributes(card_modified, n = 3, list(new_attr = TRUE), quiet = TRUE)
+    testthat::expect_equal(attributes(new_card[[5]]), list(class = "chunk_output", new_attr = TRUE))
+    testthat::expect_null(attributes(new_card[[4]]))
+    testthat::expect_equal(attributes(new_card[[3]]), list(class = "chunk_output"))
+  })
+})