feat: save_trees() can export html, rds or both for interactive plots

R/plot_tree.R

@@ -85,10 +85,10 @@ create_trees <- function(ggtree_data,
 #' @param   branch_col   Scalar string. The name of the statistic that is under study here (e.g.,
 #'   "logistic_growth_rate" or "clock_outlier"). This name will be used in the output file paths.
 #' @param   output_dir   Scalar string. The directory where the plots will be saved.
-#' @param   output_format   Scalar string (either \code{rds} or \code{html}). Which file format
-#'   should the interactive tree plot be placed? For \code{rds}, the default, a \code{ggtree} object
-#'   will be placed in an \code{rds} file. For \code{html}, an htmlwidget will be placed in a
-#'   \code{html} file.
+#' @param   output_format   String (either \code{rds} or \code{html} or both). Default: both. Which
+#'   file format(s) should the interactive tree plot(s) be placed? For \code{rds}, a \code{ggtree}
+#'   object will be placed in an \code{rds} file. For \code{html}, a \code{htmlwidget} will be
+#'   placed in a \code{html} file.
 #' @param   include_date   Boolean. Should the file-paths include the current date?
 #' @inheritParams   create_trees
 #'
@@ -100,7 +100,11 @@ save_trees <- function(tree_list,
                        output_dir,
                        output_format = c("rds", "html"),
                        include_date = FALSE) {
-  output_format <- match.arg(output_format)
+  output_format <- match.arg(output_format, several.ok = TRUE)
+  required_filetypes <- c(
+    "noninteractive",
+    c(rds = "interactive_rds", html = "interactive_html")[output_format]
+  )
 
   basename_prefix <- if (include_date) {
     glue::glue("tree-{branch_col}-{Sys.Date()}")
@@ -110,10 +114,14 @@ save_trees <- function(tree_list,
 
   basenames <- c(
     noninteractive = glue::glue("{basename_prefix}.svg"),
-    interactive = glue::glue("{basename_prefix}.{output_format}")
+    interactive_rds = glue::glue("{basename_prefix}.rds"),
+    interactive_html = glue::glue("{basename_prefix}.html")
+  )[required_filetypes]
+
+  files <- setNames(
+    file.path(output_dir, basenames),
+    required_filetypes
   )
-  files <- file.path(output_dir, basenames)
-  names(files) <- names(basenames)
 
   plot_height <- max(14, floor(n_leaves / 10))
 
@@ -125,12 +133,14 @@ save_trees <- function(tree_list,
     limitsize = FALSE
   )
 
-  if (output_format == "rds") {
+  if ("rds" %in% output_format) {
     saveRDS(
       tree_list[["interactive"]],
-      file = files[["interactive"]]
+      file = files[["interactive_rds"]]
     )
-  } else {
+  }
+
+  if ("html" %in% output_format) {
     widget <- create_widget(
       tree_list[["interactive"]],
       width_svg = 15,
@@ -139,7 +149,7 @@ save_trees <- function(tree_list,
 
     htmlwidgets::saveWidget(
       widget,
-      file = files[["interactive"]],
+      file = files[["interactive_html"]],
       title = glue::glue("SARS CoV 2 scan {Sys.Date()}")
     )
   }

tests/testthat/test-plot_tree.R

@@ -7,27 +7,76 @@ describe("save_trees", {
   )
   branch_col <- "logistic_growth_rate"
 
-  it("creates .svg / .rds files - default: without the current date", {
+  it("creates .svg / .rds / .html files - default: without the current date", {
     td <- withr::local_tempdir(pattern = "no-date-svg")
     output_rds <- file.path(td, glue::glue("tree-{branch_col}.rds"))
+    output_html <- file.path(td, glue::glue("tree-{branch_col}.html"))
     output_svg <- file.path(td, glue::glue("tree-{branch_col}.svg"))
 
     created_files <- save_trees(
       tree_list,
       branch_col = branch_col, output_dir = td, n_leaves = 100
     )
 
-    expect_equal(
+    expect_mapequal(
+      created_files,
+      c(
+        "noninteractive" = output_svg,
+        "interactive_rds" = output_rds,
+        "interactive_html" = output_html
+      )
+    )
+    expect_true(file.exists(output_svg))
+    expect_true(file.exists(output_html))
+    expect_true(file.exists(output_rds))
+  })
+
+  it("creates interactive html plot 'only' based on output_format argument", {
+    td <- withr::local_tempdir(pattern = "no-date-svg")
+    output_html <- file.path(td, glue::glue("tree-{branch_col}.html"))
+    output_svg <- file.path(td, glue::glue("tree-{branch_col}.svg"))
+    unexpected_rds <- file.path(td, glue::glue("tree-{branch_col}.rds"))
+
+    created_files <- save_trees(
+      tree_list,
+      branch_col = branch_col, output_dir = td, n_leaves = 100,
+      output_format = "html"
+    )
+
+    expect_mapequal(
+      created_files,
+      c("noninteractive" = output_svg, "interactive_html" = output_html)
+    )
+    expect_true(file.exists(output_svg))
+    expect_true(file.exists(output_html))
+    expect_false(file.exists(unexpected_rds))
+  })
+
+  it("creates interactive rds plot 'only' based on output_format argument", {
+    td <- withr::local_tempdir(pattern = "no-date-svg")
+    output_rds <- file.path(td, glue::glue("tree-{branch_col}.rds"))
+    output_svg <- file.path(td, glue::glue("tree-{branch_col}.svg"))
+    unexpected_html <- file.path(td, glue::glue("tree-{branch_col}.html"))
+
+    created_files <- save_trees(
+      tree_list,
+      branch_col = branch_col, output_dir = td, n_leaves = 100,
+      output_format = "rds"
+    )
+
+    expect_mapequal(
       created_files,
-      c("noninteractive" = output_svg, "interactive" = output_rds)
+      c("noninteractive" = output_svg, "interactive_rds" = output_rds)
     )
     expect_true(file.exists(output_svg))
     expect_true(file.exists(output_rds))
+    expect_false(file.exists(unexpected_html))
   })
 
-  it("creates .svg / .rds files - optionally including the current date", {
+  it("creates .svg / .rds / .html files - optionally including the current date", {
     td <- withr::local_tempdir(pattern = "noninteractive-svg")
     output_rds <- file.path(td, glue::glue("tree-{branch_col}-{Sys.Date()}.rds"))
+    output_html <- file.path(td, glue::glue("tree-{branch_col}-{Sys.Date()}.html"))
     output_svg <- file.path(td, glue::glue("tree-{branch_col}-{Sys.Date()}.svg"))
 
     created_files <- save_trees(
@@ -37,9 +86,14 @@ describe("save_trees", {
 
     expect_equal(
       created_files,
-      c("noninteractive" = output_svg, "interactive" = output_rds)
+      c(
+        "noninteractive" = output_svg,
+        "interactive_rds" = output_rds,
+        "interactive_html" = output_html
+      )
     )
     expect_true(file.exists(output_svg))
     expect_true(file.exists(output_rds))
+    expect_true(file.exists(output_html))
   })
 })