Major refactor of {epiparameter}

NAMESPACE

@@ -1,43 +1,32 @@
 # Generated by roxygen2: do not edit by hand
 
-S3method("$<-",epiparam)
-S3method("[",epiparam)
-S3method("names<-",epiparam)
 S3method(cdf,epidist)
 S3method(cdf,vb_epidist)
 S3method(density,epidist)
 S3method(density,vb_epidist)
 S3method(discretise,default)
 S3method(discretise,epidist)
-S3method(dplyr::dplyr_reconstruct,epiparam)
 S3method(family,epidist)
 S3method(format,epidist)
-S3method(format,epiparam)
 S3method(format,vb_epidist)
 S3method(generate,epidist)
 S3method(generate,vb_epidist)
 S3method(get_citation,epidist)
-S3method(get_citation,epiparam)
+S3method(get_citation,multi_epidist)
 S3method(get_parameters,epidist)
-S3method(head,epiparam)
 S3method(is_parameterised,epidist)
-S3method(is_parameterised,epiparam)
+S3method(is_parameterised,multi_epidist)
 S3method(mean,epidist)
 S3method(plot,epidist)
 S3method(plot,vb_epidist)
 S3method(print,epidist)
-S3method(print,epiparam)
+S3method(print,multi_epidist)
 S3method(print,vb_epidist)
 S3method(quantile,epidist)
 S3method(quantile,vb_epidist)
-S3method(summary,epiparam)
-S3method(tail,epiparam)
-export(as_epidist)
-export(as_epiparam)
-export(bind_epiparam)
 export(calc_disc_dist_quantile)
 export(clean_disease)
-export(clean_epidist_name)
+export(clean_epi_dist)
 export(convert_params_to_summary_stats)
 export(convert_summary_stats_to_params)
 export(create_epidist_citation)
@@ -49,13 +38,11 @@ export(create_epidist_uncertainty)
 export(discretise)
 export(epidist)
 export(epidist_db)
-export(epiparam)
 export(extract_param)
 export(get_citation)
 export(get_parameters)
 export(is_epidist)
 export(is_epidist_params)
-export(is_epiparam)
 export(is_parameterised)
 export(is_truncated)
 export(is_vb_epidist)
@@ -68,5 +55,3 @@ importFrom(distributional,generate)
 importFrom(stats,density)
 importFrom(stats,family)
 importFrom(stats,quantile)
-importFrom(utils,head)
-importFrom(utils,tail)

NEWS.md

@@ -10,7 +10,7 @@ Initial release of {epiparameter}, an R package to work with epidemiological par
 * The package contains a few utility functions.
 * Four vignettes are included in this initial release. One as an introduction to the package (`epiparameter.Rmd`), one as an tutorial on converting and extracting parameters (`extract_convert.Rmd`), one on the protocol used to collect entries for the library of epidemiological parameters (`data_protocol.Rmd`) and a supplementary vignette which quantifies the bias from using the parameter extraction (`extract_param()`) from {epiparameter} (`extract-bias.Rmd`).
 * Unit tests and documentation files.
-* Continuous integration workflows for R package checks, rendering the README.md, calculating test coverage, deploying the pkgdown website, updates the package citation, and validatingt the parameter library JSON file.
+* Continuous integration workflows for R package checks, rendering the README.md, calculating test coverage, deploying the pkgdown website, updates the package citation, and validating the parameter library JSON file.
 
 ## Breaking changes
 

R/accessors.R

@@ -45,32 +45,30 @@ get_parameters.epidist <- function(x, ...) {
   params
 }
 
-#' Extract citation information from `<epidist>` or `<epiparam>` objects
+#' Extract citation information from `<epidist>` or list of `<epidist>` objects
 #'
-#' @param x An `<epidist>` or `<epiparam>` object.
-#' @param ... Extra arguments to be passed to the method.
+#' @inheritParams is_parameterised
 #'
 #' @return A single character string or list of character string citations.
-#' Length of list output is equal to number of rows in the `<epiparam>` object
-#' passed to the function.
+#' Length of list output is equal to number of elements in the `<epidist>`
+#' object passed to the function.
 #' @export
 #'
 #' @examples
-#'
-#' # example with epidist
-#' eparam <- epiparam()
-#' edist <- as_epidist(eparam[12, ])
+#' # example with <epidist>
+#' edist <- epidist_db(single_epidist = TRUE)
 #' get_citation(edist)
 #'
