diff --git a/R/prepare_stan_input.R b/R/prepare_stan_input.R index d44dbd6..eea9a25 100644 --- a/R/prepare_stan_input.R +++ b/R/prepare_stan_input.R @@ -1184,10 +1184,10 @@ prepare_channel_student <- function(y, Y, channel, sampling, prepare_channel_cumulative <- function(y, Y, channel, sampling, sd_x, resp_class, priors) { stopifnot_( - all(c("ordered", "factor") %in% resp_class), + "factor" %in% resp_class, c( "Response variable {.var {y}} is invalid:", - `x` = "Cumulative family supports only {.cls ordered factor} variables." + `x` = "Cumulative family supports only {.cls factor} variables." ) ) resp_levels <- attr(resp_class, "levels") diff --git a/R/stan_utilities.R b/R/stan_utilities.R index 2313384..4a45b48 100644 --- a/R/stan_utilities.R +++ b/R/stan_utilities.R @@ -38,6 +38,7 @@ stan_array <- function(backend, type, name, arr_dims, ) ) } + #' Create A Backward Compatible Stan Array for Function Arguments #' @noRd stan_array_arg <- function(backend, type, name, n_dims = 0, data = FALSE) { @@ -53,6 +54,7 @@ stan_array_arg <- function(backend, type, name, n_dims = 0, data = FALSE) { paste0(data, type, "[",commas, "] ", name) ) } + #' Is Array Keyword Syntax Supported By Current Stan Version #' #' @param backend Either `"rstan"` or `"cmdstanr"`. diff --git a/R/stanblocks.R b/R/stanblocks.R index 1431376..dea266f 100644 --- a/R/stanblocks.R +++ b/R/stanblocks.R @@ -362,37 +362,6 @@ create_parameters_lines <- function(idt, backend, cvars, cgvars) { cgvars$univariate <- univariate } lines_wrap("parameters", family, idt, backend, cgvars) - } else if (is_cumulative(family)) { - # the linear predictor without intercept - has_varying_intercept <- cvars[[1L]]$has_varying_intercept - cvars[[1L]]$has_fixed_intercept <- FALSE - cvars[[1L]]$has_varying_intercept <- FALSE - par_main <- lines_wrap( - "parameters", "default", idt, backend, cvars[[1L]] - ) - # time-varying intercepts only - cvars[[1L]]$has_random_intercept <- FALSE - cvars[[1L]]$has_fixed <- FALSE - cvars[[1L]]$has_varying <- FALSE - cvars[[1L]]$has_random <- FALSE - cvars[[1L]]$has_lfactor <- FALSE - cvars[[1L]]$has_varying_intercept <- has_varying_intercept - par_alpha <- ulapply( - seq_len(cvars[[1L]]$S - 1L), - function(s) { - cvars[[1L]]$ydim <- cvars[[1L]]$y - cvars[[1L]]$y <- paste0(cvars[[1L]]$y, "_", s) - cvars[[1L]]$pos_omega_alpha <- s > 1L - lines_wrap( - "parameters", "default", idt, backend, cvars[[1L]] - ) - } - ) - cvars[[1L]]$default <- paste_rows( - par_main, - par_alpha, - .parse = FALSE - ) } else { if (is_categorical(family)) { cvars[[1L]]$default <- lapply( @@ -405,7 +374,40 @@ create_parameters_lines <- function(idt, backend, cvars, cgvars) { ) } ) - } else { + } else if (is_cumulative(family)) { + # the linear predictor without intercept + def_args <- cvars[[1L]] + has_varying_intercept <- def_args$has_varying_intercept + def_args$has_fixed_intercept <- FALSE + def_args$has_varying_intercept <- FALSE + par_main <- lines_wrap( + "parameters", "default", idt, backend, def_args + ) + # time-varying intercepts only + def_args$has_random_intercept <- FALSE + def_args$has_fixed <- FALSE + def_args$has_varying <- FALSE + def_args$has_random <- FALSE + def_args$has_lfactor <- FALSE + def_args$has_varying_intercept <- has_varying_intercept + par_alpha <- ulapply( + seq_len(def_args$S - 1L), + function(s) { + def_args$ydim <- def_args$y + def_args$y <- paste0(def_args$y, "_", s) + def_args$pos_omega_alpha <- s > 1L + lines_wrap( + "parameters", "default", idt, backend, def_args + ) + } + ) + cvars[[1L]]$default <- paste_rows( + par_main, + par_alpha, + .parse = FALSE + ) + } + else { cvars[[1L]]$default <- lines_wrap( "parameters", "default", idt, backend, cvars[[1L]] ) diff --git a/R/stanblocks_families.R b/R/stanblocks_families.R index 37eb035..5dbf686 100644 --- a/R/stanblocks_families.R +++ b/R/stanblocks_families.R @@ -1742,23 +1742,35 @@ transformed_parameters_lines_categorical <- function(default, idt, ...) { } transformed_parameters_lines_cumulative <- function(y, categories, - default, idt, ...) { - S <- length(categories) - declare_alpha <- glue::glue("array[T] ordered[S_{y} - 1] alpha_y;") - alpha_loop <- vapply( - seq(2L, S - 1L), - function(s) { - glue::glue("alpha_{y}[t, {s}] = alpha_{y}[t, {s - 1}] + alpha_{y}_{s}[t];") - }, - character(1L) - ) - state_alpha <- paste_rows( - "for (t in 1:T) {{", - "alpha_{y}[t, 1] = alpha_{y}_1[t];", - alpha_loop, - "}}", - .indent = idt(c(1, 2, 2, 1)) - ) + has_varying_intercept, + default, idt, + backend, ...) { + declare_alpha <- "" + state_alpha <- "" + if (has_varying_intercept) { + S <- length(categories) + declare_alpha <- glue::glue( + stan_array( + backend, "real", "alpha_{y}", "T", "", "S_{y} - 1" + ) + ) + alpha_loop <- vapply( + seq(2L, S - 1L), + function(s) { + glue::glue( + "alpha_{y}[t, {s}] = alpha_{y}[t, {s - 1}] + alpha_{y}_{s}[t];" + ) + }, + character(1L) + ) + state_alpha <- paste_rows( + "for (t in 1:T) {{", + "alpha_{y}[t, 1] = alpha_{y}_1[t];", + alpha_loop, + "}}", + .indent = idt(c(1, 2, 2, 1)) + ) + } list( declarations = paste_rows( ulapply(default, "[[", "declarations"),