|
| 1 | +#' Write Stan code to a file |
| 2 | +#' |
| 3 | +#' Convenience function for writing Stan code to a (possibly |
| 4 | +#' [temporary][base::tempfile]) file with a `.stan` extension. By default, the |
| 5 | +#' file name is chosen deterministically based on a [hash][rlang::hash()] |
| 6 | +#' of the Stan code, and the file is not overwritten if it already has correct |
| 7 | +#' contents. This means that calling this function multiple times with the same |
| 8 | +#' Stan code will reuse the compiled model. This also however means that the |
| 9 | +#' function is potentially not thread-safe. Using `hash_salt = Sys.getpid()` |
| 10 | +#' should ensure thread-safety in the rare cases when it is needed. |
| 11 | +#' |
| 12 | +#' @export |
| 13 | +#' @param code (character vector) The Stan code to write to the file. This can |
| 14 | +#' be a character vector of length one (a string) containing the entire Stan |
| 15 | +#' program or a character vector with each element containing one line of the |
| 16 | +#' Stan program. |
| 17 | +#' @param dir (string) An optional path to the directory where the file will be |
| 18 | +#' written. If omitted, a global option `cmdstanr_write_stan_file_dir` is |
| 19 | +#' used. If the global options is not set, [temporary directory][base::tempdir] |
| 20 | +#' is used. |
| 21 | +#' @param basename (string) If `dir` is specified, optionally the basename to |
| 22 | +#' use for the file created. If not specified a file name is generated |
| 23 | +#' from [hashing][rlang::hash()] the code. |
| 24 | +#' @param force_overwrite (logical) If set to `TRUE` the file will always be |
| 25 | +#' overwritten and thus the resulting model will always be recompiled. |
| 26 | +#' @param hash_salt (string) Text to add to the model code prior to hashing to |
| 27 | +#' determine the file name if `basename` is not set. |
| 28 | +#' @return The path to the file. |
| 29 | +#' |
| 30 | +#' @examples |
| 31 | +#' # stan program as a single string |
| 32 | +#' stan_program <- " |
| 33 | +#' data { |
| 34 | +#' int<lower=0> N; |
| 35 | +#' array[N] int<lower=0,upper=1> y; |
| 36 | +#' } |
| 37 | +#' parameters { |
| 38 | +#' real<lower=0,upper=1> theta; |
| 39 | +#' } |
| 40 | +#' model { |
| 41 | +#' y ~ bernoulli(theta); |
| 42 | +#' } |
| 43 | +#' " |
| 44 | +#' |
| 45 | +#' f <- write_stan_file(stan_program) |
| 46 | +#' print(f) |
| 47 | +#' |
| 48 | +#' lines <- readLines(f) |
| 49 | +#' print(lines) |
| 50 | +#' cat(lines, sep = "\n") |
| 51 | +#' |
| 52 | +#' # stan program as character vector of lines |
| 53 | +#' f2 <- write_stan_file(lines) |
| 54 | +#' identical(readLines(f), readLines(f2)) |
| 55 | +#' |
| 56 | +write_stan_file <- function(code, |
| 57 | + dir = getOption("cmdstanr_write_stan_file_dir", tempdir()), |
| 58 | + basename = NULL, |
| 59 | + force_overwrite = FALSE, |
| 60 | + hash_salt = "") { |
| 61 | + dir <- absolute_path(dir) |
| 62 | + if (!dir.exists(dir)) { |
| 63 | + dir.create(dir, recursive = TRUE) |
| 64 | + } |
| 65 | + collapsed_code <- paste0(code, collapse = "\n") |
| 66 | + |
| 67 | + if (!is.null(basename)) { |
| 68 | + if (!endsWith(basename, ".stan")) { |
| 69 | + basename <- paste0(basename, ".stan") |
| 70 | + } |
| 71 | + file <- file.path(dir, basename) |
| 72 | + } else { |
| 73 | + require_suggested_package("rlang") |
| 74 | + hash <- rlang::hash(paste0(hash_salt, collapsed_code)) |
| 75 | + file <- file.path(dir, paste0("model_", hash, ".stan")) |
| 76 | + } |
| 77 | + overwrite <- TRUE |
| 78 | + # Do not overwrite file if it has the correct contents (to avoid recompilation) |
| 79 | + if (!force_overwrite && file.exists(file)) { |
| 80 | + tryCatch({ |
| 81 | + file_contents <- paste0(readLines(file), collapse = "\n") |
| 82 | + if (gsub("\r|\n", "\n", file_contents) == gsub("\r|\n", "\n", collapsed_code)) { |
| 83 | + overwrite <- FALSE |
| 84 | + } |
| 85 | + }, |
| 86 | + error = function(e) { |
| 87 | + warning("Error when checking old file contents", e) |
| 88 | + }) |
| 89 | + } |
| 90 | + |
| 91 | + if (overwrite) { |
| 92 | + cat(code, file = file, sep = "\n") |
| 93 | + } |
| 94 | + file |
| 95 | +} |
| 96 | + |
| 97 | + |
| 98 | +#' Print a Stan file with syntax highlighting in Quarto and R Markdown |
| 99 | +#' |
| 100 | +#' Prints the contents of a Stan file, optionally with syntax highlighting |
| 101 | +#' when used in a Quarto or R Markdown document. When called inside a |
| 102 | +#' [knitr][knitr::knitr-package] code chunk with the chunk option |
| 103 | +#' `output: asis` (or `results: asis` in R Markdown), the output is a |
| 104 | +#' fenced Stan code block that Quarto renders with syntax highlighting. |
| 105 | +#' When called interactively or without `output: asis`, the code is |
| 106 | +#' printed as plain text via [writeLines()]. |
| 107 | +#' |
| 108 | +#' @export |
| 109 | +#' @param file (string) Path to a `.stan` file. |
| 110 | +#' @param fold (logical) Whether to wrap the output in an HTML `<details>` block |
| 111 | +#' so that the code is collapsed (folded) by default. Only has an effect when |
| 112 | +#' rendering with `output: asis` and when outputting HTML. Defaults to |
| 113 | +#' `FALSE`. |
| 114 | +#' @param summary (string) The summary text shown in the fold toggle |
| 115 | +#' when `fold = TRUE`. Defaults to `"Stan model code"`. |
| 116 | +#' @return The file path (invisibly). |
| 117 | +#' |
| 118 | +#' @section Quarto usage: |
| 119 | +#' Use in a Quarto code chunk with `output: asis` to get syntax |
| 120 | +#' highlighting: |
| 121 | +#' |
| 122 | +#' ```` |
| 123 | +#' ```{r} |
| 124 | +#' #| output: asis |
| 125 | +#' print_stan_file("path/to/model.stan") |
| 126 | +#' ``` |
| 127 | +#' ```` |
| 128 | +#' |
| 129 | +#' To make the code block collapsible: |
| 130 | +#' |
| 131 | +#' ```` |
| 132 | +#' ```{r} |
| 133 | +#' #| output: asis |
| 134 | +#' print_stan_file("path/to/model.stan", fold = TRUE) |
| 135 | +#' ``` |
| 136 | +#' ```` |
| 137 | +#' |
| 138 | +#' @examples |
| 139 | +#' stan_file <- write_stan_file(" |
| 140 | +#' parameters { |
| 141 | +#' real y; |
| 142 | +#' } |
| 143 | +#' model { |
| 144 | +#' y ~ std_normal(); |
| 145 | +#' } |
| 146 | +#' ") |
| 147 | +#' |
| 148 | +#' # Prints plain code at the console |
| 149 | +#' print_stan_file(stan_file) |
| 150 | +#' |
| 151 | +print_stan_file <- function(file, fold = FALSE, summary = "Stan model code") { |
| 152 | + code <- readLines(file) |
| 153 | + if (is_knitr_asis_output()) { |
| 154 | + if (fold) { |
| 155 | + cat("<details><summary>", summary, "</summary>\n\n", sep = "") |
| 156 | + } |
| 157 | + cat("```stan\n") |
| 158 | + cat(code, sep = "\n") |
| 159 | + cat("\n```\n") |
| 160 | + if (fold) { |
| 161 | + cat("\n</details>\n") |
| 162 | + } |
| 163 | + } else { |
| 164 | + writeLines(code) |
| 165 | + } |
| 166 | + invisible(file) |
| 167 | +} |
| 168 | + |
| 169 | +is_knitr_asis_output <- function() { |
| 170 | + isTRUE(getOption("knitr.in.progress")) && |
| 171 | + requireNamespace("knitr", quietly = TRUE) && |
| 172 | + identical(knitr::opts_current$get("results"), "asis") |
| 173 | +} |
0 commit comments