-#' # example with epiparam
-#' eparam <- epiparam()
-#' get_citation(eparam)
+#' # example with list of <epidist>
+#' edist <- epidist_db()
+#' get_citation(edist)
 get_citation <- function(x, ...) {
   UseMethod("get_citation")
 }
 
 #' @export
 get_citation.epidist <- function(x, ...) {
+  chkDots(...)
   if (!inherits(x$citation, "bibentry")) {
     stop("Citation should be a <bibentry>", call. = FALSE)
   }
@@ -80,27 +78,9 @@ get_citation.epidist <- function(x, ...) {
 }
 
 #' @export
-get_citation.epiparam <- function(x, ...) {
-  citation_list <- apply(x,
-    MARGIN = 1, FUN = function(y) {
-      # suppressing message as users do not need reminding of citation when
-      # retrieving citation
-      suppressMessages(
-        create_epidist_citation(
-          author = y$author,
-          year = y$year,
-          title = y$title,
-          journal = y$journal,
-          DOI = y$DOI,
-          PMID = y$PMID
-        )
-      )
-    },
-    simplify = FALSE
-  )
-
-  # remove names from list
-  citation_list <- unname(citation_list)
+get_citation.multi_epidist <- function(x, ...) {
+  chkDots(...)
+  citation_list <- lapply(x, get_citation)
 
   # return citation list
   citation_list

R/calc_dist_params.R

@@ -34,7 +34,7 @@
 #' calc_dist_params(
 #'   prob_dist = "gamma",
 #'   summary_stats = create_epidist_summary_stats(
-#'     quantiles = c(q_2.5 = 0.2, q_97.5 = 9.2)
+#'     quantiles = c("2.5" = 0.2, "97.5" = 9.2)
 #'   ),
 #'   sample_size = NA
 #' )
@@ -47,26 +47,41 @@
 #'   sample_size = 25
 #' )
 #' }
-calc_dist_params <- function(prob_dist,
+calc_dist_params <- function(prob_dist, # nolint cyclocomp
+                             prob_dist_params,
                              summary_stats,
-                             sample_size = NA) {
-  # extract mean and sd to see if conversion is possible
-  mean_sd <- c(
-    mean = summary_stats$centre_spread$mean,
-    sd = summary_stats$centre_spread$sd
-  )
+                             sample_size) {
+  if (is.na(prob_dist)) {
+    message(
+      "No adequate summary statistics available to calculate the parameters ",
+      "of the ", prob_dist, " distribution"
+    )
+    return(NA)
+  }
 
-  # convert percentile names to numbers
-  percentiles <- get_percentiles(summary_stats$quantiles)
+  if (!is.null(summary_stats$quantiles) &&
+    !all(is.na(summary_stats$quantiles))) {
+    # convert percentile names to numbers
+    percentiles <- get_percentiles(summary_stats$quantiles)
+  } else {
+    percentiles <- NA
+  }
 
   # extract median and range to calculate parameters as third choice
   median_range <- c(
-    median = summary_stats$centre_spread$median,
+    median = summary_stats$median,
     unlist(summary_stats$range)
   )
 
-  if (!anyNA(mean_sd)) {
-    # unlist and remove NAs
+  # 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)
+
+  # convert from mean and sd
+  if (all(is.numeric(mean_sd)) && !anyNA(mean_sd) && length(mean_sd) == 2) {
     summary_stats_ <- unlist(summary_stats)
     summary_stats_ <- summary_stats_[!is.na(summary_stats_)]
     # remove name prefixes from unlisting
@@ -87,6 +102,11 @@ calc_dist_params <- function(prob_dist,
       convert_summary_stats_to_params,
       args = args
     ))
+  } else if (all(is.numeric(median_disp) && length(median_disp) == 2)) {
+    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)
   } else if (!anyNA(percentiles)) {
     # calculate the parameters from the percentiles
     # percentiles required to be [0, 1] so divide by 100
@@ -96,7 +116,8 @@ calc_dist_params <- function(prob_dist,
       distribution = prob_dist,
       percentiles = as.numeric(names(percentiles)) / 100
     )
-  } else if (!anyNA(median_range) && !is.na(sample_size)) {
+  } else if (all(is.numeric(median_range)) && length(median_range) == 3 &&
+    !is.na(sample_size)) {
     prob_dist_params <- extract_param(
       type = "range",
       values = median_range,