-
Notifications
You must be signed in to change notification settings - Fork 25
/
strategy_define.R
124 lines (109 loc) · 3.05 KB
/
strategy_define.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
#' 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))
}