R/check_args.R

In ern: Effective Reproduction Number Estimation

#' @title Check parameters for daily data inference
#'
#' @param x List. Parameters for daily data inference.
#' 
#' @keywords internal
#'
#' @return NULL
check_prm.daily <- function(x){

  assertthat::assert_that(assertthat::has_name(x, "method"))
  assertthat::assert_that(assertthat::is.string(x[['method']]))
  assertthat::assert_that(x[['method']] == "renewal" | 
                          x[['method']] == "linear")
  

  if(x$method == "renewal"){
    # Check that mandatory elements are 
    # present and of the right type for this model
    for (name in c("burn", "iter", "chains")){
      # Check presence of element
      assertthat::assert_that(assertthat::has_name(x, name))
      assertthat::assert_that(assertthat::is.count(x[[name]]))
    }
    for (name in c("prior_R0_shape", "prior_R0_rate",
                   "prior_alpha_shape", "prior_alpha_rate")){
      # Check presence of element
      assertthat::assert_that(assertthat::has_name(x, name))
      assertthat::assert_that(assertthat::is.number(x[[name]]))
    }
  }
  
  # Check optional arguments
  if(!is.null(x$first.agg.period)){
    assertthat::assert_that(assertthat::is.count((x$first.agg.period)))
  }

  return()
}



#' @title Check parameters for daily data inference check
#'
#' @param x List. Parameters for daily data inference check.
#'
#' @keywords internal
#' @return NULL
check_prm.daily.check <- function(x){
  # if prm.daily.check list is NULL, return early (NULL is a valid option, turns off daily inference check)
  if(is.null(x)) return(NULL)

  # otherwise, must specify agg.reldiff.tol
  assertthat::assert_that(assertthat::has_name(x, "agg.reldiff.tol"))
  tol <- x[["agg.reldiff.tol"]]
  assertthat::assert_that(is.numeric(tol))
  if(tol <= 0) stop("prm.daily.check$agg.reldiff.tol must be positive and non-zero")

  return(NULL)
}


#' @title Check parameters for smoothing
#'
#' @param x List that specifies the type of smoothing and the parameters associated with the smoothing method.
#'
#' @keywords internal
#' @return NULL
check_prm.smooth <- function(x){
  # general checks
  if(!("method" %in% names(x))) stop('Please specify a method for smoothing (e.g. method = "rollmean") in `prm.smooth`')

  if(x$method == "rollmean"){

    # rollmean checks
    # - - - - - - - - - - - - - - - - -

    # window
    err.msg <- "For `method = 'rollmean'`, an positive integer numeric `window` value must be specified in `prm.smooth`"
    if(!("window" %in% names(x))) stop(err.msg)
    if(!assertthat::is.count(x$window)) stop(err.msg)

    # align
    if(is.null(x$align) |
       !isTRUE(x$align %in% c('center', 'left', 'right'))){
      stop("Missing or invalid `align` argument for `method = 'rollmean'` in `prm.smooth`")
    }
  }
  else if(x$method == "loess"){

    # loess checks
    err.msg <- "For `method = 'loess', a numeric `span` value greater than must be specified in `prm.smooth`"
    if(!("span" %in% names(x))) stop(err.msg)
    if(!is.numeric(x$span)) stop(err.msg)
    if(is.null(x$span) | x$span <= 0){
      stop(err.msg)
    }
  } else {

    # input method not recognized
    stop(paste0("Smoothing method of '", x$method, "' not recognized"))

  }

  return()
}

# prm.R -------------------------------------------------------------------

