init_val: g3_init_val() parameter-template helper #124

A replacement for gadgetutils::g3_init_guess(), with glob-like syntax.

NAMESPACE

@@ -77,6 +77,9 @@ export(g3_eval)
 # R/formula_utils.R
 export(g3_formula)
 
+# R/init_val.R
+export(g3_init_val)
+
 # R/likelihood_bounds.R
 export(g3l_bounds_penalty)
 

R/init_val.R

@@ -0,0 +1,92 @@
+g3_init_val <- function (
+        param_template,
+        name_spec,
+        value = NULL,
+        spread = NULL,
+        lower = if (!is.null(spread)) value * (1 - spread),
+        upper = if (!is.null(spread)) value * (1 + spread),
+        optimise = !is.null(lower) & !is.null(upper),
+        parscale = if (is.null(lower) || is.null(upper)) NULL else
+            diff(c(lower, upper), lag = length(lower)),
+        random = NULL,
+        auto_exponentiate = TRUE) {
+    stopifnot(is.data.frame(param_template) || is.list(param_template))
+    stopifnot(is.character(name_spec) && length(name_spec) == 1)
+    stopifnot(is.numeric(value) || is.null(value))
+    stopifnot(is.numeric(spread) || is.null(spread))
+    stopifnot(is.numeric(lower) || is.null(lower))
+    stopifnot(is.numeric(upper) || is.null(upper))
+    stopifnot(is.logical(optimise) || is.null(optimise))
+    stopifnot(is.numeric(parscale) || is.null(parscale))
+    stopifnot(is.logical(random) || is.null(random))
+    stopifnot(is.logical(auto_exponentiate))
+
+    # Parse name_spec --> regex
+    name_re <- paste0(vapply(strsplit(name_spec, ".", fixed = TRUE)[[1]], function (part) {
+        # [1979-1984] - range match
+        m <- regmatches(part, regexec('^\\[(\\d+)[:-](\\d+)\\]$', part))
+        if (all(vapply(m, length, numeric(1)) == 3)) {
+            m <- m[[1]]
+            return(paste0(
+                '(?:',
+                paste(seq(as.numeric(m[[2]]), as.numeric(m[[3]])), collapse = "|"),
+                ')'))
+        }
+
+        # # - numeric match
+        part <- gsub("#", "\\E\\d+\\Q", part, fixed = TRUE)
+
+        # *  - string match
+        part <- gsub("*", "\\E.*\\Q", part, fixed = TRUE)
+
+        # Make sure by default text in part is quoted
+        return(paste0('\\Q', part, '\\E'))
+    }, character(1)), collapse = "\\.")
+
+    name_re <- paste0(
+        '^',
+        name_re,
+        if (auto_exponentiate) '(_exp)?',
+        '$')
+    names_in <- if (is.data.frame(param_template)) param_template$switch else names(param_template)
+    m <- regmatches(names_in, regexec(name_re, names_in))
+
+    matches <- sapply(m, length) > 0
+    if (!any(matches)) {
+        warning("g3_init_val('", name_spec, "') didn't match any parameters")
+        return(param_template)
+    }
+
+    # Make boolean vector for all places to auto_exp 
+    if (auto_exponentiate) {
+        auto_exp <- vapply(m, function(x) length(x) >= 2 && x[[2]] == '_exp', logical(1))
+    } else {
+        auto_exp <- FALSE
+    }
+
+    if (is.data.frame(param_template)) {
+        if (!is.null(value)) {
+            param_template[matches, 'value'] <- value
+            if (any(auto_exp)) param_template[auto_exp, 'value'] <- log(param_template[auto_exp, 'value'])
+        }
+        if (!is.null(lower)) {
+            param_template[matches, 'lower'] <- lower
+            if (any(auto_exp)) param_template[auto_exp, 'lower'] <- log(param_template[auto_exp, 'lower'])
+        }
+        if (!is.null(upper)) {
+            param_template[matches, 'upper'] <- upper
+            if (any(auto_exp)) param_template[auto_exp, 'upper'] <- log(param_template[auto_exp, 'upper'])
+        }
+        # NB: Can't set optimise & random
+        if (!is.null(random)) param_template[matches, 'random'] <- random
+        if (!is.null(optimise)) param_template[matches, 'optimise'] <- optimise & !param_template[matches, 'random']
+        if (!is.null(parscale)) param_template[matches, 'parscale'] <- parscale
+    } else {  # is.list
+        if (!is.null(value)) {
+            param_template[matches] <- value
+            if (any(auto_exp)) param_template[auto_exp] <- log(param_template[auto_exp])
+        }
+    }
+
+    return(param_template)
+}

