Nothing
#' Construct a transition
#'
#' @inheritParams transition
#' @returns a `transition` object
#' @noRd
new_transition <- function(
from, to, fun, transition_type, mortality_type, predictors, parameters
) {
checkmate::assert_string(from, min.chars = 1)
checkmate::assert_string(to, min.chars = 1, null.ok = TRUE)
checkmate::assert_class(fun, "transition_function")
checkmate::assert_choice(transition_type, c("probability", "duration"))
checkmate::assert_choice(
mortality_type, c("per_day", "throughout_transition"), null.ok = TRUE
)
checkmate::assert_list(
predictors, types = "predictor_spec", unique = TRUE, names = "unique",
null.ok = TRUE
)
checkmate::assert_class(parameters, "parameters")
transition <- structure(
list(
from = from,
to = to,
transition_type = transition_type,
mortality_type = mortality_type,
fun = fun,
predictors = predictors,
parameters = parameters
),
class = "transition"
)
return(transition)
}
#' Check that a `transition` object is valid
#'
#' @param transition input to validate
#' @returns the input if it passes all checks
#' @noRd
validate_transition <- function(transition) {
if (
!is.null(transition$mortality_type) &&
transition$mortality_type == "throughout_transition" &&
transition$transition_type == "probability"
) {
stop(
"`probability` transitions only support `per_day` mortality",
call. = FALSE
)
}
if (is.null(transition$to) == is.null(transition$mortality_type)) {
stop(
"exactly 1 of `to` or `mortality_type` must be non-NULL",
call. = FALSE
)
}
# there is no overlap between parameter and predictor names
checkmate::assert_disjunct(
names(transition$parameters), names(transition$predictors)
)
# each argument to the function corresponds to a parameter or predictor
checkmate::assert_set_equal(
c(names(transition$parameters), names(transition$predictors)),
names(formals(transition$fun))
)
if (transition$transition_type == "probability") {
invalid <- get_preds_where_first_day_only_is_false(transition$predictors)
if (length(invalid) > 0) {
stop(
"Probability type transitions cannot have any predictors where the ",
"`first_day_only` attribute is `FALSE`. Found these exceptions:\n",
paste0(names(invalid), ":\n", lapply(invalid, format)),
call. = FALSE
)
}
}
return(transition)
}
#' Create a `transition` object
#'
#' A `transition` object represents a single transition between two tick life
#' stages, or the mortality rate from a life stage.
#'
#' @param from The name of the life stage a tick is transitioning from.
#' @param to The name of the life stage a tick is transitioning to, or NULL if
#' the transition is representing mortality.
#' @param fun The transition function to evaluate.
#' The inputs of the function are predictors and parameters. The output is
#' the daily probability of completing the transition, for `"probability"`
#' transitions, or the daily rate the transition takes place, for `"duration"`
#' transitions.
#' @param transition_type One of:
#' `"probability"`: the evaluated transition is interpreted as the daily
#' fraction of ticks that complete the transition. Ticks remain in the
#' original life stage if they do not complete a transition or undergo
#' mortality.
#' `"duration"`: the transition is complete on the first day that the
#' cumulative sum of the evaluated transition is greater than or equal to 1.
#' No ticks remain in the original life stage at the end of a transition -
#' they either complete the transition or die.
#' @param mortality_type One of:
#' `NULL`: the default, indicating that the transition is not mortality.
#' `"per_day"`: indicates that the evaluated transition is the fraction of
#' ticks that dies each day.
#' `"throughout_transition"`: only valid for `"duration"` type transitions,
#' where it indicates that the evaluated transition is the fraction of
#' ticks that die throughout the entire transition.
#' @param predictors Optional, a named list of \code{\link{predictor_spec}} objects
#' that specify how any predictor data should be used in evaluating `fun`. The names are
#' matched with the formal args to `fun` to determine which input in `fun`
#' each predictor will be passed to.
#' @param parameters Optional, a \code{\link{parameters}} object, or a named
#' list of numeric vectors.
#'
#' @export
#'
#' @returns a `transition` object
transition <- function(
from, to, fun, transition_type, mortality_type = NULL, predictors = NULL,
parameters = list()
) {
fun <- new_transition_function(fun)
parameters <- do.call(new_parameters, as.list(parameters))
validate_transition(new_transition(
from = from,
to = to,
transition_type = transition_type,
mortality_type = mortality_type,
fun = fun,
predictors = predictors,
parameters = parameters
))
}
#' Return whether a transition is mortality or a transition between life stages
#'
#' @param transition a `transition` object
#' @returns a boolean
#' @noRd
transition_is_mortality <- function(transition) {
!is.null(transition$mortality_type)
}
# This is just a very simple option for use within a life_cycle
format.transition <- function(x, ...) {
to <- ifelse(transition_is_mortality(x), "mortality", x[["to"]])
paste(x[["from"]], "->", to, "\n")
}
#' Print a transition
#' @export
#' @param ... not used
#' @param x A `transition`
print.transition <- function(x, ...) {
param_names <- names(x$parameters)
param_string <- ""
for (i in param_names) {
param_string <- paste(param_string, i, " = ", x$parameters[i], ", ", sep = "")
}
param_string <- sub(", $", "", param_string)
pred_names <- names(x$predictors)
pred_string <- ""
for (i in pred_names) {
pred_string <- paste(pred_string, i, " = ", x$predictors[i], ", ", sep = "")
}
pred_string <- sub(", $", "", pred_string)
function_string <- sub("structure\\(function ", "", deparse(x$fun))
function_string <- sub(', class = "(.+)"\\)$', "", function_string)
cat(
"** A transition",
"\n** ", format.transition(x),
"Transition type: ", x$transition_type,
ifelse(transition_is_mortality(x), "\nMortality type: ", ""),
ifelse(transition_is_mortality(x), x$mortality_type, ""),
ifelse(!is.null(x$predictors), "\nPredictors: ", ""),
ifelse(!is.null(x$predictors), pred_string, ""),
"\nParameters: ", param_string,
"\nFunction: ",
function_string,
"\n",
sep = ""
)
}
#' Helper function for validation. It's an issue if this case is met.
#'
#' @param transition a `transition` object
#' @param stages character vector of life stage names
#' @returns a boolean
#' @noRd
transition_uses_tick_den_predictor_with_first_day_only_false <- function(
transition, stages
) {
preds_with_errors <- lapply(
transition$predictors,
function(x) pred_is_life_stage(x, stages = stages) && !x[["first_day_only"]]
)
any(unlist(preds_with_errors))
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.