Merge pull request #1064 from metrumresearchgroup/release/1.0.8

Release/1.0.8

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: mrgsolve
 Title: Simulate from ODE-Based Models
-Version: 1.0.7
+Version: 1.0.8
 Authors@R: 
     c(person(given = "Kyle T", family = "Baron",
              role = c("aut", "cre"),
@@ -35,7 +35,7 @@ URL: https://github.com/metrumresearchgroup/mrgsolve
 BugReports: 
     https://github.com/metrumresearchgroup/mrgsolve/issues
 Depends:
-    R (>= 3.5),
+    R (>= 3.6.2),
     methods
 Imports:
     Rcpp (>= 1.0.7),
@@ -66,7 +66,6 @@ Language: en-US
 LazyLoad: yes
 NeedsCompilation: yes
 RoxygenNote: 7.2.3
-SystemRequirements: C++11
 Collate: 
     'RcppExports.R'
     'utils.R'

Makefile

@@ -85,7 +85,7 @@ install-build:
 	R CMD INSTALL --build --install-tests ${TARBALL}
 
 test:
-	R CMD INSTALL ${PKGDIR}
+	make install
 	make test-all
 
 test1:

NAMESPACE

@@ -254,6 +254,7 @@ importFrom(magrittr,"%>%")
 importFrom(rlang,"!!!")
 importFrom(rlang,"!!")
 importFrom(rlang,.data)
+importFrom(rlang,abort)
 importFrom(rlang,as_label)
 importFrom(rlang,enquo)
 importFrom(rlang,enquos)

NEWS.md

@@ -1,3 +1,34 @@
+# mrgsolve 1.0.8
+
+- `SIGMA()` is a new model macro which allows users to access on-diagonal
+  elements of `SIGMA` in the model (e.g. `SIGMA(2)` in `$ERROR`) (#1051, #1052).
+
+- `mrgsim()` and `mrgsim_q()` gain an `etasrc` argument, allowing `ETAs` to 
+  be either simulated from `OMEGA` (new default and previously the only 
+  behavior) or taken from the input data set (new option), similar to the way 
+  parameters can be scraped from the data set (#1037).
+
+- `@etas` is a new option for use with the `$CAPTURE` block to let users name
+  `ETAs` to be captured into the simulated output; for example, use 
+  `@etas 1:last` to capture all model `ETAs` in the simulated output (#1055).
+
+- Drop `CXX_STD` statement from Makevars file and DESCRIPTION to be consistent
+  with current changes in R-devel; mrgsolve continues to require compiler
+  capable of implementing C++11 standard, but this should be selected
+  automatically by R (#1060).
+
+- mrgsolve now depends on `R >= 3.6.2` (#1060).
+
+## Bugs Fixed
+
+- Fix bug when the `path` argument is used in the `$NMXML` or `$NMEXT` blocks;
+  this bug was introduced through the `@cppstem` feature in version `1.0.7` 
+  (#1046, #1048).
+
+- Fix bug in `mread_cache()` where the `project` directory wasn't getting 
+  rendered properly when passing the complete path to the model specification
+  file (#1056).
+
 # mrgsolve 1.0.7
 
 - `$NMXML` and `$NMEXT` now accept the `run` argument set to `"@cppstem"` (i.e  

R/Aaaa.R

@@ -29,7 +29,7 @@
 #' @importFrom magrittr %>%
 #' @importFrom tibble tibble as_tibble
 #' @importFrom rlang quos enquo enquos quo_name syms !!! !! eval_tidy as_label
-#' @importFrom rlang is_named .data
+#' @importFrom rlang is_named .data abort
 #' @importFrom lifecycle deprecate_soft deprecate_warn
 #' @importFrom glue glue
 #' @importFrom Rcpp evalCpp

R/class_mrgmod.R

@@ -746,8 +746,10 @@ blocks_ <- function(file,what) {
 
 parin <- function(x) {
   list(
-    ss_n = 500, ss_fixed = FALSE, 
-    interrupt = -1
+    ss_n = 500, 
+    ss_fixed = FALSE, 
+    interrupt = -1, 
+    etasrc = "omega"
   )
 }
 

R/handle_spec_block.R

@@ -356,9 +356,13 @@ handle_spec_block.specCAPTURE <- function(x, ...) {
   scrape_and_call(x, pass = "CAPTURE", narrow = TRUE, ...)
 }
 
+#' @param etas allows for block capture of ETAs in the simulated output;
+#' this should be R code that will get parsed and evaluated; the result should 
+#' be an integer-like vector which identifies which ETAs will be captured.
+#' 
 #' @rdname BLOCK_PARSE
-CAPTURE <- function(x, env, pos = 1, annotated = FALSE, ...) {
-
+CAPTURE <- function(x, env, pos = 1, annotated = FALSE, 
+                    etas = NULL, ...) {
   if(annotated) {
     context <- env[["incoming_names"]][pos]
     context <- glue("parse annotated capture block ({context})")
@@ -372,7 +376,14 @@ CAPTURE <- function(x, env, pos = 1, annotated = FALSE, ...) {
     x <- cvec_cs(x)
   }
 
-  check_block_data(x, env, pos)
+  if(!is.null(etas)) {
+    if(is.logical(etas)) {
+      abort("`etas` must be text, not a logical value.")  
+    }
+    env[["capture_etas"]] <- c(env[["capture_etas"]], etas)
+  } else {
+    check_block_data(x, env, pos)
+  }
 
   env[["capture"]][[pos]] <- x
 
@@ -849,7 +860,7 @@ handle_spec_block.specYAML <- function(x, env, ...) {
     x <- lapply(x, FUN = do.call, what = what) 
     x <- bind_rows(x)
     label <-  names(data) 
-    if(is.null(labels) & is.character(data)) label <- data
+    if(is.null(label) & is.character(data)) label <- data
     mutate(x, block = block, name = label)
   }
   names(x) <- tolower(names(x))

R/modspec.R

@@ -39,6 +39,66 @@ write_capture <- function(x) {
   paste0("_capture_[",i-1,"] = ", x[i], ";") 
 }
 
+#' This function adds ETA values to the capture list when the `@etas` 
+#' option is used in `$CAPTURE` .
+#' 
+#' @param x the model object
+#' @param env the mread parse environment
+#' 
+#' @details
+#' We look at env$capture_etas to see if there were any expression text passed
+#' through the `@etas` option. This text will be parsed and evaluated in the 
+#' model environment after adding `LAST` and `last` to represent the last
+#' ETA (or the [total] number of rows in `$OMEGA`).
+#' 
+#' An error is generated in case the expression can't be parsed and evaluated.
+#' 
+#' `@etas` must resolve to an integer-like object. Expecting most usage to be
+#' `1:last` which will be integer, but we want to support `c(1,2,5)` as well
+#' which will not be integer. 
+#'
+#' @return The model object, possibly updated.   
+#' 
+#' @noRd
+capture_etas <- function(x, env) {
+  if(!is.character(env[["capture_etas"]])) return(x)
+  last <- sum(nrow(omat(x)))
+  if(last==0) return(x)
+  parse_env <- as.list(env$ENV)
+  parse_env$last <- parse_env$LAST <- last
+  for(eta_txt in env[["capture_etas"]]) {
+    etan <- try(eval(parse(text = eta_txt), envir = parse_env), silent = TRUE)
+    if(inherits(etan, "try-error")) {
+      msg <- c(
+        glue("could not parse this expression for `etas`: {eta_txt}."), 
+        x = etan
+      )
+      abort(msg)
+    }
+    resolves_int <- is.numeric(etan) && all.equal(etan, round(etan))
+    if(!resolves_int) {
+      abort("`etas` must resolve to an integer value.")    
+    }
+    if(length(etan)==0) {
+      abort("`etas` has length 0.")  
+    }
+    etan <- unique(as.integer(round(etan)))
+    if(any(etan < 1 | etan > last)) {
+      abort(
+        message = c(
+          glue("`etas` must be integers between 1 and {last}."),
+          i = glue("minimum value in `etas`: {min(etan)}"),
+          i = glue("maximum value in `etas`: {max(etan)}")
+        )
+      )
+    }
+    old <- paste0("ETA(", etan, ")")
+    new <- paste0("ETA", etan)
+    x <- update_capture(x, .ren.chr(.ren.create(old, new)))
+  }
+  x
+}
+
 ## These are arguments to mrgsim that
 ## can be stated in $SET and then passed to mrgsim
 set_args <- c(
@@ -674,6 +734,7 @@ parse_env <- function(spec, incoming_names = names(spec),build,ENV=new.env()) {
   mread.env$ENV <- ENV 
   mread.env$blocks <- names(spec)
   mread.env$incoming_names <- incoming_names
+  mread.env$capture_etas <- NULL
   mread.env
 }
 

R/mread.R

@@ -159,7 +159,7 @@ mread <- function(model, project = getOption("mrgsolve.project", getwd()),
                   capture = NULL,
                   preclean = FALSE, recover = FALSE, ...) {
 
-  if(charthere(model, "/")) {
+  if(!identical(basename(model), as.character(model))) {
     project <- dirname(model)
     model <- basename(model)
   }
@@ -272,9 +272,10 @@ mread <- function(model, project = getOption("mrgsolve.project", getwd()),
 
   # capture  ----
   capture_more <- capture
-  capture_code <- unlist(do.call("c", nonull.list(mread.env[["capture"]])))
-  capture <- .ren.create(as.character(capture_code))
-  annot <- capture_param(annot,.ren.new(capture))
+  capture <- unlist(nonull.list(mread.env[["capture"]]))
+  capture <- .ren.create(capture)
+  capture <- .ren.sanitize(capture)
+  annot <- capture_param(annot, .ren.new(capture))
 
   # Collect potential multiples
   subr  <- collect_subr(spec)
@@ -398,6 +399,11 @@ mread <- function(model, project = getOption("mrgsolve.project", getwd()),
   }
 
   # more captures ----
+
+  # Process @etas 1:n -----
+  x <- capture_etas(x, mread.env)
+
+  # Process capture passed into mread -----
   if(is.character(capture_more)) {
     valid_capture <- get_valid_capture(
       param = param, omega = omega, sigma = sigma, build = build, 
@@ -407,6 +413,7 @@ mread <- function(model, project = getOption("mrgsolve.project", getwd()),
       capture_more <- valid_capture[valid_capture != "."]  
     }
     capture_vars <- .ren.create(capture_more)
+    capture_vars <- .ren.sanitize(capture_vars)
     if(!all(capture_vars[["old"]] %in% valid_capture)) {
       bad <- setdiff(capture_vars[["old"]], valid_capture)
       for(b in bad) {
@@ -418,13 +425,10 @@ mread <- function(model, project = getOption("mrgsolve.project", getwd()),
         call. = FALSE
       )
     }
-    capture_code <- unique(c(capture_code, capture_more))
-    capture <- .ren.create(capture_code)
-    x@capture <- .ren.chr(capture)
-    x <- default_outputs(x)
+    x <- update_capture(x, .ren.chr(capture_vars))
     build$preclean <- TRUE
   }
-  
+
   # Check mod ----
   check_pkmodel(x, subr, spec)
   check_globals(mread.env[["move_global"]], Cmt(x))
@@ -532,7 +536,7 @@ mread <- function(model, project = getOption("mrgsolve.project", getwd()),
     dbs[["cmt"]],
     table,
     spec[["PRED"]],
-    write_capture(.ren.old(capture)),
+    write_capture(names(x@capture)),
     "__END_table__",
     "", 
     sep="\n", file=def.con)
@@ -600,6 +604,11 @@ mread_cache <- function(model = NULL,
                         preclean = FALSE, 
                         capture = NULL, ...) {
 
+  if (!identical(basename(model), as.character(model))) {
+    project <- dirname(model)
+    model <- basename(model)
+  }
+
   if(is.character(capture)) preclean <- TRUE
 
   build <- new_build(file, model, project, soloc, code, preclean) 

R/mrgsim_q.R

@@ -28,16 +28,19 @@
 ##' This function should always be used for benchmarking simulation time with
 ##' mrgsolve.
 ##' 
-##' @param x a model object
-##' @param data a simulation data set
-##' @param recsort record sorting flag
+##' 
+##' @param x a model object.
+##' @param data a simulation data set.
+##' @param recsort record sorting flag.
 ##' @param stime a numeric vector of observation times; these observation
 ##' times will only be added to the output if there are no observation
-##' records in \code{data}
-##' @param skip_init_calc don't use \code{$MAIN} to calculate initial conditions
+##' records in \code{data}.
+##' @param skip_init_calc don't use \code{$MAIN} to calculate initial conditions.
 ##' @param output output data type; if \code{mrgsims}, then the default output
-##' object is returned; if \code{"df"} then a data frame is returned
-##' @param simcall not used; only the default value of 0 is allowed
+##' object is returned; if \code{"df"} then a data frame is returned.
+##' @param simcall not used; only the default value of 0 is allowed. 
+##' @param etasrc source for ETA() values in the model; values can include: 
+##' "omega", "data" or "data.all"; see 'Details' in [mrgsim()]. 
 ##' 
 ##' @details
 ##' 
@@ -95,7 +98,8 @@ mrgsim_q <- function(x,
                      stime = numeric(0),
                      output = "mrgsims",
                      skip_init_calc = FALSE, 
-                     simcall = 0) {
+                     simcall = 0, 
+                     etasrc = "omega") {
 
   if(!is.mrgmod(x)) mod_first()
 
@@ -108,13 +112,18 @@ mrgsim_q <- function(x,
     data <- valid_data_set(data,x,x@verbose)
   } 
 
+  if(!(is.character(etasrc) && length(etasrc)==1)) {
+    abort("`etasrc` must be a string.")
+  }
+
   tcol <- timename(data)
   if(is.na(tcol)) tcol <- "time"
 
   # Big list of stuff to pass to DEVTRAN
   parin <- parin(x)
   parin$recsort <- recsort
   parin$do_init_calc <- !skip_init_calc
+  parin$etasrc <- etasrc
 
   if(simcall!=0) {
     if(simcall==1) {