fix an issue in smooth_samples that was causing a failure when data w…

…as supplied and columns were being relocated #255

R/posterior-samples.R

@@ -492,14 +492,49 @@
   )
 }
 
+#' @param n_vals numeric; how many locations to evaluate the smooth at if
+#'   `data` not supplied
+#' @param term character; select which smooth's posterior to draw from.
+#'   The default (`NULL`) means the posteriors of all smooths in `model`
+#'   wil be sampled from. If supplied, a character vector of requested terms.
+#' @param rng_per_smooth logical; if TRUE, the behaviour of gratia version
+#' 0.8.1 or earlier is used, whereby a separate call the the random number
+#' generator (RNG) is performed for each smooth. If FALSE, a single call to the
+#' RNG is performed for all model parameters
+#'
+#' @section Warning:
+#' The set of variables returned and their order in the tibble is subject to
+#' change in future versions. Don't rely on position.
+#'
 #' @export
-`smooth_samples.scam` <- function(
+#'
+#' @rdname smooth_samples
+#'
+#' @inheritParams posterior_samples
+#'
+#' @importFrom mvnfast rmvn
+#' @importFrom dplyr bind_rows starts_with
+#' @importFrom tibble as_tibble add_column
+#' @importFrom tidyr pivot_longer
+#' @importFrom mgcv PredictMat
+#' @importFrom tidyselect any_of
+`smooth_samples.gam` <- function(
     model, term = NULL, n = 1, data = newdata,
-    method = c("gaussian", "mh", "inla", "user"), seed = NULL,
-    freq = FALSE, unconditional = FALSE, n_cores = 1L, n_vals = 200,
-    burnin = 1000, thin = 1, t_df = 40, rw_scale = 0.25, rng_per_smooth = FALSE,
-    draws = NULL, mvn_method = c("mvnfast", "mgcv"), ...,
-    newdata = NULL, ncores = NULL) {
+    method = c("gaussian", "mh", "inla", "user"),
+    seed = NULL,
+    freq = FALSE,
+    unconditional = FALSE,
+    n_cores = 1L,
+    n_vals = 200,
+    burnin = 1000,
+    thin = 1,
+    t_df = 40,
+    rw_scale = 0.25,
+    rng_per_smooth = FALSE,
+    draws = NULL,
+    ...,
+    newdata = NULL,
+    ncores = NULL) {
   # smooth_samples begins
   if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
     runif(1)
@@ -512,12 +547,14 @@
     RNGstate <- structure(seed, kind = as.list(RNGkind()))
     on.exit(assign(".Random.seed", R.seed, envir = .GlobalEnv))
   }
+
   S <- smooths(model) # vector of smooth labels - "s(x)"
   take <- seq_along(S) # in default case 1,2,3,..,n smooths
   if (!is.null(term)) {
     take <- which_smooths(model, term)
     S <- S[take]
   }
+
   # At least for now, don't work for random effect smooths
   # do we have ranef smooths?
   re_sms <- vapply(get_smooths_by_id(model, take),
@@ -532,34 +569,40 @@
     S <- S[!re_sms]
     take <- take[!re_sms]
   }
+
   # do we have any remaining terms?
   if (length(S) < 1L) {
     stop("No smooths left that can be sampled from.")
   }
+
   if (!is.null(newdata)) {
     newdata_deprecated()
   }
+
   if (!is.null(ncores)) {
     message("Argument `ncores` is deprecated. Use `n_cores` instead.")
     n_cores <- ncores
   }
+
   need_data <- FALSE
   if (is.null(data)) {
     need_data <- TRUE
   }
+
   # what posterior sampling are we using
   method <- match.arg(method)
-  mvn_method <- match.arg(mvn_method)
+
   # get posterior draws - call this once for all parameters
   if (isFALSE(rng_per_smooth)) {
     betas <- post_draws(
       n = n, method = method,
       n_cores = n_cores, model = model,
       burnin = burnin, thin = thin, t_df = t_df, rw_scale = rw_scale,
       index = NULL, frequentist = freq, unconditional = unconditional,
-      draws = draws, mvn_method = mvn_method, seed = seed
+      draws = draws, seed = seed,
     )
   }
+
   sims <- data_names <- vector("list", length = length(S))
   for (i in seq_along(S)) {
     if (need_data) {
@@ -585,13 +628,7 @@
       )
       Xp %*% t(betas)
     } else {
-      # In a scam model, the intercept seems to be parametrised into the
-      # smooth as PredictMat returns a constant column
-      if (isTRUE(length(idx) < ncol(Xp))) {
-        Xp[, -1, drop = FALSE] %*% t(betas[, idx, drop = FALSE])
-      } else {
-        Xp %*% t(betas[, idx, drop = FALSE])
-      }
+      Xp %*% t(betas[, idx, drop = FALSE])
     }
     colnames(simu) <- paste0("..V", seq_len(NCOL(simu)))
     simu <- as_tibble(simu)
@@ -618,7 +655,7 @@
       names_to = ".draw", values_to = ".value",
       names_transform = \(x) as.integer(sub("\\.\\.V", "", x))
     )
