Merge pull request metrumresearchgroup#1078 from metrumresearchgroup/…

…strict-inventory

Tagged parameters and inventory version 2

NAMESPACE

@@ -25,6 +25,7 @@ S3method(handle_spec_block,specCMTN)
 S3method(handle_spec_block,specFIXED)
 S3method(handle_spec_block,specINCLUDE)
 S3method(handle_spec_block,specINIT)
+S3method(handle_spec_block,specINPUT)
 S3method(handle_spec_block,specNAMESPACE)
 S3method(handle_spec_block,specNMEXT)
 S3method(handle_spec_block,specNMXML)
@@ -85,6 +86,7 @@ export(bmat)
 export(cama)
 export(carry.out)
 export(carry_out)
+export(check_data_names)
 export(cmat)
 export(cmtn)
 export(collapse_matrix)
@@ -152,6 +154,7 @@ export(obsaug)
 export(obsonly)
 export(omat)
 export(outvars)
+export(param_tags)
 export(parse_rx)
 export(plot_sims)
 export(qsim)
@@ -259,6 +262,7 @@ importFrom(rlang,as_label)
 importFrom(rlang,enquo)
 importFrom(rlang,enquos)
 importFrom(rlang,eval_tidy)
+importFrom(rlang,inform)
 importFrom(rlang,is_named)
 importFrom(rlang,quo_name)
 importFrom(rlang,quos)

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 abort warn
+#' @importFrom rlang is_named .data abort warn inform
 #' @importFrom lifecycle deprecate_soft deprecate_warn
 #' @importFrom glue glue
 #' @importFrom Rcpp evalCpp
@@ -79,7 +79,8 @@ block_list <- c("ENV", "PROB", "PARAM", "INIT",
                 "FIXED", "CMTN", "THETA", "NMXML", "VCMT",
                 "PKMODEL", "PLUGIN", "INCLUDE", "NAMESPACE",
                 "OMEGA", "SIGMA", "SET","GLOBAL", "CAPTURE", 
-                "PREAMBLE", "PRED", "BLOCK", "TRANSIT", "YAML", "NMEXT")
+                "PREAMBLE", "PRED", "BLOCK", "TRANSIT", "YAML", "NMEXT", 
+                "INPUT")
 
 Reserved_cvar <- c("SOLVERTIME","table","ETA","EPS", "AMT", "CMT",
                    "ID", "TIME", "EVID","simeps", "self", "simeta",

R/class_mrgmod.R

@@ -559,6 +559,7 @@ setMethod("as.list", "mrgmod", function(x, deep = FALSE, ...) {
     init <- as.list(init(x))
     param <- as.list(param(x))
     cmt <- cmt(x)
+    param_tag <- shlib(x)[["param_tag"]]
     covariates <- as.character(shlib(x)[["covariates"]])
     pars <- pars(x)
     neq <- neq(x)

R/handle_spec_block.R

@@ -43,7 +43,10 @@ handle_spec_block.default <- function(x, ...) {
 #' @param annotated logical
 #' @param object the name of an object in `ENV`
 #' @param as_object indicates that object code is being provided
-#' @param covariates logical
+#' @param covariates logical; mark as covariates and potentially required 
+#' data input
+#' @param input logical; mark as potentially required data input
+#' @param tag space or comma-separated user-defined tags for the parameter block
 #' @param name block name
 #' @param labels aliases to use for simulated ETA values
 #' @param prefix a prefix to add to the label
@@ -77,7 +80,7 @@ handle_spec_block.default <- function(x, ...) {
 #' @seealso [PKMODEL()]
 NULL
 
-# PARAM / FIXED ----------------------------------------------------------------
+# PARAM ----------------------------------------------------------------
 
 #' @export
 handle_spec_block.specPARAM <- function(x, ...) {
@@ -91,7 +94,9 @@ PARAM <- function(x,
                   annotated = FALSE,
                   object = NULL, 
                   as_object = FALSE,
-                  covariates = FALSE, ...) {
+                  covariates = FALSE,
+                  input = FALSE,
+                  tag = NULL, ...) {
 
   if(is.character(object)) {
     if(isTRUE(as_object)) {
@@ -114,37 +119,68 @@ PARAM <- function(x,
       named = TRUE
     )
     env[["param"]][[pos]] <- x
+    save_param_tag(env, names(x), covariates, input, tag)
     return(NULL)
   }
 
   if(annotated) {
     context <- env[["incoming_names"]][pos]
     context <- as.character(glue("parse annotated parameter block ({context})"))
     l <- parse_annot(x, block = "PARAM", envir = env$ENV, context = context)
-    env[["param"]][[pos]] <- l[["v"]]
+    env[["param"]][[pos]] <- x <- l[["v"]]
     env[["annot"]][[pos]] <- l[["an"]]
   } else {
     x <- tolist(x,envir=env$ENV) 
     if(length(x) > 0 & !is_named(x)) {
       msg <- " invalid model specification
        Block no: {pos}
        Block type: {env$incoming_names[pos]}
-       Some parameters are missing names
+       Some parameters are missing names.
       "
       stop(glue(msg), call. = FALSE)
     }
     env[["param"]][[pos]] <- x
   }
 
-  if(covariates) {
-    env[["covariates"]] <- c(
-      env[["covariates"]], names(env[["param"]][[pos]])
-    )
-  }
+  save_param_tag(env, names(x), covariates, input, tag)
 
   return(NULL)
 }
 
+save_param_tag <- function(env, pars, covariates, input, tag) {
+  if(isTRUE(covariates)) {
+    env[["covariates"]] <- c(env[["covariates"]], pars)
+    tagdf <- data.frame(
+      name = pars, 
+      tag = "covariates", 
+      stringsAsFactors = FALSE
+    )
+    tagdf <- rbind(env[["param_tag"]], tagdf)
+    env[["param_tag"]] <- unique(tagdf)
+  }
+  if(isTRUE(input)) {
+    tag <- c("input", tag)  
+  }
+  if(is.character(tag) && length(tag) > 0) {
+    tag <- cvec_cs(tag)
+    tagdf <- expand.grid(name = pars, tag = tag, stringsAsFactors = FALSE)
+    tagdf <- rbind(env[["param_tag"]], tagdf)
+    env[["param_tag"]] <- unique(tagdf)
+  }
+}
+
+# INPUT ----------------------------------------------------------------
+
+#' @export
+handle_spec_block.specINPUT <- function(x, env, ...) {
+  o <- scrape_opts(x, envir = env$ENV, ...)
+  o$pos <- o$env <- o$class <- o$input <- NULL
+  o <- c(o, attributes(x), list(env = env, input = TRUE))
+  do.call(PARAM, o) 
+}
+
+# FIXED ----------------------------------------------------------------
+
 #' @export
 handle_spec_block.specFIXED <- function(x, ...) {
   scrape_and_call(x, pass = "FIXED", ...)