#' @title Check parameters for Rt calculation
#'
#' @param x List. Parameters for Rt calculation.
#' @template param-silent
#'
#' @keywords internal
#' @return NULL
check_prm.R <- function(x, silent = FALSE){

  # Check that mandatory elements are present and of the right type
  for (name in c("iter", "CI", "window")){
    # Check presence of element
    assertthat::assert_that(assertthat::has_name(x, name))

    # Check element type
    if(name %in% c("iter", "window")){
      assertthat::assert_that(assertthat::is.count(x[[name]]))
    }

    if(name == "CI"){
      assertthat::assert_that(is.numeric(x[[name]]))
      if(x[[name]] <= 0 | x[[name]] >= 1) stop("prm.R$CI must be between 0 and 1 (non-inclusive)")
    }
  }

  # Check optional arguments
  # config.EpiEstim
  if(!is.null(x$config.EpiEstim)){
    if(!silent){
      message("-----
You are passing your own config for EpiEstim::estimate_R().
Please note that ern always uses method = 'non_parametric_si',
and thus any method specified in your config will be ignored.
Also, any config parameters that are specific to
method = 'non_parametric_si' (like si_distr) cannot be modified and
will also be ignored.")
    }
  }

  return()
}

#' @title Check distributions
#'
#' @param x family of distributions to be checked, as generated by `def_dist_()`
#' @keywords internal
#'
#' @return NULL
check_dist <- function(x){

  if(x$dist == "gamma"){
    if(!("sd" %in% names(x) | "shape" %in% names(x))){
      stop(paste0("Gamma distributions must be specified with a mean and one of
a standard deviation (sd) or a shape parameter (shape).
Neither sd nor shape found: ", print(x)))
    }
    if("sd" %in% names(x) & "shape" %in% names(x)){
      stop(paste0("Gamma distributions must be specified with a mean and either
one of a standard deviation (sd) or a shape parameter (shape).
Both sd and shape found: ", print(x)))
    }
  }

  if(x$dist == "norm"){

    assertthat::assert_that(assertthat::has_name(x, 'mean'))
    assertthat::assert_that(assertthat::is.number(x$mean))
    assertthat::assert_that(assertthat::is.number(x$sd))
    if(x$sd <= 0) {
      stop(paste0('Standard deviation for normal distribution must be positive',
                  ' (currently sd = ',x$sd,'). ABORTING.'))
    }
  }

  if(x$dist == "lnorm"){

    assertthat::assert_that(assertthat::has_name(x, 'meanlog'))
    assertthat::assert_that(assertthat::has_name(x, 'sdlog'))
    assertthat::assert_that(assertthat::is.number(x$meanlog))
    assertthat::assert_that(assertthat::is.number(x$sdlog))

    if(x$sdlog <= 0) {
      stop(paste0('Standard deviation for lognormal distribution must be positive',
                  ' (currently sdlog = ',x$sdlog,'). ABORTING.'))
    }
  }

  return()
}

#' @title Check that deconvolution inputs are compatible
#'
#' @param obs Numeric. Vector with observed signal (_e.g._, case reports)
#' @param dist Numeric. Vector of discretized distribution used as the deconvolution kernel (_e.g._, reporting delay distribution)
#'
#' @keywords internal
#' @return NULL
check_for_deconv <- function(obs, dist){
  if(length(dist) > length(obs)) stop(paste0("For deconvolutions, length of distribution vector cannot exceed number of observations.
  - length of distribution vector: ", length(dist), "
  - number of observations: ", length(obs)))
  return()
}

#' @title Check the format of input clinical data
#'
#' @template param-cl.data
#' @template param-silent
#'
#' @keywords internal
#' @return NULL
check_cl.input_format <- function(cl.data, silent = FALSE) {

  # check is df
  assertthat::assert_that(is.data.frame(cl.data))

  # check for required columns
  n = names(cl.data)

  msg.template1 <- 'The input data frame of clinical reports must have a `'
  msg.template2 <- '` column. ABORTING!'

  for(var in c("value", "date")){
    if(!(var %in% n)){
      stop(paste0(msg.template1, var, msg.template2))
    }
  }

  # check column types
  assertthat::assert_that(assertthat::is.date(cl.data$date))
  assertthat::assert_that(is.numeric(cl.data$value))

  return()
}

#' @title Check if input data is already daily
#'
#' @template param-df.input
#'
#' @keywords internal
#' @return Logical. Indicates whether input data is already daily.
check_df.input_daily <- function(df.input){
  is.daily <- (df.input
    |> dplyr::mutate(t.diff = as.numeric(date - dplyr::lag(date)))
    |> tidyr::drop_na()
    |> dplyr::mutate(t.diff.check = t.diff == 1)
    |> dplyr::summarise(check = all(t.diff.check))
    |> dplyr::pull(check)
  )
  return(is.daily)
}

#' @keywords internal
check_ww.conc_format <- function(ww.conc){

  # check is df
  assertthat::assert_that(is.data.frame(ww.conc))

  # check for required columns
  if(!isTRUE("date" %in% names(ww.conc)) |
     !isTRUE("value" %in% names(ww.conc))
  ){
    stop("`date` and `value` columns are required. Please check `ww.conc`.
         Aborting!")
  }

  # check column types
  assertthat::assert_that(assertthat::is.date(ww.conc$date))
  assertthat::assert_that(is.numeric(ww.conc$value))

}