Add c() method for <epiparameter>

NAMESPACE

@@ -4,6 +4,8 @@ S3method(as.data.frame,epiparameter)
 S3method(as.data.frame,multi_epiparameter)
 S3method(as.function,epiparameter)
 S3method(as_epiparameter,data.frame)
+S3method(c,epiparameter)
+S3method(c,multi_epiparameter)
 S3method(cdf,epiparameter)
 S3method(convert_params_to_summary_stats,character)
 S3method(convert_params_to_summary_stats,epiparameter)

R/epiparameter.R

@@ -920,3 +920,62 @@ mean.epiparameter <- function(x, ...) {
   # return mean or NA
   mean
 }
+
+#' [c()] method for `<epiparameter>` class
+#'
+#' @param ... [dots] Objects to be concatenated.
+#'
+#' @return An `<epiparameter>` or list of `<epiparameter>` objects.
+#' @export
+#'
+#' @examples
+#' db <- epiparameter_db()
+#'
+#' # combine two <epiparameter> objects into a list
+#' c(db[[1]], db[[2]])
+#'
+#' # combine a list of <epiparameter> objects and a single <epiparameter> object
+#' c(db, db[[1]])
+c.epiparameter <- function(...) {
+  x <- list(...)
+  if (!all(vapply(x, FUN = inherits, FUN.VALUE = logical(1),
+                  what = c("epiparameter", "multi_epiparameter")))) {
+    stop(
+      "Can only combine <epiparameter> or <multi_epiparameter> objects",
+      call. = FALSE
+    )
+  }
+
+  # if <multi_epiparameter> are in `...` build the new unnested list of
+  # <epiparameter> objects iteratively in order to preserve input order
+  if (any(vapply(x, FUN = inherits, FUN.VALUE = logical(1),
+                 what = "multi_epiparameter"))) {
+    # list is not pre-allocated as it's easier to append arbitrary length
+    # <multi_epiparameter> objects
+    ep_list <- list()
+    for (i in seq_along(x)) {
+      if (is_epiparameter(x[[i]])) {
+        ep_list <- c(ep_list, list(x[[i]]))
+      } else {
+        # unclass to prevent recursive dispatch
+        ep_list <- c(ep_list, unclass(x[[i]]))
+      }
+    }
+  } else {
+    ep_list <- x
+  }
+
+  # for when `...` is a single <epiparameter>
+  if (length(ep_list) == 1) {
+    ep_list <- ep_list[[1]]
+  } else {
+    # will always be triggered if called from c.multi_epiparameter
+    class(ep_list) <- "multi_epiparameter"
+  }
+  ep_list
+}
+
+#' @export
+c.multi_epiparameter <- function(...) {
+  c.epiparameter(...)
+}

tests/testthat/test-epiparameter.R

@@ -1232,3 +1232,65 @@ test_that("as.data.frame works for <epiparameter> from db", {
       "notes")
   )
 })
+
+{
+  suppressMessages(
+    db <- epiparameter_db()
+  )
+  ep <- db[[1]]
+}
+
+test_that("c.epiparameter works as expected with two <epiparameter>s", {
+  res <- c(ep, ep)
+  expect_s3_class(res, class = "multi_epiparameter")
+  expect_length(res, 2)
+  expect_s3_class(res[[1]], class = "epiparameter")
+})
+
+test_that("c.epiparameter works as expected with one <epiparameter>", {
+  res <- c(ep)
+  expect_s3_class(res, class = "epiparameter")
+  expect_true(test_epiparameter(res))
+})
+
+test_that("c.epiparameter works with <epiparameter> & <multi_epiparameter>", {
+  res <- c(ep, db)
+  expect_s3_class(res, class = "multi_epiparameter")
+  expect_length(res, length(db) + 1)
+  expect_s3_class(res[[1]], class = "epiparameter")
+})
+
+test_that("c.multi_epiparameter works with two <multi_epiparameter>s", {
+  res <- c(db, db)
+  expect_s3_class(res, class = "multi_epiparameter")
+  expect_length(res, 244)
+  expect_s3_class(res[[1]], class = "epiparameter")
+})
+
+test_that("c.multi_epiparameter works with one <multi_epiparameter>", {
+  res <- c(db)
+  expect_s3_class(res, class = "multi_epiparameter")
+  expect_length(res, length(db))
+})
+
+test_that("c.multi_epiparameter works <multi_epiparameter> & <epiparameter>", {
+  res <- c(db, ep)
+  expect_s3_class(res, class = "multi_epiparameter")
+  expect_length(res, length(db) + 1)
+  expect_s3_class(res[[1]], class = "epiparameter")
+})
+
+test_that("c.epiparameter preserves input order", {
+  res <- c(ep, db, ep)
+  expect_s3_class(res, class = "multi_epiparameter")
+  expect_length(res, length(db) + 2)
+  expect_true(identical(res[[1]], res[[2]]))
+  expect_true(identical(res[[1]], res[[length(res)]]))
+})
+
+test_that("c.epiparameter fails as expected", {
+  expect_error(
+    c(ep, 1),
+    regexp = "Can only combine <epiparameter> or <multi_epiparameter> objects"
+  )
+})

vignettes/epiparameter.Rmd

@@ -202,7 +202,7 @@ If a set of epidemiological parameter has been inferred and is known to the user
 
 ```{r add-to-library}
 # wrap <epiparameter> in list to append to database
-new_db <- append(db, list(covid_incubation))
+new_db <- append(db, covid_incubation)
 tail(new_db, n = 3)
 ```