Update <epiparameter> constructor function and internal refactor

NAMESPACE

@@ -38,7 +38,7 @@ export(convert_summary_stats_to_params)
 export(create_citation)
 export(create_metadata)
 export(create_method_assess)
-export(create_prob_dist)
+export(create_prob_distribution)
 export(create_region)
 export(create_summary_stats)
 export(create_uncertainty)

R/accessors.R

@@ -36,10 +36,10 @@ get_parameters <- function(x, ...) {
 get_parameters.epiparameter <- function(x, ...) {
   chkDots(...)
   # extract parameters depending on prob distribution class
-  if (inherits(x$prob_dist, "distcrete")) {
-    params <- unlist(x$prob_dist$parameters)
-  } else if (inherits(x$prob_dist, "distribution")) {
-    params <- unlist(distributional::parameters(x$prob_dist))
+  if (inherits(x$prob_distribution, "distcrete")) {
+    params <- unlist(x$prob_distribution$parameters)
+  } else if (inherits(x$prob_distribution, "distribution")) {
+    params <- unlist(distributional::parameters(x$prob_distribution))
 
     # if dist is truncated clean names
     if (is_truncated(x)) {
@@ -53,8 +53,8 @@ get_parameters.epiparameter <- function(x, ...) {
 
     # convert to meanlog and sdlog names
     params <- .clean_params(
-      prob_dist = family(x),
-      prob_dist_params = params
+      prob_distribution = family(x),
+      prob_distribution_params = params
     )
   } else {
     return(NA)

R/calc_dist_params.R

@@ -29,14 +29,13 @@
 #'
 #' @return A named `numeric` vector with parameters.
 #' @keywords internal
-.calc_dist_params <- function(prob_dist, # nolint cyclocomp
-                              prob_dist_params,
+.calc_dist_params <- function(prob_distribution, # nolint cyclocomp
                               summary_stats,
                               sample_size) {
-  if (is.na(prob_dist)) {
+  if (is.na(prob_distribution)) {
     message(
       "No adequate summary statistics available to calculate the parameters ",
-      "of the ", prob_dist, " distribution"
+      "of the ", prob_distribution, " distribution"
     )
     return(NA)
   }
@@ -60,19 +59,21 @@
     unlist(summary_stats$range)
   )
 
-  # extract dispersion
-  disp <- unname(prob_dist_params[names(prob_dist_params) == "dispersion"])
-  median_disp <- c(median = summary_stats$median, dispersion = disp)
-
   # extract mean and sd
   mean_sd <- c(summary_stats$mean, summary_stats$sd)
 
   is_mean_sd <- checkmate::test_numeric(
     mean_sd, any.missing = FALSE, len = 2, finite = TRUE
   )
-  is_median_disp <- checkmate::test_numeric(
-    median_disp, len = 2, finite = TRUE
+
+  is_median_disp <- checkmate::test_number(
+    summary_stats$median,
+    finite = TRUE
+  ) && checkmate::test_number(
+    summary_stats$dispersion,
+    finite = TRUE
   )
+
   is_median_range <- checkmate::test_numeric(
     median_range, len = 3, finite = TRUE
   ) && checkmate::test_count(sample_size, positive = TRUE)
@@ -93,40 +94,49 @@
     )
     summary_stats_ <- summary_stats_[idx]
     # create flat list structure to be passed to ... in conversion
-    args <- unlist(list(prob_dist, as.list(summary_stats_)), recursive = FALSE)
-    prob_dist_params <- unlist(do.call(
+    args <- unlist(
+      list(prob_distribution, as.list(summary_stats_)),
+      recursive = FALSE
+    )
+    prob_distribution_params <- unlist(do.call(
       convert_summary_stats_to_params,
       args = args
     ))
   } else if (is_median_disp) {
-    med <- summary_stats$median
-    meanlog <- log(med / sqrt(1 + disp^2))
-    sdlog <- sqrt(log(1 + disp^2))
-    prob_dist_params <- c(meanlog = meanlog, sdlog = sdlog)
+    args <- list(
+      x = prob_distribution,
+      median = summary_stats$median,
+      dispersion = summary_stats$dispersion
+    )
+    prob_distribution_params <- do.call(
+      convert_summary_stats_to_params,
+      args = args
+    )
+    prob_distribution_params <- unlist(prob_distribution_params)
   } else if (!anyNA(percentiles)) {
     # calculate the parameters from the percentiles
     # percentiles required to be [0, 1] so divide by 100
-    prob_dist_params <- extract_param(
+    prob_distribution_params <- extract_param(
       type = "percentile",
       values = percentiles,
-      distribution = prob_dist,
+      distribution = prob_distribution,
       percentiles = as.numeric(names(percentiles)) / 100
     )
   } else if (is_median_range) {
-    prob_dist_params <- extract_param(
+    prob_distribution_params <- extract_param(
       type = "range",
       values = median_range,
-      distribution = prob_dist,
+      distribution = prob_distribution,
       samples = sample_size
     )
   } else {
     message(
       "No adequate summary statistics available to calculate the parameters ",
-      "of the ", prob_dist, " distribution"
+      "of the ", prob_distribution, " distribution"
     )
     return(NA)
   }
 
   # return params
-  prob_dist_params
+  prob_distribution_params
 }

R/checkers.R

@@ -16,8 +16,10 @@
 #' ep <- epiparameter(
 #'   disease = "ebola",
 #'   epi_dist = "incubation",
-#'   prob_distribution = "gamma",
-#'   prob_distribution_params = c(shape = 1, scale = 1)
+#'   prob_distribution = create_prob_distribution(
+#'     prob_distribution = "gamma",
+#'     prob_distribution_params = c(shape = 1, scale = 1)
+#'   )
 #' )
 #' is_parameterised(ep)
 #'
@@ -43,7 +45,7 @@ is_parameterized <- is_parameterised
 is_parameterised.epiparameter <- function(x, ...) {
   chkDots(...)
   # probability distribution object
-  return(is.object(x$prob_dist))
+  return(is.object(x$prob_distribution))
 }
 
 #' @export

R/coercion.R

@@ -62,7 +62,7 @@ as.data.frame.epiparameter <- function(x, ...) {
     disease = x$disease,
     pathogen = x$pathogen,
     epi_distribution = x$epi_dist,
-    prob_distribution = I(list(prob_dist = x$prob_dist)),
+    prob_distribution = I(list(prob_dist = x$prob_distribution)),
     uncertainty = I(list(uncertainty = x$uncertainty)),
     summary_stats = I(list(summary_stats = x$summary_stats)),
     citation = I(x$citation),
@@ -220,15 +220,17 @@ is_epiparameter_df <- function(x) {
     disease = x$disease,
     pathogen = x$pathogen,
     epi_dist = x$epi_distribution,
-    prob_distribution = family(x$prob_distribution[[1]]),
-    prob_distribution_params = prob_distribution_params,
+    prob_distribution = create_prob_distribution(
+      prob_distribution = family(x$prob_distribution[[1]]),
+        prob_distribution_params = prob_distribution_params,
+      discretise = inherits(x$prob_distribution[[1]], "distcrete"),
+      truncation = truncation
+    ),
     uncertainty = uncertainty,
     summary_stats = x$summary_stats$summary_stats,
     citation = x$citation,
     metadata = x$metadata,
     method_assess = x$method_assess,
-    discretise = inherits(x$prob_distribution[[1]], "distcrete"),
-    truncation = truncation,
     notes = x$notes
   )
 }
@@ -268,7 +270,7 @@ is_epiparameter_df <- function(x) {
   sd_ <- NULL
   if (rlang::is_na(prob_dist)) {
     prob_dist_params <- NA_real_
-    uncertainty <- create_uncertainty()
+    uncertainty <- list(uncertainty = create_uncertainty())
   } else {
     prob_dist <- switch(
       prob_dist,
@@ -309,6 +311,14 @@ is_epiparameter_df <- function(x) {
     )
     prob_dist_params_names <- .clean_string(prob_dist_params_names)
     names(prob_dist_params) <- prob_dist_params_names
+
+    # overwrite prob_dist with user specified if given to make use of conversion
+    if (!is.null(prob_dist_in)) {
+      prob_dist <- prob_dist_in
+      # remove user specified to not trigger overwriting prob_dist below
+      prob_dist_in <- NULL
+    }
+
     if (all(c("mean", "sd") %in% names(prob_dist_params))) {
       sd_ <- prob_dist_params[["sd"]]
       prob_dist_params <- do.call(
@@ -422,8 +432,10 @@ is_epiparameter_df <- function(x) {
     disease = disease,
     pathogen = pathogen,
     epi_dist = epi_dist,
-    prob_distribution = prob_dist,
-    prob_distribution_params = prob_dist_params,
+    prob_distribution = create_prob_distribution(
+      prob_distribution = prob_dist,
+      prob_distribution_params = prob_dist_params
+    ),
     uncertainty = uncertainty,
     summary_stats = summary_stats,
     citation = citation,

R/convert_params.R

@@ -230,7 +230,7 @@ convert_params_to_summary_stats.epiparameter <- function(x, ...) {
   if (!is_parameterised(x)) {
     if (length(dots) > 0) {
       # unparameterised with parameters supplied through `...`
-      return(convert_params_to_summary_stats(x$prob_dist, ...))
+      return(convert_params_to_summary_stats(x$prob_distribution, ...))
     }
     # unparameterised with no parameters supplied through `...`
     stop(