-    simu <- relocate(simu, names(data), .after = last_col()) |>
+    simu <- relocate(simu, any_of(names(data)), .after = last_col()) |>
       relocate(".by", .after = 3L)
     ## nest all columns with varying data
     simu <- nest(simu, data = all_of(c(
@@ -636,48 +673,20 @@
   sims
 }
 
-#' @param n_vals numeric; how many locations to evaluate the smooth at if
-#'   `data` not supplied
-#' @param term character; select which smooth's posterior to draw from.
-#'   The default (`NULL`) means the posteriors of all smooths in `model`
-#'   wil be sampled from. If supplied, a character vector of requested terms.
-#' @param rng_per_smooth logical; if TRUE, the behaviour of gratia version
-#' 0.8.1 or earlier is used, whereby a separate call the the random number
-#' generator (RNG) is performed for each smooth. If FALSE, a single call to the
-#' RNG is performed for all model parameters
-#'
-#' @section Warning:
-#' The set of variables returned and their order in the tibble is subject to
-#' change in future versions. Don't rely on position.
-#'
 #' @export
-#'
-#' @rdname smooth_samples
-#'
-#' @inheritParams posterior_samples
-#'
 #' @importFrom mvnfast rmvn
 #' @importFrom dplyr bind_rows starts_with
 #' @importFrom tibble as_tibble add_column
 #' @importFrom tidyr pivot_longer
 #' @importFrom mgcv PredictMat
-`smooth_samples.gam` <- function(
+#' @importFrom tidyselect any_of
+`smooth_samples.scam` <- function(
     model, term = NULL, n = 1, data = newdata,
-    method = c("gaussian", "mh", "inla", "user"),
-    seed = NULL,
-    freq = FALSE,
-    unconditional = FALSE,
-    n_cores = 1L,
-    n_vals = 200,
-    burnin = 1000,
-    thin = 1,
-    t_df = 40,
-    rw_scale = 0.25,
-    rng_per_smooth = FALSE,
-    draws = NULL,
-    ...,
-    newdata = NULL,
-    ncores = NULL) {
+    method = c("gaussian", "mh", "inla", "user"), seed = NULL,
+    freq = FALSE, unconditional = FALSE, n_cores = 1L, n_vals = 200,
+    burnin = 1000, thin = 1, t_df = 40, rw_scale = 0.25, rng_per_smooth = FALSE,
+    draws = NULL, mvn_method = c("mvnfast", "mgcv"), ...,
+    newdata = NULL, ncores = NULL) {
   # smooth_samples begins
   if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
     runif(1)
@@ -690,14 +699,12 @@
     RNGstate <- structure(seed, kind = as.list(RNGkind()))
     on.exit(assign(".Random.seed", R.seed, envir = .GlobalEnv))
   }
-
   S <- smooths(model) # vector of smooth labels - "s(x)"
   take <- seq_along(S) # in default case 1,2,3,..,n smooths
   if (!is.null(term)) {
     take <- which_smooths(model, term)
     S <- S[take]
   }
-
   # At least for now, don't work for random effect smooths
   # do we have ranef smooths?
   re_sms <- vapply(get_smooths_by_id(model, take),
@@ -712,40 +719,34 @@
     S <- S[!re_sms]
     take <- take[!re_sms]
   }
-
   # do we have any remaining terms?
   if (length(S) < 1L) {
     stop("No smooths left that can be sampled from.")
   }
-
   if (!is.null(newdata)) {
     newdata_deprecated()
   }
-
   if (!is.null(ncores)) {
     message("Argument `ncores` is deprecated. Use `n_cores` instead.")
     n_cores <- ncores
   }
-
   need_data <- FALSE
   if (is.null(data)) {
     need_data <- TRUE
   }
-
   # what posterior sampling are we using
   method <- match.arg(method)
-
+  mvn_method <- match.arg(mvn_method)
   # get posterior draws - call this once for all parameters
   if (isFALSE(rng_per_smooth)) {
     betas <- post_draws(
       n = n, method = method,
       n_cores = n_cores, model = model,
       burnin = burnin, thin = thin, t_df = t_df, rw_scale = rw_scale,
       index = NULL, frequentist = freq, unconditional = unconditional,
-      draws = draws, seed = seed,
+      draws = draws, mvn_method = mvn_method, seed = seed
     )
   }
-
   sims <- data_names <- vector("list", length = length(S))
   for (i in seq_along(S)) {
     if (need_data) {
@@ -771,20 +772,17 @@
       )
       Xp %*% t(betas)
     } else {
-      Xp %*% t(betas[, idx, drop = FALSE])
+      # In a scam model, the intercept seems to be parametrised into the
+      # smooth as PredictMat returns a constant column
+      if (isTRUE(length(idx) < ncol(Xp))) {
+        Xp[, -1, drop = FALSE] %*% t(betas[, idx, drop = FALSE])
+      } else {
+        Xp %*% t(betas[, idx, drop = FALSE])
+      }
     }
     colnames(simu) <- paste0("..V", seq_len(NCOL(simu)))
     simu <- as_tibble(simu)
     nr_simu <- nrow(simu)
-    # is_fac_by <- is_factor_by_smooth(sm)
-    # if (is_fac_by)) {
-    #     simu <- add_factor_by_data(simu, n = n_vals,
-    #                                by_name = by_variable(sm),
-    #                                by_data = data, before = 1L)
-    # } else {
-    #     simu <- add_by_var_column(simu, n = nr_simu,
-    #         by_var = by_variable(sm))
-    # }
     simu <- add_by_data(simu,
       by_name = by_variable(sm), by_data = data,
       before = 1L
@@ -807,7 +805,7 @@
       names_to = ".draw", values_to = ".value",
       names_transform = \(x) as.integer(sub("\\.\\.V", "", x))
     )
-    simu <- relocate(simu, names(data), .after = last_col()) |>
+    simu <- relocate(simu, any_of(names(data)), .after = last_col()) |>
       relocate(".by", .after = 3L)
     ## nest all columns with varying data
     simu <- nest(simu, data = all_of(c(