update functions to work with the new structure of states.

Bump to version 0.10.0

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: heemod
 Title: Markov Models for Health Economic Evaluations
-Version: 0.9.4.9000
+Version: 0.10.0
 Authors@R: c(
     person("Kevin", "Zarca", email = "[email protected]", role = c("aut", "cre")),
     person("Antoine", "Filipovic-Pierucci", role = "aut"),

NEWS.md

@@ -1,4 +1,8 @@
-## heemod 0.9.4.9000
+## heemod 0.10.0
+
+### New features
+
+  * `define_state()` gains the `starting_values` argument (same as `define_strategy()`).
 
 ## heemod 0.9.4
 

R/expand.R

@@ -19,7 +19,7 @@ has_state_time.uneval_state_list <- function(x, ...) {
 
 #' @export
 has_state_time.state <- function(x, ...) {
-  any(unlist(lapply(x, function(y) "state_time" %in% all.vars(y$expr))))
+  any(unlist(lapply(x$.dots, function(y) "state_time" %in% all.vars(y$expr))))
 }
 
 substitute_dots <- function(.dots, .values) {
@@ -105,7 +105,16 @@ expand_state.uneval_state_list <- function(x, state_name, cycles) {
   id <- seq_len(cycles + 1)
   res <- lapply(
     id,
-    function(x) substitute_dots(st, list(state_time = x))
+    function(x) {
+      list(
+        .dots = substitute_dots(st$.dots, list(state_time = x)),
+        starting_values <- if (x == 1) {
+          substitute_dots(st$starting_values, list(state_time = x))
+        } else {
+          list()
+        }
+      )
+    }
   )
   names(res) <- sprintf(".%s_%i", state_name, id)
 
@@ -174,7 +183,6 @@ interpolate <- function(x, ...) {
 #' @export
 #' @rdname interpolate
 interpolate.default <- function(x, more = NULL, ...) {
-
   res <- NULL
 
   for (i in seq_along(x)) {
@@ -211,7 +219,12 @@ interpolate.uneval_matrix <- function(x, ...) {
 #' @export
 #' @rdname interpolate
 interpolate.state <- function(x, ...) {
-  res <- interpolate.default(x, ...)
+  res <- structure(
+    list(
+    .dots = interpolate.default(x$.dots, ...),
+    starting_values = x$starting_values
+    )
+  )
   define_state_(res)
 }
 
@@ -225,6 +238,9 @@ interpolate.part_surv <- function(x, ...) {
 #' @rdname interpolate
 interpolate.uneval_state_list <- function(x, ...) {
   for (i in seq_along(x)) {
+    # y <- structure(x[[i]]$.dots,
+    #                class = class(x[[i]]))
+    #x[[i]] <- interpolate(y, ...)
     x[[i]] <- interpolate(x[[i]], ...)
   }
   x

R/states_define.R

@@ -14,8 +14,10 @@
 #' 
 #' @param ... Name-value pairs of expressions defining state
 #'   values.
+#' @param starting_values Optional starting values defined
+#'   with [define_starting_values()].
 #' @param .OBJECT An object of class `state`.
-#' @param .dots Used to work around non-standard evaluation.
+#' @param x Used to work around non-standard evaluation.
 #'   
 #' @return An object of class `state` (actually a named
 #'   list of `lazy` expressions).
@@ -25,14 +27,21 @@
 #'   
 define_state <- function(..., starting_values = define_starting_values()) {
   .dots <- lazyeval::lazy_dots(...)
-  define_state_(.dots, starting_values = starting_values)
+  define_state_(list(.dots = .dots, starting_values = starting_values))
 }
 
 #' @export
 #' @rdname define_state
-define_state_ <- function(.dots, starting_values) {
+define_state_ <- function(x) {
+  .dots <- x$.dots
   check_names(names(.dots))
-  structure(.dots, 
+  starting_values <- check_starting_values(
+    x = x$starting_values,
+    ref = names(.dots)
+  )
+  structure(list(
+            .dots = .dots, 
+            starting_values = starting_values),
             class = c("state", class(.dots)))
 }
 
@@ -50,14 +59,26 @@ modify_.state <- function(.OBJECT, .dots) {
   # message d'erreur informatif quand valeurs pas dans
   # bon ordre
 
-  if (! all(names(.dots) %in% names(.OBJECT))) {
+  if ("starting_values" %in% names(.dots)) {
+    starting_values <- check_starting_values(
+      x = lazyeval::lazy_eval(.dots$starting_values),
+      ref = names(.OBJECT$.dots)
+    )
+    .OBJECT <- utils::modifyList(.OBJECT, list(starting_values = starting_values))
+    .dots <- utils::modifyList(.dots, list(starting_values = NULL))
+  }
+
+  if (!length(.dots)){
+    return(.OBJECT)
+  }
+  if (! all(names(.dots) %in% names(.OBJECT$.dots))) {
     stop(sprintf(
       "The following state values are not defined: %s.",
-      names(.dots)[names(.dots) %in% names(.OBJECT)]
+      names(.dots)[names(.dots) %in% names(.OBJECT$.dots)]
     ))
   }
 
-  utils::modifyList(.OBJECT, .dots)
+  utils::modifyList(.OBJECT$.dots, .dots)
 }
 
 #' Define Markov Model State List
@@ -107,36 +128,41 @@ modify_.state <- function(.OBJECT, .dots) {
 #' @keywords internal
 define_state_list <- function(...) {
   .dots <- list(...)
-
   define_state_list_(.dots)
 }
 
 #' @rdname define_state_list
 define_state_list_ <- function(.dots) {
-
-  state_names <- names(.dots)
+  # states <- lapply(.dots, function(x){
+  #   structure(
+  #     x$.dots,
+  #     class = class(x)
+  #   )
+  # })
+  states <- .dots
+  state_names <- names(states)
 
   if (is.null(state_names)) {
     message("No named state -> generating names.")
-    state_names <- LETTERS[seq_along(.dots)]
-    names(.dots) <- state_names
+    state_names <- LETTERS[seq_along(states)]
+    names(states) <- state_names
   }
 
   if (any(state_names == "")) {
     warning("Not all states are named -> generating names.")
-    state_names <- LETTERS[seq_along(.dots)]
-    names(.dots) <- state_names
+    state_names <- LETTERS[seq_along(states)]
+    names(states) <- state_names
   }
 
-  if (any(duplicated(names(.dots)))) {
+  if (any(duplicated(names(states)))) {
     stop("Some state names are duplicated.")
   }
 
-  if (! all(unlist(lapply(.dots,
+  if (! all(unlist(lapply(states,
                           function(x) "state" %in% class(x))))) {
 
-    .x <- names(.dots)[! unlist(lapply(
-      .dots,
+    .x <- names(states)[! unlist(lapply(
+      states,
       function(x) "state" %in% class(x)))]
 
     stop(sprintf(
@@ -146,11 +172,10 @@ define_state_list_ <- function(.dots) {
     ))
   }
 
-  check_states(.dots)
-
+  check_states(states)
   structure(
-    .dots,
-    class = c("uneval_state_list", class(.dots))
+    states,
+    class = c("uneval_state_list", class(states))
   )
 }
 
@@ -180,11 +205,11 @@ modify_.uneval_state_list <- function(.OBJECT, .dots) {
 #'   
 #' @keywords internal
 check_states <- function(x){
-  if (! list_all_same(lapply(x, length))) {
+  if (! list_all_same(lapply(x, function(y) length(y$.dots)))) {
     stop("Number of state values differ between states.")
   }
 
-  if (! list_all_same(lapply(x, function(y) sort(names(y))))) {
+  if (! list_all_same(lapply(x, function(y) sort(names(y$.dots))))) {
     stop("State value names differ between states.")
   }
   NULL
@@ -221,11 +246,11 @@ get_state_value_names <- function(x){
 }
 
 get_state_value_names.uneval_state_list <- function(x) {
-  names(x[[1]])
+  names(x[[1]][[1]])
 }
 
 get_state_value_names.state <- function(x){
-  names(x)
+  names(x[[1]])
 }
 
 #' Get State Names

R/states_eval.R

@@ -13,7 +13,7 @@
 eval_state_list <- function(x, parameters) {
 
   f <- function(x) {
-    x <- discount_hack(x)
+    x <- discount_hack(x$.dots)
 
     # update calls to dispatch_strategy()
     x <- dispatch_strategy_hack(x)

R/states_print.R

@@ -1,13 +1,30 @@
 #' @export
 print.state <- function(x, ...) {
+  val <- x$.dots
+  start <- x$starting_values
+  nb_sv <- lapply(start, function(x){
+    x$expr != 0
+  }) %>% 
+    unlist() %>%
+    sum()
+
+  phrase_start <- ifelse(nb_sv > 0, sprintf(" and %i starting value%s", nb_sv, plur(nb_sv)), "")
   cat(sprintf(
-    "A state with %i value%s.\n\n",
-    length(x), plur(length(x))))
+    "A state with %i value%s%s.\n\n",
+    length(val), plur(length(val)),
+    phrase_start))
 
-  nv <- names(x)
-  ex <- lapply(x, function(y) paste(deparse(y$expr), collapse = "\n"))
+  nv <- names(val)
+  ex <- lapply(val, function(y) paste(deparse(y$expr), collapse = "\n"))
 
-  cat(paste(nv, ex, sep = " = "), sep = "\n") 
+  cat(paste(nv, ex, sep = " = "), sep = "\n")
+  if (nb_sv > 0){
+    nv <- names(start)
+    ex <- lapply(seq_along(start), function(i) {
+      if (start[[i]]$expr > 0) paste(names(start)[i], deparse(start[[i]]$expr), collapse = "\n", sep = " = ")
+    })
+    cat("Start", paste(ex[lengths(ex) != 0]), sep = "\n")
+  }
 }
 
 #' @export

R/strategy_define.R

@@ -41,7 +41,6 @@ define_strategy <- function(...,
 #' @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)

R/strategy_eval.R

@@ -235,16 +235,12 @@ compute_values <- function(states, counts, starting_values) {
   counts_mat <- aperm(counts_mat, c(1, 3, 2))
 
   # multiply, sum, and add markov_cycle back in
-  vals_x_counts <- state_val_array * counts_mat
+  vals_x_counts <- (state_val_array +  array(unlist(starting_values), dim = dims_array_1) )* counts_mat 
   wtd_sums <- rowSums(vals_x_counts, dims = 2)
   res <- data.frame(markov_cycle = states[[1]]$markov_cycle, wtd_sums)
 
   names(res)[-1] <- state_values_names
 
-  n_indiv <- sum(counts)
-
-  res[1, names(starting_values)] <- res[1, names(starting_values)] +
-    starting_values * n_indiv
   res
 
 }
@@ -318,7 +314,6 @@ expand_if_necessary <- function(strategy, parameters,
 
     for (st in to_expand) {
       init <- expand_state(init, state_name = st, cycles = expand_limit[st])
-
       inflow <- expand_state(inflow, state_name = st, cycles = expand_limit[st])
     }
 
@@ -355,10 +350,20 @@ expand_if_necessary <- function(strategy, parameters,
 
   e_init <- unlist(eval_init(x = init, parameters[1,]))
   e_inflow <- eval_inflow(x = inflow, parameters)
-  e_starting_values <- unlist(
+
+  e_starting_values_strat <- unlist(
     eval_starting_values(
       x = strategy$starting_values,
-      parameters[1, ]))
+      parameters[1, ])
+  )
+  e_starting_values <- 
+    lapply(i_uneval_states, function(x){
+      unlist(eval_starting_values(
+        x = x$starting_values,
+        parameters[1, ]
+      )) + e_starting_values_strat
+    })
+
   n_indiv <- sum(e_init, unlist(e_inflow))
 
   if (any(is.na(e_init)) || any(is.na(e_inflow)) || any(is.na(e_starting_values))) {

R/tabular_input.R

@@ -481,14 +481,17 @@ create_states_from_tabular <- function(state_info,
       state_info$.state,
       function(state) {
         define_state_(
-          lazyeval::as.lazy_dots(
-            stats::setNames(as.character(lapply(
-              values,
-              function(value) {
-                state_info[[value]][state_info$.state == state]
-              }
-            )), values),
-            env = df_env
+          list(
+            .dots = lazyeval::as.lazy_dots(
+              stats::setNames(as.character(lapply(
+                values,
+                function(value) {
+                  state_info[[value]][state_info$.state == state]
+                }
+              )), values),
+              env = df_env
+          ), 
+          starting_values = define_starting_values()
           )
         )
       }

cran-comments.md

@@ -1,13 +1,7 @@
 ## Test environments
-* local ubuntu 18.04 install, R 3.5.2
+* local ubuntu 18.04 install, R 3.6.0
 * win-builder (devel and release)
 
 ## R CMD check results
 
-0 errors | 0 warnings | 1 note
-
-* This is a new release.
-
-In this version, I corrected the problems identified by CRAN, that I was not 
-able to reproduce. I think it was due to permission problems during the tests 
-(now the files are created in the temporary directory).
+There were no ERRORs or WARNINGs.