diff --git a/R/bind_epiparam.R b/R/bind_epiparam.R index a5ce9d76e..0276949a9 100644 --- a/R/bind_epiparam.R +++ b/R/bind_epiparam.R @@ -10,8 +10,8 @@ #' loaded in R. #' #' The `` 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 #' `` objects or ``. When binding `` 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( - " given must have the same column names as " = - setequal(colnames(epi_obj), colnames(epiparam)) + " given must include all columns in " = + all(colnames(epiparam) %in% colnames(epi_obj)) ) + # subset epi_obj cols to those in epiparam + epi_obj <- epi_obj[, colnames(epiparam)] } else { stop( - "Only , or can bind to ", + "Only , , or ", + " can bind to ", call. = FALSE ) } diff --git a/R/epiparam.R b/R/epiparam.R index 1844d7ea0..e5831d45f 100644 --- a/R/epiparam.R +++ b/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) diff --git a/R/epiparam_utils.R b/R/epiparam_utils.R index 2939d49e9..a8b089e02 100644 --- a/R/epiparam_utils.R +++ b/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"]]), diff --git a/R/list_distributions.R b/R/list_distributions.R index c9806c9df..ae6cf184c 100644 --- a/R/list_distributions.R +++ b/R/list_distributions.R @@ -44,7 +44,7 @@ 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, ] @@ -52,7 +52,7 @@ list_distributions <- function(epiparam, # 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" diff --git a/man/bind_epiparam.Rd b/man/bind_epiparam.Rd index c54a0f21b..b22481f1d 100644 --- a/man/bind_epiparam.Rd +++ b/man/bind_epiparam.Rd @@ -28,8 +28,8 @@ the library by binding them to the bottom of an existing \code{\link{epiparam}} loaded in R. The \verb{} returned by \code{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 \verb{} objects or \verb{}. When binding \verb{} objects missing data fields are given a default value before diff --git a/man/new_epiparam.Rd b/man/new_epiparam.Rd index cb92fe000..c0f67d4a3 100644 --- a/man/new_epiparam.Rd +++ b/man/new_epiparam.Rd @@ -4,7 +4,7 @@ \alias{new_epiparam} \title{epiparam constructor} \usage{ -new_epiparam(epi_dist = character()) +new_epiparam(epi_dist) } \value{ epiparam object