man/init_val.Rd

@@ -0,0 +1,106 @@
+\name{init_val}
+\alias{g3_init_val}
+
+\title{Gadget3 parameter value setter}
+\description{
+  Helper for setting initial parameter value
+}
+
+\usage{
+g3_init_val(
+        param_template,
+        name_spec,
+        value = NULL,
+        spread = NULL,
+        lower = if (!is.null(spread)) value * (1 - spread),
+        upper = if (!is.null(spread)) value * (1 + spread),
+        optimise = !is.null(lower) & !is.null(upper),
+        parscale = if (is.null(lower) || is.null(upper)) NULL else
+            diff(c(lower, upper), lag = length(lower)),
+        random = NULL,
+        auto_exponentiate = TRUE)
+}
+
+\arguments{
+  \item{param_template}{
+    A parameter template generated by \code{\link{g3_to_r}} or \code{\link{g3_to_tmb}}
+  }
+  \item{name_spec}{
+    A glob-like string to match parameter names, see Details
+  }
+  \item{value}{
+    Numeric value / vector of values to set for value / 'value' column in template.
+    Original value left if NULL
+  }
+  \item{spread}{
+    Shortcut for setting \var{lower} & \var{upper}.
+  }
+  \item{lower}{
+    Numeric value / vector of values to set for 'lower' column in template.
+    Original value left if NULL
+  }
+  \item{upper}{
+    Numeric value / vector of values to set for 'upper' column in template.
+    Original value left if NULL
+  }
+  \item{optimise}{
+    Boolean value to set for 'optimise' column in template.
+    Default is true iff both lower and upper are non-NULL.
+    Original value left if NULL
+  }
+  \item{parscale}{
+    Numeric value / vector of values to set for 'parscale' column in template.
+    Default is difference between lower & upper (or NULL if they're not set).
+    Original value left if NULL
+  }
+  \item{random}{
+    Boolean value to set for 'random' column in template.
+    Original value left if NULL
+  }
+  \item{auto_exponentiate}{
+    If TRUE, will implicitly match parameters ending with "_exp",
+    and if this is the case \code{log} all \var{value}/\var{lower}/\var{upper} values
+  }
+}
+
+\details{
+  \var{name_spec} is a glob (or wildcard) matching parameters.
+  It is a string separated by \\code{.}, where each part can be:
+  \enumerate{
+    \item{A wildcard matching anything (\code{*}), or a matching anything with a prefix, e.g. \code{m*}}
+    \item{A wildcard matching any number (\code{#}), or a matching a number with a prefix, e.g. \code{age*}}
+    \item{A range of numbers, e.g. \code{[1979-1984]}}
+  }
+}
+
+\value{A new parameter template list/table containing modifications}
+
+\seealso{
+  \code{\link{g3_parameterized}}
+}
+
+\examples{
+# A parameter template, would already be got via. attr(g3_to_tmb(...), "parameter_template")
+pt <- data.frame(
+    switch = c(
+        paste0('fish.init.', 1:9),
+        paste0('fish.rec.', 1990:2000),
+        'fish.M'),
+    value = NA,
+    lower = NA,
+    upper = NA,
+    parscale = NA,
+    optimise = FALSE,
+    random = FALSE)
+
+# Set all fish.init.# parameters to optimise
+pt <- g3_init_val(pt, 'fish.init.#', 4, spread = 8)
+
+# Set a fixed value for any .M
+pt <- g3_init_val(pt, '*.M', value = 0.3, optimise = FALSE)
+
+# Set a fixed value for a range of recruitment years, optimise the rest
+pt |>
+    g3_init_val('*.rec.#', value = 4, lower = 0, upper = 10) |>
+    g3_init_val('*.rec.[1993-1996]', value = 0, optimise = FALSE) -> pt
+}