From 15f0aac94ff0895a31810953e587c9749b69c77b Mon Sep 17 00:00:00 2001 From: Ben Goodrich Date: Sun, 31 Jan 2016 14:12:34 -0500 Subject: [PATCH] move .txt files in exec/ to inst/chunks and change their extension to .stan so that GitHub recognizes them as Stan code --- DESCRIPTION | 4 +-- R/stanmodels.R | 16 +++++---- exec/bernoulli.stan | 22 ++++++------ exec/binomial.stan | 32 ++++++++--------- exec/continuous.stan | 34 +++++++++---------- exec/count.stan | 32 ++++++++--------- exec/lm.stan | 2 +- exec/polr.stan | 12 +++---- exec/NKX.txt => inst/chunks/NKX.stan | 0 .../chunks/common_functions.stan | 0 .../data_glm.txt => inst/chunks/data_glm.stan | 0 .../chunks/eta_no_intercept.stan | 0 .../chunks/glmer_stuff.stan | 0 .../chunks/glmer_stuff2.stan | 0 .../chunks/hyperparameters.stan | 0 exec/license.txt => inst/chunks/license.stan | 0 .../make_eta.txt => inst/chunks/make_eta.stan | 0 .../chunks/make_eta_bern.stan | 0 .../chunks/parameters_glm.stan | 0 .../chunks/priors_glm.stan | 0 .../chunks/tdata_glm.stan | 0 .../chunks/tparameters_glm.stan | 0 .../chunks/weights_offset.stan | 0 tests/testthat/test_stan_functions.R | 14 +++++--- tools/make_cpp.R | 7 ++-- 25 files changed, 93 insertions(+), 82 deletions(-) rename exec/NKX.txt => inst/chunks/NKX.stan (100%) rename exec/common_functions.txt => inst/chunks/common_functions.stan (100%) rename exec/data_glm.txt => inst/chunks/data_glm.stan (100%) rename exec/eta_no_intercept.txt => inst/chunks/eta_no_intercept.stan (100%) rename exec/glmer_stuff.txt => inst/chunks/glmer_stuff.stan (100%) rename exec/glmer_stuff2.txt => inst/chunks/glmer_stuff2.stan (100%) rename exec/hyperparameters.txt => inst/chunks/hyperparameters.stan (100%) rename exec/license.txt => inst/chunks/license.stan (100%) rename exec/make_eta.txt => inst/chunks/make_eta.stan (100%) rename exec/make_eta_bern.txt => inst/chunks/make_eta_bern.stan (100%) rename exec/parameters_glm.txt => inst/chunks/parameters_glm.stan (100%) rename exec/priors_glm.txt => inst/chunks/priors_glm.stan (100%) rename exec/tdata_glm.txt => inst/chunks/tdata_glm.stan (100%) rename exec/tparameters_glm.txt => inst/chunks/tparameters_glm.stan (100%) rename exec/weights_offset.txt => inst/chunks/weights_offset.stan (100%) diff --git a/DESCRIPTION b/DESCRIPTION index 7e0d24a09..8a83c85c0 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,8 +1,8 @@ Package: rstanarm Type: Package Title: Bayesian Applied Regression Modeling via Stan -Version: 2.9.0-2 -Date: 2016-01-09 +Version: 2.9.0-3 +Date: 2016-01-31 Authors@R: c(person("Jonah", "Gabry", email = "jsg2201@columbia.edu", role = "aut"), person("Trustees of", "Columbia University", role = "cph"), person("R Core", "Deveopment Team", role = "cph", diff --git a/R/stanmodels.R b/R/stanmodels.R index d7e57617a..e2e7feaec 100644 --- a/R/stanmodels.R +++ b/R/stanmodels.R @@ -15,18 +15,22 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +# This file is only intended to be used during the installation process MODELS_HOME <- "exec" if (!file.exists(MODELS_HOME)) MODELS_HOME <- sub("R$", "exec", getwd()) -make_stanmodel <- function(f) { # nocov start +stan_files <- dir(MODELS_HOME, pattern = "stan$", full.names = TRUE) +stanmodels <- sapply(stan_files, function(f) { model_cppname <- sub("\\.stan$", "", basename(f)) - stanfit <- rstan::stanc_builder(f) + isystem <- system.file("chunks", package = "rstanarm") + if (!file.exists(file.path(isystem, "common_functions.stan"))) + isystem <- file.path("inst", "chunks") + stanfit <- rstan::stanc_builder(f, isystem) stanfit$model_cpp <- list(model_cppname = stanfit$model_name, model_cppcode = stanfit$cppcode) return(do.call(methods::new, args = c(stanfit[-(1:3)], Class = "stanmodel", mk_cppmodule = function(x) get(paste0("model_", model_cppname))))) -} # nocov end - -stan_files <- dir(MODELS_HOME, pattern = "stan$", full.names = TRUE) -stanmodels <- sapply(stan_files, make_stanmodel) + } +) names(stanmodels) <- sub("\\.stan$", "", basename(names(stanmodels))) +rm(MODELS_HOME) \ No newline at end of file diff --git a/exec/bernoulli.stan b/exec/bernoulli.stan index 3220cafc9..f9c6887f2 100644 --- a/exec/bernoulli.stan +++ b/exec/bernoulli.stan @@ -1,8 +1,8 @@ -#include "license.txt" +#include "license.stan" // GLM for a Bernoulli outcome functions { - #include "common_functions.txt" + #include "common_functions.stan" /** * Apply inverse link function to linear predictor @@ -105,7 +105,7 @@ data { vector[K] xbar; // vector of column-means of rbind(X0, X1) matrix[N[1],K] X0; // centered (by xbar) predictor matrix | y = 0 matrix[N[2],K] X1; // centered (by xbar) predictor matrix | y = 1 - #include "data_glm.txt" + #include "data_glm.stan" // weights int has_weights; // 0 = No, 1 = Yes @@ -117,8 +117,8 @@ data { vector[N[1] * has_offset] offset0; vector[N[2] * has_offset] offset1; - #include "hyperparameters.txt" - #include "glmer_stuff.txt" + #include "hyperparameters.stan" + #include "glmer_stuff.stan" // more glmer stuff int num_non_zero[2]; // number of non-zero elements in the Z matrices @@ -131,15 +131,15 @@ data { } transformed data { int NN; - #include "tdata_glm.txt" + #include "tdata_glm.stan" NN <- N[1] + N[2]; } parameters { real gamma[has_intercept]; - #include "parameters_glm.txt" + #include "parameters_glm.stan" } transformed parameters { - #include "tparameters_glm.txt" + #include "tparameters_glm.stan" if (t > 0) { theta_L <- make_theta_L(len_theta_L, p, 1.0, tau, scale, zeta, rho, z_T); @@ -147,7 +147,7 @@ transformed parameters { } } model { - #include "make_eta_bern.txt" + #include "make_eta_bern.stan" if (has_intercept == 1) { if (link != 4) { eta0 <- gamma[1] + eta0; @@ -170,7 +170,7 @@ model { increment_log_prob(dot_product(weights1, pw_bern(1, eta1, link))); } - #include "priors_glm.txt" + #include "priors_glm.stan" if (t > 0) decov_lp(z_b, z_T, rho, zeta, tau, regularization, delta, shape, t, p); } @@ -184,7 +184,7 @@ generated quantities { { vector[N[1]] pi0; vector[N[2]] pi1; - #include "make_eta_bern.txt" + #include "make_eta_bern.stan" if (has_intercept == 1) { if (link != 4) { eta0 <- gamma[1] + eta0; diff --git a/exec/binomial.stan b/exec/binomial.stan index 0e5222528..2579afe42 100644 --- a/exec/binomial.stan +++ b/exec/binomial.stan @@ -1,8 +1,8 @@ -#include "license.txt" +#include "license.stan" // GLM for a binomial outcome functions { - #include "common_functions.txt" + #include "common_functions.stan" /** * Apply inverse link function to linear predictor @@ -83,24 +83,24 @@ functions { } } data { - #include "NKX.txt" + #include "NKX.stan" int y[N]; // outcome: number of successes int trials[N]; // number of trials - #include "data_glm.txt" - #include "weights_offset.txt" - #include "hyperparameters.txt" - #include "glmer_stuff.txt" - #include "glmer_stuff2.txt" + #include "data_glm.stan" + #include "weights_offset.stan" + #include "hyperparameters.stan" + #include "glmer_stuff.stan" + #include "glmer_stuff2.stan" } transformed data { - #include "tdata_glm.txt" + #include "tdata_glm.stan" } parameters { real gamma[has_intercept]; - #include "parameters_glm.txt" + #include "parameters_glm.stan" } transformed parameters { - #include "tparameters_glm.txt" + #include "tparameters_glm.stan" if (t > 0) { theta_L <- make_theta_L(len_theta_L, p, 1.0, tau, scale, zeta, rho, z_T); @@ -108,14 +108,14 @@ transformed parameters { } } model { - #include "make_eta.txt" + #include "make_eta.stan" if (t > 0) eta <- eta + csr_matrix_times_vector(N, q, w, v, u, b); if (has_intercept == 1) { if (link != 4) eta <- eta + gamma[1]; else eta <- gamma[1] + eta - max(eta); } else { - #include "eta_no_intercept.txt" + #include "eta_no_intercept.stan" } // Log-likelihood @@ -126,7 +126,7 @@ model { else if (prior_PD == 0) increment_log_prob(dot_product(weights, pw_binom(y, trials, eta, link))); - #include "priors_glm.txt" + #include "priors_glm.stan" if (t > 0) decov_lp(z_b, z_T, rho, zeta, tau, regularization, delta, shape, t, p); @@ -138,7 +138,7 @@ generated quantities { mean_PPD <- 0; { vector[N] pi; - #include "make_eta.txt" + #include "make_eta.stan" if (t > 0) eta <- eta + csr_matrix_times_vector(N, q, w, v, u, b); if (has_intercept == 1) { if (link != 4) eta <- eta + gamma[1]; @@ -150,7 +150,7 @@ generated quantities { } } else { - #include "eta_no_intercept.txt" + #include "eta_no_intercept.stan" } pi <- linkinv_binom(eta, link); diff --git a/exec/continuous.stan b/exec/continuous.stan index 050ec66e3..797bbba07 100644 --- a/exec/continuous.stan +++ b/exec/continuous.stan @@ -1,8 +1,8 @@ -#include "license.txt" +#include "license.stan" # GLM for a Gaussian, Gamma, or inverse Gaussian outcome functions { - #include "common_functions.txt" + #include "common_functions.stan" /** * Apply inverse link function to linear predictor @@ -202,19 +202,19 @@ functions { } data { - #include "NKX.txt" + #include "NKX.stan" vector[N] y; // continuous outcome - #include "data_glm.txt" - #include "weights_offset.txt" - #include "hyperparameters.txt" - #include "glmer_stuff.txt" - #include "glmer_stuff2.txt" + #include "data_glm.stan" + #include "weights_offset.stan" + #include "hyperparameters.stan" + #include "glmer_stuff.stan" + #include "glmer_stuff2.stan" } transformed data { vector[N * (family == 3)] sqrt_y; vector[N * (family == 3)] log_y; real sum_log_y; - #include "tdata_glm.txt" + #include "tdata_glm.stan" if (family == 1) sum_log_y <- not_a_number(); else if (family == 2) sum_log_y <- sum(log(y)); else { @@ -226,12 +226,12 @@ transformed data { parameters { real gamma[has_intercept]; - #include "parameters_glm.txt" + #include "parameters_glm.stan" real dispersion_unscaled; # interpretation depends on family! } transformed parameters { real dispersion; - #include "tparameters_glm.txt" + #include "tparameters_glm.stan" if (prior_scale_for_dispersion > 0) dispersion <- prior_scale_for_dispersion * dispersion_unscaled; else dispersion <- dispersion_unscaled; @@ -242,14 +242,14 @@ transformed parameters { } } model { - #include "make_eta.txt" + #include "make_eta.stan" if (t > 0) eta <- eta + csr_matrix_times_vector(N, q, w, v, u, b); if (has_intercept == 1) { if (family == 1 || link == 2) eta <- eta + gamma[1]; else eta <- eta - min(eta) + gamma[1]; } else { - #include "eta_no_intercept.txt" + #include "eta_no_intercept.stan" } // Log-likelihood @@ -258,7 +258,7 @@ model { if (link == 1) y ~ normal(eta, dispersion); else if (link == 2) y ~ lognormal(eta, dispersion); else y ~ normal(divide_real_by_vector(1, eta), dispersion); - // divide_real_by_vector() is defined in common_functions.txt + // divide_real_by_vector() is defined in common_functions.stan } else if (family == 2) { y ~ GammaReg(eta, dispersion, link, sum_log_y); @@ -278,7 +278,7 @@ model { // Log-prior for scale if (prior_scale_for_dispersion > 0) dispersion_unscaled ~ cauchy(0, 1); - #include "priors_glm.txt" + #include "priors_glm.stan" if (t > 0) decov_lp(z_b, z_T, rho, zeta, tau, regularization, delta, shape, t, p); } @@ -289,7 +289,7 @@ generated quantities { if (has_intercept == 1) alpha[1] <- gamma[1] - dot_product(xbar, beta); { - #include "make_eta.txt" + #include "make_eta.stan" if (t > 0) eta <- eta + csr_matrix_times_vector(N, q, w, v, u, b); if (has_intercept == 1) { if (family == 1 || link == 2) eta <- eta + gamma[1]; @@ -301,7 +301,7 @@ generated quantities { } } else { - #include "eta_no_intercept.txt" + #include "eta_no_intercept.stan" } if (family == 1) { diff --git a/exec/count.stan b/exec/count.stan index 160651403..19454fd95 100644 --- a/exec/count.stan +++ b/exec/count.stan @@ -1,8 +1,8 @@ -#include "license.txt" +#include "license.stan" // GLM for a count outcome functions { - #include "common_functions.txt" + #include "common_functions.stan" vector linkinv_count(vector eta, int link) { vector[rows(eta)] phi; @@ -57,28 +57,28 @@ functions { } } data { - #include "NKX.txt" + #include "NKX.stan" int y[N]; // count outcome - #include "data_glm.txt" - #include "weights_offset.txt" - #include "hyperparameters.txt" - #include "glmer_stuff.txt" - #include "glmer_stuff2.txt" + #include "data_glm.stan" + #include "weights_offset.stan" + #include "hyperparameters.stan" + #include "glmer_stuff.stan" + #include "glmer_stuff2.stan" } transformed data{ real poisson_max; - #include "tdata_glm.txt" + #include "tdata_glm.stan" poisson_max <- pow(2.0, 30.0); } parameters { real gamma[has_intercept]; - #include "parameters_glm.txt" + #include "parameters_glm.stan" real dispersion_unscaled[family > 1]; vector[N] noise[family == 3]; // do not store this } transformed parameters { real dispersion[family > 1]; - #include "tparameters_glm.txt" + #include "tparameters_glm.stan" if (family > 1 && prior_scale_for_dispersion > 0) dispersion[1] <- prior_scale_for_dispersion * dispersion_unscaled[1]; else if (family > 1) dispersion[1] <- dispersion_unscaled[1]; @@ -93,14 +93,14 @@ transformed parameters { } } model { - #include "make_eta.txt" + #include "make_eta.stan" if (t > 0) eta <- eta + csr_matrix_times_vector(N, q, w, v, u, b); if (has_intercept == 1) { if (link == 1) eta <- eta + gamma[1]; else eta <- eta - min(eta) + gamma[1]; } else { - #include "eta_no_intercept.txt" + #include "eta_no_intercept.stan" } if (family == 3) { @@ -129,7 +129,7 @@ model { if (family > 1 && prior_scale_for_dispersion > 0) dispersion_unscaled ~ cauchy(0, 1); - #include "priors_glm.txt" + #include "priors_glm.stan" // Log-prior for noise if (family == 3) noise[1] ~ gamma(dispersion[1], 1); @@ -144,7 +144,7 @@ generated quantities { mean_PPD <- 0; { vector[N] nu; - #include "make_eta.txt" + #include "make_eta.stan" if (t > 0) eta <- eta + csr_matrix_times_vector(N, q, w, v, u, b); if (has_intercept == 1) { if (link == 1) eta <- eta + gamma[1]; @@ -156,7 +156,7 @@ generated quantities { } } else { - #include "eta_no_intercept.txt" + #include "eta_no_intercept.stan" } if (family == 3) { diff --git a/exec/lm.stan b/exec/lm.stan index cb7326a65..fd474bbc5 100644 --- a/exec/lm.stan +++ b/exec/lm.stan @@ -1,4 +1,4 @@ -#include "license.txt" +#include "license.stan" // GLM for a Gaussian outcome with no link function functions { diff --git a/exec/polr.stan b/exec/polr.stan index 70f070419..0e1b008d8 100644 --- a/exec/polr.stan +++ b/exec/polr.stan @@ -1,4 +1,4 @@ -#include "license.txt" +#include "license.stan" // GLM for an ordinal outcome with coherent priors functions { @@ -134,11 +134,11 @@ functions { } } data { - #include "NKX.txt" + #include "NKX.stan" int J; // number of outcome categories, which typically is > 2 int y[N]; // ordinal outcome - #include "data_glm.txt" - #include "weights_offset.txt" + #include "data_glm.stan" + #include "weights_offset.stan" # hyperparameter values real regularization; @@ -176,7 +176,7 @@ transformed parameters { } } model { - #include "make_eta.txt" + #include "make_eta.stan" if (has_weights == 0 && prior_PD == 0) { // unweighted log-likelihoods if (is_skewed == 0) increment_log_prob(pw_polr(y, eta, cutpoints, link, 1.0)); @@ -203,7 +203,7 @@ generated quantities { if (J == 2) zeta <- -zeta; mean_PPD <- rep_vector(0,rows(mean_PPD)); { - #include "make_eta.txt" + #include "make_eta.stan" for (n in 1:N) { vector[J] theta; int y_tilde; diff --git a/exec/NKX.txt b/inst/chunks/NKX.stan similarity index 100% rename from exec/NKX.txt rename to inst/chunks/NKX.stan diff --git a/exec/common_functions.txt b/inst/chunks/common_functions.stan similarity index 100% rename from exec/common_functions.txt rename to inst/chunks/common_functions.stan diff --git a/exec/data_glm.txt b/inst/chunks/data_glm.stan similarity index 100% rename from exec/data_glm.txt rename to inst/chunks/data_glm.stan diff --git a/exec/eta_no_intercept.txt b/inst/chunks/eta_no_intercept.stan similarity index 100% rename from exec/eta_no_intercept.txt rename to inst/chunks/eta_no_intercept.stan diff --git a/exec/glmer_stuff.txt b/inst/chunks/glmer_stuff.stan similarity index 100% rename from exec/glmer_stuff.txt rename to inst/chunks/glmer_stuff.stan diff --git a/exec/glmer_stuff2.txt b/inst/chunks/glmer_stuff2.stan similarity index 100% rename from exec/glmer_stuff2.txt rename to inst/chunks/glmer_stuff2.stan diff --git a/exec/hyperparameters.txt b/inst/chunks/hyperparameters.stan similarity index 100% rename from exec/hyperparameters.txt rename to inst/chunks/hyperparameters.stan diff --git a/exec/license.txt b/inst/chunks/license.stan similarity index 100% rename from exec/license.txt rename to inst/chunks/license.stan diff --git a/exec/make_eta.txt b/inst/chunks/make_eta.stan similarity index 100% rename from exec/make_eta.txt rename to inst/chunks/make_eta.stan diff --git a/exec/make_eta_bern.txt b/inst/chunks/make_eta_bern.stan similarity index 100% rename from exec/make_eta_bern.txt rename to inst/chunks/make_eta_bern.stan diff --git a/exec/parameters_glm.txt b/inst/chunks/parameters_glm.stan similarity index 100% rename from exec/parameters_glm.txt rename to inst/chunks/parameters_glm.stan diff --git a/exec/priors_glm.txt b/inst/chunks/priors_glm.stan similarity index 100% rename from exec/priors_glm.txt rename to inst/chunks/priors_glm.stan diff --git a/exec/tdata_glm.txt b/inst/chunks/tdata_glm.stan similarity index 100% rename from exec/tdata_glm.txt rename to inst/chunks/tdata_glm.stan diff --git a/exec/tparameters_glm.txt b/inst/chunks/tparameters_glm.stan similarity index 100% rename from exec/tparameters_glm.txt rename to inst/chunks/tparameters_glm.stan diff --git a/exec/weights_offset.txt b/inst/chunks/weights_offset.stan similarity index 100% rename from exec/weights_offset.txt rename to inst/chunks/weights_offset.stan diff --git a/tests/testthat/test_stan_functions.R b/tests/testthat/test_stan_functions.R index 517bef5ab..a433e1606 100644 --- a/tests/testthat/test_stan_functions.R +++ b/tests/testthat/test_stan_functions.R @@ -18,6 +18,8 @@ # tests can be run using devtools::test() or manually by loading testthat # package and then running the code +set.seed(12345) + MODELS_HOME <- "exec" fsep <- .Platform$file.sep if (!file.exists(MODELS_HOME)) { @@ -34,10 +36,13 @@ if (!file.exists(MODELS_HOME)) { context("setup") test_that("Stan programs are available", { message(MODELS_HOME) - expect_true(file.exists(MODELS_HOME)) + expect_true(file.exists(MODELS_HOME)) + expect_true(file.exists(file.path(system.file("chunks", package = "rstanarm"), + "common_functions.stan"))) + }) -stopifnot(require(rstan)) +library(rstan) Sys.unsetenv("R_TESTS") functions <- sapply(dir(MODELS_HOME, pattern = "stan$", full.names = TRUE), function(f) { @@ -50,8 +55,9 @@ functions <- sapply(dir(MODELS_HOME, pattern = "stan$", full.names = TRUE), func } else return(as.character(NULL)) }) -functions <- c(readLines(file.path(MODELS_HOME, "common_functions.txt")), - unlist(functions)) +print(MODELS_HOME) +functions <- c(readLines(file.path(system.file("chunks", package = "rstanarm"), + "common_functions.stan")), unlist(functions)) model_code <- paste(c("functions {", functions, "}", "model {}"), collapse = "\n") expose_stan_functions(stanc(model_code = model_code, model_name = "Stan Functions")) N <- 99L diff --git a/tools/make_cpp.R b/tools/make_cpp.R index e4435c09e..4a9ea2d0a 100644 --- a/tools/make_cpp.R +++ b/tools/make_cpp.R @@ -14,13 +14,14 @@ # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. - +options(warn = 3L) stan_files <- dir("exec", pattern = "stan$", full.names = TRUE) -cat(readLines(file.path("exec", "license.txt")), +cat(readLines(file.path("inst", "chunks", "license.stan")), "#ifndef MODELS_HPP", "#define MODELS_HPP", "#define STAN__SERVICES__COMMAND_HPP", "#include ", sapply(stan_files, FUN = function(f) { - cppcode <- rstan::stanc_builder(f)$cppcode + cppcode <- rstan::stanc_builder(f, + isystem = file.path("inst", "chunks"))$cppcode cppcode <- gsub("typedef.*stan_model.*;", "", cppcode, perl = TRUE) return(cppcode) }), "#endif", file = file.path("src", "include", "models.hpp"),