diff --git a/nCompiler/R/distributions_implementations.R b/nCompiler/R/distributions_implementations.R deleted file mode 100644 index 5404466a..00000000 --- a/nCompiler/R/distributions_implementations.R +++ /dev/null @@ -1,824 +0,0 @@ -## This file retains a lot of original nimble content that has not been updated. -## -## nCompiler develpment -## Rcpp tries to take over all interfaces even from seeing a .Call in source code -## So for now I am commenting the ones here out - - # additional distributions provided by nCompiler -# in general we use doubles on C side so convert parameters to doubles here before passing to C - -#' The Wishart Distribution -#' -#' Density and random generation for the Wishart distribution, using the Cholesky factor of either the scale matrix or the rate matrix. -#' -#' @name Wishart -#' @aliases wishart -#' -#' @param x vector of values. -#' @param n number of observations (only \code{n=1} is handled currently). -#' @param cholesky upper-triangular Cholesky factor of either the scale matrix (when \code{scale_param} is TRUE) or rate matrix (otherwise). -#' @param df degrees of freedom. -#' @param scale_param logical; if TRUE the Cholesky factor is that of the scale matrix; otherwise, of the rate matrix. -#' @param log logical; if TRUE, probability density is returned on the log scale. -#' @author Christopher Paciorek -#' @details See Gelman et al., Appendix A or the BUGS manual for mathematical details. The rate matrix as used here is defined as the inverse of the scale matrix, \eqn{S^{-1}}, given in Gelman et al. -#' @return \code{dwish_chol} gives the density and \code{rwish_chol} generates random deviates. -#' @references Gelman, A., Carlin, J.B., Stern, H.S., and Rubin, D.B. (2004) \emph{Bayesian Data Analysis}, 2nd ed. Chapman and Hall/CRC. -#' @seealso \link{Distributions} for other standard distributions -#' -#' @examples -#' df <- 40 -#' ch <- chol(matrix(c(1, .7, .7, 1), 2)) -#' x <- rwish_chol(1, ch, df = df) -#' dwish_chol(x, ch, df = df) -#' -NULL - -#' @rdname Wishart -#' @export -dwish_chol <- function(x, cholesky, df, scale_param = TRUE, log = FALSE) { - # scale_param = TRUE is the GCSR parameterization (i.e., scale matrix); scale_param = FALSE is the BUGS parameterization (i.e., rate matrix) - if(storage.mode(cholesky) != 'double') - storage.mode(cholesky) <- 'double' - if(storage.mode(x) != 'double') - storage.mode(x) <- 'double' - stop('Actual .Call commented out while working on Rcpp compileAttributs() system') - ##.Call(C_dwish_chol, x, cholesky, as.double(df), as.double(scale_param), as.logical(log)) -} - -#' @rdname Wishart -#' @export -rwish_chol <- function(n = 1, cholesky, df, scale_param = TRUE) { - if(n != 1) warning('rwish_chol only handles n = 1 at the moment') - if(storage.mode(cholesky) != 'double') - storage.mode(cholesky) <- 'double' - stop('Actual .Call commented out while working on Rcpp compileAttributs() system') - ##out <- .Call(C_rwish_chol, cholesky, as.double(df), as.double(scale_param)) - if(!is.null(out)) out <- matrix(out, nrow = sqrt(length(cholesky))) - return(out) -} - -#' The Inverse Wishart Distribution -#' -#' Density and random generation for the Inverse Wishart distribution, using the Cholesky factor of either the scale matrix or the rate matrix. -#' -#' @name Inverse-Wishart -#' @aliases inverse-wishart -#' -#' @param x vector of values. -#' @param n number of observations (only \code{n=1} is handled currently). -#' @param cholesky upper-triangular Cholesky factor of either the scale matrix (when \code{scale_param} is TRUE) or rate matrix (otherwise). -#' @param df degrees of freedom. -#' @param scale_param logical; if TRUE the Cholesky factor is that of the scale matrix; otherwise, of the rate matrix. -#' @param log logical; if TRUE, probability density is returned on the log scale. -#' @author Christopher Paciorek -#' @details See Gelman et al., Appendix A for mathematical details. The rate matrix as used here is defined as the inverse of the scale matrix, \eqn{S^{-1}}, given in Gelman et al. -#' @return \code{dinvwish_chol} gives the density and \code{rinvwish_chol} generates random deviates. -#' @references Gelman, A., Carlin, J.B., Stern, H.S., and Rubin, D.B. (2004) \emph{Bayesian Data Analysis}, 2nd ed. Chapman and Hall/CRC. -#' @seealso \link{Distributions} for other standard distributions -#' -#' @examples -#' df <- 40 -#' ch <- chol(matrix(c(1, .7, .7, 1), 2)) -#' x <- rwish_chol(1, ch, df = df) -#' dwish_chol(x, ch, df = df) -#' -NULL - -#' @rdname Inverse-Wishart -#' @export -dinvwish_chol <- function(x, cholesky, df, scale_param = TRUE, log = FALSE) { - # scale_param = FALSE is the GCSR parameterization (i.e., inverse scale matrix); scale_param = TRUE is the parameterization best for conjugacy calculations (i.e., scale matrix) - if(storage.mode(cholesky) != 'double') - storage.mode(cholesky) <- 'double' - if(storage.mode(x) != 'double') - storage.mode(x) <- 'double' - stop('Actual .Call commented out while working on Rcpp compileAttributs() system') - ##.Call(C_dinvwish_chol, x, cholesky, as.double(df), as.double(scale_param), as.logical(log)) -} - -#' @rdname Inverse-Wishart -#' @export -rinvwish_chol <- function(n = 1, cholesky, df, scale_param = TRUE) { - if(n != 1) warning('rinvwish_chol only handles n = 1 at the moment') - if(storage.mode(cholesky) != 'double') - storage.mode(cholesky) <- 'double' - stop('Actual .Call commented out while working on Rcpp compileAttributs() system') - ##out <- .Call(C_rinvwish_chol, cholesky, as.double(df), as.double(scale_param)) - if(!is.null(out)) out <- matrix(out, nrow = sqrt(length(cholesky))) - return(out) -} - - -#' The Improper Uniform Distribution -#' -#' Improper flat distribution for use as a prior distribution in BUGS models -#' -#' @name flat -#' @aliases halfflat -#' -#' @param x vector of values. -#' @param n number of observations. -#' @param log logical; if TRUE, probability density is returned on the log scale. -#' -#' @author Christopher Paciorek -#' @return \code{dflat} gives the pseudo-density value of 1, while \code{rflat} and \code{rhalfflat} return \code{NaN}, -#' since one cannot simulate from an improper distribution. Similarly, \code{dhalfflat} -#' gives a pseudo-density value of 1 when \code{x} is non-negative. -#' @seealso \link{Distributions} for other standard distributions -#' -#' @examples -#' dflat(1) -NULL - -#' @rdname flat -#' @export -dflat <- function(x, log = FALSE) { - if(log) out <- rep(0, length(x)) else out <- rep(1, length(x)) - nas <- is.na(x) - out[nas] <- x[nas] - return(out) -} - -#' @rdname flat -#' @export -rflat <- function(n = 1) { - return(rep(NaN, n)) -} - -#' @rdname flat -#' @export -dhalfflat <- function(x, log = FALSE) { - out <- rep(0, length(x)) - out[x < 0] <- -Inf - nas <- is.na(x) - out[nas] <- x[nas] - if(log) return(out) else return(exp(out)) -} - -#' @rdname flat -#' @export -rhalfflat <- function(n = 1) { - return(rep(NaN, n)) -} - -#' The Dirichlet Distribution -#' -#' Density and random generation for the Dirichlet distribution -#' -#' @name Dirichlet -#' @aliases dirichlet -#' -#' @param x vector of values. -#' @param n number of observations (only \code{n=1} is handled currently). -#' @param alpha vector of parameters of same length as \code{x} -#' @param log logical; if TRUE, probability density is returned on the log scale. -#' @author Christopher Paciorek -#' @details See Gelman et al., Appendix A or the BUGS manual for mathematical details. -#' @return \code{ddirch} gives the density and \code{rdirch} generates random deviates. -#' @references Gelman, A., Carlin, J.B., Stern, H.S., and Rubin, D.B. (2004) \emph{Bayesian Data Analysis}, 2nd ed. Chapman and Hall/CRC. -#' @seealso \link{Distributions} for other standard distributions -#' -#' @examples -#' alpha <- c(1, 10, 30) -#' x <- rdirch(1, alpha) -#' ddirch(x, alpha) -NULL - -#' @rdname Dirichlet -#' @export -ddirch <- function(x, alpha, log = FALSE) { - stop('Actual .Call commented out while working on Rcpp compileAttributs() system') - ##.Call(C_ddirch, as.double(x), as.double(alpha), as.logical(log)) -} - -#' @rdname Dirichlet -#' @export -rdirch <- function(n = 1, alpha) { - if(n != 1) warning('rdirch only handles n = 1 at the moment') - stop('Actual .Call commented out while working on Rcpp compileAttributs() system') - ##.Call(C_rdirch, as.double(alpha)) -} - -#' The Multinomial Distribution -#' -#' Density and random generation for the multinomial distribution -#' -#' @name Multinomial -#' @aliases multinomial -#' -#' @param x vector of values. -#' @param n number of observations (only \code{n=1} is handled currently). -#' @param size number of trials. -#' @param prob vector of probabilities, internally normalized to sum to one, of same length as \code{x} -#' @param log logical; if TRUE, probability density is returned on the log scale. -#' @author Christopher Paciorek -#' @details See Gelman et al., Appendix A or the BUGS manual for mathematical details. -#' @return \code{dmulti} gives the density and \code{rmulti} generates random deviates. -#' @references Gelman, A., Carlin, J.B., Stern, H.S., and Rubin, D.B. (2004) \emph{Bayesian Data Analysis}, 2nd ed. Chapman and Hall/CRC. -#' @seealso \link{Distributions} for other standard distributions -#' -#' @examples -#' size <- 30 -#' probs <- c(1/4, 1/10, 1 - 1/4 - 1/10) -#' x <- rmulti(1, size, probs) -#' dmulti(x, size, probs) -NULL - -#' @rdname Multinomial -#' @export -dmulti <- function(x, size = sum(x), prob, log = FALSE) { - stop('Actual .Call commented out while working on Rcpp compileAttributs() system') - ##.Call(C_dmulti, as.double(x), as.double(size), as.double(prob), as.logical(log)) -} - -#' @rdname Multinomial -#' @export -rmulti <- function(n = 1, size, prob) { - if(n != 1) warning('rmulti only handles n = 1 at the moment') - stop('Actual .Call commented out while working on Rcpp compileAttributs() system') - ##.Call(C_rmulti, as.double(size), as.double(prob)) -} - -#' The Categorical Distribution -#' -#' Density and random generation for the categorical distribution -#' -#' @name Categorical -#' -#' @param x non-negative integer-value numeric value. -#' @param n number of observations. -#' @param prob vector of probabilities, internally normalized to sum to one. -#' @param log logical; if TRUE, probability density is returned on the log scale. -#' @author Christopher Paciorek -#' @details See the BUGS manual for mathematical details. -#' @return \code{dcat} gives the density and \code{rcat} generates random deviates. -##' @seealso \link{Distributions} for other standard distributions -#' -#' @examples -#' probs <- c(1/4, 1/10, 1 - 1/4 - 1/10) -#' x <- rcat(n = 30, probs) -#' dcat(x, probs) -#' -NULL - -#' @rdname Categorical -#' @export -dcat <- function(x, prob, log = FALSE) { - stop('Actual .Call commented out while working on Rcpp compileAttributs() system') - ##.Call(C_dcat, as.double(x), as.double(prob), as.logical(log)) -} - -#' @rdname Categorical -#' @export -rcat <- function(n = 1, prob) { - stop('Actual .Call commented out while working on Rcpp compileAttributs() system') - ##.Call(C_rcat, as.integer(n), as.double(prob)) -} - - -#' The t Distribution -#' -#' Density, distribution function, quantile function and random generation -#' for the t distribution with \code{df} degrees of freedom, -#' allowing non-zero location, \code{mu}, -#' and non-unit scale, \code{sigma} -#' -#' @name t -#' -#' @param x vector of values. -#' @param n number of observations. -#' @param df vector of degrees of freedom values. -#' @param p vector of probabilities. -#' @param q vector of quantiles. -#' @param mu vector of location values. -#' @param sigma vector of scale values. -#' @param log logical; if TRUE, probability density is returned on the log scale. -#' @param log.p logical; if TRUE, probabilities p are given by user as log(p). -#' @param lower.tail logical; if TRUE (default) probabilities are \eqn{P[X \le x]}; otherwise, \eqn{P[X > x]}. -#' @author Christopher Paciorek -#' @details See Gelman et al., Appendix A or the BUGS manual for mathematical details. -#' @return \code{dt_nonstandard} gives the density, \code{pt_nonstandard} gives the distribution -#' function, \code{qt_nonstandard} gives the quantile function, and \code{rt_nonstandard} -#' generates random deviates. -#' @references Gelman, A., Carlin, J.B., Stern, H.S., and Rubin, D.B. (2004) \emph{Bayesian Data Analysis}, 2nd ed. Chapman and Hall/CRC. -#' @seealso \link{Distributions} for other standard distributions -#' -#' @examples -#' x <- rt_nonstandard(50, df = 1, mu = 5, sigma = 1) -#' dt_nonstandard(x, 3, 5, 1) -NULL - -#' @rdname t -#' @export -dt_nonstandard <- function(x, df = 1, mu = 0, sigma = 1, log = FALSE) { - stop('Actual .Call commented out while working on Rcpp compileAttributs() system') - ##.Call(C_dt_nonstandard, as.double(x), as.double(df), as.double(mu), as.double(sigma), as.logical(log)) -} - -#' @rdname t -#' @export -rt_nonstandard <- function(n, df = 1, mu = 0, sigma = 1) { - stop('Actual .Call commented out while working on Rcpp compileAttributs() system') - ##.Call(C_rt_nonstandard, as.integer(n), as.double(df), as.double(mu), as.double(sigma)) -} - -#' @rdname t -#' @export -pt_nonstandard <- function(q, df = 1, mu = 0, sigma = 1, lower.tail = TRUE, log.p = FALSE) { - stop('Actual .Call commented out while working on Rcpp compileAttributs() system') - ##.Call(C_pt_nonstandard, as.double(q), as.double(df), as.double(mu), as.double(sigma), as.logical(lower.tail), as.logical(log.p)) -} - -#' @rdname t -#' @export -qt_nonstandard <- function(p, df = 1, mu = 0, sigma = 1, lower.tail = TRUE, log.p = FALSE) { - stop('Actual .Call commented out while working on Rcpp compileAttributs() system') - ##.Call(C_qt_nonstandard, as.double(p), as.double(df), as.double(mu), as.double(sigma), as.logical(lower.tail), as.logical(log.p)) -} - -#' The Multivariate Normal Distribution -#' -#' Density and random generation for the multivariate normal distribution, using the Cholesky factor of either the precision matrix or the covariance matrix. -#' -#' @name MultivariateNormal -#' -#' @param x vector of values. -#' @param n number of observations (only \code{n=1} is handled currently). -#' @param mean vector of values giving the mean of the distribution. -#' @param cholesky upper-triangular Cholesky factor of either the precision matrix (when \code{prec_param} is TRUE) or covariance matrix (otherwise). -#' @param prec_param logical; if TRUE the Cholesky factor is that of the precision matrix; otherwise, of the covariance matrix. -#' @param log logical; if TRUE, probability density is returned on the log scale. -#' @author Christopher Paciorek -#' @details See Gelman et al., Appendix A or the BUGS manual for mathematical details. The rate matrix as used here is defined as the inverse of the scale matrix, \eqn{S^{-1}}, given in Gelman et al. -#' @return \code{dmnorm_chol} gives the density and \code{rmnorm_chol} generates random deviates. -#' @references Gelman, A., Carlin, J.B., Stern, H.S., and Rubin, D.B. (2004) \emph{Bayesian Data Analysis}, 2nd ed. Chapman and Hall/CRC. -#' @seealso \link{Distributions} for other standard distributions -#' -#' @examples -#' mean <- c(-10, 0, 10) -#' covmat <- matrix(c(1, .9, .3, .9, 1, -0.1, .3, -0.1, 1), 3) -#' ch <- chol(covmat) -#' x <- rmnorm_chol(1, mean, ch, prec_param = FALSE) -#' dmnorm_chol(x, mean, ch, prec_param = FALSE) -NULL - -#' @rdname MultivariateNormal -#' @export -dmnorm_chol <- function(x, mean, cholesky, prec_param = TRUE, log = FALSE) { - # cholesky should be upper triangular - # FIXME: allow cholesky to be lower tri - if(storage.mode(cholesky) != 'double') - storage.mode(cholesky) <- 'double' - stop('Actual .Call commented out while working on Rcpp compileAttributs() system') - ##.Call(C_dmnorm_chol, as.double(x), as.double(mean), cholesky, as.double(prec_param), as.logical(log)) -} - -#' @rdname MultivariateNormal -#' @export -rmnorm_chol <- function(n = 1, mean, cholesky, prec_param = TRUE) { - ## cholesky should be upper triangular - ## FIXME: allow cholesky to be lower tri - if(n != 1) warning('rmnorm_chol only handles n = 1 at the moment') - if(storage.mode(cholesky) != 'double') - storage.mode(cholesky) <- 'double' - stop('Actual .Call commented out while working on Rcpp compileAttributs() system') - ##.Call(C_rmnorm_chol, as.double(mean), cholesky, as.double(prec_param)) -} - -#' The Multivariate t Distribution -#' -#' Density and random generation for the multivariate t distribution, using the Cholesky factor of either the precision matrix (i.e., inverse scale matrix) or the scale matrix. -#' -#' @name Multivariate-t -#' -#' @aliases mvt multivariate-t -#' -#' @param x vector of values. -#' @param n number of observations (only \code{n=1} is handled currently). -#' @param mu vector of values giving the location of the distribution. -#' @param cholesky upper-triangular Cholesky factor of either the precision matrix (i.e., inverse scale matrix) (when \code{prec_param} is TRUE) or scale matrix (otherwise). -#' @param df degrees of freedom. -#' @param prec_param logical; if TRUE the Cholesky factor is that of the precision matrix; otherwise, of the scale matrix. -#' @param log logical; if TRUE, probability density is returned on the log scale. -#' @author Peter Sujan -#' @details See Gelman et al., Appendix A or the BUGS manual for mathematical details. The 'precision' matrix as used here is defined as the inverse of the scale matrix, \eqn{\Sigma^{-1}}, given in Gelman et al. -#' @return \code{dmvt_chol} gives the density and \code{rmvt_chol} generates random deviates. -#' @references Gelman, A., Carlin, J.B., Stern, H.S., and Rubin, D.B. (2004) \emph{Bayesian Data Analysis}, 2nd ed. Chapman and Hall/CRC. -#' @seealso \link{Distributions} for other standard distributions -#' -#' @examples -#' mu <- c(-10, 0, 10) -#' scalemat <- matrix(c(1, .9, .3, .9, 1, -0.1, .3, -0.1, 1), 3) -#' ch <- chol(scalemat) -#' x <- rmvt_chol(1, mu, ch, df = 1, prec_param = FALSE) -#' dmvt_chol(x, mu, ch, df = 1, prec_param = FALSE) -#' -NULL - -#' @rdname Multivariate-t -#' @export -dmvt_chol <- function(x, mu, cholesky, df, prec_param = TRUE, log = FALSE) { - # cholesky should be upper triangular - # FIXME: allow cholesky to be lower tri - if(storage.mode(cholesky) != 'double') - storage.mode(cholesky) <- 'double' - stop('Actual .Call commented out while working on Rcpp compileAttributs() system') - ##.Call(C_dmvt_chol, as.double(x), as.double(mu), cholesky, - ## as.double(df), as.double(prec_param), as.logical(log)) -} - -#' @rdname Multivariate-t -#' @export -rmvt_chol <- function(n = 1, mu, cholesky, df, prec_param = TRUE) { - ## cholesky should be upper triangular - ## FIXME: allow cholesky to be lower tri - if(n != 1) warning('rmvt_chol only handles n = 1 at the moment') - if(storage.mode(cholesky) != 'double') - storage.mode(cholesky) <- 'double' - stop('Actual .Call commented out while working on Rcpp compileAttributs() system') - ##.Call(C_rmvt_chol, as.double(mu), cholesky, - ## as.double(df), as.double(prec_param)) -} - -#' Interval calculations -#' -#' Calculations to handle censoring -#' -#' @name Interval -#' -#' @param x vector of interval indices. -#' @param n number of observations. -#' @param t vector of values. -#' @param c vector of one or more values delineating the intervals. -#' @param log logical; if TRUE, probability density is returned on the log scale. -#' @author Christopher Paciorek -#' @details Used for working with censoring in BUGS code. -#' Taking \code{c} to define the endpoints of two or more intervals (with implicit endpoints of plus/minus infinity), \code{x} (or the return value of \code{rinterval}) gives the non-negative integer valued index of the interval in which \code{t} falls. See the nCompiler manual for additional details. -#' @return \code{dinterval} gives the density and \code{rinterval} generates random deviates, -#' but these are unusual as the density is 1 if \code{x} indicates the interval in which \code{t} -#' falls and 0 otherwise and the deviates are simply the interval(s) in which \code{t} falls. -##' @seealso \link{Distributions} for other standard distributions -#' -#' @examples -#' endpoints <- c(-3, 0, 3) -#' vals <- c(-4, -1, 1, 5) -#' x <- rinterval(4, vals, endpoints) -#' dinterval(x, vals, endpoints) -#' dinterval(c(1, 5, 2, 3), vals, endpoints) -NULL - - -#' @rdname Interval -#' @export -dinterval <- function(x, t, c, log = FALSE) { - stop('Actual .Call commented out while working on Rcpp compileAttributs() system') - ##.Call(C_dinterval, as.double(x), as.double(t), as.double(c), as.logical(log)) -} - -#' @rdname Interval -#' @export -rinterval <- function(n = 1, t, c) { - stop('Actual .Call commented out while working on Rcpp compileAttributs() system') - ##.Call(C_rinterval, as.integer(n), as.double(t), as.double(c)) -} - -#' Constraint calculations in nCompiler -#' -#' Calculations to handle censoring -#' -#' @name Constraint -#' -#' @param x value indicating whether \code{cond} is TRUE or FALSE -#' @param n number of observations (only \code{n=1} is handled currently). -#' @param cond logical value -#' @param log logical; if TRUE, probability density is returned on the log scale. -#' @author Christopher Paciorek -#' @details Used for working with constraints in BUGS code. -#' See the nCompiler manual for additional details. -#' @return \code{dconstraint} gives the density and \code{rconstraint} generates random deviates, -#' but these are unusual as the density is 1 if \code{x} matches \code{cond} and -#' 0 otherwise and the deviates are simply the value of \code{cond} -##' @seealso \link{Distributions} for other standard distributions -#' -#' @examples -#' constr <- 3 > 2 && 4 > 0 -#' x <- rconstraint(1, constr) -#' dconstraint(x, constr) -#' dconstraint(0, 3 > 4) -#' dconstraint(1, 3 > 4) -#' rconstraint(1, 3 > 4) -NULL - -#' @rdname Constraint -#' @export -dconstraint <- function(x, cond, log = FALSE) { - if(length(x) > 1 || length(cond) > 1) stop('dconstraint is not vectorized') - if(is.na(x) || is.na(cond)) return(x + cond) # mimic how R's C functions handle NA and NaN inputs - if(x == cond || x == 0) result <- 1 else result <- 0 - if(log) return(log(result)) else return(result) -} - -#' @rdname Constraint -#' @export -rconstraint <- function(n = 1, cond) { - if(n != 1 || length(cond) > 1) stop('rconstraint only handles n = 1 at the moment') - if(is.na(cond)) { - warning("NAs produced") - return(NaN) - } - return(as.integer(cond)) -} - -# exp_nimble extends R to allow rate or scale and provide common interface via 'rate' to C functions - -#' The Exponential Distribution -#' -#' Density, distribution function, quantile function and random -#' generation for the exponential distribution with rate -#' (i.e., mean of \code{1/rate}) or scale parameterizations. -#' -#' @name Exponential -#' -#' @param x vector of values. -#' @param n number of observations. -#' @param p vector of probabilities. -#' @param q vector of quantiles. -#' @param rate vector of rate values. -#' @param scale vector of scale values. -#' @param log logical; if TRUE, probability density is returned on the log scale. -#' @param log.p logical; if TRUE, probabilities p are given by user as log(p). -#' @param lower.tail logical; if TRUE (default) probabilities are \eqn{P[X \le x]}; otherwise, \eqn{P[X > x]}. -#' @author Christopher Paciorek -#' @details nimble's exponential distribution functions use Rmath's functions -#' under the hood, but are parameterized to take both rate and scale and to -#' use 'rate' as the core parameterization in C, unlike Rmath, which uses 'scale'. -#' See Gelman et al., Appendix A or -#' the BUGS manual for mathematical details. -#' @return \code{dexp_nimble} gives the density, \code{pexp_nimble} gives the distribution -#' function, \code{qexp_nimble} gives the quantile function, and \code{rexp_nimble} -#' generates random deviates. -#' @references Gelman, A., Carlin, J.B., Stern, H.S., and Rubin, D.B. (2004) \emph{Bayesian Data Analysis}, 2nd ed. Chapman and Hall/CRC. -#' @seealso \link{Distributions} for other standard distributions -#' -#' @examples -#' x <- rexp_nimble(50, scale = 3) -#' dexp_nimble(x, scale = 3) -NULL - - -#' @rdname Exponential -#' @export -dexp_nimble <- function(x, rate = 1/scale, scale = 1, log = FALSE) { - if (!missing(rate) && !missing(scale)) { - if (abs(rate * scale - 1) < 1e-15) - warning("specify 'rate' or 'scale' but not both") - else stop("specify 'rate' or 'scale' but not both") - } - stop('Actual .Call commented out while working on Rcpp compileAttributs() system') - ##.Call(C_dexp_nimble, as.double(x), as.double(rate), as.logical(log)) -} - -#' @rdname Exponential -#' @export -rexp_nimble <- function(n = 1, rate = 1/scale, scale = 1) { - if (!missing(rate) && !missing(scale)) { - if (abs(rate * scale - 1) < 1e-15) - warning("specify 'rate' or 'scale' but not both") - else stop("specify 'rate' or 'scale' but not both") - } - stop('Actual .Call commented out while working on Rcpp compileAttributs() system') - ##.Call(C_rexp_nimble, as.integer(n), as.double(rate)) -} - -#' @rdname Exponential -#' @export -pexp_nimble <- function(q, rate = 1/scale, scale = 1, lower.tail = TRUE, log.p = FALSE) { - if (!missing(rate) && !missing(scale)) { - if (abs(rate * scale - 1) < 1e-15) - warning("specify 'rate' or 'scale' but not both") - else stop("specify 'rate' or 'scale' but not both") - } - stop('Actual .Call commented out while working on Rcpp compileAttributs() system') - ##.Call(C_pexp_nimble, as.double(q), as.double(rate), as.logical(lower.tail), as.logical(log.p)) -} - -#' @rdname Exponential -#' @export -qexp_nimble <- function(p, rate = 1/scale, scale = 1, lower.tail = TRUE, log.p = FALSE) { - if (!missing(rate) && !missing(scale)) { - if (abs(rate * scale - 1) < 1e-15) - warning("specify 'rate' or 'scale' but not both") - else stop("specify 'rate' or 'scale' but not both") - } - stop('Actual .Call commented out while working on Rcpp compileAttributs() system') - ##.Call(C_qexp_nimble, as.double(p), as.double(rate), as.logical(lower.tail), as.logical(log.p)) -} - -#' The Inverse Gamma Distribution -#' -#' Density, distribution function, quantile function and random -#' generation for the inverse gamma distribution with rate -#' or scale (mean = scale / (shape - 1)) parameterizations. -#' -#' @name Inverse-Gamma -#' -#' @param x vector of values. -#' @param n number of observations. -#' @param p vector of probabilities. -#' @param q vector of quantiles. -#' @param shape vector of shape values, must be positive. -#' @param rate vector of rate values, must be positive. -#' @param scale vector of scale values, must be positive. -#' @param log logical; if TRUE, probability density is returned on the log scale. -#' @param log.p logical; if TRUE, probabilities p are given by user as log(p). -#' @param lower.tail logical; if TRUE (default) probabilities are \eqn{P[X \le x]}; otherwise, \eqn{P[X > x]}. -#' @author Christopher Paciorek -#' @details The inverse gamma distribution with parameters \code{shape} \eqn{=\alpha}{= a} and -#' \code{scale} \eqn{=\sigma}{= s} has density -#' \deqn{ -#' f(x)= \frac{s^a}{\Gamma(\alpha)} {x}^{-(\alpha+1)} e^{-\sigma/x}% -#' }{f(x)= (s^a / Gamma(a)) x^-(a+1) e^-(s/x)} -#' for \eqn{x \ge 0}, \eqn{\alpha > 0}{a > 0} and \eqn{\sigma > 0}{s > 0}. -#' (Here \eqn{\Gamma(\alpha)}{Gamma(a)} is the function implemented by \R's -#' \link{gamma}) and defined in its help. -#' -#' The mean and variance are -#' \eqn{E(X) = \frac{\sigma}{\alpha}-1}{E(X) = s/(a-1)} and -#' \eqn{Var(X) = \frac{\sigma^2}{(\alpha-1)^2 (\alpha-2)}}{Var(X) = s^2 / ((a-1)^2 * (a-2))}, -#' with the mean defined only -#' for \eqn{\alpha > 1}{a > 1} and the variance only for \eqn{\alpha > 2}{a > 2}. -#' -#' See Gelman et al., Appendix A or -#' the BUGS manual for mathematical details. -#' @return \code{dinvgamma} gives the density, \code{pinvgamma} gives the distribution -#' function, \code{qinvgamma} gives the quantile function, and \code{rinvgamma} -#' generates random deviates. -#' @references Gelman, A., Carlin, J.B., Stern, H.S., and Rubin, D.B. (2004) \emph{Bayesian Data Analysis}, 2nd ed. Chapman and Hall/CRC. -#' @seealso \link{Distributions} for other standard distributions -#' -#' @examples -#' x <- rinvgamma(50, shape = 1, scale = 3) -#' dinvgamma(x, shape = 1, scale = 3) -NULL - - -#' @rdname Inverse-Gamma -#' @export -dinvgamma <- function(x, shape, scale = 1, rate = 1/scale, log = FALSE) { - if (!missing(rate) && !missing(scale)) { - if (abs(rate * scale - 1) < 1e-15) - warning("specify 'rate' or 'scale' but not both") - else stop("specify 'rate' or 'scale' but not both") - } - stop('Actual .Call commented out while working on Rcpp compileAttributs() system') - ##.Call(C_dinvgamma, as.double(x), as.double(shape), as.double(rate), as.logical(log)) -} - -#' @rdname Inverse-Gamma -#' @export -rinvgamma <- function(n = 1, shape, scale = 1, rate = 1/scale) { - if (!missing(rate) && !missing(scale)) { - if (abs(rate * scale - 1) < 1e-15) - warning("specify 'rate' or 'scale' but not both") - else stop("specify 'rate' or 'scale' but not both") - } - stop('Actual .Call commented out while working on Rcpp compileAttributs() system') - ##.Call(C_rinvgamma, as.integer(n), as.double(shape), as.double(rate)) -} - - -#' @rdname Inverse-Gamma -#' @export -pinvgamma <- function(q, shape, scale = 1, rate = 1/scale, lower.tail = TRUE, log.p = FALSE) { - if (!missing(rate) && !missing(scale)) { - if (abs(rate * scale - 1) < 1e-15) - warning("specify 'rate' or 'scale' but not both") - else stop("specify 'rate' or 'scale' but not both") - } - stop('Actual .Call commented out while working on Rcpp compileAttributs() system') - ##.Call(C_pinvgamma, as.double(q), as.double(shape), as.double(rate), as.logical(lower.tail), as.logical(log.p)) -} - -#' @rdname Inverse-Gamma -#' @export -qinvgamma <- function(p, shape, scale = 1, rate = 1/scale, lower.tail = TRUE, log.p = FALSE) { - if (!missing(rate) && !missing(scale)) { - if (abs(rate * scale - 1) < 1e-15) - warning("specify 'rate' or 'scale' but not both") - else stop("specify 'rate' or 'scale' but not both") - } - stop('Actual .Call commented out while working on Rcpp compileAttributs() system') - ##.Call(C_qinvgamma, as.double(p), as.double(shape), as.double(rate), as.logical(lower.tail), as.logical(log.p)) -} - -# sqrtinvgamma is intended solely for use in conjugacy with dhalfflat -#' @export -dsqrtinvgamma <- function(x, shape, scale = 1, rate = 1/scale, log = FALSE) { - if (!missing(rate) && !missing(scale)) { - if (abs(rate * scale - 1) < 1e-15) - warning("specify 'rate' or 'scale' but not both") - else stop("specify 'rate' or 'scale' but not both") - } - stop('Actual .Call commented out while working on Rcpp compileAttributs() system') - ##.Call(C_dsqrtinvgamma, as.double(x), as.double(shape), as.double(rate), as.logical(log)) -} - -#' @export -rsqrtinvgamma <- function(n = 1, shape, scale = 1, rate = 1/scale) { - if (!missing(rate) && !missing(scale)) { - if (abs(rate * scale - 1) < 1e-15) - warning("specify 'rate' or 'scale' but not both") - else stop("specify 'rate' or 'scale' but not both") - } - stop('Actual .Call commented out while working on Rcpp compileAttributs() system') - ##.Call(C_rsqrtinvgamma, as.integer(n), as.double(shape), as.double(rate)) -} - - -#' The CAR-Normal Distribution -#' -#' Density function and random generation for the improper (intrinsic) -#' Gaussian conditional autoregressive (CAR) distribution. -#' -#' @name CAR-Normal -#' -#' @param x vector of values. -#' @param n number of observations. -#' @param adj vector of indices of the adjacent locations (neighbors) of each spatial location. This is a sparse representation of the full adjacency matrix. -#' @param weights vector of symmetric unnormalized weights associated with each pair of adjacent locations, of the same length as adj. If omitted, all weights are taken to be one. -#' @param num vector giving the number of neighbors of each spatial location, with length equal to the total number of locations. -#' @param tau scalar precision of the Gaussian CAR prior. -#' @param c integer number of constraints to impose on the improper density function. If omitted, \code{c} is calculated as the number of disjoint groups of spatial locations in the adjacency structure. Note that \code{c} should be equal to the number of eigenvalues of the precision matrix that are zero. For example if the neighborhood structure is based on a second-order Markov random field in one dimension has two zero eigenvalue and in two dimensinos has three zero eigenvalues. See Rue and Held (2005) for more information. -#' @param zero_mean integer specifying whether to set the mean of all locations to zero during MCMC sampling of a node specified with this distribution in BUGS code (default \code{0}). This argument is used only in BUGS model code when specifying models in nimble. If \code{0}, the overall process mean is included implicitly in the value of each location in a BUGS model; if \code{1}, then during MCMC sampling, the mean of all locations is set to zero at each MCMC iteration, and a separate intercept term should be included in the BUGS model. Note that centering during MCMC as implemented in nimble follows the ad hoc approach of \pkg{WinBUGS} and does not sample under the constraint that the mean is zero as discussed on p. 36 of Rue and Held (2005). See details. -#' @param log logical; if TRUE, probability density is returned on the log scale. -#' -#' @author Daniel Turek -#' -#' @details -#' -#' When specifying a CAR distribution in BUGS model code, the \code{zero_mean} parameter should be specified as either 0 or 1 (rather than TRUE or FALSE). -#' -#' Note that because the distribution is improper, \code{rcar_normal} does not generated a sample from the distribution, though as discussed in Rue and Held (2005), it is possible to generate a sample from the distribution under constraints imposed based on the eigenvalues of the precision matrix that are zero. -#' -#' @return \code{dcar_normal} gives the density, and \code{rcar_normal} returns the current process values, since this distribution is improper. -#' -#' @references -#' Banerjee, S., Carlin, B.P., and Gelfand, A.E. (2015). \emph{Hierarchical Modeling and Analysis for Spatial Data}, 2nd ed. Chapman and Hall/CRC. -#' -#' Rue, H. and L. Held (2005). \emph{Gaussian Markov Random Fields}, Chapman and Hall/CRC. -#' -#' @seealso \link{Distributions} for other standard distributions -#' -#' @examples -#' x <- c(1, 3, 3, 4) -#' num <- c(1, 2, 2, 1) -#' adj <- c(2, 1,3, 2,4, 3) -#' weights <- c(1, 1, 1, 1, 1, 1) -#' lp <- dcar_normal(x, adj, weights, num, tau = 1) -NULL - -#' @rdname CAR-Normal -#' @export -dcar_normal <- function(x, adj, weights, num, tau, c = CAR_calcNumIslands(adj, num), zero_mean = 0, log = FALSE) { - CAR_checkAdjWeightsNum(adj, weights, num) - if(storage.mode(x) != 'double') storage.mode(x) <- 'double' - if(storage.mode(adj) != 'double') storage.mode(adj) <- 'double' - if(storage.mode(weights) != 'double') storage.mode(weights) <- 'double' - if(storage.mode(num) != 'double') storage.mode(num) <- 'double' - ## - ##k <- length(x) - ##c <- 1 - ##lp <- 0 - ##count <- 1 - ##for(i in 1:k) { - ## if(num[i] == 0) c <- c + 1 - ## xi <- x[i] - ## for(j in 1:num[i]) { - ## xj <- x[adj[count]] - ## lp <- lp + weights[count] * (xi-xj)^2 - ## count <- count + 1 - ## } - ##} - ##if(count != (length(adj)+1)) stop('something wrong') - ##lp <- lp / 2 - ##lp <- lp * (-1/2) * tau - ##lp <- lp + (k-c)/2 * log(tau/2/pi) - ##if(log) return(lp) - ##return(exp(lp)) - ## - stop('Actual .Call commented out while working on Rcpp compileAttributs() system') - ##.Call(C_dcar_normal, as.double(x), as.double(adj), as.double(weights), as.double(num), as.double(tau), as.double(c), as.double(zero_mean), as.logical(log)) -} - -#' @rdname CAR-Normal -#' @export -rcar_normal <- function(n = 1, adj, weights, num, tau, c = CAR_calcNumIslands(adj, num), zero_mean = 0) { - ## it's important that simulation via rcar_normal() does *not* set all values to NA (or NaN), - ## since initializeModel() will call this simulate method if there are any NA's present, - ## (which is allowed for island components), which over-writes all the other valid initial values. - ##return(rep(NaN, length(num))) - currentValues <- eval(quote(model[[nodes]]), parent.frame(3)) - return(currentValues) -} - diff --git a/nCompiler/R/distributions_inputList.R b/nCompiler/R/distributions_inputList.R deleted file mode 100644 index ff808de4..00000000 --- a/nCompiler/R/distributions_inputList.R +++ /dev/null @@ -1,235 +0,0 @@ -## This file retains a lot of original nimble content that has not been updated. - -# the format of this list should be as follows: -# the name of the element is the name of the BUGS density -# the first string in each element is the BUGS density definition with the BUGS parameters as the first parameters, in order (the parameter names do NOT need to match the names in the BUGS manual since BUGS does not use parameter names), followed by any alternative parameter names -# the second and subsequent strings in an element are any reparameterizations, with the density name as in R/nCompiler and the canonical parameter names as used in R's math library (and nCompiler extensions) -# if R/nCompiler uses the same parameterization (in the same order) and same density name, the element may simply be the BUGS density definition (e.g., dichisq()) -# if R/nCompiler uses the same parameterization but in a different order, then one should define the reordering as a reparameterization (e.g., dbin()) - - - -distributionsInputList <- list( - - - ############################################ - #### univariate distributions, discrete #### - ############################################ - - - dbern = list(BUGSdist = 'dbern(prob)', - Rdist = 'dbinom(size = 1, prob)', - discrete = TRUE, - range = c(0, 1), - pqAvail = TRUE), - - dbin = list(BUGSdist = 'dbin(prob, size)', - Rdist = 'dbinom(size, prob)', - discrete = TRUE, - range = c('lower = 0', 'upper = size'), - pqAvail = TRUE, - alias = 'dbinom'), - - dcat = list(BUGSdist = 'dcat(prob)', - Rdist = 'dcat(prob)', - types = c('prob = double(1)'), - range = c(1, Inf), - discrete = TRUE), - - ## construct used to enforce constraints - 0/1 random variable depending on if cond is TRUE - dconstraint = list(BUGSdist = 'dconstraint(cond)', - range = c(0, 1), - discrete = TRUE), - - ## construct used to enforce censoring. - ## takes values 0,1,...,len(c), depending on which interval t falls into - dinterval = list(BUGSdist = 'dinterval(t, c)', - types = c('c = double(1)'), - range = c(0, Inf), - discrete = TRUE), - - dnegbin = list(BUGSdist = 'dnegbin(prob, size)', - Rdist = 'dnbinom(size, prob)', - discrete = TRUE, - range = c(0, Inf), - pqAvail = TRUE, - alias = 'dnbinom'), - - dpois = list(BUGSdist = 'dpois(lambda)', - discrete = TRUE, - range = c(0, Inf), - pqAvail = TRUE), - - - ############################################## - #### univariate distributions, continuous #### - ############################################## - - - dbeta = list(BUGSdist = 'dbeta(shape1, shape2, mean, sd)', - Rdist = 'dbeta(shape1 = mean^2*(1-mean)/sd^2-mean, shape2 = mean*(1-mean)^2/sd^2+mean-1)', - altParams= c('mean = shape1/(shape1+shape2)', - 'sd = sqrt(shape1*shape2/((shape1 + shape2)^2*(shape1+shape2+1)))'), - range = c(0, 1), - pqAvail = TRUE), - - dchisq = list(BUGSdist = 'dchisq(df)', - range = c(0, Inf), - pqAvail = TRUE, - alias = 'dchisqr'), - - ## ddexp = list('ddexp(location, scale, rate)'), ## 'ddexp' function not implemented yet? -DT - ## provide 'laplace' as alias - - dexp = list(BUGSdist = 'dexp(rate, scale)', - Rdist = 'dexp_nimble(rate = 1/scale)', - altParams= 'scale = 1/rate', - range = c(0, Inf), - pqAvail = TRUE), - - dflat = list(BUGSdist = 'dflat()', - pqAvail = FALSE), - - dhalfflat = list(BUGSdist = 'dhalfflat()', - range = c(0, Inf), - pqAvail = FALSE), - - dgamma = list(BUGSdist = 'dgamma(shape, rate, scale, mean, sd)', - Rdist = c('dgamma(shape, scale = 1/rate)', - 'dgamma(shape = mean^2/sd^2, scale = sd^2/mean)'), - altParams= c('rate = 1/scale', - 'mean = scale*shape', - 'sd = scale * sqrt(shape)'), - range = c(0, Inf), - pqAvail = TRUE), - - # (shape,scale) is BUGSdist as scale provides conjugacy - # calculation of shape/scale from mean/sd not obvious - # (solution to cubic polynomial) so not using as alternative param - dinvgamma = list(BUGSdist = 'dinvgamma(shape, scale, rate)', - Rdist = c('dinvgamma(shape, rate = 1/scale)'), - altParams= c('scale = 1/rate', - 'mean = 1 / (rate * (max(shape,1)-1))', - 'sd = 1 / (rate * (max(shape,1)-1) * sqrt(max(shape,2)-2))'), # max ensures Inf moment when appropriate - range = c(0, Inf), - pqAvail = TRUE), - - # intended solely for use in dhalfflat conjugacy - dsqrtinvgamma = list(BUGSdist = 'dsqrtinvgamma(shape, scale, rate)', - Rdist = c('dsqrtinvgamma(shape, rate = 1/scale)'), - range = c(0, Inf), - pqAvail = FALSE), - - ## gen.gamma = list(BUGSdist = 'gen.gamma(r, mu, beta)'), ## not sure the state of this? -DT - - dlnorm = list(BUGSdist = 'dlnorm(meanlog, taulog, sdlog, varlog)', - Rdist = c('dlnorm(meanlog, sdlog = 1/sqrt(taulog))', - 'dlnorm(meanlog, sdlog = sqrt(varlog))'), - altParams= c('taulog = sdlog^-2', - 'varlog = sdlog^2'), - range = c(0, Inf), - pqAvail = TRUE), - - dlogis = list(BUGSdist = 'dlogis(location, rate, scale)', - Rdist = 'dlogis(location, scale = 1/rate)', - altParams = 'rate = 1/scale', - pqAvail = TRUE), - - dnorm = list(BUGSdist = 'dnorm(mean, tau, sd, var)', - Rdist = c('dnorm(mean, sd = 1/sqrt(tau))', - 'dnorm(mean, sd = sqrt(var))'), - altParams= c('tau = sd^-2', - 'var = sd*sd'), - pqAvail = TRUE), - - dt = list(BUGSdist = 'dt(mu, tau, df, sigma, sigma2)', - Rdist = c('dt_nonstandard(df, mu, sigma = 1/sqrt(tau))', - 'dt_nonstandard(df, mu, sigma = sqrt(sigma2))'), - altParams = c('tau = sigma^-2', - 'sigma2 = sigma^2'), - pqAvail = TRUE), - - dunif = list(BUGSdist = 'dunif(min, max, mean, sd)', - Rdist = c('dunif(min = mean - sqrt(3)*sd, max = mean + sqrt(3)*sd)'), - altParams = c('mean = (min + max)/2', - 'sd = (max - min)/sqrt(12)'), - range = c('lower = min', 'upper = max'), - pqAvail = TRUE), - - dweib = list(BUGSdist = 'dweib(shape, lambda, scale, rate)', - Rdist = c('dweibull(shape, scale = lambda^(-1/shape))', - 'dweibull(shape, scale = 1/rate)'), - altParams= c('rate = 1/scale', - 'lambda = scale^(-shape)'), - range = c(0, Inf), - pqAvail = TRUE, - alias = 'dweibull'), - - - #################################### - #### multivariate distributions #### - #################################### - - - dcar_normal = list(BUGSdist = 'dcar_normal(adj, weights, num, tau, c, zero_mean)', - Rdist = c('dcar_normal(adj, weights, num, tau, c, zero_mean = 0)', - 'dcar_normal(adj, weights, num, tau, c = CAR_calcNumIslands(adj, num), zero_mean )', - 'dcar_normal(adj, weights, num, tau, c = CAR_calcNumIslands(adj, num), zero_mean = 0)', - 'dcar_normal(adj, weights = adj/adj, num, tau, c, zero_mean )', - 'dcar_normal(adj, weights = adj/adj, num, tau, c, zero_mean = 0)', - 'dcar_normal(adj, weights = adj/adj, num, tau, c = CAR_calcNumIslands(adj, num), zero_mean )', - 'dcar_normal(adj, weights = adj/adj, num, tau, c = CAR_calcNumIslands(adj, num), zero_mean = 0)'), - types = c('value = double(1)', 'adj = double(1)', 'weights = double(1)', 'num = double(1)', 'tau = double(0)', 'c = double(0)', 'zero_mean = double(0)'), - mixedSizes = TRUE, - alias = 'car.normal'), - - ddirch = list(BUGSdist = 'ddirch(alpha)', - Rdist = 'ddirch(alpha)', - types = c('value = double(1)', 'alpha = double(1)'), - range = c(0, 1), - alias = 'ddirich'), - - dmnorm = list(BUGSdist = 'dmnorm(mean, prec, cov, cholesky, prec_param)', - Rdist = c('dmnorm_chol(mean, cholesky = chol(prec), prec_param = 1)', - 'dmnorm_chol(mean, cholesky = chol(cov), prec_param = 0)', - 'dmnorm_chol(mean, cholesky, prec_param)'), - altParams= c('prec = calc_dmnormAltParams(cholesky, prec_param, 1)', - 'cov = calc_dmnormAltParams(cholesky, prec_param, 0)'), - types = c('value = double(1)', 'mean = double(1)', 'cholesky = double(2)', 'prec = double(2)', 'cov = double(2)')), - - dmulti = list(BUGSdist = 'dmulti(prob, size)', - Rdist = 'dmulti(size, prob)', - types = c('value = double(1)', 'prob = double(1)'), - range = c(0, Inf), - discrete = TRUE, - alias = 'dmultinom'), - - dmvt = list(BUGSdist = 'dmvt(mu, prec, scale, cholesky, df, prec_param)', - Rdist = c('dmvt_chol(mu, cholesky = chol(prec), df = df, prec_param = 1)', - 'dmvt_chol(mu, cholesky = chol(scale), df = df, prec_param = 0)', - 'dmvt_chol(mu, cholesky, df = df, prec_param)'), - altParams= c('prec = calc_dmnormAltParams(cholesky, prec_param, 1)', - 'scale = calc_dmnormAltParams(cholesky, prec_param, 0)'), - types = c('value = double(1)', 'mu = double(1)', 'cholesky = double(2)', 'df = double(0)', 'prec = double(2)', 'scale = double(2)')), - - dwish = list(BUGSdist = 'dwish(R, df, S, cholesky, scale_param)', - Rdist = c('dwish_chol(cholesky = chol(R), df, scale_param = 0)', - 'dwish_chol(cholesky = chol(S), df, scale_param = 1)', - 'dwish_chol(cholesky, df, scale_param)'), - altParams = c('R = calc_dwishAltParams(cholesky, scale_param, 0)', - 'S = calc_dwishAltParams(cholesky, scale_param, 1)'), - alias = 'dwishart', - types = c('value = double(2)', 'R = double(2)', 'S = double(2)', 'cholesky = double(2)')), - - dinvwish = list(BUGSdist = 'dinvwish(S, df, R, cholesky, scale_param)', - Rdist = c('dinvwish_chol(cholesky = chol(S), df, scale_param = 1)', - 'dinvwish_chol(cholesky = chol(R), df, scale_param = 0)'), - altParams = c('R = calc_dwishAltParams(cholesky, scale_param, 0)', - 'S = calc_dwishAltParams(cholesky, scale_param, 1)'), - alias = 'dinvwishart', - types = c('value = double(2)', 'S = double(2)', 'R = double(2)', 'cholesky = double(2)')) -) - - - - diff --git a/nCompiler/R/distributions_processInputList.R b/nCompiler/R/distributions_processInputList.R deleted file mode 100644 index 370aa0db..00000000 --- a/nCompiler/R/distributions_processInputList.R +++ /dev/null @@ -1,877 +0,0 @@ -## This file contains a lot of original nimble content that has not been updated - -distributionsClass <- setRefClass( - Class = 'distributionsClass', - - fields = list( - distObjects = 'ANY', #'list', ## a list of distClass objects, names of each element are the BUGS distribution name - namesVector = 'ANY', #'character', ## a character vector of the (BUGS) names of all distributions - namesExprList = 'ANY', #'list', ## a list of the expressions of the (BUGS) names of all distributions - matchCallEnv = 'ANY', #'environment', ## an environment containing distribution functions which run match.call() - translations = 'ANY' #'list' ## a list of the (R) d-dist and r-dist function names. element names are BUGS distributions - ), - - methods = list( - initialize = function(dil) { - distObjects <<- list() - namesExprList <<- list() - translations <<- list() - for(i in seq_along(dil)) distObjects[[i]] <<- distClass(dil[[i]], names(dil)[i]) - names(distObjects) <<- names(dil) - namesVector <<- names(dil) - namesExprList <<- lapply(namesVector, as.name) - matchCallEnv <<- new.env() - for(distName in namesVector) assign(distName, distObjects[[distName]]$makeMatchCallFunction(), matchCallEnv) - translations <<- lapply(distObjects, function(d) c(d$densityName, d$simulateName)) - }, - - add = function(dil) { - distObjectsNew <- list() - nms <- names(dil) - dupl <- which(nms %in% getAllDistributionsInfo('namesVector', userOnly = TRUE)) - if(length(dupl)) { - for(i in seq_along(dupl)) remove(nms[dupl]) - ## distObjects[dupl] <<- NULL - ## namesVector <<- namesVector[-dupl] - ## namesExprList[dupl] <<- NULL - ## translations[dupl] <<- NULL - cat("Overwriting the following user-supplied distributions:", nms[dupl], ".\n", sep = " ") - } - for(i in seq_along(dil)) distObjectsNew[[i]] <- distClass(dil[[i]], nms[i]) - names(distObjectsNew) <- nms - translations <<- c(translations, lapply(distObjectsNew, function(d) c(d$densityName, d$simulateName))) - - distObjects <<- c(distObjects, distObjectsNew) - namesVector <<- c(namesVector, nms) - namesExprList <<- c(namesExprList, lapply(nms, as.name)) - for(distName in nms) assign(distName, distObjects[[distName]]$makeMatchCallFunction(), matchCallEnv) - }, - - remove = function(dn) { - namesVector <<- namesVector[!namesVector %in% dn] - namesExprList[namesExprList == as.name(dn)] <<- NULL - eval(substitute(rm(x, envir = matchCallEnv), list(x = dn))) - translations[dn] <<- NULL - distObjects[dn] <<- NULL - } - ) - ) - - -setMethod('[[', 'distributionsClass', - function(x, i) { - return(x$distObjects[[i]]) - } -) - -setMethod('[', 'distributionsClass', - function(x, i) { - return(x$distObjects[i]) - } -) - - -distClass <- setRefClass( - Class = 'distClass', - - fields = list( - BUGSdistName = 'ANY', #'character', ## the (BUGS) name of the distribution - BUGSdistExpr = 'ANY', # the BUGS distribution expression, as provided in the original inputs list, with all possible parameter names - RdistExprList = 'ANY', #'list', ## a list of the R distribution expressions, along with their parameters and re-parametrizations - numAlts = 'ANY', #'numeric', ## the number of alternate reparametrizations provided - alts = 'ANY', #'list', - exprs = 'ANY', #'list', - reqdArgs = 'ANY', #'character', ## chracter vector of the required arguments in our R implementation of each distribution; we always reparametrize to this - densityName = 'ANY', #'character', ## the (R) name of the d-dist function, e.g. 'dnorm' - simulateName = 'ANY', #'character', ## the (R) name of the r-dist function, e.g. 'rnorm' - altParams = 'ANY', #'list', ## the (named) list of alternate parameters we'll have available, list elements are the expressions for each parameter - discrete = 'ANY', #'logical', ## logical, if the distribution is discrete - pqAvail = 'ANY', #'logical', ## if the p (CDF) and q (inverse CDF/quantile) functions are available - mixedSizes = 'ANY', ## if TRUE, then parameters of this distribution could have varied sizes, and is exempted from this check in model$checkBasics() - range = 'ANY', #'numeric', ## lower and upper limits of distribution domain - types = 'ANY', #'list', ## named list (names are 'node', ALL reqdArgs, and ALL altParams), each element is a named list: list(type = 'double', nDim = 0) <- default values - paramIDs = 'ANY' #'integer' ## named vector of unique integer ID for each parameter -### typesForVirtualNodeFunction = 'ANY' #'list' ## version of 'types' for making the virtualNodeFunction definiton. same as above, except without 'value' - ), - - methods = list( - initialize = function(distInputList, BUGSdistName) { - RdistExprList <<- list() - alts <<- list() - exprs <<- list() - altParams <<- list() - types <<- list() - BUGSdistName <<- BUGSdistName - BUGSdistExpr <<- parse(text=distInputList$BUGSdist)[[1]] - if(BUGSdistExpr[[1]] != BUGSdistName) stop(paste0('inconsistent BUGS distribution names for distribution: ', BUGSdistName)) - RdistTextVector <- if(is.null(distInputList$Rdist)) character() else distInputList$Rdist - RdistExprList <<- lapply(RdistTextVector, function(t) parse(text=t)[[1]]) - numAlts <<- length(RdistExprList) - init_altsExprsReqdArgs() - simulateName <<- sub('^d', 'r', densityName) - init_altParams(distInputList) - discrete <<- if(is.null(distInputList$discrete)) FALSE else distInputList$discrete - pqAvail <<- if(is.null(distInputList$pqAvail)) FALSE else distInputList$pqAvail - mixedSizes <<- if(is.null(distInputList$mixedSizes)) FALSE else distInputList$mixedSizes - init_range(distInputList) - init_types(distInputList) - init_paramIDs() - }, - - init_altsExprsReqdArgs = function() { - alts <<- list() - exprs <<- list() - if(numAlts == 0) { - params <- as.list(BUGSdistExpr[-1]) # removes the distribution name - paramsText <- lapply(params, deparse) - reqdArgs <<- sapply(paramsText, function(pt) init_getReqdArgs(pt)) - densityName <<- as.character(BUGSdistExpr[[1]]) - } else { - params <- lapply(RdistExprList, `[`, -1) # removes the distribution names - paramsText <- lapply(params, function(x) lapply(x, deparse)) - reqdArgsList <- lapply(paramsText, function(pt) init_getReqdArgs(pt)) - densityNamesList <- lapply(RdistExprList, function(expr) as.character(expr[[1]])) - if(length(unique(reqdArgsList)) > 1) - stop('R/nCompiler parameter names and order not consistent across alternative parameterizations') - if(length(unique(densityNamesList)) > 1) - stop('R/nCompiler density names not consistent across alternative parameterizations') - reqdArgs <<- reqdArgsList[[1]] - densityName <<- densityNamesList[[1]] - for(i in seq_along(params)) { - boolNoDefault <- if (is.null(names(paramsText[[i]]))) seq_along(paramsText[[i]]) else names(paramsText[[i]]) == '' - if(sum(!boolNoDefault)) { - exprs[[i]] <<- lapply(params[[i]][!boolNoDefault], function(x) {names(x) <- NULL; x}) - BUGSargs <- unique(unlist(c(lapply(exprs[[i]], all.vars), paramsText[[i]][boolNoDefault]))) - names(BUGSargs) <- NULL - if(!identical(sort(BUGSargs), sort(reqdArgs))) alts[[i]] <<- BUGSargs - } - } - } - }, - - init_getReqdArgs = function(x) { - args <- if(is.null(names(x))) rep('', length(x)) else names(x) - args[args == ''] <- unlist(x[args == '']) - return(args) - }, - - init_range = function(distInputList) { - if(!is.null(distInputList$range)) { - if(length(distInputList$range) != 2) - stop("'Range' element of ", BUGSdistExpr[[1]], " must be a vector of length two.") - if(is.numeric(distInputList$range)) { - range <<-list(lower = distInputList$range[1], upper = distInputList$range[2]) - } else { - parsedRangeArg <- lapply(distInputList$range, function(x) parse(text=x)[[1]]) - range <<- lapply(parsedRangeArg, function(x) x[[3]]) - names(range) <<- unlist(lapply(parsedRangeArg, function(x) x[[2]])) - if(!identical(names(range), c('lower', 'upper'))) - stop("'Range' element of ", BUGSdistExpr[[1]], " expected to contain 'lower' and 'upper'.") - } - } else range <<- list(lower = -Inf, upper = Inf) - }, - - init_altParams = function(distInputList) { - altParams <<- list() - if(!is.null(distInputList$altParams)) { - parsedAltParamArg <- lapply(distInputList$altParams, function(x) parse(text=x)[[1]]) - altParams <<- lapply(parsedAltParamArg, function(x) x[[3]]) - names(altParams) <<- unlist(lapply(parsedAltParamArg, function(x) x[[2]])) - } - }, - - init_types = function(distInputList) { - typeArgCharVector <- if(!is.null(distInputList$types)) distInputList$types else character(0) - typeArgList <- init_types_makeArgList(typeArgCharVector) - if('value' %in% c(reqdArgs, names(altParams))) stop('going to have a name conflict with \'value\' in distribution declaration') - allTypeNames <- c('value', reqdArgs, names(altParams)) - for(typeName in allTypeNames) { - typeList <- if(typeName %in% names(typeArgList)) typeArgList[[typeName]] else list(type='double', nDim=0) # default type - if(!(typeList$type %in% c('double', 'integer', 'logical'))) stop(paste0('unknown type specified in distribution: ', typeList$type)) - if(!(typeList$nDim %in% 0:1000)) stop(paste0('unknown nDim specified in distribution: ', typeList$nDim)) ## yes, specificying maximum dimension of 1000 - types[[typeName]] <<- typeList - } - }, - - init_paramIDs = function() { - paramIDs <<- seq_along(types) - names(paramIDs) <<- names(types) - }, - - init_types_makeArgList = function(typeArgCharVector) { - parsedArgList <- lapply(typeArgCharVector, function(x) parse(text=x)[[1]]) - allNames <- unlist(lapply(parsedArgList, function(pa) as.character(pa[[2]]))) - declExprs <- lapply(parsedArgList, function(pa) pa[[3]]) - allTypes <- unlist(lapply(parsedArgList, function(pa) as.character(pa[[3]][[1]]))) - allDims <- unlist(lapply(parsedArgList, function(pa) if(length(pa[[3]]) == 1) 0 else as.numeric(pa[[3]][[2]]))) - argList <- list() - for(i in seq_along(allNames)) { - argList[[allNames[i]]] <- list(type = allTypes[i], nDim = allDims[i]) - } - return(argList) - }, - - makeMatchCallFunction = function() { - vars <- BUGSdistExpr[-1] - functionText <- paste0('function(', paste0(vars, collapse=', '), ') { match.call() }') - functionDef <- parse(text = functionText)[[1]] - eval(functionDef) - } - ) -) - -##################################################################################################### -##################################################################################################### -##### process user-supplied distributions ########################################################## -##################################################################################################### -##################################################################################################### - -checkDistributionInput <- function(distributionInput) { - allowedFields <- unique(unlist(sapply(distributionsInputList, names))) - if(sum(!names(distributionInput) %in% allowedFields)) - stop(paste0(names(distributionInput), " has unknown field.")) - if(!sum(is.character(distributionInput$BUGSdist))) stop(paste0(distributionInput$BUGSdist, ": field 'BUGSdist' is not of type character.")) - if(exists("Rdist", distributionInput) && !sum(is.character(distributionInput$Rdist))) stop(paste0(distributionInput$BUGSdist, ": field 'Rdist' is not type of character.")) - if(exists("discrete", distributionInput) && !sum(is.logical(distributionInput$discrete))) stop(paste0(distributionInput$BUGSdist, ": field 'discrete' is not type logical.")) - if(exists("pqAvail", distributionInput) && !sum(is.logical(distributionInput$pqAvail))) stop(paste0(distributionInput$BUGSdist, ": field 'pqAvail' is not of type logical.")) - if(exists("range", distributionInput) && (!is.numeric(distributionInput$range) || length(distributionInput$range) != 2)) stop(paste0(distributionInput$BUGSdist, ": field 'range' is not a vector of two numeric values.")) - if(exists("types", distributionInput) && !sum(is.character(distributionInput$types))) stop(paste0(distributionInput$BUGSdist, ": field 'types' is not of type character.")) - if(exists("altParams", distributionInput) && !sum(is.character(distributionInput$altParams))) stop(paste0(distributionInput$BUGSdist, ": field 'altParams' is not of type character.")) - if(length(distributionInput$BUGSdist) > 1 || (exists('discrete', distributionInput) && length(distributionInput$discrete) > 1) || (exists('pqAvail', distributionInput) && length(distributionInput$pqAvail) > 1)) - stop(paste0(names(distributionInput), " field 'BUGSdist', 'discrete', 'altParams', or 'pqAvail' is not of length one.")) - invisible(NULL) -} - - -# check for log last in d, n as first in r, lower.tail, log.p in p,q -checkDistributionFunctions <- function(distributionInput, userEnv) { - if(is.list(distributionInput)) { - if(exists('Rdist', distributionInput)) - inputString <- distributionInput$Rdist else inputString <- distributionInput$BUGSdist - densityName <- as.character(parse(text = inputString)[[1]][[1]]) - } else densityName <- distributionInput - simulateName <- sub('^d', 'r', densityName) - if(!exists(densityName, where = userEnv) || - !is.rcf(get(densityName, pos = userEnv))) - stop(paste0("checkDistributionFunctions: density function for ", densityName, - " is not available as a nFunction without setup code.")) - if(!exists(simulateName, where = userEnv) || !is.rcf(get(simulateName, pos = userEnv))) { - cat(paste0("Warning: random generation function for ", densityName, - " is not available as a nFunction without setup code. nCompiler is generating a placeholder function that will invoke an error if an algorithm needs to simulate from this distribution. Some algorithms (such as random-walk Metropolis MCMC sampling) will work without the ability to simulate from the distribution.\n")) - rargInfo <- environment(get(densityName, pos = userEnv))$nfMethodRCobject$argInfo - returnType <- deparse(unlist(rargInfo[[1]])) - rargInfo <- rargInfo[-length(rargInfo)] # remove 'log' argument - rargInfo[[1]] <- quote(integer(0)) - names(rargInfo)[1] <- 'n' - args <- paste(names(rargInfo), as.character(rargInfo), sep = "=", collapse = ', ') - # build nf from text as unclear how to pairlist info in rargInfo with substitute - nfCode <- paste0("nFunction(run = function(", args, ") { stop('user-defined distribution ", densityName, " provided without random generation function.')\nreturnType(", returnType, ")})") - assign(simulateName, eval(parse(text = nfCode)), envir = userEnv) - } - - dargs <- args <- formals(get(densityName, pos = userEnv)) - nArgs <- length(args) - if(nArgs < 2) stop(paste0("checkDistributionFunctions: expecting at least two arguments ('x', 'log') as arguments for the density function for ", densityName, ".")) - if(names(args)[1] != "x") stop(paste0("checkDistributionFunctions: expecting 'x' as the first argument for the density function for ", densityName, ".")) - if(names(args)[nArgs] != "log") stop(paste0("checkDistributionFunctions: expecting 'log' as the last argument for the density function for ", densityName, ".")) - dargs <- dargs[-c(1,nArgs)] - - rargs <- args <- formals(get(simulateName, pos = userEnv)) - nArgs <- length(args) - if(nArgs < 1) stop(paste0("checkDistributionFunctions: expecting at least one argument ('n') as arguments for the simulation function for ", densityName, ".")) - if(names(args)[1] != "n") stop(paste0("checkDistributionFunctions: expecting 'n' as the first argument for the simulation function for ", densityName, ".")) - rargs <- rargs[-1] - - if(!identical(dargs, rargs)) - warning(paste0("checkDistributionFunctions: parameter arguments not the same amongst density and simulation functions for ", densityName, ". Continuing anyway based on arguments to the density function; algorithms using the simulation function are unlikely to function properly.")) - if(!is.null(distributionInput) && is.list(distributionInput) && exists("pqAvail", distributionInput) && distributionInput$pqAvail) { - cdfName <- sub('^d', 'p', densityName) - quantileName <- sub('^d', 'q', densityName) - if(!is.rcf(get(cdfName, pos = userEnv)) || !is.rcf(get(quantileName, pos = userEnv))) - stop(paste0("checkDistributionFunctions: Either distribution (CDF) or quantile (inverse CDF) functions for ", densityName, - " are not available as nFunctions without setup code.")) - - pargs <- args <- formals(get(cdfName, pos = userEnv)) - nArgs <- length(args) - if(nArgs < 3) stop(paste0("checkDistributionFunctions: expecting at least three arguments ('q', 'lower.tail', and 'log.p') as arguments for the distribution function for ", densityName, ".")) - if(names(args)[1] != "q") stop(paste0("checkDistributionFunctions: expecting 'q' as the first argument for the distribution function for ", densityName, ".")) - if(names(args)[nArgs] != "log.p") stop(paste0("checkDistributionFunctions: expecting 'log.p' as the last argument for the distribution function for ", densityName, ".")) - if(names(args)[nArgs-1] != "lower.tail") stop(paste0("checkDistributionFunctions: expecting 'lower.tail' as the last argument for the distribution function for ", densityName, ".")) - pargs <- pargs[-c(1,nArgs-1,nArgs)] - - qargs <- args <- formals(get(quantileName, pos = userEnv)) - nArgs <- length(args) - if(nArgs < 3) stop(paste0("checkDistributionFunctions: expecting at least three arguments ('p', 'lower.tail', and 'log.p') as arguments for the quantile function for ", densityName, ".")) - if(names(args)[1] != "p") stop(paste0("checkDistributionFunctions: expecting 'p' as the first argument for the quantile function for ", densityName, ".")) - if(names(args)[nArgs] != "log.p") stop(paste0("checkDistributionFunctions: expecting 'log.p' as the last argument for the quantile function for ", densityName, ".")) - if(names(args)[nArgs-1] != "lower.tail") stop(paste0("checkDistributionFunctions: expecting 'lower.tail' as the last argument for the quantile function for ", densityName, ".")) - qargs <- qargs[-c(1,nArgs-1,nArgs)] - - if(!identical(dargs, pargs) || !identical(dargs, qargs)) - stop(paste0("checkDistributionFunctions: parameter arguments not the same amongst density, distribution, and quantile functions for ", densityName, ".")) - } - invisible(NULL) -} - - -getMaxDim <- function(typeList) - max(sapply(typeList, '[[', 'nDim')) - -getValueDim <- function(distObject) - distObject$types$value$nDim - -prepareDistributionInput <- function(dist) { - out <- list() - args <- formals(dist) - args <- args[!names(args) %in% c('x', 'log')] - if(!length(args)) - argInfo <- NULL - if(length(args) == 1) - argInfo <- names(args) - if(length(args) > 1) - argInfo <- paste0(paste0(names(args)[-length(args)], sep = ',', collapse = ''), names(args)[length(args)], - collapse = '') - out$BUGSdist <- paste0(dist, "(", argInfo, ")", collapse = '') - typeInfo <- get('nfMethodRCobject', environment(eval(as.name(dist))))$argInfo - out$types <- paste0('value = ', deparse(typeInfo$x)) - typeInfo <- typeInfo[!names(typeInfo) %in% c('x', 'log')] - if(length(typeInfo)) - out$types <- c(out$types, paste0(names(typeInfo), ' = ', sapply(typeInfo, deparse))) - - # check consistent types - simulateName <- sub('^d', 'r', dist) - typeInfo <- get('nfMethodRCobject', environment(eval(as.name(simulateName))))$argInfo - typeInfo <- typeInfo[names(typeInfo) != "n"] - rtypes <- character(0) - if(length(typeInfo)) - rtypes <- c(rtypes, paste0(names(typeInfo), ' = ', sapply(typeInfo, deparse))) - if(!identical(out$types[-1], rtypes)) - stop(paste0("prepareDistributionInfo: types/dimensions of parameters are not the same in the density and simulation functions for ", dist, ".")) - - # check for p and q functions - cdfName <- sub('^d', 'p', dist) - quantileName <- sub('^d', 'q', dist) - out$pqAvail <- exists(cdfName) && exists(quantileName) && is.rcf(get(cdfName)) && is.rcf(get(quantileName)) - - # check consistent types - if(out$pqAvail) { - typeInfo <- get('nfMethodRCobject', environment(eval(as.name(cdfName))))$argInfo - typeInfo <- typeInfo[!names(typeInfo) %in% c('q', 'log.p', 'lower.tail')] - ptypes <- numeric(0) - if(length(typeInfo)) - ptypes <- c(ptypes, paste0(names(typeInfo), ' = ', sapply(typeInfo, deparse))) - if(!identical(out$types[-1], ptypes)) - stop(paste0("prepareDistributionInfo: types/dimensions of parameters are not the same in the density and distribution functions for ", dist, ".")) - - typeInfo <- get('nfMethodRCobject', environment(eval(as.name(quantileName))))$argInfo - typeInfo <- typeInfo[!names(typeInfo) %in% c('p', 'log.p', 'lower.tail')] - qtypes <- numeric(0) - if(length(typeInfo)) - qtypes <- c(qtypes, paste0(names(typeInfo), ' = ', sapply(typeInfo, deparse))) - if(!identical(out$types[-1], qtypes)) - stop(paste0("prepareDistributionInfo: types/dimensions of parameters are not the same in the density and quantile functions for ", dist, ".")) - } - return(out) -} - -#' Add user-supplied distributions for use in nCompiler BUGS models -#' -#' Register distributional information so that nCompiler can process -#' user-supplied distributions in BUGS model code -#' -#' @param distributionsInput either a list or character vector specifying the user-supplied distributions. If a list, it should be a named list of lists in the form of that shown in \code{nCompiler:::distributionsInputList} with each list having required field \code{BUGSdist} and optional fields \code{Rdist}, \code{altParams}, \code{discrete}, \code{pqAvail}, \code{types}, and with the name of the list the same as that of the density function. Alternatively, simply a character vector providing the names of the density functions for the user-supplied distributions. -#' @param userEnv environment in which to look for the nFunctions that provide the distribution; this will generally not need to be set by the user as it will default to the environment from which this function was called. -#' @author Christopher Paciorek -#' @export -#' @details -#' When \code{distributionsInput} is a list of lists, see below for more information on the structure of the list. When \code{distributionsInput} is a character vector, the distribution is assumed to be of standard form, with parameters assumed to be the arguments provided in the density nFunction, no alternative parameterizations, and the distribution assumed to be continuous with range from minus infinity to infinity. The availability of distribution and quantile functions is inferred from whether appropriately-named functions exist in the global environment. -#' -#' Finally, note that one no longer needs to explicitly call \code{registerDistributions} as it will be called automatically when the user-supplied distribution is used for the first time in BUGS code. However, if one wishes to provide alternative parameterizations, to provide a range, or to indicate a distribution is discrete, then one still must explicitly register the distribution using \code{registerDistributions} with the argument in the list format. -#' -#' Format of the component lists when \code{distributionsInput} is a list of lists: -#' \itemize{ -#' \item{\code{BUGSdist}} { -#' a character string in the form of the density name (starting with 'd') followed by the names of the parameters in parentheses. When alternative parameterizations are given in \code{Rdist}, this should be an exhaustive list of the unique parameter names from all possible parameterizations, with the default parameters specified first. -#' } -#' \item{\code{Rdist}} { -#' an optional character vector with one or more alternative specifications of the density; each alternative specification can be an alternative name for the density, a different ordering of the parameters, different parameter name(s), or an alternative parameterization. In the latter case, the character string in parentheses should provide a given reparameterization as comma-separated name = value pairs, one for each default parameter, where name is the name of the default parameter and value is a mathematical expression relating the default parameter to the alternative parameters or other default parameters. The default parameters should correspond to the input arguments of the nFunctions provided as the density and random generation functions. The mathematical expression can use any of the math functions allowed in nCompiler (see the User Manual) as well as user-supplied nFunctions without setup code. The names of your nFunctions for the distribution functions must match the function name in the \code{Rdist} entry (or if missing, the function name in the \code{BUGSdist} entry -#' } -#' \item{\code{discrete}} { -#' a optional logical indicating if the distribution is that of a discrete random variable. If not supplied, distribution is assumed to be for a continuous random variable. -#' } -#' \item{\code{pqAvail}} { -#' an optional logical indicating if distribution (CDF) and quantile (inverse CDF) functions are provided as nFunctions. These are required for one to be able to use truncated versions of the distribution. Only applicable for univariate distributions. If not supplied, assumed to be FALSE. -#' } -#' \item{\code{altParams}} { -#' a character vector of comma-separated 'name = value' pairs that provide the mathematical expressions relating non-canonical parameters to canonical parameters (canonical parameters are those passed as arguments to your distribution functions). These inverse functions are used for MCMC conjugacy calculations when a conjugate relationship is expressed in terms of non-default parameters (such as the precision for normal-normal conjugacy). If not supplied, the system will still function but with a possible loss of efficiency in certain algorithms. -#' } -#' \item{\code{types}} { -#' a character vector of comma-separated 'name = input' pairs indicating the type and dimension of the random variable and parameters (including default and alternative parameters). 'input' should take the form 'double(d)' or 'integer(d)', where 'd' is 0 for scalars, 1 for vectors, 2 for matrices. Note that since nCompiler uses doubles for numerical calculations and the default type is \code{double(0)}, one should generally use 'double' and one need only specify the type for non-scalars. 'name' should be either 'value' to indicate the random variable itself or the parameter name to indicate a given parameter. -#' } -#' \item{\code{range}} { -#' a vector of two values giving the range of the distribution for possible use in future algorithms (not used currently). When the lower or upper limit involves a strict inequality (e.g., $x>0$), you should simply treat it as a non-strict inequality ($x>=0$, and set the lower value to 0). Also we do not handle ranges that are functions of parameters, so simply use the smallest/largest possible values given the possible parameter values. If not supplied this is taken to be \code{(-Inf, Inf)}. -#' } -#' } -#' @examples -#' dmyexp <- nFunction( -#' run = function(x = double(0), rate = double(0), log = integer(0)) { -#' returnType(double(0)) -#' logProb <- log(rate) - x*rate -#' if(log) { -#' return(logProb) -#' } else { -#' return(exp(logProb)) -#' } -#' }) -#' rmyexp <- nFunction( -#' run = function(n = integer(0), rate = double(0)) { -#' returnType(double(0)) -#' if(n != 1) nimPrint("rmyexp only allows n = 1; using n = 1.") -#' dev <- runif(1, 0, 1) -#' return(-log(1-dev) / rate) -#' } -#' ) -#' registerDistributions(list( -#' dmyexp = list( -#' BUGSdist = "dmyexp(rate, scale)", -#' Rdist = "dmyexp(rate = 1/scale)", -#' altParams = "scale = 1/rate", -#' pqAvail = FALSE))) -#' code <- nParse({ -#' y ~ dmyexp(rate = r) -#' r ~ dunif(0, 100) -#' }) -#' m <- nimbleModel(code, inits = list(r = 1), data = list(y = 2)) -#' calculate(m, 'y') -#' m$r <- 2 -#' calculate(m, 'y') -#' m$resetData() -#' simulate(m, 'y') -#' m$y -#' -#' # alternatively, simply specify a character vector with the -#' # name of one or more 'd' functions -#' deregisterDistributions('dmyexp') -#' registerDistributions('dmyexp') -#' -#' # or simply use in BUGS code without registration -#' deregisterDistributions('dmyexp') -#' m <- nimbleModel(code, inits = list(r = 1), data = list(y = 2)) -#' -#' # example of Dirichlet-multinomial registration to illustrate -#' # use of 'types' (note that registration is not actually needed -#' # in this case) -#' ddirchmulti <- nFunction( -#' run = function(x = double(1), alpha = double(1), size = double(0), -#' log = integer(0, default = 0)) { -#' returnType(double(0)) -#' logProb <- lgamma(size) - sum(lgamma(x)) + lgamma(sum(alpha)) - -#' sum(lgamma(alpha)) + sum(lgamma(alpha + x)) - lgamma(sum(alpha) + -#' size) -#' if(log) return(logProb) -#' else return(exp(logProb)) -#' }) -#' -#' rdirchmulti <- nFunction( -#' run = function(n = integer(0), alpha = double(1), size = double(0)) { -#' returnType(double(1)) -#' if(n != 1) print("rdirchmulti only allows n = 1; using n = 1.") -#' p <- rdirch(1, alpha) -#' return(rmulti(1, size = size, prob = p)) -#' }) -#' -#' registerDistributions(list( -#' ddirchmulti = list( -#' BUGSdist = "ddirchmulti(alpha, size)", -#' types = c('value = double(1)', 'alpha = double(1)') -#' ) -#' )) -registerDistributions <- function(distributionsInput, userEnv = parent.frame()) { - if(missing(distributionsInput)) { - cat("No distribution information supplied.\n") - } else { - if(!(is.character(distributionsInput) || (is.list(distributionsInput) && - (length(distributionsInput) == 1 || is.list(distributionsInput[[1]]))))) - stop("'distributionsInput' should be a named list of lists or a character vector") - if(is.character(distributionsInput)) { - nms <- distributionsInput - } else { - nms <- names(distributionsInput) - } - cat("Registering the following user-provided distributions:", nms, ".\n") - dupl <- nms[nms %in% getAllDistributionsInfo('namesVector', nCompilerOnly = TRUE)] - if(length(dupl)) { - distributionsInput[dupl] <- NULL - cat("Ignoring the following user-supplied distributions as they have the same names as default nCompiler distributions:", dupl, ". Please rename to avoid the conflict.\n") - } - - if(is.list(distributionsInput)) - sapply(distributionsInput, checkDistributionInput) - sapply(distributionsInput, checkDistributionFunctions, userEnv = userEnv) - if(is.character(distributionsInput)) { - distributionsInput <- lapply(distributionsInput, prepareDistributionInput) - names(distributionsInput) <- nms - } - - if(exists('distributions', nCompilerUserNamespace)) { - nCompilerUserNamespace$distributions$add(distributionsInput) - } else - nCompilerUserNamespace$distributions <- distributionsClass(distributionsInput) - virtualNodeFunctionDefinitions <- ndf_createVirtualNodeFunctionDefinitionsList(userAdded = TRUE) - createNamedObjectsFromList(virtualNodeFunctionDefinitions, envir = .GlobalEnv) - - # note don't use rFunHandler as rUserDist nFunction needs n as first arg so it works on R side, therefore we have n in the C version of the nFunction and don't want to strip it out in Cpp generation - } - invisible(NULL) - -} - - -#' Remove user-supplied distributions from use in nCompiler BUGS models -#' -#' Deregister distributional information originally supplied by the user -#' for use in BUGS model code -#' -#' @param distributionsNames a character vector giving the names of the distributions to be dergistered -#' @author Christopher Paciorek -#' @export -deregisterDistributions <- function(distributionsNames) { - if(!exists('distributions', nCompilerUserNamespace)) - cat("No user-supplied distributions are registered.\n") - matched <- distributionsNames %in% getAllDistributionsInfo('namesVector', userOnly = TRUE) - if(sum(matched)) - cat(paste("Deregistering", distributionsNames[matched], "from user-registered distributions.\n")) - if(sum(!matched)) - for(nm in distributionsNames[!matched]) - cat(paste0("Cannot deregister ", nm, " as it is not registered as a user-defined distribution.\n")) - - distributionsNames <- distributionsNames[matched] - if(length(distributionsNames)) { - if(sum(!nCompilerUserNamespace$distributions$namesVector %in% distributionsNames)) { - sapply(distributionsNames, function(x) nCompilerUserNamespace$distributions$remove(x)) - } else { # all distributions to be removed - rm(distributions, envir = nCompilerUserNamespace) - } - } - invisible(NULL) -} - -##################################################################################################### -##################################################################################################### -##### API for accessing info about distributions ################################################### -##################################################################################################### -##################################################################################################### - - -getDistributionList <- function(dists) { - boolNative <- dists %in% distributions$namesVector - if(all(boolNative)) return(distributions[dists]) - missingDists <- dists[!boolNative] - allFound <- FALSE - if(exists('distributions', nCompilerUserNamespace)) { - if(all(missingDists %in% nCompilerUserNamespace$distributions$namesVector)) - allFound <- TRUE - } - if(allFound) { - ans <- vector('list', length(dists)) - ans[boolNative] <- distributions[dists[boolNative]] - ans[!boolNative] <- nCompilerUserNamespace$distributions[missingDists] - return(ans) - } - notFound <- missingDists[ !(missingDists %in% nCompilerUserNamespace$distributions$namesVector) ] - stop(paste0('In getDistributions, distributions named ', paste(notFound, sep = ',', collapse = ","), ' could not be found.')) -} - -# note that getDimension and isDiscrete are not included as aliases below because they have the same name as modelBaseClass methods so we are having help for them direct to help(modelBaseClass) as we expect more usage of the modelBaseClass methods by users - -#' Get information about a distribution -#' -#' Give information about each BUGS distribution -#' -#' @name distributionInfo -#' @aliases isUserDefined pqDefined getType getParamNames getDistributionInfo -#' -#' @param dist a character vector of length one, giving the name of the distribution (as used in BUGS code), e.g. \code{'dnorm'} -#' -#' @param params an optional character vector of names of parameters for which dimensions are desired (possibly including \'value\' and alternate parameters) -#' -#' @param valueOnly a logical indicating whether to only return the dimension of the value of the node -#' -#' @param includeParams a logical indicating whether to return dimensions of parameters. If TRUE and \'params\' is NULL then dimensions of all parameters, including the dimension of the value of the node, are returned -#' -#' @param includeValue a logical indicating whether to return the string 'value', which is the name of the node value -#' -#' @author Christopher Paciorek -#' @details -#' nCompiler provides various functions to give information about a BUGS distribution. In some cases, functions of the same name and similar functionality operate on the node(s) of a model as well (see \code{help(modelBaseClass)}). -#' -#' \code{getDistributionInfo} returns an internal data structure (a reference class object) providing various information about the distribution. The output is not very user-friendly, but does contain all of the information that nCompiler has about the distribution. -#' -#' \code{isDiscrete} tests if a BUGS distribution is a discrete distribution. -#' -#' \code{isUserDefined} tests if a BUGS distribution is a user-defined distribution. -#' -#' \code{pqAvail} tests if a BUGS distribution provides distribution ('p') and quantile ('q') functions. -#' -#' \code{getDimension} provides the dimension of the value and/or parameters of a BUGS distribution. The return value is a numeric vector with an element for each parameter/value requested. -#' -#' \code{getType} provides the type (numeric, logical, integer) of the value and/or parameters of a BUGS distribution. The return value is a character vector with an element for each parameter/value requested. At present, all quantities are stored as numeric (double) values, so this function is of little practical use but could be exploited in the future. -#' -#' \code{getParamNames} provides the value and/or parameter names of a BUGS distribution. -#' -#' @examples -#' distInfo <- getDistributionInfo('dnorm') -#' distInfo -#' distInfo$range -#' -#' isDiscrete('dbin') -#' -#' isUserDefined('dbin') -#' -#' pqDefined('dgamma') -#' pqDefined('dmnorm') -#' -#' getDimension('dnorm') -#' getDimension('dnorm', includeParams = TRUE) -#' getDimension('dnorm', c('var', 'sd')) -#' getDimension('dcat', includeParams = TRUE) -#' getDimension('dwish', includeParams = TRUE) -#' -#' getType('dnorm') -#' getType('dnorm', includeParams = TRUE) -#' getType('dnorm', c('var', 'sd')) -#' getType('dcat', includeParams = TRUE) -#' getType('dwish', includeParams = TRUE) -#' -#' getParamNames('dnorm', includeValue = FALSE) -#' getParamNames('dmnorm') -#' -NULL - -#' @rdname distributionInfo -#' @export -getDistributionInfo <- function(dist) { - if(is.na(dist)) return(NA) - if(dist %in% distributions$namesVector) return(distributions[[dist]]) - if(exists('distributions', nCompilerUserNamespace) && dist %in% nCompilerUserNamespace$distributions$namesVector) - return(nCompilerUserNamespace$distributions[[dist]]) - stop(paste0("getDistributionInfo: ", dist, " is not a distribution provided by nCompiler or supplied by the user.")) -} - -getAllDistributionsInfo <- function(kind, nCompilerOnly = FALSE, userOnly = FALSE) { - if(kind %in% c('namesVector', 'namesExprList', 'translations')) { - if(userOnly) out <- NULL else out <- get(kind, distributions) - if(!nCompilerOnly && exists('distributions', nCompilerUserNamespace)) - out <- c(out, get(kind, nCompilerUserNamespace$distributions)) - return(out) - } - -if(kind %in% c('pqAvail', 'discrete')) { - if(userOnly) out <- NULL else out <- sapply(distributions$distObjects, '[[', kind) - if(!nCompilerOnly && exists('distributions', nCompilerUserNamespace)) - out <- c(out, sapply(nCompilerUserNamespace$distributions$distObjects, '[[', kind)) - return(out) - } - stop(paste0("getAllDistributionInfo: ", kind, " is not available from the distributions information.")) -} - -evalInDistsMatchCallEnv <- function(expr) { - dist <- as.character(expr[[1]]) - if(dist %in% distributions$namesVector) - return(eval(expr, distributions$matchCallEnv)) - if(exists('distributions', nCompilerUserNamespace) && - dist %in% nCompilerUserNamespace$distributions$namesVector) - return(eval(expr, nCompilerUserNamespace$distributions$matchCallEnv)) - stop(paste0("evalInDistsMatchCallEnv: ", dist, " is not a distribution provided by nCompiler or supplied by the user.")) -} - -stripPrefix <- function(vec, prefix = "d") - return(gsub(paste0("^", prefix), "", vec)) - -BUGSdistToRdist <- function(BUGSdists, dIncluded = FALSE) { - Rdists <- lapply(getAllDistributionsInfo('translations'), `[[`, 1) - if(!dIncluded) names(Rdists) <- stripPrefix(names(Rdists)) - results <- unlist(Rdists[BUGSdists]) - names(results) <- NULL - if(!dIncluded) return(stripPrefix(results)) else return(results) -} - -#' @export -isDiscrete <- function(dist) { - if(is.na(dist)) return(NA) - if(length(dist) > 1 || class(dist) != 'character') - stop("isDiscrete: 'dist' should be a character vector of length 1") - return(getDistributionInfo(dist)$discrete) -} - -#' @rdname distributionInfo -#' @export -isUserDefined <- function(dist) { - if(is.na(dist)) return(dist) - if(length(dist) > 1 || class(dist) != 'character') - stop("isUserDistribution: 'dist' should be a character vector of length 1") - if(exists('distributions', nCompilerUserNamespace) && dist %in% getAllDistributionsInfo('namesVector', userOnly = TRUE)) - return(TRUE) else return(FALSE) -} - -#' @rdname distributionInfo -#' @export -pqDefined <- function(dist) { - if(is.na(dist)) return(NA) - if(length(dist) > 1 || class(dist) != 'character') - stop("pqDefined: 'dist' should be a character vector of length 1") - return(getDistributionInfo(dist)$pqAvail) -} - -## not user-facing. only for use in model$checkBasics(), -## to avoid "same size check" for distribution parameters -isMixedSizes <- function(dist) { - if(is.na(dist)) return(NA) - if(length(dist) > 1 || class(dist) != 'character') - stop("isMixedSizes: 'dist' should be a character vector of length 1") - return(getDistributionInfo(dist)$mixedSizes) -} - -#' @export -getDimension <- function(dist, params = NULL, valueOnly = is.null(params) && - !includeParams, includeParams = !is.null(params)) { - if(length(dist) == 1 && is.na(dist)) return(NA) # in case of passing a determ node - if(length(dist) > 1 || class(dist) != 'character') - stop("getDimension: 'dist' should be a character vector of length 1") - distInfo <- getDistributionInfo(dist) - - if(!includeParams && !valueOnly) - stop("getDimension: no parameters or value requested") - if(valueOnly && (!is.null(params) || includeParams)) - stop("getDimension: 'valueOnly' cannot be TRUE if parameters also requested") - if(!includeParams && !is.null(params)) - stop("getDimension: 'params' is not NULL but 'includeParams' is FALSE") - if(valueOnly) { - params <- 'value' - } else { - if(includeParams && is.null(params)) - params <- getParamNames(dist, includeValue = TRUE) - } - notFound <- which(! params %in% getParamNames(dist)) - if(length(notFound)) - stop("getDimension: these parameter names not found: ", params[notFound]) - out <- sapply(params, function(p) distInfo$types[[p]]$nDim) - return(out) -} - -getParamID <- function(dist, params = NULL, valueOnly = is.null(params) && - !includeParams, includeParams = !is.null(params)) { - if(length(dist) == 1 && is.na(dist)) return(NA) - if(length(dist) > 1 || class(dist) != 'character') - stop("getType: 'dist' should be a character vector of length 1") - distInfo <- getDistributionInfo(dist) - - if(!includeParams && !valueOnly) - stop("getDimension: no parameters or value requested") - if(valueOnly && (!is.null(params) || includeParams)) - stop("getDimension: 'valueOnly' cannot be TRUE if parameters also requested") - if(!includeParams && !is.null(params)) - stop("getDimension: 'params' is not NULL but 'includeParams' is FALSE") - if(valueOnly) { - params <- 'value' - } else { - if(includeParams && is.null(params)) - params <- getParamNames(dist, includeValue = TRUE) - } - notFound <- which(! params %in% getParamNames(dist)) - if(length(notFound)) - stop("getParamID: these parameter names not found: ", params[notFound]) - out <- distInfo$paramIDs[params] - return(out) -} - -#' @rdname distributionInfo -#' @export -getType <- function(dist, params = NULL, valueOnly = is.null(params) && - !includeParams, includeParams = !is.null(params)) { - if(length(dist) == 1 && is.na(dist)) return(NA) - if(length(dist) > 1 || class(dist) != 'character') - stop("getType: 'dist' should be a character vector of length 1") - distInfo <- getDistributionInfo(dist) - - if(!includeParams && !valueOnly) - stop("getType: no parameters or value requested") - if(valueOnly && (!is.null(params) || includeParams)) - stop("getType: 'valueOnly' cannot be TRUE if parameters also requested") - if(!includeParams && !is.null(params)) - stop("getType: 'params' is not NULL but 'includeParams' is FALSE") - if(valueOnly) { - params <- 'value' - } else { - if(includeParams && is.null(params)) - params <- getParamNames(dist, includeValue = TRUE) - } - notFound <- which(! params %in% getParamNames(dist)) - if(length(notFound)) - stop("getType: these parameter names not found: ", params[notFound]) - out <- sapply(params, function(p) distInfo$types[[p]]$type) - return(out) -} - -# perhaps have args to allow only reqdArgs or only altParams? - -#' @rdname distributionInfo -#' @export -getParamNames <- function(dist, includeValue = TRUE) { - if(length(dist) == 1 && is.na(dist)) return(NA) - if(length(dist) > 1 || class(dist) != 'character') - stop("getParamNames: 'dist' should be a character vector of length 1") - distInfo <- getDistributionInfo(dist) - names <- names(distInfo$paramIDs) - if(!includeValue) - names <- names[!names == 'value'] - return(names) -} - -##################################################################################################### -##################################################################################################### -##### executable code, creates global system variable 'distributions' and 'distribution_aliases ### -##################################################################################################### -##################################################################################################### - -distributions <- distributionsClass(distributionsInputList) - -# removed by CJP as getDistribution() and getDistributionsInfo() make it unneeded -# getDistributionsObject <- function() { -# distributions -# } - -processDistributionAliases <- function(distributionsInputList) { - tmp <- sapply(distributionsInputList, function(x) if(length(x$alias)) x$alias else NULL) - # next two lines avoid need for regex processing if we used unlist() when a dist has multiple aliases - aliases <- rep(names(tmp), sapply(tmp, length)) - names(aliases) <- unlist(tmp, use.names = FALSE) - - return(aliases) -} - -distributionAliases <- processDistributionAliases(distributionsInputList) - - -distribution_dFuns <- BUGSdistToRdist(getAllDistributionsInfo('namesVector'), dIncluded = TRUE) -distribution_rFuns <- gsub("^d", "r", distribution_dFuns) - -pqAvail <- names(which(getAllDistributionsInfo('pqAvail'))) -pqDists <- BUGSdistToRdist(pqAvail, dIncluded = TRUE) - -distribution_pFuns <- gsub("^d", "p", pqDists) -distribution_qFuns <- gsub("^d", "q", pqDists) - -distributionFuns <- c(distribution_dFuns, distribution_rFuns, distribution_pFuns, distribution_qFuns) - -## following sections are added for use in genCpp_operatorLists and other places. Slightly different need is to have separate list of scalar distributions and to use Rdist names -scalar_distribution_bool <- unlist(lapply(getAllDistributionsInfo('namesVector'), function(x) all(unlist(lapply(getDistributionInfo(x)$types, function(y) y$nDim == 0 ))))) -scalar_distribution_dFuns <- BUGSdistToRdist(getAllDistributionsInfo('namesVector')[scalar_distribution_bool], dIncluded = TRUE) -scalar_distribution_rFuns <- gsub("^d", "r", scalar_distribution_dFuns) - -scalar_pqAvail_bool <- getAllDistributionsInfo('pqAvail') & scalar_distribution_bool -scalar_pqAvail_dFuns <- BUGSdistToRdist(getAllDistributionsInfo('namesVector')[scalar_pqAvail_bool], dIncluded = TRUE) -scalar_distribution_pFuns <- gsub("^d", "p", scalar_pqAvail_dFuns) -scalar_distribution_qFuns <- gsub("^d", "q", scalar_pqAvail_dFuns) - -rm(scalar_distribution_bool, scalar_pqAvail_bool, scalar_pqAvail_dFuns) diff --git a/nCompiler/R/nimbleModels.R b/nCompiler/R/nimbleModels.R deleted file mode 100644 index a0756e7f..00000000 --- a/nCompiler/R/nimbleModels.R +++ /dev/null @@ -1,674 +0,0 @@ -# Here we are drafting support for new implementation of nimbleModels. -# This should eventually live in a separate package, but for now it is easier to draft here. -# -# see test-nimbleModel too. - -## modelBase_nClass will be a base class with methods that -## have separate Rfun and Cfun contents and are predefined. -## -## model_nClass will inherit from modelBase_nClass and in C++ will -## use CRTP for a derived model. -## It will also split Rfun and Cfun and provide a custom inheritance statement -## It may provide different sets of calculate modes. -## It will also be predefined (will it get an interface?) - -## a model will inherit from model_nClass - -# When doing development work on nClass -# if things are broken then having nClasses -# defined in the package prohibits package -# building and makes development harder. -# This flag should normally be NULL -# but may be false for some development work -# on nClasses. -NMdevel <- NULL - -#' @export -nodeInstr_nClass <- NMdevel %||% nClass( - classname = "nodeInstr_nClass", - Cpublic = list( - methodInstr = 'integerVector', - indsInstrVec = "nList(integerVector())", - nodeInstr_nClass = nFunction(function(){ - indsInstrVec <- nList(integerVector())$new() - }, - compileInfo = list(constructor=TRUE) - )), - predefined = quote(system.file(file.path("include","nCompiler", "predef"), package="nCompiler") |> - file.path("nodeInstr_nC")), - compileInfo=list(interface="full", - createFromR = TRUE, - needed_units = list("nList(integerVector())"), - exportName = "nodeInstr_nClass_new", - packageNames = c(uncompiled = "nodeInstr_nClass_R", compiled="nodeInstr_nClass") - ) -) - -#' @export -calcInstr_nClass <- NMdevel %||% nClass( - classname = "calcInstr_nClass", - Cpublic = list( - nodeIndex = 'integerScalar', - nodeInstrVec = "nList(nodeInstr_nClass())", - calcInstr_nClass = nFunction(function(){ - nodeInstrVec <- nList(nodeInstr_nClass())$new() - }, - compileInfo = list(constructor=TRUE) - )), - predefined = quote(system.file(file.path("include","nCompiler", "predef"), package="nCompiler") |> - file.path("calcInstr_nC")), - compileInfo=list(interface="full", - createFromR = TRUE, - # The Hincludes should be picked up automatically but I think it's not - # because it is in the nCppVec type and that is not being scanned for needed nClasses. - # These do need to be in "" not <>, for case of nCompile(...., package=TRUE) - Hincludes = '"nodeInstr_nClass_c_.h"', - # In the format here, needed_units is a list with either objects (nFunction or nClass (generators), - # or names. If names, we will use scoping to look them up and decide what they are. - # The list can mix objects and names of nClasses and nFunctions. - needed_units = list("nodeInstr_nClass", "nList(nodeInstr_nClass())"), - exportName = "calcInstr_nClass_new", - packageNames = c(uncompiled="calcInstr_nClass_R", compiled="calcInstr_nClass") - ) -) - -#' @export -calcInstrList_nClass <- NMdevel %||% nList(calcInstr_nClass()) - -#' @export -## calcInstrList_nClass <- NMdevel %||% nClass( -## classname = "calcInstrList_nClass", -## Cpublic = list( -## calcInstrList = "nCppVec('calcInstr_nClass')" -## ), -## predefined = quote(system.file(file.path("include","nCompiler", "predef"), package="nCompiler") |> -## file.path("calcInstrList_nC")), -## compileInfo=list(interface="full", -## createFromR = TRUE, -## Hincludes = '"calcInstr_nClass_c_.h"', -## exportName = "calcInstrList_nClass_new", -## packageNames = c(uncompiled = "calcInstrList_nClass", compiled = "calcInstrList_nClass_C"), -## needed_units = list("calcInstr_nClass") -## ) -## ) - -#' @export -nodeFxnBase_nClass <- NMdevel %||% nClass( - classname = "nodeFxnBase_nClass", - Cpublic = list( - ping = nFunction( - name = "ping", - function() {return(TRUE); returnType(logical())}, - compileInfo = list(virtual=TRUE) - ), - calculate = nFunction( - name = "calculate", - function(nodeInstr = 'nodeInstr_nClass') {return(0); returnType(double())}, - compileInfo = list(virtual=TRUE) - ) - ), - # We haven't dealt with ensuring a virtual destructor when any method is virtual - # For now I did it manually by editing the .h and .cpp - predefined = quote(system.file(file.path("include","nCompiler", "predef"), package="nCompiler") |> - file.path("nodeFxnBase_nC")), - compileInfo=list(interface="full", - createFromR = FALSE, - exportName = "nodeFxnBase_nClass_new", - needed_units = list("nodeInstr_nClass"), - packageNames = c(uncompiled="nodeFxnBase_nClass_R", compiled="nodeFxnBase_nClass") - ) -) -# Manually add -# # "#include " in the hContent -# after the header content. - -# nCompile(nodeFxnBase_nClass, control=list(generate_predefined=TRUE)) - -#' @export -modelBase_nClass <- NMdevel %||% nClass( - classname = "modelBase_nClass", - Cpublic = list( - ping = nFunction( - name = "ping", - function() {return(TRUE); returnType(logical())}, - compileInfo = list(virtual=TRUE) - ), - calculate = nFunction( - name = "calculate", - function(calcInstrList) { - cat("In uncompiled calculate\n") - # This is where uncompiled stepping through the calcInstrList happens. - for(calcInstr in calcInstrList$calcInstrList) { - nodeIdx <- calcInstr$nodeIndex - nodemember_name <- self$nodeObjNames[nodeIdx] # nodeObjNames is found in the derived class - for(nodeInstr in calcInstr$nodeInstrVec) { - self[[nodemember_name]]$calculate(nodeInstr) - } - } - return(0) - }, - returnType = 'numericScalar', - compileInfo = list( - C_fun = function(calcInstrList='calcInstrList_nClass') { - cppLiteral('Rprintf("modelBase_nClass calculate (should not see this)\\n");'); return(0)}, - virtual=TRUE - ) - ) - ), - # See comment above about needing to ensure a virtual destructor - predefined = quote(system.file(file.path("include","nCompiler", "predef"), package="nCompiler") |> file.path("modelBase_nC")), - compileInfo=list(interface="full", - createFromR = FALSE, - Hincludes = c('"nodeFxnBase_nClass_c_.h"'), #, '"calcInstrList_nClass_c_.h"'), # "nodeFxnBase_nClass_c_.h" needed for package = TRUE - needed_units = list("nodeFxnBase_nClass","calcInstrList_nClass"), - exportName = "modelBase_nClass_new", - packageNames = c(uncompiled="modelBase_nClass_R", compiled="modelBase_nClass") - ) -) -# Manually add -# # "#include " to that file, -# after the header content. - - -rm(NMdevel) - -# nCompile(modelBase_nClass, control=list(generate_predefined=TRUE)) - -## The two "addModelDollarSign" functions are borrowed directly from nimble. -## This should add model$ in front of any names that are not already part of a '$' expression -nm_addModelDollarSign <- function(expr, exceptionNames = character(0)) { - if(is.numeric(expr)) return(expr) - if(is(expr, 'srcref')) return(expr) - if(is.name(expr)) { - if((as.character(expr) %in% exceptionNames) || (as.character(expr) == '')) return(expr) - proto <- quote(model$a) - proto[[3]] <- expr - return(proto) - } - if(is.call(expr)) { - if(expr[[1]] == '$'){ - expr[2] <- lapply(expr[2], function(listElement) nm_addModelDollarSign(listElement, exceptionNames)) - return(expr) - } - if(expr[[1]] == 'returnType') - return(expr) - if(length(expr) > 1) { - expr[2:length(expr)] <- lapply(expr[-1], function(listElement) nm_addModelDollarSign(listElement, exceptionNames)) - return(expr) - } - } - return(expr) -} - -# Turn variables and methods into a nodeFxn nClass -make_node_nClass <- function(varInfo = list(), - methods = list(), - classname) { - # varInfo will be a list (names not used) of name, nDim, sizes. - # These are the model member variables to be used by the nodeFxn. - # They will be used in a constructor to set up C++ references to model variables. - CpublicVars <- varInfo |> lapply(\(x) paste0("ref(double(", x$nDim ,", interface=FALSE))")) - names(CpublicVars) <- varInfo |> lapply(\(x) x$name) |> unlist() - - -# varInfo_2_symbol <- \(x) nCompiler:::symbolBasic$new( -# type="double", nDim=x$nDim, name="", isRef=TRUE, isConst=FALSE, interface=FALSE) # In future maybe isConst=TRUE, but it might not matter much -# symbolList <- varInfo |> lapply(varInfo_2_symbol) -# names(symbolList) <- varInfo |> lapply(\(x) x$name) |> unlist() - numVars <- length(varInfo) - -# CpublicVars <- names(symbolList) |> lapply(\(x) eval(substitute(quote(T(symbolList$NAME)), -# list(NAME=as.name(x))))) -# names(CpublicVars) <- names(symbolList) - # This is a kluge to have a model field in the Cpublic_obj, - # needed for uncompiled purposes, and for compiled purposes - # we instead use references to model variables. So - # the declared type here is arbitrary. - initFun <- function(){} - - if(numVars > 0) { - # ctorArgNames <- paste0(names(symbolList), '_') - ctorArgNames <- paste0(names(CpublicVars), '_') - # List used when generating C++ constructor code to allow direct initializers, necessary for references. - # initializersList <- paste0(names(symbolList), '(', ctorArgNames ,')') - initializersList <- paste0(names(CpublicVars), '(', ctorArgNames ,')') - formals(initFun) <- structure(as.pairlist(CpublicVars), names = ctorArgNames) - } else { - initializersList <- character() - } - if(missing(classname)) - classname <- nodeFxnLabelCreator() - - baseclass <- paste0("nodeFxnClass_<", classname, ">") - - # Rpublic method to set the model pointer/reference. - setModel <- function(model) { - if(!isCompiled()) { - self$model <- model - #private$Cpublic_obj$model <- model - } - else - warning("setModel called on compiled object; no action taken") - } - -# This was a prototype - node_nClass <- substitute( - nClass( - inherit = nodeFxnBase_nClass, - classname = CLASSNAME, - Rpublic = RPUBLIC, - Cpublic = CPUBLIC, - compileInfo = list( - createFromR = FALSE, # Without a default constructor (which we've disabled here), createFromR is impossible - nClass_inherit = list(base = BASECLASS)) # Ideally this line would be obtained from a base nClass, but we insert it directly for now - ), - list( - CPUBLIC = c( - list( - nFunction( - initFun, - compileInfo = list(constructor=TRUE, initializers = initializersList) - ) - ) |> structure(names = classname), - CpublicVars, - list(model = "RcppList"), - methods - ), - RPUBLIC = list(#model = NULL, - setModel = setModel), - CLASSNAME = classname, - BASECLASS = baseclass - )) - eval(node_nClass) -} -#test <- nCompiler:::type2symbol('CppVar(baseType = type2cpp("numericVector"), ref=TRUE, const=TRUE)') - -# Make all the info needed to include a node in a model class. -# The nodeFxn_nClass should be created first. -# Currently it needs to have a name to include in nCompile(). Later we might be able to pass the object itself -# At first drafting this is fairly trivial but could grow in complexity. - -make_node_info_for_model_nClass <- function(membername, - nodeFxnName, - classname, - varInfo = list() - ) { - ctorArgs <- varInfo |> lapply(\(x) x$name) |> unlist() - - list(nodeFxnName = nodeFxnName, - membername = membername, - classname = classname, - ctorArgs = ctorArgs) -} - -makeModel_nClass <- function(varInfo, - nodes = list(), - classname, - sizes = list(), - inits = list(), - env = parent.frame() - ) { - # varInfo will be a list (names not used) of name, nDim, sizes. - CpublicModelVars <- varInfo |> lapply(\(x) paste0("numericArray(nDim=",x$nDim,")")) - names(CpublicModelVars) <- varInfo |> lapply(\(x) x$name) |> unlist() - opDefs <- list( - base_ping = getOperatorDef("custom_call"), - setup_node_mgmt = getOperatorDef("custom_call"), - do_setup_node_mgmt_from_names = getOperatorDef("custom_call") - ) - opDefs$base_ping$returnType <- nCompiler:::type2symbol(quote(void())) - opDefs$base_ping$labelAbstractTypes$recurse <- FALSE - opDefs$setup_node_mgmt$returnType <- nCompiler:::type2symbol(quote(void())) - opDefs$setup_node_mgmt$labelAbstractTypes$recurse <- FALSE - opDefs$do_setup_node_mgmt_from_names$returnType <- nCompiler:::type2symbol(quote(void())) - opDefs$do_setup_node_mgmt_from_names$labelAbstractTypes$recurse <- FALSE - - if(missing(classname)) - classname <- modelLabelCreator() - - CpublicMethods <- list( - do_setup_node_mgmt = nFunction( - name = "call_setup_node_mgmt", - function() {}, - compileInfo=list( - C_fun = function() {setup_node_mgmt()}) - ), - setup_node_mgmt_from_names = nFunction( - name = "call_setup_node_mgmt_from_names", - function(nodeNames) {}, - compileInfo=list( - C_fun = function(nodeNames="RcppCharacterVector") {do_setup_node_mgmt_from_names(nodeNames)}) - ), - print_nodes = nFunction( - name = "print_nodes", - function() {}, - compileInfo=list( - C_fun = function() {cppLiteral('modelClass_::c_print_nodes();')}) - ), - set_from_list = nFunction( - name = "set_from_list", - function(Rlist) {for(v in names(Rlist)) - if(exists(v, self, inherits=FALSE)) self[[v]] <- Rlist[[v]]}, - compileInfo=list( - C_fun=function(Rlist = 'RcppList') {cppLiteral('modelClass_::set_from_list(Rlist);')}) - ), - resize_from_list = nFunction( - name = "resize_from_list", - function(Rlist) {for(v in names(Rlist)) - if(exists(v, self, inherits=FALSE)) self[[v]] <- nArray(dim=Rlist[[v]])}, - compileInfo = list( - C_fun=function(Rlist = 'RcppList') {cppLiteral('modelClass_::resize_from_list(Rlist);')}) - ) - ) - # nodes will be a list of membername, nodeFxnName, (node) classname, ctorArgs (list) - node_pieces <- nodes |> lapply(\(x) { - #nClass_type <- paste0(x$nodeFxnName, "()") - init_string <- paste0('nCpp("', x$membername, '( new ', x$classname, '(', - paste0(x$ctorArgs, collapse=","), '))")') - list(nClass_type = x$nodeFxnName, - init_string = init_string, - membername = x$membername) - }) - nodeObjNames <- (node_pieces |> lapply(\(x) x$membername) |> unlist()) %||% character() - # nodeObjNames also serves for canonical lookup of names by index. - # e.g. nodeObjNames[i] gives the member name of the index=i node member. - nodeObjName_2_nodeIndex <- seq_along(nodeObjNames) |> structure(names=nodeObjNames) - # Inversely, nodeobjName_2_nodeIndex["node_3"] gives the index of that node. - CpublicNodeFuns <- node_pieces |> lapply(\(x) x$nClass_type) |> setNames(nodeObjNames) - # CpublicNodeFuns <- list( - # beta_node = 'node_dnorm()' - # ) - CpublicCtor <- list( - nFunction( - function(){}, - compileInfo = list(constructor=TRUE, - #initializers = c('nCpp("beta_node(new node_dnorm(mu, beta, 1))")')) - initializers = node_pieces |> lapply(\(x) x$init_string) |> unlist()) - ) - ) |> structure(names = classname) - initialize <- function(sizes = list(), inits = list()) { - # It is not very easy to set debug onto the initialize function, so - # here is a magic flag. - if(isTRUE(.GlobalEnv$.debugModelInit)) browser() - super$initialize() - if(isCompiled()) - self$setup_node_mgmt_from_names(self$nodeObjNames) - if(!isCompiled()) { - for(nodeObj in self$nodeObjNames) { - self[[nodeObj]] <- eval(as.name(self$CpublicNodeFuns[[nodeObj]]))$new() - self[[nodeObj]]$setModel(self) - } - } - - # First expand any provided or default sizes - # To-Do possibly merge the argument sizes and defaultSizes by element. - if(missing(sizes)) sizes <- self$defaultSizes - if(length(sizes)) resize_from_list(sizes) - - # Then any provided inits over-ride any provided sizes - # To-Do: Ditto - if(missing(inits)) inits <- self$defaultInits - if(length(inits)) init_from_list(inits) - } - baseclass <- paste0("modelClass_<", classname, ">") - # CpublicNodeFuns has elements like "node_1 = quote(nodeFxn_1())" - # We provide it in Cpublic to declare C++ member variables with types. - # We also place the list itself in the class so that we can look up for uncompiled execution - # the objects that need to be created in initialize. - # If we someday make type declarations and initializations more automatic, we can avoid this duplication. - ans <- substitute( - nClass( - classname = CLASSNAME, - inherit = modelBase_nClass, - compileInfo = list(opDefs = OPDEFS, - nClass_inherit = list(base=BASECLASS)#, -# needed_units = list("nodeFxnBase_nClass"), # needed for package=TRUE -# Hincludes = '"nodeFxnBase_nClass_c_.h"' # needed for package=TRUE - ), - Rpublic = RPUBLIC, - Cpublic = CPUBLIC, - env = env - ), - list(OPDEFS = opDefs, - # A list of individual elements - RPUBLIC = list(initialize=initialize, - nodeObjNames = nodeObjNames, - nodeObjName_2_nodeIndex = nodeObjName_2_nodeIndex, - defaultSizes = sizes, - defaultInits = inits, - CpublicNodeFuns = CpublicNodeFuns), - # A concatenation of lists - CPUBLIC = c(CpublicNodeFuns, CpublicModelVars, CpublicCtor, CpublicMethods), - CLASSNAME = classname, - BASECLASS = baseclass) - ) - eval(ans) -} - -## Get varInfo from new nimbleModel -get_varInfo_from_nimbleModel <- function(model) { - mDef <- model$modelDef - extract <- \(x) x |> lapply(\(x) list(name = x$varName, nDim = x$nDim)) - vars <- mDef$varInfo |> extract() - logProbVars <- mDef$logProbVarInfo |> extract() - # The resize_from_list method will error out if a scalar is included. - # The maxs is empty for scalars, so they are automatically omitted from the sizes result here. - extract_sizes <- \(x) x|> lapply(\(x) x$maxs) - sizes <- mDef$varInfo |> extract_sizes() - logProb_sizes <- mDef$logProbVarInfo |> extract_sizes() - list( - vars = c(vars, logProbVars), - sizes = c(sizes, logProb_sizes) - ) -} - -# make_stoch_calculate <- function(LHSrep, RHSrep, logProbExprRep) { -# lenRHS <- length(RHSrep) -# if(length(RHS) > 1) { -# RHSrep[3:(lenRHS+1)] <- RHSrep[2:lenRHS] -# names(RHSrep)[3:(lenRHS+1)] <- names(RHSrep)[2:lenRHS] -# } -# RHSrep[[2]] <- LHSrep -# names(RHSrep)[2] <- "" -# RHSrep[[lenRHS+2]] <- 1 -# names(RHSrep)[lenRHS+2] <- "log" -# # We create separate code for R and C execution. -# calc1Cfun <- substitute( -# function(idx) {LHS <- RHS; return(LHS)}, -# list(LHS = logProbExprRep, RHS = RHSrep) -# ) |> eval() -# make_calculate_from_Cfun(calc1Cfun) -# } - -make_stoch_sim_line <- function(LHSrep, RHSrep) { - BUGSdistName <- safeDeparse(RHSrep[[1]]) - distInfo <- getDistributionInfo(BUGSdistName) - sim_code <- as.name(distInfo$simulateName) - if(is.null(sim_code)) stop("Could not find simulation ('r') function for ", BUGSdistName) - RHSrep[[1]] <- sim_code - # scoot all named arguments right 1 position - if(length(RHSrep) > 1) { - for(i in (length(RHSrep)+1):3) { - RHSrep[i] <- RHSrep[i-1] - names(RHSrep)[i] <- names(RHSrep)[i-1] - } - } - RHSrep[[2]] <- 1 - names(RHSrep)[2] <- '' - sim_line <- substitute( - LHS <- RHS, - list(LHS = LHSrep, RHS = RHSrep)) - sim_line -} - -make_stoch_calc_line <- function(LHSrep, RHSrep, logProbExprRep, diff = FALSE) { - lenRHS <- length(RHSrep) - if(length(RHSrep) > 1) { - RHSrep[3:(lenRHS+1)] <- RHSrep[2:lenRHS] - names(RHSrep)[3:(lenRHS+1)] <- names(RHSrep)[2:lenRHS] - } - RHSrep[[2]] <- LHSrep - names(RHSrep)[2] <- "" - RHSrep[[lenRHS+2]] <- 1 - names(RHSrep)[lenRHS+2] <- "log" - # We create separate code for R and C execution. - if(!diff) { - calc_line <- substitute( - LHS <- RHS, - list(LHS = logProbExprRep, RHS = RHSrep)) - } else { - calc_line <- substitute( - LocalNewLogProb_ <- RHS, - list(RHS = RHSrep)) - } - calc_line -} - -make_determ_calc_line <- function(LHSrep, RHSrep) { - calc_line <- substitute( - LHS <- RHS, - list(LHS = LHSrep, RHS = RHSrep)) - calc_line -} - -make_nFxn_from_Cfun <- function(Cfun) { - Rfun <- Cfun - body(calc1Rfun) <- nm_addModelDollarSign(body(Cfun), exceptionNames = c("idx")) - nFxn <- nFunction( - name = "calc_one", - fun = Rfun, - compileInfo=list(C_fun=Cfun), - argTypes = list(idx = 'integerVector'), - returnType = 'numericScalar') - #nodeVars <- all.vars(body(calc1Cfun)) |> setdiff("idx") - nFxn -} - -make_node_method_nFxn <- function(f, name, returnType='numericScalar') { - Cfun <- f - Rfun <- f - body(Rfun) <- nm_addModelDollarSign(body(f), exceptionNames = c("idx", "LocalNewLogProb_", "LocalAns_")) - if(is.null(returnType)) returnType <- 'void' - nFxn <- nFunction( - name = name, - fun = Rfun, - argTypes = list(idx = 'integerVector'), - returnType = returnType, - compileInfo=list(C_fun=Cfun), - ) - nFxn -} - -make_node_methods_from_declInfo <- function(declInfo) { - # pieces are adapted from Chris' code in nimbleModel and/or old nimble. - # - # This function creates a calc_one nFunction that calculates single index case. - # This will then be used by generic iterator over indices. - # Vectorized cases can be added in this basic framework later. - modelCode <- declInfo$calculateCode - LHS <- modelCode[[2]] - RHS <- modelCode[[3]] - type <- if(modelCode[[1]]=="~") "stoch" else "determ" # or use declInfo$stoch (logical) - context <- declInfo$declRule$context - replacements <- sapply(seq_along(context$singleContexts), - function(i) parse(text = paste0('idx[',i,']'))[[1]]) - names(replacements) <- context$indexVarNames - LHSrep <- eval(substitute(substitute(e, replacements), list(e = LHS))) - RHSrep <- eval(substitute(substitute(e, replacements), list(e = RHS))) - - if(type == 'determ') { - methodList <- eval(substitute( - list( - sim_one = (function(idx) {calc_one(idx)}) |> - make_node_method_nFxn("sim_one", NULL), - calc_one = (function(idx) {DETERMCALC; return(invisible(0))}) |> - make_node_method_nFxn("calc_one"), - calcDiff_one = (function(idx) {calc_one(idx);return(invisible(0))}) |> - make_node_method_nFxn("calcDiff_one"), - getLogProb_one = (function(idx) {return(0)}) |> - make_node_method_nFxn("getLogProb_one") - ), - list(DETERMCALC = make_determ_calc_line(LHSrep, RHSrep)) - )) - } - if(type == 'stoch') { - logProbExpr <- declInfo$genLogProbExpr() - logProbExprRep <- eval(substitute(substitute(e, replacements), list(e = logProbExpr))) - methodList <- eval(substitute( - list( - sim_one = (function(idx) { STOCHSIM }) |> - make_node_method_nFxn("sim_one", NULL), - calc_one = (function(idx) { STOCHCALC; return(invisible(LOGPROB)) }) |> - make_node_method_nFxn("calc_one"), - calcDiff_one = (function(idx) {STOCHCALC_DIFF; LocalAns_ <- LocalNewLogProb_ - LOGPROB; - LOGPROB <- LocalNewLogProb_; return(invisible(LocalAns_))}) |> - make_node_method_nFxn("calcDiff_one"), - getLogProb_one = (function(idx) { return(LOGPROB) }) |> - make_node_method_nFxn("getLogProb_one") - ), - list( LOGPROB = logProbExprRep, - STOCHSIM = make_stoch_sim_line(LHSrep, RHSrep), - STOCHCALC = make_stoch_calc_line(LHSrep, RHSrep, logProbExprRep), - STOCHCALC_DIFF = make_stoch_calc_line(LHSrep, RHSrep, logProbExprRep, diff=TRUE)) - )) - } - methodList -} - -make_model_from_nimbleModel <- function(m, compile=FALSE) { - mDef <- m$modelDef - allVarInfo <- get_varInfo_from_nimbleModel(m) - modelVarInfo <- allVarInfo$vars - nodeFxnNames <- character() - nodeInfoList <- list() - nodeFxnList <- list() - # two vectors for canonical use for calculation instructions - # to move between names and indices of nodeFxns: - for(i in seq_along(mDef$declInfo)) { - declInfo <- mDef$declInfo[[i]] - node_methods <- make_node_methods_from_declInfo(declInfo) - nodeVars <- node_methods |> lapply(\(x) all.vars(body(x))) |> unlist() |> unique() |> setdiff(c("idx", "LocalNewLogProb_", "LocalAns_", "model")) %||% character() - nodeVarInfo <- modelVarInfo[nodeVars] - SLN <- declInfo$sourceLineNumber - node_classname <- paste0("nodeClass_", SLN) # name of an nClass generator - node_RvarName <- paste0("nodeFxn_", SLN) # name of an R variable holding the nClass generator - node_membername <- paste0("node_", SLN) # name of model member variable holding an instance of the nClass - # Currently, we can't just make a list of these but need them as named objects in the environment - nodeFxnList[[node_RvarName]] <- make_node_nClass(nodeVarInfo, node_methods, node_classname) - assign(node_RvarName, - nodeFxnList[[node_RvarName]] - ) - nodeInfoList[[i]] <- nCompiler:::make_node_info_for_model_nClass(node_membername, node_RvarName, node_classname, nodeVarInfo) - } - model <- makeModel_nClass(modelVarInfo, nodeInfoList, classname = "my_model", env = environment()) - if(!compile) - return(model) - Cmodel <- nCompile(model) - return(Cmodel) -} - -calcInputList_to_calcInstrList <- function(calcInputList, comp) { - message("need to set up nodeFxn_2_nodeIndex") - if(missing(comp)) - stop("comp should be a list returned from nCompile including calcInstr_nClass and nodeInstr_nClass") - calcInstrList <- vector(length = length(calcInputList), mode='list') - for(iCalc in seq_along(calcInputList)) { - calcInstr <- comp$calcInstr_nClass$new() - calcInput <- calcInputList[[iCalc]] - calcInstr$nodeIndex <- nodeFxn_2_nodeIndex[ calcInput[[1]] ] #$nodeFxn] - nodeInputVec <- calcInput[[2]]#$nodeInputVec - nodeInstrVec <- vector(length=length(nodeInputVec), mode='list') - for(iMethod in seq_along(nodeInputVec)) { - nodeInstr <- comp$nodeInstr_nClass$new() - nodeInput <- nodeInputVec[[iMethod]] - nodeInstr$methodInstr <- nodeInput[[1]]#$methodInput - nodeInstr$indsInstrVec <- nodeInput[[2]]#$indsInputVec - nodeInstrVec[[iMethod]] <- nodeInstr - } - calcInstr$nodeInstrVec <- nodeInstrVec - calcInstrList[[iCalc]] <- calcInstr - } - calcInstrListObj <- comp$calcInstrList_nClass$new() - calcInstrListObj$calcInstrList <- calcInstrList - return(calcInstrListObj) -} diff --git a/nCompiler/inst/include/nCompiler/predef/calcInstrList_nC_deprecated/calcInstrList_nClass_copyFiles.txt b/nCompiler/inst/include/nCompiler/predef/calcInstrList_nC_deprecated/calcInstrList_nClass_copyFiles.txt deleted file mode 100644 index e69de29b..00000000 diff --git a/nCompiler/inst/include/nCompiler/predef/calcInstrList_nC_deprecated/calcInstrList_nClass_cppContent.cpp b/nCompiler/inst/include/nCompiler/predef/calcInstrList_nC_deprecated/calcInstrList_nClass_cppContent.cpp deleted file mode 100644 index 20bc4cf0..00000000 --- a/nCompiler/inst/include/nCompiler/predef/calcInstrList_nC_deprecated/calcInstrList_nClass_cppContent.cpp +++ /dev/null @@ -1,45 +0,0 @@ -/* OPENER (Do not edit this comment) */ -#ifndef __calcInstrList_nClass_CPP -#define __calcInstrList_nClass_CPP -/* BODY (Do not edit this comment) */ -#ifndef R_NO_REMAP -#define R_NO_REMAP -#endif -#include -#include "calcInstrList_nClass_c_.h" -using namespace Rcpp; -// [[Rcpp::plugins(nCompiler_Eigen_plugin)]] -// [[Rcpp::depends(RcppParallel)]] -// [[Rcpp::depends(nCompiler)]] -// [[Rcpp::depends(Rcereal)]] - - calcInstrList_nClass::calcInstrList_nClass ( ) { -RESET_EIGEN_ERRORS -} - -// [[Rcpp::export(name = "calcInstrList_nClass_new")]] - SEXP new_calcInstrList_nClass ( ) { -RESET_EIGEN_ERRORS -return CREATE_NEW_NCOMP_OBJECT(calcInstrList_nClass);; -} - -// [[Rcpp::export(name = "set_CnClass_env_calcInstrList_nClass_new")]] - void set_CnClass_env_calcInstrList_nClass ( SEXP env ) { -RESET_EIGEN_ERRORS -SET_CNCLASS_ENV(calcInstrList_nClass, env);; -} - -// [[Rcpp::export(name = "get_CnClass_env_calcInstrList_nClass_new")]] - Rcpp::Environment get_CnClass_env_calcInstrList_nClass ( ) { -RESET_EIGEN_ERRORS -return GET_CNCLASS_ENV(calcInstrList_nClass);; -} - -NCOMPILER_INTERFACE( -calcInstrList_nClass, -NCOMPILER_FIELDS( -field("calcInstrList", &calcInstrList_nClass::calcInstrList) -), -NCOMPILER_METHODS() -) -#endif diff --git a/nCompiler/inst/include/nCompiler/predef/calcInstrList_nC_deprecated/calcInstrList_nClass_filebase.txt b/nCompiler/inst/include/nCompiler/predef/calcInstrList_nC_deprecated/calcInstrList_nClass_filebase.txt deleted file mode 100644 index 6b2e8b13..00000000 --- a/nCompiler/inst/include/nCompiler/predef/calcInstrList_nC_deprecated/calcInstrList_nClass_filebase.txt +++ /dev/null @@ -1 +0,0 @@ -calcInstrList_nClass_c_ diff --git a/nCompiler/inst/include/nCompiler/predef/calcInstrList_nC_deprecated/calcInstrList_nClass_hContent.h b/nCompiler/inst/include/nCompiler/predef/calcInstrList_nC_deprecated/calcInstrList_nClass_hContent.h deleted file mode 100644 index a10bb990..00000000 --- a/nCompiler/inst/include/nCompiler/predef/calcInstrList_nC_deprecated/calcInstrList_nClass_hContent.h +++ /dev/null @@ -1,24 +0,0 @@ -/* OPENER (Do not edit this comment) */ -#ifndef __calcInstrList_nClass_H -#define __calcInstrList_nClass_H -/* BODY (Do not edit this comment) */ -#ifndef R_NO_REMAP -#define R_NO_REMAP -#endif -#include -#include "calcInstr_nClass_c_.h" - -class calcInstrList_nClass : public interface_resolver< genericInterfaceC >, public loadedObjectHookC { -public: - calcInstrList_nClass ( ) ; - nCppVec > calcInstrList; -}; - - SEXP new_calcInstrList_nClass ( ) ; - - void set_CnClass_env_calcInstrList_nClass ( SEXP env ) ; - - Rcpp::Environment get_CnClass_env_calcInstrList_nClass ( ) ; - - -#endif diff --git a/nCompiler/inst/include/nCompiler/predef/calcInstrList_nC_deprecated/calcInstrList_nClass_manifest.txt b/nCompiler/inst/include/nCompiler/predef/calcInstrList_nC_deprecated/calcInstrList_nClass_manifest.txt deleted file mode 100644 index c9d48e0f..00000000 --- a/nCompiler/inst/include/nCompiler/predef/calcInstrList_nC_deprecated/calcInstrList_nClass_manifest.txt +++ /dev/null @@ -1,7 +0,0 @@ -list(saved_at = structure(1772141341.98022, class = c("POSIXct", -"POSIXt")), packet_name = "calcInstrList_nClass", elements = c("preamble", -"cppContent", "hContent", "filebase", "post_cpp_compiler", "copyFiles" -), files = list(preamble = "calcInstrList_nClass_preamble.cpp", - cppContent = "calcInstrList_nClass_cppContent.cpp", hContent = "calcInstrList_nClass_hContent.h", - filebase = "calcInstrList_nClass_filebase.txt", post_cpp_compiler = "calcInstrList_nClass_post_cpp_compiler.txt", - copyFiles = "calcInstrList_nClass_copyFiles.txt")) diff --git a/nCompiler/inst/include/nCompiler/predef/calcInstrList_nC_deprecated/calcInstrList_nClass_post_cpp_compiler.txt b/nCompiler/inst/include/nCompiler/predef/calcInstrList_nC_deprecated/calcInstrList_nClass_post_cpp_compiler.txt deleted file mode 100644 index e69de29b..00000000 diff --git a/nCompiler/inst/include/nCompiler/predef/calcInstrList_nC_deprecated/calcInstrList_nClass_preamble.cpp b/nCompiler/inst/include/nCompiler/predef/calcInstrList_nC_deprecated/calcInstrList_nClass_preamble.cpp deleted file mode 100644 index 494e8c39..00000000 --- a/nCompiler/inst/include/nCompiler/predef/calcInstrList_nC_deprecated/calcInstrList_nClass_preamble.cpp +++ /dev/null @@ -1,6 +0,0 @@ -#define NCOMPILER_HANDLE_EIGEN_ERRORS -#define NCOMPILER_USES_EIGEN -// #define NCOMPILER_USES_TBB -#define NCOMPILER_USES_NCPPVEC -#define USES_NCOMPILER -#define NCOMPILER_USES_NCLASS_INTERFACE diff --git a/nCompiler/inst/include/nCompiler/predef/calcInstr_nC/calcInstr_nClass_copyFiles.txt b/nCompiler/inst/include/nCompiler/predef/calcInstr_nC/calcInstr_nClass_copyFiles.txt deleted file mode 100644 index e69de29b..00000000 diff --git a/nCompiler/inst/include/nCompiler/predef/calcInstr_nC/calcInstr_nClass_cppContent.cpp b/nCompiler/inst/include/nCompiler/predef/calcInstr_nC/calcInstr_nClass_cppContent.cpp deleted file mode 100644 index 5c98d3d4..00000000 --- a/nCompiler/inst/include/nCompiler/predef/calcInstr_nC/calcInstr_nClass_cppContent.cpp +++ /dev/null @@ -1,46 +0,0 @@ -/* OPENER (Do not edit this comment) */ -#ifndef __calcInstr_nClass_CPP -#define __calcInstr_nClass_CPP -/* BODY (Do not edit this comment) */ -#ifndef R_NO_REMAP -#define R_NO_REMAP -#endif -#include -#include "calcInstr_nClass_c_.h" -using namespace Rcpp; -// [[Rcpp::plugins(nCompiler_Eigen_plugin)]] -// [[Rcpp::depends(RcppParallel)]] -// [[Rcpp::depends(nCompiler)]] -// [[Rcpp::depends(Rcereal)]] - - calcInstr_nClass::calcInstr_nClass ( ) { -RESET_EIGEN_ERRORS -} - -// [[Rcpp::export(name = "calcInstr_nClass_new")]] - SEXP new_calcInstr_nClass ( ) { -RESET_EIGEN_ERRORS -return CREATE_NEW_NCOMP_OBJECT(calcInstr_nClass);; -} - -// [[Rcpp::export(name = "set_CnClass_env_calcInstr_nClass_new")]] - void set_CnClass_env_calcInstr_nClass ( SEXP env ) { -RESET_EIGEN_ERRORS -SET_CNCLASS_ENV(calcInstr_nClass, env);; -} - -// [[Rcpp::export(name = "get_CnClass_env_calcInstr_nClass_new")]] - Rcpp::Environment get_CnClass_env_calcInstr_nClass ( ) { -RESET_EIGEN_ERRORS -return GET_CNCLASS_ENV(calcInstr_nClass);; -} - -NCOMPILER_INTERFACE( -calcInstr_nClass, -NCOMPILER_FIELDS( -field("nodeIndex", &calcInstr_nClass::nodeIndex), -field("nodeInstrVec", &calcInstr_nClass::nodeInstrVec) -), -NCOMPILER_METHODS() -) -#endif diff --git a/nCompiler/inst/include/nCompiler/predef/calcInstr_nC/calcInstr_nClass_filebase.txt b/nCompiler/inst/include/nCompiler/predef/calcInstr_nC/calcInstr_nClass_filebase.txt deleted file mode 100644 index d7176de5..00000000 --- a/nCompiler/inst/include/nCompiler/predef/calcInstr_nC/calcInstr_nClass_filebase.txt +++ /dev/null @@ -1 +0,0 @@ -calcInstr_nClass_c_ diff --git a/nCompiler/inst/include/nCompiler/predef/calcInstr_nC/calcInstr_nClass_hContent.h b/nCompiler/inst/include/nCompiler/predef/calcInstr_nC/calcInstr_nClass_hContent.h deleted file mode 100644 index 33c01195..00000000 --- a/nCompiler/inst/include/nCompiler/predef/calcInstr_nC/calcInstr_nClass_hContent.h +++ /dev/null @@ -1,26 +0,0 @@ -/* OPENER (Do not edit this comment) */ -#ifndef __calcInstr_nClass_H -#define __calcInstr_nClass_H -/* BODY (Do not edit this comment) */ -#ifndef R_NO_REMAP -#define R_NO_REMAP -#endif -#include -#include "nList_nodeInstr_nClass_c_.h" -#include "nodeInstr_nClass_c_.h" - -class calcInstr_nClass : public interface_resolver< genericInterfaceC >, public loadedObjectHookC { -public: - calcInstr_nClass ( ) ; - int nodeIndex; - std::shared_ptr nodeInstrVec; -}; - - SEXP new_calcInstr_nClass ( ) ; - - void set_CnClass_env_calcInstr_nClass ( SEXP env ) ; - - Rcpp::Environment get_CnClass_env_calcInstr_nClass ( ) ; - - -#endif diff --git a/nCompiler/inst/include/nCompiler/predef/calcInstr_nC/calcInstr_nClass_manifest.txt b/nCompiler/inst/include/nCompiler/predef/calcInstr_nC/calcInstr_nClass_manifest.txt deleted file mode 100644 index d0440acc..00000000 --- a/nCompiler/inst/include/nCompiler/predef/calcInstr_nC/calcInstr_nClass_manifest.txt +++ /dev/null @@ -1,7 +0,0 @@ -list(saved_at = structure(1777917141.79881, class = c("POSIXct", -"POSIXt")), packet_name = "calcInstr_nClass", elements = c("preamble", -"cppContent", "hContent", "filebase", "post_cpp_compiler", "copyFiles" -), files = list(preamble = "calcInstr_nClass_preamble.cpp", cppContent = "calcInstr_nClass_cppContent.cpp", - hContent = "calcInstr_nClass_hContent.h", filebase = "calcInstr_nClass_filebase.txt", - post_cpp_compiler = "calcInstr_nClass_post_cpp_compiler.txt", - copyFiles = "calcInstr_nClass_copyFiles.txt")) diff --git a/nCompiler/inst/include/nCompiler/predef/calcInstr_nC/calcInstr_nClass_post_cpp_compiler.txt b/nCompiler/inst/include/nCompiler/predef/calcInstr_nC/calcInstr_nClass_post_cpp_compiler.txt deleted file mode 100644 index e69de29b..00000000 diff --git a/nCompiler/inst/include/nCompiler/predef/calcInstr_nC/calcInstr_nClass_preamble.cpp b/nCompiler/inst/include/nCompiler/predef/calcInstr_nC/calcInstr_nClass_preamble.cpp deleted file mode 100644 index 494e8c39..00000000 --- a/nCompiler/inst/include/nCompiler/predef/calcInstr_nC/calcInstr_nClass_preamble.cpp +++ /dev/null @@ -1,6 +0,0 @@ -#define NCOMPILER_HANDLE_EIGEN_ERRORS -#define NCOMPILER_USES_EIGEN -// #define NCOMPILER_USES_TBB -#define NCOMPILER_USES_NCPPVEC -#define USES_NCOMPILER -#define NCOMPILER_USES_NCLASS_INTERFACE diff --git a/nCompiler/inst/include/nCompiler/predef/modelBase_nC/modelBase_nClass_copyFiles.txt b/nCompiler/inst/include/nCompiler/predef/modelBase_nC/modelBase_nClass_copyFiles.txt deleted file mode 100644 index e69de29b..00000000 diff --git a/nCompiler/inst/include/nCompiler/predef/modelBase_nC/modelBase_nClass_cppContent.cpp b/nCompiler/inst/include/nCompiler/predef/modelBase_nC/modelBase_nClass_cppContent.cpp deleted file mode 100644 index fe5b5006..00000000 --- a/nCompiler/inst/include/nCompiler/predef/modelBase_nC/modelBase_nClass_cppContent.cpp +++ /dev/null @@ -1,49 +0,0 @@ -/* OPENER (Do not edit this comment) */ -#ifndef __modelBase_nClass_CPP -#define __modelBase_nClass_CPP -/* BODY (Do not edit this comment) */ -#ifndef R_NO_REMAP -#define R_NO_REMAP -#endif -#include -#include "modelBase_nClass_c_.h" -using namespace Rcpp; -// [[Rcpp::plugins(nCompiler_Eigen_plugin)]] -// [[Rcpp::depends(RcppParallel)]] -// [[Rcpp::depends(nCompiler)]] -// [[Rcpp::depends(Rcereal)]] - - bool modelBase_nClass::ping ( ) { -RESET_EIGEN_ERRORS -return(true); -} - double modelBase_nClass::calculate ( std::shared_ptr calcInstrList ) { -RESET_EIGEN_ERRORS -Rprintf("modelBase_nClass calculate (should not see this)\n");; -return(0.0); -} - modelBase_nClass::modelBase_nClass ( ) { -RESET_EIGEN_ERRORS -} - -// [[Rcpp::export(name = "set_CnClass_env_modelBase_nClass_new")]] - void set_CnClass_env_modelBase_nClass ( SEXP env ) { -RESET_EIGEN_ERRORS -SET_CNCLASS_ENV(modelBase_nClass, env);; -} - -// [[Rcpp::export(name = "get_CnClass_env_modelBase_nClass_new")]] - Rcpp::Environment get_CnClass_env_modelBase_nClass ( ) { -RESET_EIGEN_ERRORS -return GET_CNCLASS_ENV(modelBase_nClass);; -} - -NCOMPILER_INTERFACE( -modelBase_nClass, -NCOMPILER_FIELDS(), -NCOMPILER_METHODS( -method("ping", &modelBase_nClass::ping, args({{}})), -method("calculate", &modelBase_nClass::calculate, args({{arg("calcInstrList",copy)}})) -) -) -#endif diff --git a/nCompiler/inst/include/nCompiler/predef/modelBase_nC/modelBase_nClass_filebase.txt b/nCompiler/inst/include/nCompiler/predef/modelBase_nC/modelBase_nClass_filebase.txt deleted file mode 100644 index e8994f83..00000000 --- a/nCompiler/inst/include/nCompiler/predef/modelBase_nC/modelBase_nClass_filebase.txt +++ /dev/null @@ -1 +0,0 @@ -modelBase_nClass_c_ diff --git a/nCompiler/inst/include/nCompiler/predef/modelBase_nC/modelBase_nClass_hContent.h b/nCompiler/inst/include/nCompiler/predef/modelBase_nC/modelBase_nClass_hContent.h deleted file mode 100644 index 656a0a62..00000000 --- a/nCompiler/inst/include/nCompiler/predef/modelBase_nC/modelBase_nClass_hContent.h +++ /dev/null @@ -1,25 +0,0 @@ -/* OPENER (Do not edit this comment) */ -#ifndef __modelBase_nClass_H -#define __modelBase_nClass_H -/* BODY (Do not edit this comment) */ -#ifndef R_NO_REMAP -#define R_NO_REMAP -#endif -#include -#include "nodeFxnBase_nClass_c_.h" -#include "nList_calcInstr_nClass_c_.h" - -class modelBase_nClass : public interface_resolver< genericInterfaceC >, public loadedObjectHookC { -public: - virtual bool ping ( ) ; - virtual double calculate ( std::shared_ptr calcInstrList ) ; - modelBase_nClass ( ) ; -}; - - void set_CnClass_env_modelBase_nClass ( SEXP env ) ; - - Rcpp::Environment get_CnClass_env_modelBase_nClass ( ) ; - -#include - -#endif diff --git a/nCompiler/inst/include/nCompiler/predef/modelBase_nC/modelBase_nClass_manifest.txt b/nCompiler/inst/include/nCompiler/predef/modelBase_nC/modelBase_nClass_manifest.txt deleted file mode 100644 index c2f80d5b..00000000 --- a/nCompiler/inst/include/nCompiler/predef/modelBase_nC/modelBase_nClass_manifest.txt +++ /dev/null @@ -1,7 +0,0 @@ -list(saved_at = structure(1778176589.0932, class = c("POSIXct", -"POSIXt")), packet_name = "modelBase_nClass", elements = c("preamble", -"cppContent", "hContent", "filebase", "post_cpp_compiler", "copyFiles" -), files = list(preamble = "modelBase_nClass_preamble.cpp", cppContent = "modelBase_nClass_cppContent.cpp", - hContent = "modelBase_nClass_hContent.h", filebase = "modelBase_nClass_filebase.txt", - post_cpp_compiler = "modelBase_nClass_post_cpp_compiler.txt", - copyFiles = "modelBase_nClass_copyFiles.txt")) diff --git a/nCompiler/inst/include/nCompiler/predef/modelBase_nC/modelBase_nClass_post_cpp_compiler.txt b/nCompiler/inst/include/nCompiler/predef/modelBase_nC/modelBase_nClass_post_cpp_compiler.txt deleted file mode 100644 index e69de29b..00000000 diff --git a/nCompiler/inst/include/nCompiler/predef/modelBase_nC/modelBase_nClass_preamble.cpp b/nCompiler/inst/include/nCompiler/predef/modelBase_nC/modelBase_nClass_preamble.cpp deleted file mode 100644 index 494e8c39..00000000 --- a/nCompiler/inst/include/nCompiler/predef/modelBase_nC/modelBase_nClass_preamble.cpp +++ /dev/null @@ -1,6 +0,0 @@ -#define NCOMPILER_HANDLE_EIGEN_ERRORS -#define NCOMPILER_USES_EIGEN -// #define NCOMPILER_USES_TBB -#define NCOMPILER_USES_NCPPVEC -#define USES_NCOMPILER -#define NCOMPILER_USES_NCLASS_INTERFACE diff --git a/nCompiler/inst/include/nCompiler/predef/modelClass_/modelClass_.h b/nCompiler/inst/include/nCompiler/predef/modelClass_/modelClass_.h deleted file mode 100644 index 5c884795..00000000 --- a/nCompiler/inst/include/nCompiler/predef/modelClass_/modelClass_.h +++ /dev/null @@ -1,153 +0,0 @@ -// to be included from the predefined modelBase_nClass. -// Add "#include " to that file, -// after the declaration of modelBase_nClass. - - -template -class modelClass_ : public modelBase_nClass { -public: - modelClass_() {}; - std::vector< std::shared_ptr > nodeFxnPtrs; - std::map name2index_map; - double calculate(std::shared_ptr calcInstrList) override { - double logProb(0.0); - const auto& calcInstrVec = calcInstrList->contents(); - auto calcInstr = calcInstrVec.cbegin(); - auto calcInstrEnd = calcInstrVec.cend(); - for( ; calcInstr != calcInstrEnd; ++calcInstr) { - auto nodeFxnPtr = nodeFxnPtrs[(*calcInstr)->nodeIndex-1]; - const auto& nodeInstrVec = (*calcInstr)->nodeInstrVec->contents(); - auto nodeInstr = nodeInstrVec.cbegin(); - auto nodeInstrEnd = nodeInstrVec.cend(); - for( ; nodeInstr != nodeInstrEnd; ) { - logProb += nodeFxnPtr->calculate(*nodeInstr++); - } - } - return(logProb); - } - - // This version takes a character vector of names from R so that - // the ordering of nodeFxns matches that in R, which is important for - // the calculation instructions. - void do_setup_node_mgmt_from_names(Rcpp::CharacterVector names) { - Rprintf("Attempting setup_node_mgmt_from_names with %d names\n", (int)names.length()); - Derived *self = static_cast(this); - const auto& name2access = self->get_name2access(); - nodeFxnPtrs.clear(); - name2index_map.clear(); - size_t n = names.length(); - for(size_t i = 0; i < n; ++i) { - std::string name = Rcpp::as(names[i]); - auto it = name2access.find(name); - if(it != name2access.end()) { - std::shared_ptr ptr = it->second->getInterfacePtr(dynamic_cast(self)); - // When looking up this way, we do expect always to find objects (ptr valid) and that they are nodeFxn ptrs (ptr2 valid). - // So we can turn these messages into errors once things are working. - bool got_one = (ptr != nullptr); - if(got_one) { - Rprintf("HOORAY: field %s is genericInterfaceBaseC\n", name.c_str()); - std::shared_ptr ptr2 = std::dynamic_pointer_cast(ptr); - bool step_two = (ptr2 != nullptr); - if(step_two) { - Rprintf("AND IT IS A NODEFXN PTR!\n"); - name2index_map.emplace(name, nodeFxnPtrs.size()); - nodeFxnPtrs.push_back(ptr2); - } else { - Rprintf("but it is not a nodefxn ptr\n"); - } - } else { - Rprintf("field %s is NOT a genericInterfaceBaseC\n", name.c_str()); - } - } - } - } - - // This version scans all members to find nodeFxns. - // The resulting ordering comes from the order of the name2access map, - // and so may not match R. This was written first but may fall out of common use. - void setup_node_mgmt() { - Derived *self = static_cast(this); - const auto& name2access = self->get_name2access(); - size_t n = name2access.size(); - Rprintf("There are %d member variables indexed:\n", (int)n); - auto i_n2a = name2access.begin(); - auto end_n2a = name2access.end(); - nodeFxnPtrs.clear(); - name2index_map.clear(); - size_t index = 0; - for(; i_n2a != end_n2a; ++i_n2a) { - std::shared_ptr ptr = i_n2a->second->getInterfacePtr(dynamic_cast(self)); - bool got_one = (ptr != nullptr); - if(got_one) { - Rprintf("HOORAY: field %s is genericInterfaceBaseC\n", i_n2a->first.c_str()); - std::shared_ptr ptr2 = std::dynamic_pointer_cast(ptr); - bool step_two = (ptr2 != nullptr); - if(step_two) { - Rprintf("AND IT IS A NODEFXN PTR!\n"); - nodeFxnPtrs.push_back(ptr2); - name2index_map.emplace(i_n2a->first, index++); - } else { - Rprintf("but it is not a nodefxn ptr\n"); - } - } - else - Rprintf("field %s is NOT a genericInterfaceBaseC\n", i_n2a->first.c_str()); - } - } - void c_print_nodes() { - auto i_n2i = name2index_map.begin(); - auto end_n2i = name2index_map.end(); - Rprintf("0-based index: name\n"); - for(; i_n2i != end_n2i; ++i_n2i) { - Rprintf("%d: %s\n", i_n2i->first.c_str(), (int)i_n2i->second); - } - } - void set_from_list(Rcpp::List Rlist) { - Rcpp::CharacterVector Rnames = Rlist.names(); - size_t len = Rnames.length(); - for(size_t i = 0; i < len; ++i) { - // explicit cast is needed because even though Rnames[i] can cast to a string, - // set_value takes a const string& so we need an object in place here. - // set_value fails safely if a name is not found. - static_cast(this)->set_value(std::string(Rnames[i]), Rlist[i]); - } - } - void resize_from_list(Rcpp::List Rlist) { - Rcpp::CharacterVector Rnames = Rlist.names(); - size_t len = Rnames.length(); - size_t vec_len; - Rcpp::IntegerVector vs; - for(size_t i = 0; i < len; ++i) { - // explicit cast is needed because even though Rnames[i] can cast to a string, - // set_value takes a const string& so we need an object in place here. - vs = Rlist[i]; - vec_len = vs.length(); - std::unique_ptr ETA = static_cast(this)->access(std::string(Rnames[i])); - // if the name was not found, a "Problem:" message was emitted, and we skip using it here. - if(ETA) { - switch(vec_len) { - case 0 : - break; - case 1 : - ETA->template ref<1>().resize(vs[0]); - break; - case 2 : - ETA->template ref<2>().resize(vs[0], vs[1]); - break; - case 3 : - ETA->template ref<3>().resize(vs[0], vs[1], vs[2]); - break; - case 4 : - ETA->template ref<4>().resize(vs[0], vs[1], vs[2], vs[3]); - break; - case 5 : - ETA->template ref<5>().resize(vs[0], vs[1], vs[2], vs[3], vs[4]); - break; - case 6 : - ETA->template ref<6>().resize(vs[0], vs[1], vs[2], vs[3], vs[4], vs[5]); - break; - } - } - } - } -}; \ No newline at end of file diff --git a/nCompiler/inst/include/nCompiler/predef/nodeFxnBase_nC/nodeFxnBase_nClass_copyFiles.txt b/nCompiler/inst/include/nCompiler/predef/nodeFxnBase_nC/nodeFxnBase_nClass_copyFiles.txt deleted file mode 100644 index e69de29b..00000000 diff --git a/nCompiler/inst/include/nCompiler/predef/nodeFxnBase_nC/nodeFxnBase_nClass_cppContent.cpp b/nCompiler/inst/include/nCompiler/predef/nodeFxnBase_nC/nodeFxnBase_nClass_cppContent.cpp deleted file mode 100644 index a0f994db..00000000 --- a/nCompiler/inst/include/nCompiler/predef/nodeFxnBase_nC/nodeFxnBase_nClass_cppContent.cpp +++ /dev/null @@ -1,48 +0,0 @@ -/* OPENER (Do not edit this comment) */ -#ifndef __nodeFxnBase_nClass_CPP -#define __nodeFxnBase_nClass_CPP -/* BODY (Do not edit this comment) */ -#ifndef R_NO_REMAP -#define R_NO_REMAP -#endif -#include -#include "nodeFxnBase_nClass_c_.h" -using namespace Rcpp; -// [[Rcpp::plugins(nCompiler_Eigen_plugin)]] -// [[Rcpp::depends(RcppParallel)]] -// [[Rcpp::depends(nCompiler)]] -// [[Rcpp::depends(Rcereal)]] - - bool nodeFxnBase_nClass::ping ( ) { -RESET_EIGEN_ERRORS -return(true); -} - double nodeFxnBase_nClass::calculate ( std::shared_ptr nodeInstr ) { -RESET_EIGEN_ERRORS -return(0.0); -} - nodeFxnBase_nClass::nodeFxnBase_nClass ( ) { -RESET_EIGEN_ERRORS -} - -// [[Rcpp::export(name = "set_CnClass_env_nodeFxnBase_nClass_new")]] - void set_CnClass_env_nodeFxnBase_nClass ( SEXP env ) { -RESET_EIGEN_ERRORS -SET_CNCLASS_ENV(nodeFxnBase_nClass, env);; -} - -// [[Rcpp::export(name = "get_CnClass_env_nodeFxnBase_nClass_new")]] - Rcpp::Environment get_CnClass_env_nodeFxnBase_nClass ( ) { -RESET_EIGEN_ERRORS -return GET_CNCLASS_ENV(nodeFxnBase_nClass);; -} - -NCOMPILER_INTERFACE( -nodeFxnBase_nClass, -NCOMPILER_FIELDS(), -NCOMPILER_METHODS( -method("ping", &nodeFxnBase_nClass::ping, args({{}})), -method("calculate", &nodeFxnBase_nClass::calculate, args({{arg("nodeInstr",copy)}})) -) -) -#endif diff --git a/nCompiler/inst/include/nCompiler/predef/nodeFxnBase_nC/nodeFxnBase_nClass_filebase.txt b/nCompiler/inst/include/nCompiler/predef/nodeFxnBase_nC/nodeFxnBase_nClass_filebase.txt deleted file mode 100644 index 1be34d68..00000000 --- a/nCompiler/inst/include/nCompiler/predef/nodeFxnBase_nC/nodeFxnBase_nClass_filebase.txt +++ /dev/null @@ -1 +0,0 @@ -nodeFxnBase_nClass_c_ diff --git a/nCompiler/inst/include/nCompiler/predef/nodeFxnBase_nC/nodeFxnBase_nClass_hContent.h b/nCompiler/inst/include/nCompiler/predef/nodeFxnBase_nC/nodeFxnBase_nClass_hContent.h deleted file mode 100644 index 828ee435..00000000 --- a/nCompiler/inst/include/nCompiler/predef/nodeFxnBase_nC/nodeFxnBase_nClass_hContent.h +++ /dev/null @@ -1,24 +0,0 @@ -/* OPENER (Do not edit this comment) */ -#ifndef __nodeFxnBase_nClass_H -#define __nodeFxnBase_nClass_H -/* BODY (Do not edit this comment) */ -#ifndef R_NO_REMAP -#define R_NO_REMAP -#endif -#include -#include "nodeInstr_nClass_c_.h" - -class nodeFxnBase_nClass : public interface_resolver< genericInterfaceC >, public loadedObjectHookC { -public: - virtual bool ping ( ) ; - virtual double calculate ( std::shared_ptr nodeInstr ) ; - nodeFxnBase_nClass ( ) ; -}; - - void set_CnClass_env_nodeFxnBase_nClass ( SEXP env ) ; - - Rcpp::Environment get_CnClass_env_nodeFxnBase_nClass ( ) ; - -#include - -#endif diff --git a/nCompiler/inst/include/nCompiler/predef/nodeFxnBase_nC/nodeFxnBase_nClass_manifest.txt b/nCompiler/inst/include/nCompiler/predef/nodeFxnBase_nC/nodeFxnBase_nClass_manifest.txt deleted file mode 100644 index cce5d19b..00000000 --- a/nCompiler/inst/include/nCompiler/predef/nodeFxnBase_nC/nodeFxnBase_nClass_manifest.txt +++ /dev/null @@ -1,7 +0,0 @@ -list(saved_at = structure(1777917314.32296, class = c("POSIXct", -"POSIXt")), packet_name = "nodeFxnBase_nClass", elements = c("preamble", -"cppContent", "hContent", "filebase", "post_cpp_compiler", "copyFiles" -), files = list(preamble = "nodeFxnBase_nClass_preamble.cpp", - cppContent = "nodeFxnBase_nClass_cppContent.cpp", hContent = "nodeFxnBase_nClass_hContent.h", - filebase = "nodeFxnBase_nClass_filebase.txt", post_cpp_compiler = "nodeFxnBase_nClass_post_cpp_compiler.txt", - copyFiles = "nodeFxnBase_nClass_copyFiles.txt")) diff --git a/nCompiler/inst/include/nCompiler/predef/nodeFxnBase_nC/nodeFxnBase_nClass_post_cpp_compiler.txt b/nCompiler/inst/include/nCompiler/predef/nodeFxnBase_nC/nodeFxnBase_nClass_post_cpp_compiler.txt deleted file mode 100644 index e69de29b..00000000 diff --git a/nCompiler/inst/include/nCompiler/predef/nodeFxnBase_nC/nodeFxnBase_nClass_preamble.cpp b/nCompiler/inst/include/nCompiler/predef/nodeFxnBase_nC/nodeFxnBase_nClass_preamble.cpp deleted file mode 100644 index 494e8c39..00000000 --- a/nCompiler/inst/include/nCompiler/predef/nodeFxnBase_nC/nodeFxnBase_nClass_preamble.cpp +++ /dev/null @@ -1,6 +0,0 @@ -#define NCOMPILER_HANDLE_EIGEN_ERRORS -#define NCOMPILER_USES_EIGEN -// #define NCOMPILER_USES_TBB -#define NCOMPILER_USES_NCPPVEC -#define USES_NCOMPILER -#define NCOMPILER_USES_NCLASS_INTERFACE diff --git a/nCompiler/inst/include/nCompiler/predef/nodeFxnClass_/nodeFxnClass_.h b/nCompiler/inst/include/nCompiler/predef/nodeFxnClass_/nodeFxnClass_.h deleted file mode 100644 index 0737ccb6..00000000 --- a/nCompiler/inst/include/nCompiler/predef/nodeFxnClass_/nodeFxnClass_.h +++ /dev/null @@ -1,21 +0,0 @@ -// to be included from the predefined nodeFxnBase_nClass. -// Add "#include " to that file, -// after the declaration of nodeFxnBase_nClass. - -template -class nodeFxnClass_ : public nodeFxnBase_nClass { -public: - double v; - nodeFxnClass_() {}; - - double calculate ( std::shared_ptr nodeInstr ) override { -RESET_EIGEN_ERRORS -double logProb(0.0); -const auto& methodInstr = nodeInstr->methodInstr; -const auto& indsInstrVec = nodeInstr->indsInstrVec; -logProb += static_cast(this)->calc_one((*indsInstrVec)[0]); -return(logProb); - } - - virtual ~nodeFxnClass_() {}; -}; diff --git a/nCompiler/inst/include/nCompiler/predef/nodeInstr_nC/nodeInstr_nClass_copyFiles.txt b/nCompiler/inst/include/nCompiler/predef/nodeInstr_nC/nodeInstr_nClass_copyFiles.txt deleted file mode 100644 index e69de29b..00000000 diff --git a/nCompiler/inst/include/nCompiler/predef/nodeInstr_nC/nodeInstr_nClass_cppContent.cpp b/nCompiler/inst/include/nCompiler/predef/nodeInstr_nC/nodeInstr_nClass_cppContent.cpp deleted file mode 100644 index d372f7f8..00000000 --- a/nCompiler/inst/include/nCompiler/predef/nodeInstr_nC/nodeInstr_nClass_cppContent.cpp +++ /dev/null @@ -1,46 +0,0 @@ -/* OPENER (Do not edit this comment) */ -#ifndef __nodeInstr_nClass_CPP -#define __nodeInstr_nClass_CPP -/* BODY (Do not edit this comment) */ -#ifndef R_NO_REMAP -#define R_NO_REMAP -#endif -#include -#include "nodeInstr_nClass_c_.h" -using namespace Rcpp; -// [[Rcpp::plugins(nCompiler_Eigen_plugin)]] -// [[Rcpp::depends(RcppParallel)]] -// [[Rcpp::depends(nCompiler)]] -// [[Rcpp::depends(Rcereal)]] - - nodeInstr_nClass::nodeInstr_nClass ( ) { -RESET_EIGEN_ERRORS -} - -// [[Rcpp::export(name = "nodeInstr_nClass_new")]] - SEXP new_nodeInstr_nClass ( ) { -RESET_EIGEN_ERRORS -return CREATE_NEW_NCOMP_OBJECT(nodeInstr_nClass);; -} - -// [[Rcpp::export(name = "set_CnClass_env_nodeInstr_nClass_new")]] - void set_CnClass_env_nodeInstr_nClass ( SEXP env ) { -RESET_EIGEN_ERRORS -SET_CNCLASS_ENV(nodeInstr_nClass, env);; -} - -// [[Rcpp::export(name = "get_CnClass_env_nodeInstr_nClass_new")]] - Rcpp::Environment get_CnClass_env_nodeInstr_nClass ( ) { -RESET_EIGEN_ERRORS -return GET_CNCLASS_ENV(nodeInstr_nClass);; -} - -NCOMPILER_INTERFACE( -nodeInstr_nClass, -NCOMPILER_FIELDS( -field("methodInstr", &nodeInstr_nClass::methodInstr), -field("indsInstrVec", &nodeInstr_nClass::indsInstrVec) -), -NCOMPILER_METHODS() -) -#endif diff --git a/nCompiler/inst/include/nCompiler/predef/nodeInstr_nC/nodeInstr_nClass_filebase.txt b/nCompiler/inst/include/nCompiler/predef/nodeInstr_nC/nodeInstr_nClass_filebase.txt deleted file mode 100644 index d98d544e..00000000 --- a/nCompiler/inst/include/nCompiler/predef/nodeInstr_nC/nodeInstr_nClass_filebase.txt +++ /dev/null @@ -1 +0,0 @@ -nodeInstr_nClass_c_ diff --git a/nCompiler/inst/include/nCompiler/predef/nodeInstr_nC/nodeInstr_nClass_hContent.h b/nCompiler/inst/include/nCompiler/predef/nodeInstr_nC/nodeInstr_nClass_hContent.h deleted file mode 100644 index b013b3ba..00000000 --- a/nCompiler/inst/include/nCompiler/predef/nodeInstr_nC/nodeInstr_nClass_hContent.h +++ /dev/null @@ -1,25 +0,0 @@ -/* OPENER (Do not edit this comment) */ -#ifndef __nodeInstr_nClass_H -#define __nodeInstr_nClass_H -/* BODY (Do not edit this comment) */ -#ifndef R_NO_REMAP -#define R_NO_REMAP -#endif -#include -#include "nList_I1_c_.h" - -class nodeInstr_nClass : public interface_resolver< genericInterfaceC >, public loadedObjectHookC { -public: - nodeInstr_nClass ( ) ; - Eigen::Tensor methodInstr; - std::shared_ptr indsInstrVec; -}; - - SEXP new_nodeInstr_nClass ( ) ; - - void set_CnClass_env_nodeInstr_nClass ( SEXP env ) ; - - Rcpp::Environment get_CnClass_env_nodeInstr_nClass ( ) ; - - -#endif diff --git a/nCompiler/inst/include/nCompiler/predef/nodeInstr_nC/nodeInstr_nClass_manifest.txt b/nCompiler/inst/include/nCompiler/predef/nodeInstr_nC/nodeInstr_nClass_manifest.txt deleted file mode 100644 index 9ec4b175..00000000 --- a/nCompiler/inst/include/nCompiler/predef/nodeInstr_nC/nodeInstr_nClass_manifest.txt +++ /dev/null @@ -1,7 +0,0 @@ -list(saved_at = structure(1777917112.83372, class = c("POSIXct", -"POSIXt")), packet_name = "nodeInstr_nClass", elements = c("preamble", -"cppContent", "hContent", "filebase", "post_cpp_compiler", "copyFiles" -), files = list(preamble = "nodeInstr_nClass_preamble.cpp", cppContent = "nodeInstr_nClass_cppContent.cpp", - hContent = "nodeInstr_nClass_hContent.h", filebase = "nodeInstr_nClass_filebase.txt", - post_cpp_compiler = "nodeInstr_nClass_post_cpp_compiler.txt", - copyFiles = "nodeInstr_nClass_copyFiles.txt")) diff --git a/nCompiler/inst/include/nCompiler/predef/nodeInstr_nC/nodeInstr_nClass_post_cpp_compiler.txt b/nCompiler/inst/include/nCompiler/predef/nodeInstr_nC/nodeInstr_nClass_post_cpp_compiler.txt deleted file mode 100644 index e69de29b..00000000 diff --git a/nCompiler/inst/include/nCompiler/predef/nodeInstr_nC/nodeInstr_nClass_preamble.cpp b/nCompiler/inst/include/nCompiler/predef/nodeInstr_nC/nodeInstr_nClass_preamble.cpp deleted file mode 100644 index 494e8c39..00000000 --- a/nCompiler/inst/include/nCompiler/predef/nodeInstr_nC/nodeInstr_nClass_preamble.cpp +++ /dev/null @@ -1,6 +0,0 @@ -#define NCOMPILER_HANDLE_EIGEN_ERRORS -#define NCOMPILER_USES_EIGEN -// #define NCOMPILER_USES_TBB -#define NCOMPILER_USES_NCPPVEC -#define USES_NCOMPILER -#define NCOMPILER_USES_NCLASS_INTERFACE diff --git a/nCompiler/tests/testthat/nimble_tests/test-nimbleModel.R b/nCompiler/tests/testthat/nimble_tests/test-nimbleModel.R deleted file mode 100644 index a4866b55..00000000 --- a/nCompiler/tests/testthat/nimble_tests/test-nimbleModel.R +++ /dev/null @@ -1,206 +0,0 @@ -# Test code needed for new nimbleModel system. -# Some or all of this should eventually go in a separate package. - -library(nCompiler) -library(testthat) - -## # To update the set of predefined nClasses -## # generate new predef/nodeInstr_nC. Move that directly to package code inst/nCompiler/predef/nodeInstr_nC -## nCompile(nodeInstr_nClass, control=list(generate_predefined=TRUE)) -## test <- nCompile(nodeInstr_nClass) -## # -## # generate new predef/calcInstr_nC. Ditto: move directly to package code -## nCompile(calcInstr_nClass, control=list(generate_predefined=TRUE)) -## test <- nCompile(calcInstr_nClass) -## # -## # Previously this was a predefined; not any more. -## # generate new predef/calcInstrList_nC. Ditto: move directly to package code -## #nCompile(calcInstrList_nClass, control=list(generate_predefined=TRUE)) -## #test <- nCompile(calcInstrList_nClass) -## # -## # generate new predef/nodeFxnBase_nC. Move to package and add -## # "#include " in the hContent -## # after declaration of newFxnBase_nClass -## nCompile(nodeFxnBase_nClass, control=list(generate_predefined=TRUE)) -## test <- nCompile(nodeFxnBase_nClass) -## # -## # generate new predef/modelBase_nC. Move to package and add -## # "#include " to that file, -## # after the declaration of modelBase_nClass. -## nCompile(modelBase_nClass, control=list(generate_predefined=TRUE)) -## test <- nCompile(modelBase_nClass) -## #nCompile(nodeFxnBase_nClass, nodeInstr_nClass, control=list(generate_predefined=TRUE)) -## #nCompile(nodeInstr_nClass, calcInstr_nClass, modelBase_nClass, nodeFxnBase_nClass, calcInstrList_nClass, control=list(generate_predefined=TRUE)) - -test_that("nimble model prototype works", { - nodeVarInfo <- list(list(name = "x", nDim = 1), list(name = "mu", nDim = 1), - list(name = "sd", nDim = 0)) - calc_one <- nFunction( - name = "calc_one", - fun = function(inds) { - ans <- model$x[inds[1]] - return(ans) - }, - compileInfo = list( - C_fun = function(inds = 'integerVector') { - returnType('numericScalar') - ans <- x[inds[1]] - return(ans) - } - ) - ) - my_nodeFxn <- nCompiler:::make_node_nClass(nodeVarInfo, list(calc_one=calc_one), "test_node") - my_nodeInfo <- nCompiler:::make_node_info_for_model_nClass("beta_NF1", "my_nodeFxn", "test_node", nodeVarInfo) - - modelVarInfo <- list(list(name="x", nDim = 1), - list(name = "mu", nDim = 1), - list(name = "sd", nDim = 0), - list(name = "gamma", nDim = 2)) - #debug(makeModel_nClass) - ncm1 <- nCompiler:::makeModel_nClass(modelVarInfo, list(my_nodeInfo), classname = "my_model", env=environment()) - #undebug(nCompiler:::addGenericInterface_impl) - #undebug(nCompiler:::nCompile_finish_nonpackage) - for(package in c(FALSE, TRUE)) { - Cncm1 <- nCompile(ncm1, returnList=TRUE, package=package) - #Cncm1 <- nCompile(modelBase_nClass, nodeFxnBase_nClass, calcInstrList_nClass, calcInstr_nClass, nodeInstr_nClass, ncm1, my_nodeFxn) - for(mode in c("uncompiled", "compiled")) { - if(mode=="compiled") { - obj <- Cncm1$ncm1$new() - } else { - obj <- ncm1$new() - } - # obj$do_setup_node_mgmt() - nodeObj <- obj$beta_NF1 - obj$x <- 1:3 - expect_equal(obj$x, 1:3) - - obj$set_from_list(list(x = 10:11)) - # expect Problem msg: (alpha is not a field in the class) - obj$set_from_list(list(mu = 110, x = 11:20, alpha = 101)) - obj$mu - - obj$resize_from_list(list(x = 7)) - # expect Problem msg: - obj$resize_from_list(list(alpha = 5, mu = 3, gamma = c(2, 4))) - expect_equal(length(obj$mu), 3) - expect_equal(dim(obj$gamma), c(2, 4)) - obj$resize_from_list(list(x = 5, gamma = c(3, 5))) - expect_equal(length(obj$x), 5) - expect_equal(dim(obj$gamma), c(3, 5)) - - obj$x <- 11:15 - expect_equal(nodeObj$calc_one(c(3)), 13) - rm(obj, nodeObj); gc() - } - } -}) - -test_that("nodeInstr_nClass and calcInstr_nClass basics work", { - for(package in c(FALSE, TRUE)) { - test <- nCompile(nodeInstr_nClass, calcInstr_nClass, calcInstrList_nClass, control=list(generate_predefined=FALSE), package = package) - calcInstrList <- test$nList_calcInstr_nClass$new() - calcInstr <- test$calcInstr_nClass$new() - expect_equal(calcInstr$nodeInstrVec, NULL) - ni1 <- test$nodeInstr_nClass$new() - ni2 <- test$nodeInstr_nClass$new() - ni1$methodInstr <- 1 - ni2$methodInstr <- 2 -# nList("integerVector")$new() -# ni1$indsInstrVec <- nList("integerVector")$new() - ni1$indsInstrVec[1:2] <- list(1:2, 3:4) - ni2$indsInstrVec - ni2$indsInstrVec[1:2] <- list(11:12, 13:14) - calcInstr$nodeInstrVec - calcInstr$nodeInstrVec[1:2] <- list(ni1, ni2) - - expect_true(length(calcInstr$nodeInstrVec)==2) - expect_identical(calcInstr$nodeInstrVec[[1]]$indsInstrVec |> as.list(), list(1:2, 3:4)) - expect_identical(calcInstr$nodeInstrVec[[2]]$indsInstrVec |> as.list(), list(11:12, 13:14)) - calcInstrList[1] <- list(calcInstr) - expect_equal(calcInstrList |> as.list(), list(calcInstr)) - rm(calcInstrList, calcInstr, ni1, ni2); gc() - } -}) - -###### - -## This is somewhat redundant with the first test -test_that("nimble model variables are set up", { - library(nimbleModel) - code <- quote({ - sd ~ dunif(0, 10) - for(i in 1:5) { - y[i] ~ dnorm(x[i+1], sd = sd) - } - }) - m <- modelClass$new(code) - varInfo <- nCompiler:::get_varInfo_from_nimbleModel(m) - modelVars <- varInfo$vars - # Try making a model with no nodeFxns - ncm1 <- makeModel_nClass(modelVars, list(), classname = "my_model", env = environment()) - Cncm1 <- nCompile(ncm1, returnList=TRUE) - #Cncm1 <- nCompile(modelBase_nClass, nodeFxnBase_nClass, calcInstrList_nClass, calcInstr_nClass, nodeInstr_nClass, ncm1) - obj <- Cncm1$ncm1$new() - obj$resize_from_list(varInfo$sizes) - expect_equal(length(obj$x), 6) - expect_equal(length(obj$y), 5) - expect_equal(length(obj$logProb_y), 5) -}) - -######## -# nOptions(pause_after_writing_files=TRUE) -# Try automating the whole model creation including nodeFxns -# Ditto: this works but relies on nimbleModel -test_that("nimble model with stochastic and deterministic nodes is created and compiles", { - library(nimbleModel) - code <- quote({ - sd ~ dunif(0, 10) - for(i in 1:5) { - z[i] <- x[i+1] + 10 - y[i] ~ dnorm(x[i+1], sd = sd) - } - }) - m <- modelClass$new(code) - - ## Check that a separate R implementation was created - mDef_ <- m$modelDef - dI <- mDef_$declInfo[[2]] - nFxn <- nCompiler:::make_node_methods_from_declInfo(dI) - expect_true(!is.null(NFinternals(nFxn[[1]])$R_fun)) - dI <- mDef_$declInfo[[3]] - nFxn <- nCompiler:::make_node_methods_from_declInfo(dI) - expect_true(!is.null(NFinternals(nFxn[[1]])$R_fun)) - - for(mode in c("uncompiled", "compiled")) { - package_options <- if(mode=="compiled") c(FALSE, TRUE) else TRUE - for(package in package_options) { - nMod <- nCompiler:::make_model_from_nimbleModel(m, compile=FALSE) - if(mode=="compiled") { - expect_no_error(CnMod <- nCompile(nMod, package = package)) - nMod <- CnMod - } - expect_no_error(obj <- nMod$new()) - obj$y <- 1:5 - expect_equal(obj$y, 1:5) - vals <- list(x = 2:7, y = 11:15, sd = 8) - obj$set_from_list(vals) - expect_equal(obj$x, vals$x) - rm(obj); gc() - } - } -}) - -message("test-nimbleModel does not have tests of calculate etc.") - -if(FALSE) { - nodeFxn_2_nodeIndex <- c(nodeFxn_1 = 1, nodeFxn_3 = 2) - - calcInputList <- list(list(nodeFxn="nodeFxn_1", # which declaration (nodeFxn) - nodeInputVec = list(list(methodInput=1, # which index iteration method - indsInputVec=list(1))))) # input(s) to index iterations - - calcInstrList <- calcInputList_to_calcInstrList(calcInputList, test) - - obj$calculate(calcInstrList) -} -########