diff --git a/R/plot_tree.R b/R/plot_tree.R index ef53978..3dbfa03 100644 --- a/R/plot_tree.R +++ b/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()}") ) } diff --git a/man/save_trees.Rd b/man/save_trees.Rd index 5bdc76b..a140cf7 100644 --- a/man/save_trees.Rd +++ b/man/save_trees.Rd @@ -24,10 +24,10 @@ entries will be saved to an external file. As generated by \code{create_trees}.} \item{output_dir}{Scalar string. The directory where the plots will be saved.} -\item{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.} +\item{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.} \item{include_date}{Boolean. Should the file-paths include the current date?} } diff --git a/tests/testthat/test-plot_tree.R b/tests/testthat/test-plot_tree.R index c535583..2931518 100644 --- a/tests/testthat/test-plot_tree.R +++ b/tests/testthat/test-plot_tree.R @@ -7,9 +7,10 @@ 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( @@ -17,17 +18,65 @@ describe("save_trees", { 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)) }) })