updated epiparam functions and documentation

R/bind_epiparam.R

@@ -10,8 +10,8 @@
 #' loaded in R.
 #'
 #' The `<epiparam>` returned by `bind_epiparam()` contains the matching columns
-#' of the input objects. Therefore, if one of the input object extra columns
-#' added with are not present in the other input object these will be missing
+#' of the input objects. Therefore, if one of the input objects contains extra
+#' columns which are not present in the other input object these will be missing
 #' from the returned object. This also applies whether binding other
 #' `<epiparam>` objects or `<data.frames>`. When binding `<epidist>` objects
 #' missing data fields are given a default value before
@@ -48,12 +48,15 @@ bind_epiparam <- function(epiparam, epi_obj) {
     validate_epiparam(epi_obj)
   } else if (is.data.frame(epi_obj)) {
     stopifnot(
-      "<data.frame> given must have the same column names as <epiparam>" =
-        setequal(colnames(epi_obj), colnames(epiparam))
+      "<data.frame> given must include all columns in <epiparam>" =
+        all(colnames(epiparam) %in% colnames(epi_obj))
     )
+    # subset epi_obj cols to those in epiparam
+    epi_obj <- epi_obj[, colnames(epiparam)]
   } else {
     stop(
-      "Only <epidist>, <vb_epidist> or <epiparam> can bind to <epiparam>",
+      "Only <epidist>, <vb_epidist>, <epiparam> or <data.frame>",
+      " can bind to <epiparam>",
       call. = FALSE
     )
   }

R/epiparam.R

@@ -8,7 +8,7 @@
 #'
 #' @examples
 #' eparam <- epiparameter:::new_epiparam("all")
-new_epiparam <- function(epi_dist = character()) {
+new_epiparam <- function(epi_dist) {
 
   # check input
   checkmate::assert_string(epi_dist)

R/epiparam_utils.R

@@ -22,9 +22,7 @@ as_epidist <- function(x) {
   validate_epiparam(x)
 
   # convert each epiparam row into an epidist object
-  out <- apply(x, 1, function(y) {
-    make_epidist(x = y)
-  })
+  out <- apply(x, 1, make_epidist)
 
   # remove names of list
   names(out) <- NULL
@@ -231,7 +229,7 @@ as_epiparam <- function(x) {
     truncation <- NA_real_
   } else {
     discretised <- FALSE
-    if (isFALSE("upper" %in% names(params))) {
+    if (!("upper" %in% names(params))) {
       truncation <- NA_real_
     } else {
       truncation <- params[["upper"]]
@@ -309,66 +307,42 @@ as_epiparam <- function(x) {
     quantile_97.5 = unname(x$summary_stats$quantiles["q_97.5"]),
     lower_range = x$summary_stats$range$lower_range,
     upper_range = x$summary_stats$range$upper_range,
-    shape = ifelse(
-      test = is.na(unname(params["shape"])),
-      yes = NA_real_,
-      no = params["shape"]
-    ),
+    shape = unname(params["shape"]),
     shape_ci_limits = NA,
     shape_ci = ifelse(
       test = is.null(x$uncertainty[["shape"]]),
       yes = NA_real_,
       no = x$uncertainty$shape$ci
     ),
-    scale = ifelse(
-      test = is.na(unname(params["scale"])),
-      yes = NA_real_,
-      no = params["scale"]
-    ),
+    scale = unname(params["scale"]),
     scale_ci_limits = NA,
     scale_ci = ifelse(
       test = is.null(x$uncertainty[["scale"]]),
       yes = NA_real_,
       no = x$uncertainty$scale$ci
     ),
-    meanlog = ifelse(
-      test = is.na(unname(params["meanlog"])),
-      yes = NA_real_,
-      no = params["meanlog"]
-    ),
+    meanlog = unname(params["meanlog"]),
     meanlog_ci_limits = NA,
     meanlog_ci = ifelse(
       test = is.null(x$uncertainty[["meanlog"]]),
       yes = NA_real_,
       no = x$uncertainty$meanlog$ci
     ),
-    sdlog = ifelse(
-      test = is.na(unname(params["sdlog"])),
-      yes = NA_real_,
-      no = params["sdlog"]
-    ),
+    sdlog = unname(params["sdlog"]),
     sdlog_ci_limits = NA,
     sdlog_ci = ifelse(
       test = is.null(x$uncertainty[["sdlog"]]),
       yes = NA_real_,
       no = x$uncertainty$sdlog$ci
     ),
-    dispersion = ifelse(
-      test = is.na(unname(params["dispersion"])),
-      yes = NA_real_,
-      no = params["dispersion"]
-    ),
+    dispersion = unname(params["dispersion"]),
     dispersion_ci_limits = NA,
     dispersion_ci = ifelse(
       test = is.null(x$uncertainty[["dispersion"]]),
       yes = NA_real_,
       no = x$uncertainty$dispersion$ci
     ),
-    precision = ifelse(
-      test = is.na(unname(params["precision"])),
-      yes = NA_real_,
-      no = params["precision"]
-    ),
+    precision = unname(params["precision"]),
     precision_ci_limits = NA,
     precision_ci = ifelse(
       test = is.null(x$uncertainty[["precision"]]),

R/list_distributions.R

@@ -44,15 +44,15 @@ list_distributions <- function(epiparam,
   # check input
   validate_epiparam(epiparam)
   epi_dist <- match.arg(arg = epi_dist, several.ok = FALSE)
-  checkmate::assert_logical(subset_db)
+  checkmate::assert_logical(subset_db, len = 1)
 
   # subset to chosen distribution
   epiparam <- epiparam[epiparam$epi_distribution == epi_dist, ]
 
   # strip epiparam class to return data frame
   class(epiparam) <- "data.frame"
 
-  if (isTRUE(subset_db)) {
+  if (subset_db) {
     epiparam <- epiparam[, c(
       "disease", "epi_distribution", "prob_distribution", "author", "year",
       "sample_size"