#' Define a Markov Model
#'
#' Combine information on parameters, transition matrix and
#' states defined through [define_parameters()],
#' [define_transition()] and [define_state()] respectively.
#'
#' This function checks whether the objects are compatible
#' in the same model (same state names...).
#'
#' State values and transition probabilities referencing
#' `state_time` are automatically expanded to implicit
#' tunnel states.
#'
#' @param transition An object generated by
#' [define_transition()].
#' @param ... Objects generated by [define_state()]. Each object should be named
#' with the state names of the transition matrix.
#' @param states List of states, only used by
#' `define_strategy_` to avoid using `...`.
#' @param starting_values Optional starting values defined
#' with [define_starting_values()].
#'
#' @return An object of class `uneval_model` (a list
#' containing the unevaluated parameters, matrix and
#' states).
#'
#' @export
#'
#' @example inst/examples/example_define_strategy.R
define_strategy <- function(...,
transition = define_transition(),
starting_values = define_starting_values()) {
states <- define_state_list_(list(...))
define_strategy_(
transition = transition,
states = states,
starting_values = starting_values
)
}
#' @rdname define_strategy
#' @export
define_strategy_ <- function(transition, states, starting_values) {
starting_values <- check_starting_values(
x = starting_values,
ref = get_state_value_names(states)
)
if (! get_state_number(states) == get_state_number(transition)) {
stop(sprintf(
"Number of state in model input (%i) differ from number of state in transition object (%i).",
get_state_number(states),
length(get_state_names(transition))
))
}
if (! identical(
as.vector(sort(get_state_names(states))),
as.vector(sort(get_state_names(transition)))
)) {
stop("State names differ from transition object.")
}
structure(
list(
transition = transition,
states = states,
starting_values = starting_values
), class = "uneval_model")
}
#' Get Markov Model Transition Matrix
#'
#' Works on both unevaluated and evaluated models.
#'
#' @param x An `uneval_model` or `eval_model`
#' object.
#'
#' @return An `uneval_matrix` or `uneval_matrix`
#' object.
#'
#' @keywords internal
get_transition <- function(x){
UseMethod("get_transition")
}
get_transition.default <- function(x){
x$transition
}
set_transition <- function(x, m) {
UseMethod("set_transition")
}
set_transition.default <- function(x, m) {
x$transition <- m
x
}
get_states <- function(x){
UseMethod("get_states")
}
get_states.default <- function(x) {
x$states
}
set_states <- function(x, s) {
UseMethod("set_states")
}
set_states.default <- function(x, s) {
x$states <- s
x
}
get_state_value_names.uneval_model <- function(x) {
get_state_value_names(get_states(x))
}
get_state_names.uneval_model <- function(x, ...) {
get_state_names(get_states(x))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.