diff --git a/NEWS.md b/NEWS.md index 0c1fc03..401fcc4 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,8 +1,11 @@ -# spAbundance 0.1.4 +# spAbundance 0.2.0 ++ Updated `svcAbund()` to now work with Poisson and negative binomial families. Note that the function now defaults to use `family = 'Poisson'`, which differs from the previous implementation when only `family = 'Gaussian'` was supported. This switch was done to maintain consistency with other spAbundance model-fitting functions. + Added functionality for independent priors on the species-specific effects to allow species-effects to be treated as fixed effects as opposed to random effects from a common community-level distribution for the following model types: `msNMix()`. + Added in a check at the top of all model fitting functions to return an error when the number of posterior samples saved based on the MCMC criteria (`n.batch`, `batch.length`, `n.samples`, `n.burn`, `n.thin`, `n.chains`) are specified in a way that leads to a non-integer value. In such situations, models would previously run and return without an error, but sometimes the last posterior sample in any given chain could have widely inaccurate values, or values that prevented subsequent functions from working. Thanks to Wendy Leuenberger for bringing this to my attention. ++ Fixed some typos in the documentation. + Updated C++ code to adhere to the new lack of re-mapping of functions in Rinternals.h and R_ext/Error.h when building packages on CRAN. ++ Fixed a typo in the generation of initial values for latent unstructured random effects in all model functions. The typo had no major ramifications, if anything it just led to slower convergence, as it resulted in very large (or very small) initial values for the latent random effects that are not really viable on the log scale. # spAbundance 0.1.3 diff --git a/R/DS.R b/R/DS.R index 581ddbb..10ffd76 100644 --- a/R/DS.R +++ b/R/DS.R @@ -537,7 +537,7 @@ DS <- function(abund.formula, det.formula, data, inits, priors, tuning, } } beta.star.indx <- rep(0:(p.abund.re - 1), n.abund.re.long) - beta.star.inits <- rnorm(n.abund.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.abund.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) } else { sigma.sq.mu.inits <- 0 beta.star.indx <- 0 @@ -777,7 +777,7 @@ DS <- function(abund.formula, det.formula, data, inits, priors, tuning, alpha.inits <- runif(p.det, -10, 10) if (p.abund.re > 0) { sigma.sq.mu.inits <- runif(p.abund.re, 0.05, 1) - beta.star.inits <- rnorm(n.abund.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.abund.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) } if (p.det.re > 0) { sigma.sq.p.inits <- runif(p.det.re, 0.05, 0.5) diff --git a/R/NMix.R b/R/NMix.R index 2919745..9dba503 100644 --- a/R/NMix.R +++ b/R/NMix.R @@ -576,7 +576,7 @@ NMix <- function(abund.formula, det.formula, data, inits, priors, tuning, } } beta.star.indx <- rep(0:(p.abund.re - 1), n.abund.re.long) - beta.star.inits <- rnorm(n.abund.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.abund.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) } else { sigma.sq.mu.inits <- 0 beta.star.indx <- 0 @@ -606,7 +606,7 @@ NMix <- function(abund.formula, det.formula, data, inits, priors, tuning, } } alpha.star.indx <- rep(0:(p.det.re - 1), n.det.re.long) - alpha.star.inits <- rnorm(n.det.re, sqrt(sigma.sq.p.inits[alpha.star.indx + 1])) + alpha.star.inits <- rnorm(n.det.re, 0, sqrt(sigma.sq.p.inits[alpha.star.indx + 1])) } else { sigma.sq.p.inits <- 0 alpha.star.indx <- 0 @@ -811,11 +811,11 @@ NMix <- function(abund.formula, det.formula, data, inits, priors, tuning, alpha.inits <- rnorm(p.det, 0, 1) if (p.abund.re > 0) { sigma.sq.mu.inits <- runif(p.abund.re, 0.05, 2) - beta.star.inits <- rnorm(n.abund.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.abund.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) } if (p.det.re > 0) { sigma.sq.p.inits <- runif(p.det.re, 0.05, 2) - alpha.star.inits <- rnorm(n.det.re, sqrt(sigma.sq.p.inits[alpha.star.indx + 1])) + alpha.star.inits <- rnorm(n.det.re, 0, sqrt(sigma.sq.p.inits[alpha.star.indx + 1])) } if (family == 'NB') { kappa.inits <- runif(1, kappa.a, kappa.b) diff --git a/R/abund.R b/R/abund.R index f5135e7..d835c98 100644 --- a/R/abund.R +++ b/R/abund.R @@ -395,7 +395,7 @@ abund <- function(formula, data, inits, priors, tuning, } } beta.star.indx <- rep(0:(p.abund.re - 1), n.abund.re.long) - beta.star.inits <- rnorm(n.abund.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.abund.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) } else { sigma.sq.mu.inits <- 0 beta.star.indx <- 0 @@ -545,7 +545,7 @@ abund <- function(formula, data, inits, priors, tuning, } if (p.abund.re > 0) { sigma.sq.mu.inits <- runif(p.abund.re, 0.05, 1) - beta.star.inits <- rnorm(n.abund.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.abund.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) } } storage.mode(chain.info) <- "integer" diff --git a/R/abundGaussian.R b/R/abundGaussian.R index c98fa38..15d90f8 100644 --- a/R/abundGaussian.R +++ b/R/abundGaussian.R @@ -364,7 +364,7 @@ abundGaussian <- function(formula, data, inits, priors, tuning, n.batch, } } beta.star.indx <- rep(0:(p.re - 1), n.re.long) - beta.star.inits <- rnorm(n.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) } else { sigma.sq.mu.inits <- 0 beta.star.indx <- 0 @@ -449,7 +449,7 @@ abundGaussian <- function(formula, data, inits, priors, tuning, n.batch, beta.inits <- rnorm(p, mu.beta, sqrt(sigma.beta)) if (p.re > 0) { sigma.sq.mu.inits <- runif(p.re, 0.5, 10) - beta.star.inits <- rnorm(n.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) } tau.sq.inits <- runif(1, 0.1, 10) } diff --git a/R/generics.R b/R/generics.R index 4bfa39c..6b77419 100644 --- a/R/generics.R +++ b/R/generics.R @@ -494,7 +494,7 @@ predict.spAbund <- function(object, X.0, coords.0, if (object$dist %in% c('Gaussian', 'zi-Gaussian')) { predict.svcAbund(object, X.0, coords.0, n.omp.threads, - verbose, n.report, ignore.RE, z.0.samples) + verbose, n.report, ignore.RE, z.0.samples, include.sp) } else { ptm <- proc.time() # Check for unused arguments ------------------------------------------ @@ -520,8 +520,8 @@ predict.spAbund <- function(object, X.0, coords.0, if (missing(object)) { stop("error: predict expects object\n") } - if (!(class(object) %in% c('spAbund'))) { - stop("error: requires an output object of class spAbund\n") + if (!(class(object) %in% c('spAbund', 'svcAbund'))) { + stop("error: requires an output object of class spAbund, svcAbund\n") } if (missing(X.0)) { @@ -557,11 +557,20 @@ predict.spAbund <- function(object, X.0, coords.0, X.0 <- X.0[non.missing.indx, , drop = FALSE] n.post <- object$n.post * object$n.chains + p.abund <- dim(X)[3] X <- object$X + if (is(object, 'spAbund')) { + svc.cols <- 1 + p.svc <- 1 + X.w.0 <- matrix(1, nrow = X.0, ncol = 1) + } else { + svc.cols <- object$svc.cols + p.svc <- length(svc.cols) + X.w.0 <- X.0[, svc.cols, drop = FALSE] + } coords <- object$coords n.obs <- sum(!is.na(object$y)) J <- nrow(coords) - p.abund <- dim(X)[3] theta.samples <- object$theta.samples beta.samples <- object$beta.samples w.samples <- object$w.samples @@ -580,10 +589,6 @@ predict.spAbund <- function(object, X.0, coords.0, coords.indx <- match.indx[!is.na(match.indx)] coords.place.indx <- which(!is.na(match.indx)) - # if (length(coords.indx) == nrow(X.0)) { - # stop("error: no new locations to predict at. See object$psi.samples for occurrence probabilities at sampled sites.") - # } - if (object$muRE & !ignore.RE) { beta.star.samples <- object$beta.star.samples re.level.names <- object$re.level.names @@ -669,7 +674,11 @@ predict.spAbund <- function(object, X.0, coords.0, } # Sub-sample previous beta.samples <- t(beta.samples) + w.samples <- matrix(w.samples, n.post, J * p.svc) + # Order: iteration, site within iteration, svc within site. + # Example: site 1, svc 1, iter 1, site 1, svc 2, iter 1, ..., site 2, svc 1, iter 1 w.samples <- t(w.samples) + beta.star.sites.0.samples <- t(beta.star.sites.0.samples) if (object$dist == 'NB') { kappa.samples <- t(object$kappa.samples) @@ -701,8 +710,10 @@ predict.spAbund <- function(object, X.0, coords.0, storage.mode(J) <- "integer" storage.mode(n.obs) <- "integer" storage.mode(p.abund) <- "integer" + storage.mode(p.svc) <- "integer" storage.mode(n.neighbors) <- "integer" storage.mode(X.fix) <- "double" + storage.mode(X.w.0) <- 'double' storage.mode(coords.0) <- "double" storage.mode(J.0) <- "integer" storage.mode(n.obs.0) <- "integer" @@ -724,11 +735,11 @@ predict.spAbund <- function(object, X.0, coords.0, ptm <- proc.time() - out <- .Call("spAbundNNGPPredict", coords, J, n.obs, p.abund, n.neighbors, - X.fix, coords.0, J.0, n.obs.0, sites.link, sites.0.sampled, sites.0.indx, - nn.indx.0, beta.samples, + out <- .Call("svcAbundNNGPPredict", coords, J, n.obs, p.abund, p.svc, n.neighbors, + X.fix, X.w.0, coords.0, J.0, n.obs.0, sites.link, sites.0.sampled, sites.0.indx, + nn.indx.0, beta.samples, theta.samples, w.samples, beta.star.sites.0.samples, kappa.samples, - n.post, cov.model.indx, n.omp.threads, verbose, n.report, family.c) + n.post, cov.model.indx, n.omp.threads, verbose, n.report, family.c) } tmp <- matrix(NA, n.post, length(c(missing.indx, non.missing.indx))) @@ -737,12 +748,19 @@ predict.spAbund <- function(object, X.0, coords.0, tmp <- matrix(NA, n.post, length(c(missing.indx, non.missing.indx))) tmp[, non.missing.indx] <- t(out$mu.0.samples) out$mu.0.samples <- array(tmp, dim = c(n.post, J.0, K.max.0)) - out$w.0.samples <- mcmc(t(out$w.0.samples)) + out$w.0.samples <- array(out$w.0.samples, dim = c(p.svc, J.0, n.post)) + out$w.0.samples <- aperm(out$w.0.samples, c(3, 1, 2)) + if (is(object, 'spAbund')) { + out$w.0.samples <- mcmc(matrix(out$w.0.samples[, 1, ], n.post, J.0)) + } out$run.time <- proc.time() - ptm } out$call <- cl out$object.class <- class(object) - class(out) <- "predict.spAbund" + class(out) <- 'predict.svcAbund' + if (is(object, 'spAbund')) { + class(out) <- "predict.spAbund" + } out } } @@ -3301,7 +3319,7 @@ predict.sfMsNMix <- function(object, X.0, coords.0, n.omp.threads = 1, X.fix, coords.0, J.str, nn.indx.0, beta.samples, theta.samples, kappa.samples, lambda.samples, w.samples, beta.star.sites.0.samples, n.post, - cov.model.indx, n.omp.threads, verbose, n.report, + cov.model.indx, n.omp.threads, verbose, n.report, sites.link, sites.0.sampled) } out$N.0.samples <- array(out$N.0.samples, dim = c(n.sp, J.str, n.post)) @@ -4387,269 +4405,275 @@ fitted.svcAbund <- function(object, ...) { return(object$y.rep.samples) } -summary.svcAbund <- function(object, - quantiles = c(0.025, 0.5, 0.975), - digits = max(3L, getOption("digits") - 3L), ...) { +summary.svcAbund <- function(object, quantiles = c(0.025, 0.5, 0.975), + digits = max(3L, getOption("digits") - 3L), ...) { summary.spAbund(object, quantiles, digits) - } predict.svcAbund <- function(object, X.0, coords.0, n.omp.threads = 1, verbose = TRUE, n.report = 100, - ignore.RE = FALSE, z.0.samples, ...) { - # Check for unused arguments ------------------------------------------ - formal.args <- names(formals(sys.function(sys.parent()))) - elip.args <- names(list(...)) - for(i in elip.args){ - if(! i %in% formal.args) - warning("'",i, "' is not an argument") - } - # Call ---------------------------------------------------------------- - cl <- match.call() - - # Functions --------------------------------------------------------------- - logit <- function(theta, a = 0, b = 1) {log((theta-a)/(b-theta))} - logit.inv <- function(z, a = 0, b = 1) {b-(b-a)/(1+exp(z))} + ignore.RE = FALSE, z.0.samples, + include.sp = TRUE, ...) { - # Some initial checks --------------------------------------------------- - if (missing(object)) { - stop("error: predict expects object\n") - } + if (object$dist %in% c('Poisson', 'NB')) { + predict.spAbund(object, X.0, coords.0, n.omp.threads, verbose, + n.report, ignore.RE, z.0.samples, include.sp) + } else { + # Check for unused arguments ------------------------------------------ + formal.args <- names(formals(sys.function(sys.parent()))) + elip.args <- names(list(...)) + for(i in elip.args){ + if(! i %in% formal.args) + warning("'",i, "' is not an argument") + } + # Call ---------------------------------------------------------------- + cl <- match.call() - # Check X.0 ------------------------------------------------------------- - if (missing(X.0)) { - stop("error: X.0 must be specified\n") - } - if (!any(is.data.frame(X.0), is.matrix(X.0))) { - stop("error: X.0 must be a data.frame or matrix\n") - } + # Functions --------------------------------------------------------------- + logit <- function(theta, a = 0, b = 1) {log((theta-a)/(b-theta))} + logit.inv <- function(z, a = 0, b = 1) {b-(b-a)/(1+exp(z))} - # Abundance predictions ------------------------------------------------ - if (missing(coords.0)) { - stop("error: coords.0 must be specified\n") - } - if (!any(is.data.frame(coords.0), is.matrix(coords.0))) { - stop("error: coords.0 must be a data.frame or matrix\n") - } - if (!ncol(coords.0) == 2){ - stop("error: coords.0 must have two columns\n") - } - coords.0 <- as.matrix(coords.0) + # Some initial checks --------------------------------------------------- + if (missing(object)) { + stop("error: predict expects object\n") + } - p.abund <- ncol(object$X) - p.design <- p.abund - X <- object$X - if (is(object, 'spAbund') & object$dist %in% c('Gaussian', 'zi-Gaussian')) { - svc.cols <- 1 - p.svc <- 1 - X.w.0 <- matrix(1, nrow = nrow(X.0), ncol = 1) - X.w <- matrix(1, nrow = nrow(object$X), ncol = 1) - } else { - svc.cols <- object$svc.cols - p.svc <- length(svc.cols) - X.w.0 <- X.0[, svc.cols, drop = FALSE] - X.w <- object$X.w - } - coords <- object$coords - J <- nrow(X) - beta.samples <- as.matrix(object$beta.samples) - n.post <- object$n.post * object$n.chains - family <- object$dist - family.c <- ifelse(family == 'zi-Gaussian', 3, 2) - theta.samples <- object$theta.samples - w.samples <- object$w.samples - n.neighbors <- object$n.neighbors - cov.model.indx <- object$cov.model.indx - re.cols <- object$re.cols - sp.type <- object$type - out <- list() - if (object$muRE) { - p.abund.re <- length(object$re.level.names) - } else { - p.abund.re <- 0 - } + # Check X.0 ------------------------------------------------------------- + if (missing(X.0)) { + stop("error: X.0 must be specified\n") + } + if (!any(is.data.frame(X.0), is.matrix(X.0))) { + stop("error: X.0 must be a data.frame or matrix\n") + } - # Eliminate prediction sites that have already sampled been for now - match.indx <- match(do.call("paste", as.data.frame(coords.0)), do.call("paste", as.data.frame(coords))) - coords.0.indx <- which(is.na(match.indx)) - coords.indx <- match.indx[!is.na(match.indx)] - coords.place.indx <- which(!is.na(match.indx)) - # coords.0.new <- coords.0[coords.0.indx, , drop = FALSE] - # X.0.new <- X.0[coords.0.indx, , drop = FALSE] + # Abundance predictions ------------------------------------------------ + if (missing(coords.0)) { + stop("error: coords.0 must be specified\n") + } + if (!any(is.data.frame(coords.0), is.matrix(coords.0))) { + stop("error: coords.0 must be a data.frame or matrix\n") + } + if (!ncol(coords.0) == 2){ + stop("error: coords.0 must have two columns\n") + } + coords.0 <- as.matrix(coords.0) - if (object$muRE & !ignore.RE) { - beta.star.samples <- object$beta.star.samples - re.level.names <- object$re.level.names - # Get columns in design matrix with random effects - x.re.names <- colnames(object$X.re) - x.0.names <- colnames(X.0) - re.long.indx <- sapply(re.cols, length) - tmp <- sapply(x.re.names, function(a) which(colnames(X.0) %in% a)) - indx <- list() - for (i in 1:length(tmp)) { - indx[[i]] <- rep(tmp[i], re.long.indx[i]) + p.abund <- ncol(object$X) + p.design <- p.abund + X <- object$X + if (is(object, 'spAbund') & object$dist %in% c('Gaussian', 'zi-Gaussian')) { + svc.cols <- 1 + p.svc <- 1 + X.w.0 <- matrix(1, nrow = nrow(X.0), ncol = 1) + X.w <- matrix(1, nrow = nrow(object$X), ncol = 1) + } else { + svc.cols <- object$svc.cols + p.svc <- length(svc.cols) + X.w.0 <- X.0[, svc.cols, drop = FALSE] + X.w <- object$X.w } - indx <- unlist(indx) - if (length(indx) == 0) { - stop("error: column names in X.0 must match variable names in data$abund.covs") + coords <- object$coords + J <- nrow(X) + beta.samples <- as.matrix(object$beta.samples) + n.post <- object$n.post * object$n.chains + family <- object$dist + family.c <- ifelse(family == 'zi-Gaussian', 3, 2) + theta.samples <- object$theta.samples + w.samples <- object$w.samples + n.neighbors <- object$n.neighbors + cov.model.indx <- object$cov.model.indx + re.cols <- object$re.cols + sp.type <- object$type + out <- list() + if (object$muRE) { + p.abund.re <- length(object$re.level.names) + } else { + p.abund.re <- 0 } - n.abund.re <- length(indx) - n.unique.abund.re <- length(unique(indx)) - # Check RE columns - for (i in 1:n.abund.re) { - if (is.character(re.cols[[i]])) { - # Check if all column names in svc are in occ.covs - if (!all(re.cols[[i]] %in% x.0.names)) { - missing.cols <- re.cols[[i]][!(re.cols[[i]] %in% x.0.names)] - stop(paste("error: variable name ", paste(missing.cols, collapse=" and "), " not in abundance covariates", sep="")) - } - # Convert desired column names into the numeric column index - re.cols[[i]] <- which(x.0.names %in% re.cols[[i]]) - } else if (is.numeric(re.cols[[i]])) { - # Check if all column indices are in 1:p.abund - if (!all(re.cols %in% 1:p.abund)) { - missing.cols <- re.cols[[i]][!(re.cols[[i]] %in% (1:p.abund))] - stop(paste("error: column index ", paste(missing.cols, collapse=" "), " not in design matrix columns", sep="")) + # Eliminate prediction sites that have already sampled been for now + match.indx <- match(do.call("paste", as.data.frame(coords.0)), do.call("paste", as.data.frame(coords))) + coords.0.indx <- which(is.na(match.indx)) + coords.indx <- match.indx[!is.na(match.indx)] + coords.place.indx <- which(!is.na(match.indx)) + # coords.0.new <- coords.0[coords.0.indx, , drop = FALSE] + # X.0.new <- X.0[coords.0.indx, , drop = FALSE] + + if (object$muRE & !ignore.RE) { + beta.star.samples <- object$beta.star.samples + re.level.names <- object$re.level.names + # Get columns in design matrix with random effects + x.re.names <- colnames(object$X.re) + x.0.names <- colnames(X.0) + re.long.indx <- sapply(re.cols, length) + tmp <- sapply(x.re.names, function(a) which(colnames(X.0) %in% a)) + indx <- list() + for (i in 1:length(tmp)) { + indx[[i]] <- rep(tmp[i], re.long.indx[i]) + } + indx <- unlist(indx) + if (length(indx) == 0) { + stop("error: column names in X.0 must match variable names in data$abund.covs") + } + n.abund.re <- length(indx) + n.unique.abund.re <- length(unique(indx)) + # Check RE columns + for (i in 1:n.abund.re) { + if (is.character(re.cols[[i]])) { + # Check if all column names in svc are in occ.covs + if (!all(re.cols[[i]] %in% x.0.names)) { + missing.cols <- re.cols[[i]][!(re.cols[[i]] %in% x.0.names)] + stop(paste("error: variable name ", paste(missing.cols, collapse=" and "), " not in abundance covariates", sep="")) + } + # Convert desired column names into the numeric column index + re.cols[[i]] <- which(x.0.names %in% re.cols[[i]]) + + } else if (is.numeric(re.cols[[i]])) { + # Check if all column indices are in 1:p.abund + if (!all(re.cols %in% 1:p.abund)) { + missing.cols <- re.cols[[i]][!(re.cols[[i]] %in% (1:p.abund))] + stop(paste("error: column index ", paste(missing.cols, collapse=" "), " not in design matrix columns", sep="")) + } } } - } - re.cols <- unlist(re.cols) - X.re <- as.matrix(X.0[, indx, drop = FALSE]) - X.fix <- as.matrix(X.0[, -indx, drop = FALSE]) - X.random <- as.matrix(X.0[, re.cols, drop = FALSE]) - n.abund.re <- length(unlist(re.level.names)) - X.re.ind <- matrix(NA, nrow(X.re), p.abund.re) - for (i in 1:p.abund.re) { - for (j in 1:nrow(X.re)) { - tmp <- which(re.level.names[[i]] == X.re[j, i]) - if (length(tmp) > 0) { - X.re.ind[j, i] <- tmp + re.cols <- unlist(re.cols) + X.re <- as.matrix(X.0[, indx, drop = FALSE]) + X.fix <- as.matrix(X.0[, -indx, drop = FALSE]) + X.random <- as.matrix(X.0[, re.cols, drop = FALSE]) + n.abund.re <- length(unlist(re.level.names)) + X.re.ind <- matrix(NA, nrow(X.re), p.abund.re) + for (i in 1:p.abund.re) { + for (j in 1:nrow(X.re)) { + tmp <- which(re.level.names[[i]] == X.re[j, i]) + if (length(tmp) > 0) { + X.re.ind[j, i] <- tmp + } } } - } - if (p.abund.re > 1) { - for (j in 2:p.abund.re) { - X.re.ind[, j] <- X.re.ind[, j] + max(X.re.ind[, j - 1]) + if (p.abund.re > 1) { + for (j in 2:p.abund.re) { + X.re.ind[, j] <- X.re.ind[, j] + max(X.re.ind[, j - 1]) + } } + # Create the random effects corresponding to each + # new location + # ORDER: ordered by site, then species within site. + beta.star.sites.0.samples <- matrix(0, n.post, nrow(X.re)) + for (t in 1:p.abund.re) { + for (j in 1:nrow(X.re)) { + if (!is.na(X.re.ind[j, t])) { + beta.star.sites.0.samples[, j] <- + beta.star.samples[, X.re.ind[j, t]] * X.random[j, t] + + beta.star.sites.0.samples[, j] + } else { + beta.star.sites.0.samples[, j] <- + rnorm(n.post, 0, sqrt(object$sigma.sq.mu.samples[, t])) * X.random[j, t] + + beta.star.sites.0.samples[, j] + } + } # j + } # t + } else { + X.fix <- X.0 + beta.star.sites.0.samples <- matrix(0, n.post, nrow(X.0)) + p.abund.re <- 0 } - # Create the random effects corresponding to each - # new location - # ORDER: ordered by site, then species within site. - beta.star.sites.0.samples <- matrix(0, n.post, nrow(X.re)) - for (t in 1:p.abund.re) { - for (j in 1:nrow(X.re)) { - if (!is.na(X.re.ind[j, t])) { - beta.star.sites.0.samples[, j] <- - beta.star.samples[, X.re.ind[j, t]] * X.random[j, t] + - beta.star.sites.0.samples[, j] - } else { - beta.star.sites.0.samples[, j] <- - rnorm(n.post, 0, sqrt(object$sigma.sq.mu.samples[, t])) * X.random[j, t] + - beta.star.sites.0.samples[, j] - } - } # j - } # t - } else { - X.fix <- X.0 - beta.star.sites.0.samples <- matrix(0, n.post, nrow(X.0)) - p.abund.re <- 0 - } - # Get samples in proper format for C++ - beta.samples <- t(beta.samples) - w.samples <- matrix(w.samples, n.post, J * p.svc) - # Order: iteration, site within iteration, svc within site. - # Example: site 1, svc 1, iter 1, site 1, svc 2, iter 1, ..., site 2, svc 1, iter 1 - w.samples <- t(w.samples) - beta.star.sites.0.samples <- t(beta.star.sites.0.samples) - if (family %in% c('Gaussian', 'zi-Gaussian')) { - tau.sq.samples <- t(object$tau.sq.samples) - } else { - tau.sq.samples <- matrix(0, 1, n.post) - } - theta.samples <- t(theta.samples) + # Get samples in proper format for C++ + beta.samples <- t(beta.samples) + w.samples <- matrix(w.samples, n.post, J * p.svc) + # Order: iteration, site within iteration, svc within site. + # Example: site 1, svc 1, iter 1, site 1, svc 2, iter 1, ..., site 2, svc 1, iter 1 + w.samples <- t(w.samples) + beta.star.sites.0.samples <- t(beta.star.sites.0.samples) + if (family %in% c('Gaussian', 'zi-Gaussian')) { + tau.sq.samples <- t(object$tau.sq.samples) + } else { + tau.sq.samples <- matrix(0, 1, n.post) + } + theta.samples <- t(theta.samples) - sites.0.indx <- 0:(nrow(X.0) - 1) - J.0 <- length(unique(sites.0.indx)) - sites.0.sampled <- ifelse(!is.na(match.indx), 1, 0) - sites.link <- rep(NA, J.0) - sites.link[which(!is.na(match.indx))] <- coords.indx - # For C - sites.link <- sites.link - 1 + sites.0.indx <- 0:(nrow(X.0) - 1) + J.0 <- length(unique(sites.0.indx)) + sites.0.sampled <- ifelse(!is.na(match.indx), 1, 0) + sites.link <- rep(NA, J.0) + sites.link[which(!is.na(match.indx))] <- coords.indx + # For C + sites.link <- sites.link - 1 - # Check stage 1 samples - if (family == 'zi-Gaussian') { - if (missing(z.0.samples)) { - stop("z.0.samples must be supplied for a zi-Gaussian model") - } - if (!is.matrix(z.0.samples)) { - stop(paste("z.0.samples must be a matrix with ", n.post, " rows and ", - J.0, " columns.", sep = '')) - } - if (nrow(z.0.samples) != n.post | ncol(z.0.samples) != J.0) { - stop(paste("z.0.samples must be a matrix with ", n.post, " rows and ", - J.0, " columns.", sep = '')) - } - } else { - if (!missing(z.0.samples)) { - message("z.0.samples is ignored for the current model family\n") + # Check stage 1 samples + if (family == 'zi-Gaussian') { + if (missing(z.0.samples)) { + stop("z.0.samples must be supplied for a zi-Gaussian model") + } + if (!is.matrix(z.0.samples)) { + stop(paste("z.0.samples must be a matrix with ", n.post, " rows and ", + J.0, " columns.", sep = '')) + } + if (nrow(z.0.samples) != n.post | ncol(z.0.samples) != J.0) { + stop(paste("z.0.samples must be a matrix with ", n.post, " rows and ", + J.0, " columns.", sep = '')) + } + } else { + if (!missing(z.0.samples)) { + message("z.0.samples is ignored for the current model family\n") + } + z.0.samples <- NA } - z.0.samples <- NA - } - z.0.samples <- t(z.0.samples) - - if (sp.type == 'GP') { - stop("NNGP = FALSE is not currently supported for svcAbund") - } else { - # Get nearest neighbors - # nn2 is a function from RANN. - nn.indx.0 <- nn2(coords, coords.0, k=n.neighbors)$nn.idx-1 + z.0.samples <- t(z.0.samples) - storage.mode(coords) <- "double" - storage.mode(J) <- "integer" - storage.mode(p.abund) <- "integer" - storage.mode(p.svc) <- 'integer' - storage.mode(n.neighbors) <- "integer" - storage.mode(X.fix) <- "double" - storage.mode(X.w.0) <- 'double' - storage.mode(coords.0) <- "double" - storage.mode(J.0) <- "integer" - storage.mode(sites.link) <- "integer" - storage.mode(sites.0.sampled) <- 'integer' - storage.mode(sites.0.indx) <- 'integer' - storage.mode(beta.samples) <- "double" - storage.mode(theta.samples) <- "double" - storage.mode(tau.sq.samples) <- "double" - storage.mode(family.c) <- "integer" - storage.mode(w.samples) <- "double" - storage.mode(beta.star.sites.0.samples) <- "double" - storage.mode(n.post) <- "integer" - storage.mode(cov.model.indx) <- "integer" - storage.mode(nn.indx.0) <- "integer" - storage.mode(n.omp.threads) <- "integer" - storage.mode(verbose) <- "integer" - storage.mode(n.report) <- "integer" - storage.mode(z.0.samples) <- "double" + if (sp.type == 'GP') { + stop("NNGP = FALSE is not currently supported for svcAbund") + } else { + # Get nearest neighbors + # nn2 is a function from RANN. + nn.indx.0 <- nn2(coords, coords.0, k=n.neighbors)$nn.idx-1 + + storage.mode(coords) <- "double" + storage.mode(J) <- "integer" + storage.mode(p.abund) <- "integer" + storage.mode(p.svc) <- 'integer' + storage.mode(n.neighbors) <- "integer" + storage.mode(X.fix) <- "double" + storage.mode(X.w.0) <- 'double' + storage.mode(coords.0) <- "double" + storage.mode(J.0) <- "integer" + storage.mode(sites.link) <- "integer" + storage.mode(sites.0.sampled) <- 'integer' + storage.mode(sites.0.indx) <- 'integer' + storage.mode(beta.samples) <- "double" + storage.mode(theta.samples) <- "double" + storage.mode(tau.sq.samples) <- "double" + storage.mode(family.c) <- "integer" + storage.mode(w.samples) <- "double" + storage.mode(beta.star.sites.0.samples) <- "double" + storage.mode(n.post) <- "integer" + storage.mode(cov.model.indx) <- "integer" + storage.mode(nn.indx.0) <- "integer" + storage.mode(n.omp.threads) <- "integer" + storage.mode(verbose) <- "integer" + storage.mode(n.report) <- "integer" + storage.mode(z.0.samples) <- "double" + + ptm <- proc.time() + + out <- .Call("svcAbundNNGPGaussianPredict", coords, J, family.c, p.abund, p.svc, n.neighbors, + X.fix, X.w.0, coords.0, J.0, nn.indx.0, beta.samples, + theta.samples, tau.sq.samples, w.samples, beta.star.sites.0.samples, + sites.link, sites.0.sampled, sites.0.indx, + n.post, cov.model.indx, n.omp.threads, verbose, n.report, z.0.samples) + } + out$y.0.samples <- mcmc(t(out$y.0.samples)) + out$mu.0.samples <- mcmc(t(out$mu.0.samples)) + out$w.0.samples <- array(out$w.0.samples, dim = c(p.svc, J.0, n.post)) + out$w.0.samples <- aperm(out$w.0.samples, c(3, 1, 2)) + if (is(object, 'spAbund') & object$dist %in% c('Gaussian', 'zi-Gaussian')) { + out$w.0.samples <- matrix(out$w.0.samples[, 1, ], n.post, J.0) + } + out$call <- cl - ptm <- proc.time() + class(out) <- "predict.svcAbund" + out - out <- .Call("svcAbundNNGPPredict", coords, J, family.c, p.abund, p.svc, n.neighbors, - X.fix, X.w.0, coords.0, J.0, nn.indx.0, beta.samples, - theta.samples, tau.sq.samples, w.samples, beta.star.sites.0.samples, - sites.link, sites.0.sampled, sites.0.indx, - n.post, cov.model.indx, n.omp.threads, verbose, n.report, z.0.samples) } - out$y.0.samples <- mcmc(t(out$y.0.samples)) - out$mu.0.samples <- mcmc(t(out$mu.0.samples)) - out$w.0.samples <- array(out$w.0.samples, dim = c(p.svc, J.0, n.post)) - out$w.0.samples <- aperm(out$w.0.samples, c(3, 1, 2)) - if (is(object, 'spAbund') & object$dist %in% c('Gaussian', 'zi-Gaussian')) { - out$w.0.samples <- matrix(out$w.0.samples[, 1, ], n.post, J.0) - } - out$call <- cl - - class(out) <- "predict.spNMix" - out } diff --git a/R/lfMsAbund.R b/R/lfMsAbund.R index d2ae20c..cd399bf 100644 --- a/R/lfMsAbund.R +++ b/R/lfMsAbund.R @@ -529,7 +529,7 @@ lfMsAbund <- function(formula, data, inits, priors, } } beta.star.indx <- rep(0:(p.abund.re - 1), n.abund.re.long) - beta.star.inits <- rnorm(n.abund.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.abund.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) # Starting values for all species beta.star.inits <- rep(beta.star.inits, n.sp) } else { @@ -776,7 +776,7 @@ lfMsAbund <- function(formula, data, inits, priors, lambda.inits <- c(lambda.inits) if (p.abund.re > 0) { sigma.sq.mu.inits <- runif(p.abund.re, 0.05, 1) - beta.star.inits <- rnorm(n.abund.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.abund.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) beta.star.inits <- rep(beta.star.inits, n.sp) } } diff --git a/R/lfMsAbundGaussian.R b/R/lfMsAbundGaussian.R index 596712e..6586f20 100644 --- a/R/lfMsAbundGaussian.R +++ b/R/lfMsAbundGaussian.R @@ -479,7 +479,7 @@ lfMsAbundGaussian <- function(formula, data, inits, priors, tuning, n.factors, } } beta.star.indx <- rep(0:(p.re - 1), n.re.long) - beta.star.inits <- rnorm(n.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) beta.star.inits <- rep(beta.star.inits, N) } else { sigma.sq.mu.inits <- 0 @@ -633,7 +633,7 @@ lfMsAbundGaussian <- function(formula, data, inits, priors, tuning, n.factors, tau.sq.inits <- runif(N, 0.01, 3) if (p.re > 0) { sigma.sq.mu.inits <- runif(p.re, 0.5, 10) - beta.star.inits <- rnorm(n.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) beta.star.inits <- rep(beta.star.inits, N) } } diff --git a/R/lfMsDS.R b/R/lfMsDS.R index 8c53162..a804cf7 100644 --- a/R/lfMsDS.R +++ b/R/lfMsDS.R @@ -749,7 +749,7 @@ lfMsDS <- function(abund.formula, det.formula, data, inits, priors, tuning, } } beta.star.indx <- rep(0:(p.abund.re - 1), n.abund.re.long) - beta.star.inits <- rnorm(n.abund.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.abund.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) # Starting values for all species beta.star.inits <- rep(beta.star.inits, n.sp) } else { @@ -780,7 +780,7 @@ lfMsDS <- function(abund.formula, det.formula, data, inits, priors, tuning, } } alpha.star.indx <- rep(0:(p.det.re - 1), n.det.re.long) - alpha.star.inits <- rnorm(n.det.re, sqrt(sigma.sq.p.inits[alpha.star.indx + 1])) + alpha.star.inits <- rnorm(n.det.re, 0, sqrt(sigma.sq.p.inits[alpha.star.indx + 1])) alpha.star.inits <- rep(alpha.star.inits, n.sp) } else { sigma.sq.p.inits <- 0 @@ -1090,12 +1090,12 @@ lfMsDS <- function(abund.formula, det.formula, data, inits, priors, tuning, lambda.inits <- c(lambda.inits) if (p.abund.re > 0) { sigma.sq.mu.inits <- runif(p.abund.re, 0.05, 1) - beta.star.inits <- rnorm(n.abund.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.abund.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) beta.star.inits <- rep(beta.star.inits, n.sp) } if (p.det.re > 0) { sigma.sq.p.inits <- runif(p.det.re, 0.05, 1) - alpha.star.inits <- rnorm(n.det.re, sqrt(sigma.sq.p.inits[alpha.star.indx + 1])) + alpha.star.inits <- rnorm(n.det.re, 0, sqrt(sigma.sq.p.inits[alpha.star.indx + 1])) alpha.star.inits <- rep(alpha.star.inits, n.sp) } if (family == 'NB') { diff --git a/R/lfMsNMix.R b/R/lfMsNMix.R index 987a031..ac30c09 100644 --- a/R/lfMsNMix.R +++ b/R/lfMsNMix.R @@ -780,7 +780,7 @@ lfMsNMix <- function(abund.formula, det.formula, data, inits, priors, } } beta.star.indx <- rep(0:(p.abund.re - 1), n.abund.re.long) - beta.star.inits <- rnorm(n.abund.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.abund.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) # Starting values for all species beta.star.inits <- rep(beta.star.inits, n.sp) } else { @@ -811,7 +811,7 @@ lfMsNMix <- function(abund.formula, det.formula, data, inits, priors, } } alpha.star.indx <- rep(0:(p.det.re - 1), n.det.re.long) - alpha.star.inits <- rnorm(n.det.re, sqrt(sigma.sq.p.inits[alpha.star.indx + 1])) + alpha.star.inits <- rnorm(n.det.re, 0, sqrt(sigma.sq.p.inits[alpha.star.indx + 1])) alpha.star.inits <- rep(alpha.star.inits, n.sp) } else { sigma.sq.p.inits <- 0 @@ -1120,12 +1120,12 @@ lfMsNMix <- function(abund.formula, det.formula, data, inits, priors, lambda.inits <- c(lambda.inits) if (p.abund.re > 0) { sigma.sq.mu.inits <- runif(p.abund.re, 0.05, 1) - beta.star.inits <- rnorm(n.abund.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.abund.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) beta.star.inits <- rep(beta.star.inits, n.sp) } if (p.det.re > 0) { sigma.sq.p.inits <- runif(p.det.re, 0.05, 1) - alpha.star.inits <- rnorm(n.det.re, sqrt(sigma.sq.p.inits[alpha.star.indx + 1])) + alpha.star.inits <- rnorm(n.det.re, 0, sqrt(sigma.sq.p.inits[alpha.star.indx + 1])) alpha.star.inits <- rep(alpha.star.inits, n.sp) } } diff --git a/R/msAbund.R b/R/msAbund.R index d45ae06..7ded022 100644 --- a/R/msAbund.R +++ b/R/msAbund.R @@ -516,7 +516,7 @@ msAbund <- function(formula, data, inits, priors, tuning, } } else { message("beta.star is not specified in initial values.\nSetting initial values from the prior.\n") - beta.star.inits <- rnorm(n.abund.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.abund.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) # Starting values for all species beta.star.inits <- rep(beta.star.inits, n.sp) } @@ -687,7 +687,7 @@ msAbund <- function(formula, data, inits, priors, tuning, } if (p.abund.re > 0) { sigma.sq.mu.inits <- runif(p.abund.re, 0.05, 1) - beta.star.inits <- rnorm(n.abund.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.abund.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) beta.star.inits <- rep(beta.star.inits, n.sp) } } diff --git a/R/msAbundGaussian.R b/R/msAbundGaussian.R index 1d271ed..d6f19bd 100644 --- a/R/msAbundGaussian.R +++ b/R/msAbundGaussian.R @@ -457,7 +457,7 @@ msAbundGaussian <- function(formula, data, inits, priors, tuning, } } beta.star.indx <- rep(0:(p.re - 1), n.re.long) - beta.star.inits <- rnorm(n.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) beta.star.inits <- rep(beta.star.inits, N) } else { sigma.sq.mu.inits <- 0 @@ -556,7 +556,7 @@ msAbundGaussian <- function(formula, data, inits, priors, tuning, tau.sq.inits <- runif(N, 0.01, 3) if (p.re > 0) { sigma.sq.mu.inits <- runif(p.re, 0.5, 10) - beta.star.inits <- rnorm(n.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) beta.star.inits <- rep(beta.star.inits, N) } } diff --git a/R/msDS.R b/R/msDS.R index 659237b..f5aa5c5 100644 --- a/R/msDS.R +++ b/R/msDS.R @@ -717,7 +717,7 @@ msDS <- function(abund.formula, det.formula, data, inits, priors, tuning, } } beta.star.indx <- rep(0:(p.abund.re - 1), n.abund.re.long) - beta.star.inits <- rnorm(n.abund.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.abund.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) # Starting values for all species beta.star.inits <- rep(beta.star.inits, n.sp) } else { @@ -983,7 +983,7 @@ msDS <- function(abund.formula, det.formula, data, inits, priors, tuning, alpha.inits <- matrix(runif(n.sp * p.det, -10, 10), n.sp, p.det) if (p.abund.re > 0) { sigma.sq.mu.inits <- runif(p.abund.re, 0.05, 1) - beta.star.inits <- rnorm(n.abund.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.abund.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) beta.star.inits <- rep(beta.star.inits, n.sp) } if (p.det.re > 0) { diff --git a/R/msNMix.R b/R/msNMix.R index 15d8ffd..3843372 100644 --- a/R/msNMix.R +++ b/R/msNMix.R @@ -780,7 +780,7 @@ msNMix <- function(abund.formula, det.formula, data, inits, priors, } } beta.star.indx <- rep(0:(p.abund.re - 1), n.abund.re.long) - beta.star.inits <- rnorm(n.abund.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.abund.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) # Starting values for all species beta.star.inits <- rep(beta.star.inits, n.sp) } else { @@ -811,7 +811,7 @@ msNMix <- function(abund.formula, det.formula, data, inits, priors, } } alpha.star.indx <- rep(0:(p.det.re - 1), n.det.re.long) - alpha.star.inits <- rnorm(n.det.re, sqrt(sigma.sq.p.inits[alpha.star.indx + 1])) + alpha.star.inits <- rnorm(n.det.re, 0, sqrt(sigma.sq.p.inits[alpha.star.indx + 1])) alpha.star.inits <- rep(alpha.star.inits, n.sp) } else { sigma.sq.p.inits <- 0 @@ -1046,12 +1046,12 @@ msNMix <- function(abund.formula, det.formula, data, inits, priors, } if (p.abund.re > 0) { sigma.sq.mu.inits <- runif(p.abund.re, 0.05, 1) - beta.star.inits <- rnorm(n.abund.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.abund.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) beta.star.inits <- rep(beta.star.inits, n.sp) } if (p.det.re > 0) { sigma.sq.p.inits <- runif(p.det.re, 0.05, 1) - alpha.star.inits <- rnorm(n.det.re, sqrt(sigma.sq.p.inits[alpha.star.indx + 1])) + alpha.star.inits <- rnorm(n.det.re, 0, sqrt(sigma.sq.p.inits[alpha.star.indx + 1])) alpha.star.inits <- rep(alpha.star.inits, n.sp) } } diff --git a/R/sfMsAbund.R b/R/sfMsAbund.R index b68eb1f..4cae506 100644 --- a/R/sfMsAbund.R +++ b/R/sfMsAbund.R @@ -4,7 +4,7 @@ sfMsAbund <- function(formula, data, inits, priors, n.batch, batch.length, accept.rate = 0.43, family = 'Poisson', n.omp.threads = 1, verbose = TRUE, n.report = 100, n.burn = round(.10 * n.batch * batch.length), - n.thin = 1, n.chains = 1, save.fitted = TRUE, ...){ + n.thin = 1, n.chains = 1, save.fitted = TRUE, ...){ ptm <- proc.time() @@ -622,7 +622,7 @@ sfMsAbund <- function(formula, data, inits, priors, } } beta.star.indx <- rep(0:(p.abund.re - 1), n.abund.re.long) - beta.star.inits <- rnorm(n.abund.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.abund.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) # Starting values for all species beta.star.inits <- rep(beta.star.inits, n.sp) } else { @@ -1012,7 +1012,7 @@ sfMsAbund <- function(formula, data, inits, priors, } if (p.abund.re > 0) { sigma.sq.mu.inits <- runif(p.abund.re, 0.05, 1) - beta.star.inits <- rnorm(n.abund.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.abund.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) beta.star.inits <- rep(beta.star.inits, n.sp) } } diff --git a/R/sfMsAbundGaussian.R b/R/sfMsAbundGaussian.R index 5f1d1b6..1b9e4a7 100644 --- a/R/sfMsAbundGaussian.R +++ b/R/sfMsAbundGaussian.R @@ -640,7 +640,7 @@ sfMsAbundGaussian <- function(formula, data, inits, priors, } } beta.star.indx <- rep(0:(p.re - 1), n.re.long) - beta.star.inits <- rnorm(n.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) beta.star.inits <- rep(beta.star.inits, N) } else { sigma.sq.mu.inits <- 0 @@ -853,7 +853,7 @@ sfMsAbundGaussian <- function(formula, data, inits, priors, } if (p.re > 0) { sigma.sq.mu.inits <- runif(p.re, 0.5, 10) - beta.star.inits <- rnorm(n.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) beta.star.inits <- rep(beta.star.inits, N) } } diff --git a/R/sfMsDS.R b/R/sfMsDS.R index 2bbc493..1dd7d58 100644 --- a/R/sfMsDS.R +++ b/R/sfMsDS.R @@ -823,7 +823,7 @@ sfMsDS <- function(abund.formula, det.formula, data, inits, priors, tuning, } } beta.star.indx <- rep(0:(p.abund.re - 1), n.abund.re.long) - beta.star.inits <- rnorm(n.abund.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.abund.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) # Starting values for all species beta.star.inits <- rep(beta.star.inits, n.sp) } else { @@ -854,7 +854,7 @@ sfMsDS <- function(abund.formula, det.formula, data, inits, priors, tuning, } } alpha.star.indx <- rep(0:(p.det.re - 1), n.det.re.long) - alpha.star.inits <- rnorm(n.det.re, sqrt(sigma.sq.p.inits[alpha.star.indx + 1])) + alpha.star.inits <- rnorm(n.det.re, 0, sqrt(sigma.sq.p.inits[alpha.star.indx + 1])) alpha.star.inits <- rep(alpha.star.inits, n.sp) } else { sigma.sq.p.inits <- 0 @@ -1306,12 +1306,12 @@ sfMsDS <- function(abund.formula, det.formula, data, inits, priors, tuning, } if (p.abund.re > 0) { sigma.sq.mu.inits <- runif(p.abund.re, 0.05, 1) - beta.star.inits <- rnorm(n.abund.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.abund.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) beta.star.inits <- rep(beta.star.inits, n.sp) } if (p.det.re > 0) { sigma.sq.p.inits <- runif(p.det.re, 0.05, 1) - alpha.star.inits <- rnorm(n.det.re, sqrt(sigma.sq.p.inits[alpha.star.indx + 1])) + alpha.star.inits <- rnorm(n.det.re, 0, sqrt(sigma.sq.p.inits[alpha.star.indx + 1])) alpha.star.inits <- rep(alpha.star.inits, n.sp) } if (family == 'NB') { diff --git a/R/sfMsNMix.R b/R/sfMsNMix.R index 78a78d9..d9e5998 100644 --- a/R/sfMsNMix.R +++ b/R/sfMsNMix.R @@ -866,7 +866,7 @@ sfMsNMix <- function(abund.formula, det.formula, data, inits, priors, } } beta.star.indx <- rep(0:(p.abund.re - 1), n.abund.re.long) - beta.star.inits <- rnorm(n.abund.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.abund.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) # Starting values for all species beta.star.inits <- rep(beta.star.inits, n.sp) } else { @@ -897,7 +897,7 @@ sfMsNMix <- function(abund.formula, det.formula, data, inits, priors, } } alpha.star.indx <- rep(0:(p.det.re - 1), n.det.re.long) - alpha.star.inits <- rnorm(n.det.re, sqrt(sigma.sq.p.inits[alpha.star.indx + 1])) + alpha.star.inits <- rnorm(n.det.re, 0, sqrt(sigma.sq.p.inits[alpha.star.indx + 1])) alpha.star.inits <- rep(alpha.star.inits, n.sp) } else { sigma.sq.p.inits <- 0 @@ -1349,12 +1349,12 @@ sfMsNMix <- function(abund.formula, det.formula, data, inits, priors, } if (p.abund.re > 0) { sigma.sq.mu.inits <- runif(p.abund.re, 0.05, 1) - beta.star.inits <- rnorm(n.abund.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.abund.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) beta.star.inits <- rep(beta.star.inits, n.sp) } if (p.det.re > 0) { sigma.sq.p.inits <- runif(p.det.re, 0.05, 1) - alpha.star.inits <- rnorm(n.det.re, sqrt(sigma.sq.p.inits[alpha.star.indx + 1])) + alpha.star.inits <- rnorm(n.det.re, 0, sqrt(sigma.sq.p.inits[alpha.star.indx + 1])) alpha.star.inits <- rep(alpha.star.inits, n.sp) } } diff --git a/R/simAbund.R b/R/simAbund.R index 578b0ec..edc750d 100644 --- a/R/simAbund.R +++ b/R/simAbund.R @@ -1,6 +1,6 @@ simAbund <- function(J.x, J.y, n.rep, n.rep.max, beta, kappa, tau.sq, mu.RE = list(), offset = 1, sp = FALSE, svc.cols = 1, cov.model, sigma.sq, phi, - nu, family = 'Poisson', z, x.positive = FALSE, ...) { + nu, family = 'Poisson', z, trend = FALSE, x.positive = FALSE, ...) { # Check for unused arguments ------------------------------------------ formal.args <- names(formals(sys.function(sys.parent()))) @@ -78,9 +78,6 @@ simAbund <- function(J.x, J.y, n.rep, n.rep.max, beta, kappa, tau.sq, mu.RE = li if (length(svc.cols) > 1 & !sp) { stop("error: if simulating data with spatially-varying coefficients, set sp = TRUE") } - if (length(svc.cols) > 1 & family %in% c('Poisson', 'NB')) { - stop("spatially-varying coefficient models are only currently supported for Gaussian and zi-Gaussian models") - } if (sp) { if(missing(sigma.sq)) { stop("error: sigma.sq must be specified when sp = TRUE") @@ -140,16 +137,30 @@ simAbund <- function(J.x, J.y, n.rep, n.rep.max, beta, kappa, tau.sq, mu.RE = li } X[, , 1] <- 1 if (n.beta > 1) { - for (i in 2:n.beta) { + if (trend) { # if simulating data with a trend for (j in 1:J) { - if (x.positive) { - X[j, rep.indx[[j]], i] <- runif(n.rep[j], 0, 5) - - } else { - X[j, rep.indx[[j]], i] <- rnorm(n.rep[j]) - } + X[j, rep.indx[[j]], 2] <- (scale(1:n.rep.max))[rep.indx[[j]]] + if (n.beta > 2) { + for (i in 3:n.beta) { + if (x.positive) { + X[j, rep.indx[[j]], i] <- runif(n.rep[j], 0, 5) + } else { + X[j, rep.indx[[j]], i] <- rnorm(n.rep[j]) + } + } + } } - } # i + } else { + for (i in 2:n.beta) { + for (j in 1:J) { + if (x.positive) { + X[j, rep.indx[[j]], i] <- runif(n.rep[j], 0, 5) + } else { + X[j, rep.indx[[j]], i] <- rnorm(n.rep[j]) + } + } + } # i + } } # Simulate spatial random effect ---------------------------------------- diff --git a/R/spAbund.R b/R/spAbund.R index a5bd46d..c208077 100644 --- a/R/spAbund.R +++ b/R/spAbund.R @@ -491,7 +491,7 @@ spAbund <- function(formula, data, inits, priors, tuning, } } beta.star.indx <- rep(0:(p.abund.re - 1), n.abund.re.long) - beta.star.inits <- rnorm(n.abund.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.abund.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) } else { sigma.sq.mu.inits <- 0 beta.star.indx <- 0 @@ -837,7 +837,7 @@ spAbund <- function(formula, data, inits, priors, tuning, beta.inits <- rnorm(p.abund, 0, 1) if (p.abund.re > 0) { sigma.sq.mu.inits <- runif(p.abund.re, 0.05, 1) - beta.star.inits <- rnorm(n.abund.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.abund.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) } if (family == 'NB') { kappa.inits <- runif(1, kappa.a, kappa.b) diff --git a/R/spAbundGaussian.R b/R/spAbundGaussian.R index 6de2e75..7445078 100644 --- a/R/spAbundGaussian.R +++ b/R/spAbundGaussian.R @@ -504,7 +504,7 @@ spAbundGaussian <- function(formula, data, inits, priors, tuning, } } beta.star.indx <- rep(0:(p.re - 1), n.re.long) - beta.star.inits <- rnorm(n.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) } else { sigma.sq.mu.inits <- 0 beta.star.indx <- 0 @@ -724,7 +724,7 @@ spAbundGaussian <- function(formula, data, inits, priors, tuning, } if (p.re > 0) { sigma.sq.mu.inits <- runif(p.re, 0.5, 10) - beta.star.inits <- rnorm(n.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) } tau.sq.inits <- runif(1, 0.1, 10) } diff --git a/R/spDS.R b/R/spDS.R index 98a7b49..e7f63d3 100644 --- a/R/spDS.R +++ b/R/spDS.R @@ -619,7 +619,7 @@ spDS <- function(abund.formula, det.formula, data, inits, priors, tuning, } } beta.star.indx <- rep(0:(p.abund.re - 1), n.abund.re.long) - beta.star.inits <- rnorm(n.abund.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.abund.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) } else { sigma.sq.mu.inits <- 0 beta.star.indx <- 0 @@ -1063,7 +1063,7 @@ spDS <- function(abund.formula, det.formula, data, inits, priors, tuning, alpha.inits <- runif(p.det, -10, 10) if (p.abund.re > 0) { sigma.sq.mu.inits <- runif(p.abund.re, 0.05, 1) - beta.star.inits <- rnorm(n.abund.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.abund.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) } if (p.det.re > 0) { sigma.sq.p.inits <- runif(p.det.re, 0.05, 0.5) diff --git a/R/spNMix.R b/R/spNMix.R index 6f023b7..4bcc799 100644 --- a/R/spNMix.R +++ b/R/spNMix.R @@ -669,7 +669,7 @@ spNMix <- function(abund.formula, det.formula, data, inits, priors, tuning, } } beta.star.indx <- rep(0:(p.abund.re - 1), n.abund.re.long) - beta.star.inits <- rnorm(n.abund.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.abund.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) } else { sigma.sq.mu.inits <- 0 beta.star.indx <- 0 @@ -699,7 +699,7 @@ spNMix <- function(abund.formula, det.formula, data, inits, priors, tuning, } } alpha.star.indx <- rep(0:(p.det.re - 1), n.det.re.long) - alpha.star.inits <- rnorm(n.det.re, sqrt(sigma.sq.p.inits[alpha.star.indx + 1])) + alpha.star.inits <- rnorm(n.det.re, 0, sqrt(sigma.sq.p.inits[alpha.star.indx + 1])) } else { sigma.sq.p.inits <- 0 alpha.star.indx <- 0 @@ -1105,11 +1105,11 @@ spNMix <- function(abund.formula, det.formula, data, inits, priors, tuning, alpha.inits <- rnorm(p.det, 0, 1) if (p.abund.re > 0) { sigma.sq.mu.inits <- runif(p.abund.re, 0.05, 2) - beta.star.inits <- rnorm(n.abund.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rnorm(n.abund.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) } if (p.det.re > 0) { sigma.sq.p.inits <- runif(p.det.re, 0.5, 2) - alpha.star.inits <- rnorm(n.det.re, sqrt(sigma.sq.p.inits[alpha.star.indx + 1])) + alpha.star.inits <- rnorm(n.det.re, 0, sqrt(sigma.sq.p.inits[alpha.star.indx + 1])) } kappa.inits <- runif(1, kappa.a, kappa.b) if (!sigma.sq.ig) { diff --git a/R/svcAbund.R b/R/svcAbund.R index 0ea2525..ba2aeee 100644 --- a/R/svcAbund.R +++ b/R/svcAbund.R @@ -1,915 +1,1072 @@ -svcAbund <- function(formula, data, inits, priors, tuning, - svc.cols = 1, cov.model = 'exponential', NNGP = TRUE, - n.neighbors = 15, search.type = 'cb', n.batch, - batch.length, accept.rate = 0.43, family = 'Gaussian', - n.omp.threads = 1, verbose = TRUE, n.report = 100, - n.burn = round(.10 * n.batch * batch.length), - n.thin = 1, n.chains = 1, ...){ +svcAbund <- function(formula, data, inits, priors, tuning, svc.cols = 1, + cov.model = 'exponential', NNGP = TRUE, + n.neighbors = 15, search.type = 'cb', + n.batch, batch.length, accept.rate = 0.43, family = 'Poisson', + n.omp.threads = 1, verbose = TRUE, + n.report = 100, n.burn = round(.10 * n.batch * batch.length), n.thin = 1, + n.chains = 1, save.fitted = TRUE, ...){ ptm <- proc.time() - # Make it look nice - if (verbose) { - cat("----------------------------------------\n"); - cat("\tPreparing to run the model\n"); - cat("----------------------------------------\n"); + if (!(family) %in% c('Poisson', 'NB', 'Gaussian', 'zi-Gaussian')) { + stop("family must be either 'Poisson', 'NB', 'Gaussian', or 'zi-Gaussian'") } - - # Functions --------------------------------------------------------------- - logit <- function(theta, a = 0, b = 1) {log((theta-a)/(b-theta))} - logit.inv <- function(z, a = 0, b = 1) {b-(b-a)/(1+exp(z))} - rigamma <- function(n, a, b){ - 1/rgamma(n = n, shape = a, rate = b) - } - - # Check for unused arguments ------------------------------------------ - formal.args <- names(formals(sys.function(sys.parent()))) - elip.args <- names(list(...)) - for(i in elip.args){ - if(! i %in% formal.args) - warning("'",i, "' is not an argument") - } - # Call ---------------------------------------------------------------- - # Returns a call in which all of the specified arguments are - # specified by their full names. - cl <- match.call() - - # Some initial checks ------------------------------------------------- - if (missing(data)) { - stop("error: data must be specified") - } - if (!is.list(data)) { - stop("error: data must be a list") - } - names(data) <- tolower(names(data)) - if (missing(formula)) { - stop("error: formula must be specified") - } - if (!'y' %in% names(data)) { - stop("error: detection-nondetection data y must be specified in data") - } - y <- c(data$y) - if (!'covs' %in% names(data)) { - if (formula == ~ 1) { - if (verbose) { - message("covariates (covs) not specified in data.\nAssuming intercept only model.\n") - } - data$covs <- matrix(1, length(y), 1) - } else { - stop("error: covs must be specified in data for a model with covariates") - } - } - if (!is.list(data$covs)) { - if (is.matrix(data$covs)) { - data$covs <- data.frame(data$covs) - } else { - stop("error: covs must be a list, data frame, or matrix") - } - } - if (!'coords' %in% names(data)) { - stop("error: coords must be specified in data for a spatial model.") - } - if (!is.matrix(data$coords) & !is.data.frame(data$coords)) { - stop("error: coords must be a matrix or data frame") - } - coords <- as.matrix(data$coords) - - if (!(family) %in% c('Gaussian', 'zi-Gaussian')) { - stop("svcAbund currently only supports family = 'Gaussian' or 'zi-Gaussian'") - } - if (family == 'zi-Gaussian') { - two.stage <- TRUE - } else { - two.stage <- FALSE - } - if (two.stage) { - if (!'z' %in% names(data)) { - stop("error: z must be specified in data for a two stage model") - } - z <- data$z + if (family %in% c('Gaussian', 'zi-Gaussian')) { + svcAbundGaussian(formula, data, inits, priors, tuning, svc.cols, cov.model, NNGP, + n.neighbors, search.type, n.batch, batch.length, accept.rate, + family, n.omp.threads, verbose, n.report, n.burn, n.thin, + n.chains) } else { - z <- rep(1, length(y)) - } - - # First subset covariates to only use those that are included in the analysis. - # Get occurrence covariates in proper format - # Subset covariates to only use those that are included in the analysis - data$covs <- data$covs[names(data$covs) %in% all.vars(formula)] - # Null model support - if (length(data$covs) == 0) { - data$covs <- list(int = rep(1, length(y))) - } - # Ordered by rep, then site within rep - data$covs <- data.frame(lapply(data$covs, function(a) unlist(c(a)))) - - # Check first-stage sample ---------------------------------------------- - if (length(z) != length(y)) { - stop(paste("z must be a vector of length ", length(y), ".", sep = '')) - } - # Number of points where z == 1 - J.est <- sum(z == 1) - # Number of points where z != 1 - J.zero <- sum(z == 0) - # Index for the sites where z == 1 - z.indx <- which(z == 1) - - # Filter all objects to only use sites with z == 1 - y.orig <- y - y <- y[z.indx] - coords <- coords[z.indx, ] - data$covs <- data$covs[z.indx, , drop = FALSE] - - # Neighbors and Ordering ---------------------------------------------- - if (NNGP) { - u.search.type <- 2 - ## Order by x column. Could potentially allow this to be user defined. - ord <- order(coords[,1]) - # Reorder everything to align with NN ordering - y <- y[ord, drop = FALSE] - coords <- coords[ord, , drop = FALSE] - # Occupancy covariates - data$covs <- data$covs[ord, , drop = FALSE] - } - - data$covs <- as.data.frame(data$covs) - # Checking missing values --------------------------------------------- - # y ------------------------------- - if (sum(is.na(y) > 0)) { - stop("error: some sites in y have missing values. Remove these sites from all objects in the 'data' argument, then use 'predict' to obtain predictions at these locations if desired.") - } - # covs ------------------------ - if (sum(is.na(data$covs)) != 0) { - stop("error: missing values in covs. Please remove these sites from all objects in data or somehow replace the NA values with non-missing values (e.g., mean imputation).") - } - - # Check whether random effects are sent in as numeric, and - # return error if they are. - # Occurrence ---------------------- - if (!is.null(findbars(formula))) { - re.names <- unique(unlist(sapply(findbars(formula), all.vars))) - for (i in 1:length(re.names)) { - if (is(data$covs[, re.names[i]], 'factor')) { - stop(paste("error: random effect variable ", re.names[i], " specified as a factor. Random effect variables must be specified as numeric.", sep = '')) - } - if (is(data$covs[, re.names[i]], 'character')) { - stop(paste("error: random effect variable ", re.names[i], " specified as character. Random effect variables must be specified as numeric.", sep = '')) - } + # Make it look nice + if (verbose) { + cat("----------------------------------------\n"); + cat("\tPreparing to run the model\n"); + cat("----------------------------------------\n"); } - } - # Formula ------------------------------------------------------------- - # Occupancy ----------------------- - if (is(formula, 'formula')) { - tmp <- parseFormula(formula, data$covs) - X <- as.matrix(tmp[[1]]) - X.re <- as.matrix(tmp[[4]]) - x.re.names <- colnames(X.re) - x.names <- tmp[[2]] - X.random <- as.matrix(tmp[[5]]) - x.random.names <- colnames(X.random) - } else { - stop("error: formula is misspecified") - } - # Get RE level names - re.level.names <- lapply(data$covs[, x.re.names, drop = FALSE], - function (a) sort(unique(a))) - x.re.names <- x.random.names - - # Get basic info from inputs ------------------------------------------ - # Number of sites - J <- nrow(coords) - # Number of parameters - p <- ncol(X) - # Number of random effect parameters - p.re <- ncol(X.re) - # Number of latent random effect values - n.re <- length(unlist(apply(X.re, 2, unique))) - n.re.long <- apply(X.re, 2, function(a) length(unique(a))) - if (missing(n.batch)) { - stop("error: must specify number of MCMC batches") - } - if (missing(batch.length)) { - stop("error: must specify length of each MCMC batch") - } - n.samples <- n.batch * batch.length - if (n.burn > n.samples) { - stop("error: n.burn must be less than n.samples") - } - if (n.thin > n.samples) { - stop("error: n.thin must be less than n.samples") - } - # Check if n.burn, n.thin, and n.samples result in an integer and error if otherwise. - if (((n.samples - n.burn) / n.thin) %% 1 != 0) { - stop("the number of posterior samples to save ((n.samples - n.burn) / n.thin) is not a whole number. Please respecify the MCMC criteria such that the number of posterior samples saved is a whole number.") - } - n.post.samples <- length(seq(from = n.burn + 1, - to = n.samples, - by = as.integer(n.thin))) - - # Check SVC columns ----------------------------------------------------- - if (is.character(svc.cols)) { - # Check if all column names in svc are in covs - if (!all(svc.cols %in% x.names)) { - missing.cols <- svc.cols[!(svc.cols %in% x.names)] - stop(paste("error: variable name ", paste(missing.cols, collapse=" and "), " not inurrence covariates", sep="")) + # Functions --------------------------------------------------------------- + logit <- function(theta, a = 0, b = 1) {log((theta-a)/(b-theta))} + logit.inv <- function(z, a = 0, b = 1) {b-(b-a)/(1+exp(z))} + rigamma <- function(n, a, b){ + 1/rgamma(n = n, shape = a, rate = b) } - # Convert desired column names into the numeric column index - svc.cols <- (1:p)[x.names %in% svc.cols] - } else if (is.numeric(svc.cols)) { - # Check if all column indices are in 1:p - if (!all(svc.cols %in% 1:p)) { - missing.cols <- svc.cols[!(svc.cols %in% (1:p))] - stop(paste("error: column index ", paste(missing.cols, collapse=" "), " not in design matrix columns", sep="")) + # Check for unused arguments ------------------------------------------ + formal.args <- names(formals(sys.function(sys.parent()))) + elip.args <- names(list(...)) + for(i in elip.args){ + if(! i %in% formal.args) + warning("'",i, "' is not an argument") } - } - p.svc <- length(svc.cols) + # Call ---------------------------------------------------------------- + # Returns a call in which all of the specified arguments are + # specified by their full names. + cl <- match.call() - # Get random effect matrices all set ---------------------------------- - X.re <- X.re - 1 - if (p.re > 1) { - for (j in 2:p.re) { - X.re[, j] <- X.re[, j] + max(X.re[, j - 1]) + 1 - } - } + # Some initial checks ------------------------------------------------- + if (missing(data)) { + stop("error: data must be specified") + } + if (!is.list(data)) { + stop("error: data must be a list") + } + names(data) <- tolower(names(data)) + if (missing(formula)) { + stop("error: formula must be specified") + } + if (!'y' %in% names(data)) { + stop("error: data y must be specified in data") + } + y <- as.matrix(data$y) + # Offset + if ('offset' %in% names(data)) { + offset <- data$offset + if (length(offset) == 1) { + offset <- matrix(offset, nrow(y), ncol(y)) + } else if (length(dim(offset)) == 1) { # Value for each site + if (length(offset) != nrow(y)) { + stop(paste0("offset must be a single value, vector of length ", nrow(y), " or a matrix with ", + nrow(y), " rows and ", ncol(y), " columns.")) + } + offset <- matrix(offset, nrow(y), ncol(y)) + } else if (length(dim(offset)) == 2) { # Value for each site/obs + if (nrow(offset) != nrow(y) | ncol(offset) != ncol(y)) { + stop(paste0("offset must be a single value, vector of length ", nrow(y), " or a matrix with ", + nrow(y), " rows and ", ncol(y), " columns.")) - # Priors -------------------------------------------------------------- - if (missing(priors)) { - priors <- list() - } - names(priors) <- tolower(names(priors)) - # beta ----------------------- - if ("beta.normal" %in% names(priors)) { - if (!is.list(priors$beta.normal) | length(priors$beta.normal) != 2) { - stop("error: beta.normal must be a list of length 2") - } - mu.beta <- priors$beta.normal[[1]] - sigma.beta <- priors$beta.normal[[2]] - if (length(mu.beta) != p & length(mu.beta) != 1) { - if (p == 1) { - stop(paste("error: beta.normal[[1]] must be a vector of length ", - p, " with elements corresponding to betas' mean", sep = "")) - } else { - stop(paste("error: beta.normal[[1]] must be a vector of length ", - p, " or 1 with elements corresponding to betas' mean", sep = "")) + } } + } else { + offset <- matrix(1, nrow(y), ncol(y)) } - if (length(sigma.beta) != p & length(sigma.beta) != 1) { - if (p == 1) { - stop(paste("error: beta.normal[[2]] must be a vector of length ", - p, " with elements corresponding to betas' variance", sep = "")) + if (!'covs' %in% names(data)) { + if (formula == ~ 1) { + if (verbose) { + message("abundance covariates (covs) not specified in data.\nAssuming intercept only abundance model.\n") + } + data$covs <- list(int = array(1, dim = dim(y))) } else { - stop(paste("error: beta.normal[[2]] must be a vector of length ", - p, " or 1 with elements corresponding to betas' variance", sep = "")) + stop("error: covs must be specified in data for an abundance model with covariates") } } - if (length(sigma.beta) != p) { - sigma.beta <- rep(sigma.beta, p) + if (!is.list(data$covs)) { + stop("error: covs must be a list of matrices, data frames, and/or vectors") } - if (length(mu.beta) != p) { - mu.beta <- rep(mu.beta, p) + if (!'coords' %in% names(data)) { + stop("error: coords must be specified in data for a spatial GLMM.") } - Sigma.beta <- sigma.beta * diag(p) - } else { - if (verbose) { - message("No prior specified for beta.normal.\nSetting prior mean to 0 and prior variance to 100\n") + if (!is.matrix(data$coords) & !is.data.frame(data$coords)) { + stop("error: coords must be a matrix or data frame") } - mu.beta <- rep(0, p) - sigma.beta <- rep(100, p) - Sigma.beta <- diag(p) * 100 - } - # phi ----------------------------- - # Get distance matrix which is used if priors are not specified - if ("phi.unif" %in% names(priors)) { - if (!is.list(priors$phi.unif) | length(priors$phi.unif) != 2) { - stop("error: phi.unif must be a list of length 2") - } - phi.a <- priors$phi.unif[[1]] - phi.b <- priors$phi.unif[[2]] - if (length(phi.a) != p.svc & length(phi.a) != 1) { - stop(paste("error: phi.unif[[1]] must be a vector of length ", - p.svc, - " or 1 with elements corresponding to phis' lower bound for each covariate with spatially-varying coefficients", - sep = "")) - } - if (length(phi.b) != p.svc & length(phi.b) != 1) { - stop(paste("error: phi.unif[[2]] must be a vector of length ", - p.svc, - " or 1 with elements corresponding to phis' upper bound for each covariate with spatially-varying coefficients", sep = "")) - } - if (length(phi.a) != p.svc) { - phi.a <- rep(phi.a, p.svc) - } - if (length(phi.b) != p.svc) { - phi.b <- rep(phi.b, p.svc) + coords <- as.matrix(data$coords) + if (missing(n.batch)) { + stop("error: must specify number of MCMC batches") } - } else { - if (verbose) { - message("No prior specified for phi.unif.\nSetting uniform bounds based on the range of observed spatial coordinates.\n") + if (missing(batch.length)) { + stop("error: must specify length of each MCMC batch") } - coords.D <- iDist(coords) - phi.a <- rep(3 / max(coords.D), p.svc) - phi.b <- rep(3 / sort(unique(c(coords.D)))[2], p.svc) - } - # tau.sq.t ---------------------- - if ("tau.sq.ig" %in% names(priors)) { - if (!is.vector(priors$tau.sq.ig) | !is.atomic(priors$tau.sq.ig) | length(priors$tau.sq.ig) != 2) { - stop("error: tau.sq.ig must be a vector of length 2 with elements corresponding to tau.sq's shape and scale parameters") + n.samples <- n.batch * batch.length + if (n.burn > n.samples) { + stop("error: n.burn must be less than n.samples") } - tau.sq.a <- priors$tau.sq.ig[1] - tau.sq.b <- priors$tau.sq.ig[2] - } else { - if (verbose) { - message("No prior specified for tau.sq.\nUsing an inverse-Gamma prior with the shape parameter set to 2 and scale parameter to 0.5.\n") + if (n.thin > n.samples) { + stop("error: n.thin must be less than n.samples") } - tau.sq.a <- 2 - tau.sq.b <- 0.5 - } - # sigma.sq ----------------------------- - if ("sigma.sq.ig" %in% names(priors)) { - if (!is.list(priors$sigma.sq.ig) | length(priors$sigma.sq.ig) != 2) { - stop("error: sigma.sq.ig must be a list of length 2") + # Check if n.burn, n.thin, and n.samples result in an integer and error if otherwise. + if (((n.samples - n.burn) / n.thin) %% 1 != 0) { + stop("the number of posterior samples to save ((n.samples - n.burn) / n.thin) is not a whole number. Please respecify the MCMC criteria such that the number of posterior samples saved is a whole number.") } - sigma.sq.a <- priors$sigma.sq.ig[[1]] - sigma.sq.b <- priors$sigma.sq.ig[[2]] - if (length(sigma.sq.a) != p.svc & length(sigma.sq.a) != 1) { - stop(paste("error: sigma.sq.ig[[1]] must be a vector of length ", - p.svc, " or 1 with elements corresponding to sigma.sqs' shape for each covariate with spatially-varying coefficients", sep = "")) + + if (!(family) %in% c('Poisson', 'NB')) { + stop("family must be either 'Poisson' or 'NB'") } - if (length(sigma.sq.b) != p.svc & length(sigma.sq.b) != 1) { - stop(paste("error: sigma.sq.ig[[2]] must be a vector of length ", - p.svc, " or 1 with elements corresponding to sigma.sqs' scale for each covariate with spatially-varying coefficients", sep = "")) + + if (family == 'NB' & verbose) { + message('**NOTE**: spatial negative binomial models can be difficult to\nestimate as they contain two forms of overdispersion. If experiencing\nvery poor mixing/convergence of MCMC chains (particularly kappa and phi),\nconsider using a spatial Poisson model or more informative\npriors on kappa or phi.\n') } - if (length(sigma.sq.a) != p.svc) { - sigma.sq.a <- rep(sigma.sq.a, p.svc) + + # Neighbors and Ordering ---------------------------------------------- + if (NNGP) { + u.search.type <- 2 + ## Order by x column. Could potentially allow this to be user defined. + ord <- order(coords[,1]) + # Reorder everything to align with NN ordering + y <- y[ord, , drop = FALSE] + offset <- offset[ord, , drop = FALSE] + coords <- coords[ord, , drop = FALSE] + # Covariates + for (i in 1:length(data$covs)) { + if (!is.null(dim(data$covs[[i]]))) { + data$covs[[i]] <- data$covs[[i]][ord, , drop = FALSE] + } else { + data$covs[[i]] <- data$covs[[i]][ord] + } + } } - if (length(sigma.sq.b) != p.svc) { - sigma.sq.b <- rep(sigma.sq.b, p.svc) + y.mat <- y + offset.mat <- offset + + # First subset covariates to only use those that are included in the analysis. + # Get occurrence covariates in proper format + # Subset covariates to only use those that are included in the analysis + data$covs <- data$covs[names(data$covs) %in% all.vars(formula)] + # Null model support + if (length(data$covs) == 0) { + data$covs <- list(int = matrix(1, nrow = dim(y)[1], ncol = dim(y)[2])) + } + # Ordered by rep, then site within rep + data$covs <- data.frame(lapply(data$covs, function(a) unlist(c(a)))) + # Check if only site-level covariates are included + if (nrow(data$covs) == dim(y)[1]) { + data$covs <- as.data.frame(lapply(data$covs, rep, dim(y)[2])) } - } else { - if (verbose) { - message("No prior specified for sigma.sq.ig.\nSetting the shape parameter to 2 and scale parameter to 1.\n") + + # Check whether random effects are sent in as numeric, and + # return error if they are. + # Abundance ------------------------- + if (!is.null(findbars(formula))) { + abund.re.names <- unique(unlist(sapply(findbars(formula), all.vars))) + for (i in 1:length(abund.re.names)) { + if (is(data$covs[, abund.re.names[i]], 'factor')) { + stop(paste("error: random effect variable ", abund.re.names[i], " specified as a factor. Random effect variables must be specified as numeric.", sep = '')) + } + if (is(data$covs[, abund.re.names[i]], 'character')) { + stop(paste("error: random effect variable ", abund.re.names[i], " specified as character. Random effect variables must be specified as numeric.", sep = '')) + } + } } - sigma.sq.a <- rep(2, p.svc) - sigma.sq.b <- rep(1, p.svc) - } - # nu ----------------------------- - if (cov.model == "matern") { - if (!"nu.unif" %in% names(priors)) { - stop("error: nu.unif must be specified in priors value list") + # Checking missing values --------------------------------------------- + # y ------------------------------- + y.na.test <- apply(y, 1, function(a) sum(!is.na(a))) + if (sum(y.na.test == 0) > 0) { + stop("error: some sites in y have all missing detection histories. Remove these sites from all objects in the 'data' argument, then use 'predict' to obtain predictions at these locations if desired.") + } + # covs ------------------------------ + for (i in 1:ncol(data$covs)) { + if (sum(is.na(data$covs[, i])) > sum(is.na(y))) { + stop("error: some elements in covs have missing values where there is an observed data value in y. Please either replace the NA values in covs with non-missing values (e.g., mean imputation) or set the corresponding values in y to NA where the covariate is missing.") + } } - nu.a <- priors$nu.unif[[1]] - nu.b <- priors$nu.unif[[2]] - if (!is.list(priors$nu.unif) | length(priors$nu.unif) != 2) { - stop("error: nu.unif must be a list of length 2") + # Misalignment between y and covs + y.missing <- which(is.na(y)) + covs.missing <- lapply(data$covs, function(a) which(is.na(a))) + for (i in 1:length(covs.missing)) { + tmp.indx <- !(y.missing %in% covs.missing[[i]]) + if (sum(tmp.indx) > 0) { + if (i == 1 & verbose) { + message("There are missing values in data$y with corresponding non-missing values in data$covs.\nRemoving these site/replicate combinations for fitting the model.") + } + data$covs[y.missing, i] <- NA + } } - if (length(nu.a) != p.svc & length(nu.a) != 1) { - stop(paste("error: nu.unif[[1]] must be a vector of length ", - p.svc, " or 1 with elements corresponding to nus' lower bound for each covariate with spatially-varying coefficients", sep = "")) + # Remove missing values in covariates prior to sending to parseFormula + if (length(unique(unlist(covs.missing))) > 0) { + data$covs <- data$covs[-c(unique(unlist(covs.missing))), , drop = FALSE] } - if (length(nu.b) != p.svc & length(nu.b) != 1) { - stop(paste("error: nu.unif[[2]] must be a vector of length ", - p.svc, " or 1 with elements corresponding to nus' upper bound for each covariate with spatially-varying coefficients", sep = "")) + + # Check save.fitted --------------------------------------------------- + if (!(save.fitted %in% c(TRUE, FALSE))) { + stop("save.fitted must be either TRUE or FALSE") } - if (length(nu.a) != p.svc) { - nu.a <- rep(nu.a, p.svc) + + # Formula ------------------------------------------------------------- + # Abundance ------------------------- + if (is(formula, 'formula')) { + tmp <- parseFormula(formula, data$covs) + X <- as.matrix(tmp[[1]]) + X.re <- as.matrix(tmp[[4]]) + x.re.names <- colnames(X.re) + x.names <- tmp[[2]] + X.random <- as.matrix(tmp[[5]]) + x.random.names <- colnames(X.random) + } else { + stop("error: formula is misspecified") } - if (length(nu.b) != p.svc) { - nu.b <- rep(nu.b, p.svc) + # Get RE level names + re.level.names <- lapply(data$covs[, x.re.names, drop = FALSE], + function (a) sort(unique(a))) + x.re.names <- x.random.names + + # Get basic info from inputs ------------------------------------------ + # Number of sites + J <- nrow(y) + # Number of abundance parameters + p.abund <- ncol(X) + # Number of abundance random effect parameters + p.abund.re <- ncol(X.re) + # Number of latent abundance random effect values + n.abund.re <- length(unlist(apply(X.re, 2, unique))) + n.abund.re.long <- apply(X.re, 2, function(a) length(unique(a))) + # Number of replicates at each site + n.rep <- apply(y, 1, function(a) sum(!is.na(a))) + # Max number of repeat visits + K.max <- ncol(y) + # Because I like K better than n.rep + K <- n.rep + + # Get indices to map N to y --------------------------------------------- + site.indx <- rep(1:J, dim(y)[2]) + site.indx <- site.indx[!is.na(c(y))] + # Subtract 1 for indices in C + site.indx <- site.indx - 1 + y <- c(y) + offset <- c(offset) + names.long <- which(!is.na(y)) + # Remove missing observations when the covariate data are available but + # there are missing abundance data. + if (nrow(X) == length(y)) { + X <- X[!is.na(y), , drop = FALSE] + } + if (nrow(X.re) == length(y) & p.abund.re > 0) { + X.re <- X.re[!is.na(y), , drop = FALSE] + } + if (nrow(X.random) == length(y) & p.abund.re > 0) { + X.random <- X.random[!is.na(y), , drop = FALSE] + } + y <- y[!is.na(y.mat)] + offset <- offset[!is.na(y.mat)] + # Number of data points for the y vector + n.obs <- nrow(X) + + # Check SVC columns ----------------------------------------------------- + if (is.character(svc.cols)) { + # Check if all column names in svc are in covs + if (!all(svc.cols %in% x.names)) { + missing.cols <- svc.cols[!(svc.cols %in% x.names)] + stop(paste("error: variable name ", + paste(missing.cols, collapse=" and "), " not inurrence covariates", sep="")) + } + # Convert desired column names into the numeric column index + svc.cols <- (1:p.abund)[x.names %in% svc.cols] + + } else if (is.numeric(svc.cols)) { + # Check if all column indices are in 1:p.abund + if (!all(svc.cols %in% 1:p.abund)) { + missing.cols <- svc.cols[!(svc.cols %in% (1:p.abund))] + stop(paste("error: column index ", + paste(missing.cols, collapse=" "), " not in design matrix columns", sep="")) + } } - } else { - nu.a <- rep(0, p.svc) - nu.b <- rep(0, p.svc) - } + p.svc <- length(svc.cols) - # sigma.sq.mu -------------------- - if (p.re > 0) { - if ("sigma.sq.mu.ig" %in% names(priors)) { - if (!is.list(priors$sigma.sq.mu.ig) | length(priors$sigma.sq.mu.ig) != 2) { - stop("error: sigma.sq.mu.ig must be a list of length 2") - } - sigma.sq.mu.a <- priors$sigma.sq.mu.ig[[1]] - sigma.sq.mu.b <- priors$sigma.sq.mu.ig[[2]] - if (length(sigma.sq.mu.a) != p.re & length(sigma.sq.mu.a) != 1) { - if (p.re == 1) { - stop(paste("error: sigma.sq.mu.ig[[1]] must be a vector of length ", - p.re, " with elements corresponding to sigma.sq.mus' shape", sep = "")) + # Get random effect matrices all set ---------------------------------- + X.re <- X.re - 1 + if (p.abund.re > 1) { + # Subtract 1 for C + for (j in 2:p.abund.re) { + X.re[, j] <- X.re[, j] + max(X.re[, j - 1]) + 1 + } + } + # Priors -------------------------------------------------------------- + if (missing(priors)) { + priors <- list() + } + names(priors) <- tolower(names(priors)) + # beta ----------------------- + if ("beta.normal" %in% names(priors)) { + if (!is.list(priors$beta.normal) | length(priors$beta.normal) != 2) { + stop("error: beta.normal must be a list of length 2") + } + mu.beta <- priors$beta.normal[[1]] + sigma.beta <- priors$beta.normal[[2]] + if (length(mu.beta) != p.abund & length(mu.beta) != 1) { + if (p.abund == 1) { + stop(paste("error: beta.normal[[1]] must be a vector of length ", + p.abund, " with elements corresponding to betas' mean", sep = "")) } else { - stop(paste("error: sigma.sq.mu.ig[[1]] must be a vector of length ", - p.re, " or 1 with elements corresponding to sigma.sq.mus' shape", sep = "")) + stop(paste("error: beta.normal[[1]] must be a vector of length ", + p.abund, " or 1 with elements corresponding to betas' mean", sep = "")) } } - if (length(sigma.sq.mu.b) != p.re & length(sigma.sq.mu.b) != 1) { - if (p.re == 1) { - stop(paste("error: sigma.sq.mu.ig[[2]] must be a vector of length ", - p.re, " with elements corresponding to sigma.sq.mus' scale", sep = "")) + if (length(sigma.beta) != p.abund & length(sigma.beta) != 1) { + if (p.abund == 1) { + stop(paste("error: beta.normal[[2]] must be a vector of length ", + p.abund, " with elements corresponding to betas' variance", sep = "")) } else { - stop(paste("error: sigma.sq.mu.ig[[2]] must be a vector of length ", - p.re, " or 1with elements corresponding to sigma.sq.mus' scale", sep = "")) + stop(paste("error: beta.normal[[2]] must be a vector of length ", + p.abund, " or 1 with elements corresponding to betas' variance", sep = "")) } } - if (length(sigma.sq.mu.a) != p.re) { - sigma.sq.mu.a <- rep(sigma.sq.mu.a, p.re) + if (length(sigma.beta) != p.abund) { + sigma.beta <- rep(sigma.beta, p.abund) } - if (length(sigma.sq.mu.b) != p.re) { - sigma.sq.mu.b <- rep(sigma.sq.mu.b, p.re) + if (length(mu.beta) != p.abund) { + mu.beta <- rep(mu.beta, p.abund) } - } else { + Sigma.beta <- sigma.beta * diag(p.abund) + } else { if (verbose) { - message("No prior specified for sigma.sq.mu.ig.\nSetting prior shape to 0.1 and prior scale to 0.1\n") + message("No prior specified for beta.normal.\nSetting prior mean to 0 and prior variance to 100\n") } - sigma.sq.mu.a <- rep(0.1, p.re) - sigma.sq.mu.b <- rep(0.1, p.re) - } - } else { - sigma.sq.mu.a <- 0 - sigma.sq.mu.b <- 0 - } - - # Starting values ----------------------------------------------------- - if (missing(inits)) { - inits <- list() - } - names(inits) <- tolower(names(inits)) - # beta ----------------------- - if ("beta" %in% names(inits)) { - beta.inits <- inits[["beta"]] - if (length(beta.inits) != p & length(beta.inits) != 1) { - if (p == 1) { - stop(paste("error: initial values for beta must be of length ", p, - sep = "")) - + mu.beta <- rep(0, p.abund) + sigma.beta <- rep(100, p.abund) + Sigma.beta <- diag(p.abund) * sigma.beta + } + # sigma.sq.mu -------------------- + if (p.abund.re > 0) { + if ("sigma.sq.mu.ig" %in% names(priors)) { + if (!is.list(priors$sigma.sq.mu.ig) | length(priors$sigma.sq.mu.ig) != 2) { + stop("error: sigma.sq.mu.ig must be a list of length 2") + } + sigma.sq.mu.a <- priors$sigma.sq.mu.ig[[1]] + sigma.sq.mu.b <- priors$sigma.sq.mu.ig[[2]] + if (length(sigma.sq.mu.a) != p.abund.re & length(sigma.sq.mu.a) != 1) { + if (p.abund.re == 1) { + stop(paste("error: sigma.sq.mu.ig[[1]] must be a vector of length ", + p.abund.re, " with elements corresponding to sigma.sq.mus' shape", sep = "")) + } else { + stop(paste("error: sigma.sq.mu.ig[[1]] must be a vector of length ", + p.abund.re, " or 1 with elements corresponding to sigma.sq.mus' shape", sep = "")) + } + } + if (length(sigma.sq.mu.b) != p.abund.re & length(sigma.sq.mu.b) != 1) { + if (p.abund.re == 1) { + stop(paste("error: sigma.sq.mu.ig[[2]] must be a vector of length ", + p.abund.re, " with elements corresponding to sigma.sq.mus' scale", sep = "")) + } else { + stop(paste("error: sigma.sq.mu.ig[[2]] must be a vector of length ", + p.abund.re, " or 1with elements corresponding to sigma.sq.mus' scale", sep = "")) + } + } + if (length(sigma.sq.mu.a) != p.abund.re) { + sigma.sq.mu.a <- rep(sigma.sq.mu.a, p.abund.re) + } + if (length(sigma.sq.mu.b) != p.abund.re) { + sigma.sq.mu.b <- rep(sigma.sq.mu.b, p.abund.re) + } + } else { + if (verbose) { + message("No prior specified for sigma.sq.mu.ig.\nSetting prior shape to 0.1 and prior scale to 0.1\n") + } + sigma.sq.mu.a <- rep(0.1, p.abund.re) + sigma.sq.mu.b <- rep(0.1, p.abund.re) + } + } else { + sigma.sq.mu.a <- 0 + sigma.sq.mu.b <- 0 + } + # kappa ----------------------------- + if (family == 'NB') { + if ("kappa.unif" %in% names(priors)) { + if (!is.vector(priors$kappa.unif) | !is.atomic(priors$kappa.unif) | length(priors$kappa.unif) != 2) { + stop("error: kappa.unif must be a vector of length 2 with elements corresponding to kappa's lower and upper bounds") + } + kappa.a <- priors$kappa.unif[1] + kappa.b <- priors$kappa.unif[2] } else { - stop(paste("error: initial values for beta must be of length ", p, " or 1", - sep = "")) + if (verbose) { + message("No prior specified for kappa.unif.\nSetting uniform bounds of 0 and 100.\n") + } + kappa.a <- 0 + kappa.b <- 100 } - } - if (length(beta.inits) != p) { - beta.inits <- rep(beta.inits, p) - } - } else { - beta.inits <- rnorm(p, mu.beta, sqrt(sigma.beta)) - if (verbose) { - message('beta is not specified in initial values.\nSetting initial values to random values from the prior distribution\n') - } - } - # phi ----------------------------- - if ("phi" %in% names(inits)) { - phi.inits <- inits[["phi"]] - if (length(phi.inits) != p.svc & length(phi.inits) != 1) { - stop(paste("error: initial values for phi must be of length ", p.svc, " or 1", - sep = "")) - } - if (length(phi.inits) != p.svc) { - phi.inits <- rep(phi.inits, p.svc) - } - } else { - phi.inits <- runif(p.svc, phi.a, phi.b) - if (verbose) { - message("phi is not specified in initial values.\nSetting initial value to random values from the prior distribution\n") - } - } - # tau.sq ------------------------ - if ("tau.sq" %in% names(inits)) { - tau.sq.inits <- inits[["tau.sq"]] - if (length(tau.sq.inits) != 1) { - stop("error: initial values for tau.sq must be of length 1") - } - } else { - tau.sq.inits <- runif(1, 0.5, 10) - if (verbose) { - message("tau.sq is not specified in initial values.\nSetting initial value to random value between 0.5 and 10\n") - } - } - # sigma.sq ------------------------ - if ("sigma.sq" %in% names(inits)) { - sigma.sq.inits <- inits[["sigma.sq"]] - if (length(sigma.sq.inits) != p.svc & length(sigma.sq.inits) != 1) { - stop(paste("error: initial values for sigma.sq must be of length ", p.svc, " or 1", - sep = "")) - } - if (length(sigma.sq.inits) != p.svc) { - sigma.sq.inits <- rep(sigma.sq.inits, p.svc) - } - } else { - sigma.sq.inits <- rigamma(p.svc, sigma.sq.a, sigma.sq.b) - if (verbose) { - message("sigma.sq is not specified in initial values.\nSetting initial values to random values from the prior distribution\n") - } - } - # w ----------------------------- - if ("w" %in% names(inits)) { - w.inits <- inits[["w"]] - if (!is.matrix(w.inits)) { - stop(paste("error: initial values for w must be a matrix with dimensions ", - p.svc, " x ", J.est, sep = "")) - } - if (nrow(w.inits) != p.svc | ncol(w.inits) != J.est) { - stop(paste("error: initial values for w must be a matrix with dimensions ", - p.svc, " x ", J.est, sep = "")) - } - if (NNGP) { - w.inits <- w.inits[, ord, drop = FALSE] - } - } else { - w.inits <- matrix(0, p.svc, J.est) - if (verbose) { - message("w is not specified in initial values.\nSetting initial value to 0\n") - } - } - # nu ------------------------ - if ("nu" %in% names(inits)) { - nu.inits <- inits[["nu"]] - if (length(nu.inits) != p.svc & length(nu.inits) != 1) { - stop(paste("error: initial values for nu must be of length ", p.svc, " or 1", - sep = "")) - } - if (length(nu.inits) != p.svc) { - nu.inits <- rep(nu.inits, p.svc) - } - } else { - if (cov.model == 'matern') { + } else { + kappa.a <- 0 + kappa.b <- 0 + } + # phi ----------------------------- + # Get distance matrix which is used if priors are not specified + if ("phi.unif" %in% names(priors)) { + if (!is.list(priors$phi.unif) | length(priors$phi.unif) != 2) { + stop("error: phi.unif must be a list of length 2") + } + phi.a <- priors$phi.unif[[1]] + phi.b <- priors$phi.unif[[2]] + if (length(phi.a) != p.svc & length(phi.a) != 1) { + stop(paste("error: phi.unif[[1]] must be a vector of length ", + p.svc, + " or 1 with elements corresponding to phis' lower bound for each covariate with spatially-varying coefficients", + sep = "")) + } + if (length(phi.b) != p.svc & length(phi.b) != 1) { + stop(paste("error: phi.unif[[2]] must be a vector of length ", + p.svc, + " or 1 with elements corresponding to phis' upper bound for each covariate with spatially-varying coefficients", sep = "")) + } + if (length(phi.a) != p.svc) { + phi.a <- rep(phi.a, p.svc) + } + if (length(phi.b) != p.svc) { + phi.b <- rep(phi.b, p.svc) + } + } else { if (verbose) { - message("nu is not specified in initial values.\nSetting initial values to random values from the prior distribution\n") + message("No prior specified for phi.unif.\nSetting uniform bounds based on the range of observed spatial coordinates.\n") + } + coords.D <- iDist(coords) + phi.a <- rep(3 / max(coords.D), p.svc) + phi.b <- rep(3 / sort(unique(c(coords.D)))[2], p.svc) + } + # sigma.sq ----------------------------- + if ("sigma.sq.ig" %in% names(priors)) { + if (!is.list(priors$sigma.sq.ig) | length(priors$sigma.sq.ig) != 2) { + stop("error: sigma.sq.ig must be a list of length 2") + } + sigma.sq.a <- priors$sigma.sq.ig[[1]] + sigma.sq.b <- priors$sigma.sq.ig[[2]] + if (length(sigma.sq.a) != p.svc & length(sigma.sq.a) != 1) { + stop(paste("error: sigma.sq.ig[[1]] must be a vector of length ", + p.svc, " or 1 with elements corresponding to sigma.sqs' shape for each covariate with spatially-varying coefficients", sep = "")) + } + if (length(sigma.sq.b) != p.svc & length(sigma.sq.b) != 1) { + stop(paste("error: sigma.sq.ig[[2]] must be a vector of length ", + p.svc, " or 1 with elements corresponding to sigma.sqs' scale for each covariate with spatially-varying coefficients", sep = "")) + } + if (length(sigma.sq.a) != p.svc) { + sigma.sq.a <- rep(sigma.sq.a, p.svc) + } + if (length(sigma.sq.b) != p.svc) { + sigma.sq.b <- rep(sigma.sq.b, p.svc) } - nu.inits <- runif(p.svc, nu.a, nu.b) } else { - nu.inits <- rep(0, p.svc) + if (verbose) { + message("No prior specified for sigma.sq.ig.\nSetting the shape parameter to 2 and scale parameter to 1.\n") + } + sigma.sq.a <- rep(2, p.svc) + sigma.sq.b <- rep(1, p.svc) } - } - # sigma.sq.mu ------------------- - if (p.re > 0) { - if ("sigma.sq.mu" %in% names(inits)) { - sigma.sq.mu.inits <- inits[["sigma.sq.mu"]] - if (length(sigma.sq.mu.inits) != p.re & length(sigma.sq.mu.inits) != 1) { - if (p.re == 1) { - stop(paste("error: initial values for sigma.sq.mu must be of length ", p.re, - sep = "")) + + # nu ----------------------------- + if (cov.model == "matern") { + if (!"nu.unif" %in% names(priors)) { + stop("error: nu.unif must be specified in priors value list") + } + nu.a <- priors$nu.unif[[1]] + nu.b <- priors$nu.unif[[2]] + if (!is.list(priors$nu.unif) | length(priors$nu.unif) != 2) { + stop("error: nu.unif must be a list of length 2") + } + if (length(nu.a) != p.svc & length(nu.a) != 1) { + stop(paste("error: nu.unif[[1]] must be a vector of length ", + p.svc, " or 1 with elements corresponding to nus' lower bound for each covariate with spatially-varying coefficients", sep = "")) + } + if (length(nu.b) != p.svc & length(nu.b) != 1) { + stop(paste("error: nu.unif[[2]] must be a vector of length ", + p.svc, " or 1 with elements corresponding to nus' upper bound for each covariate with spatially-varying coefficients", sep = "")) + } + if (length(nu.a) != p.svc) { + nu.a <- rep(nu.a, p.svc) + } + if (length(nu.b) != p.svc) { + nu.b <- rep(nu.b, p.svc) + } + } else { + nu.a <- rep(0, p.svc) + nu.b <- rep(0, p.svc) + } + # Starting values ----------------------------------------------------- + if (missing(inits)) { + inits <- list() + } + names(inits) <- tolower(names(inits)) + # beta ----------------------- + if ("beta" %in% names(inits)) { + beta.inits <- inits[["beta"]] + if (length(beta.inits) != p.abund & length(beta.inits) != 1) { + if (p.abund == 1) { + stop(paste("error: initial values for beta must be of length ", p.abund, + sep = "")) + } else { - stop(paste("error: initial values for sigma.sq.mu must be of length ", p.re, - " or 1", sep = "")) + stop(paste("error: initial values for beta must be of length ", p.abund, " or 1", + sep = "")) } } - if (length(sigma.sq.mu.inits) != p.re) { - sigma.sq.mu.inits <- rep(sigma.sq.mu.inits, p.re) + if (length(beta.inits) != p.abund) { + beta.inits <- rep(beta.inits, p.abund) } } else { - sigma.sq.mu.inits <- runif(p.re, 0.5, 10) + beta.inits <- rnorm(p.abund, 0, 1) if (verbose) { - message("sigma.sq.mu is not specified in initial values.\nSetting initial values to random values between 0.5 and 10\n") + message('beta is not specified in initial values.\nSetting initial values to random values from a standard normal distribution\n') } } - beta.star.indx <- rep(0:(p.re - 1), n.re.long) - beta.star.inits <- rnorm(n.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) - } else { - sigma.sq.mu.inits <- 0 - beta.star.indx <- 0 - beta.star.inits <- 0 - } - # Should initial values be fixed -- - if ("fix" %in% names(inits)) { - fix.inits <- inits[["fix"]] - if ((fix.inits != TRUE) & (fix.inits != FALSE)) { - stop(paste("error: inits$fix must take value TRUE or FALSE")) + # sigma.sq.mu ------------------- + if (p.abund.re > 0) { + if ("sigma.sq.mu" %in% names(inits)) { + sigma.sq.mu.inits <- inits[["sigma.sq.mu"]] + if (length(sigma.sq.mu.inits) != p.abund.re & length(sigma.sq.mu.inits) != 1) { + if (p.abund.re == 1) { + stop(paste("error: initial values for sigma.sq.mu must be of length ", p.abund.re, + sep = "")) + } else { + stop(paste("error: initial values for sigma.sq.mu must be of length ", p.abund.re, + " or 1", sep = "")) + } + } + if (length(sigma.sq.mu.inits) != p.abund.re) { + sigma.sq.mu.inits <- rep(sigma.sq.mu.inits, p.abund.re) + } + } else { + sigma.sq.mu.inits <- runif(p.abund.re, 0.05, 1) + if (verbose) { + message("sigma.sq.mu is not specified in initial values.\nSetting initial values to random values between 0.05 and 1\n") + } + } + beta.star.indx <- rep(0:(p.abund.re - 1), n.abund.re.long) + beta.star.inits <- rnorm(n.abund.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + } else { + sigma.sq.mu.inits <- 0 + beta.star.indx <- 0 + beta.star.inits <- 0 + } + # kappa --------------------------- + if (family == 'NB') { + if ("kappa" %in% names(inits)) { + kappa.inits <- inits[["kappa"]] + if (length(kappa.inits) != 1) { + stop("error: initial values for kappa must be of length 1") + } + } else { + kappa.inits <- runif(1, kappa.a, kappa.b) + if (verbose) { + message("kappa is not specified in initial values.\nSetting initial value to random value from the prior distribution\n") + } + } + } else { + kappa.inits <- 0 + } + # phi ----------------------------- + if ("phi" %in% names(inits)) { + phi.inits <- inits[["phi"]] + if (length(phi.inits) != p.svc & length(phi.inits) != 1) { + stop(paste("error: initial values for phi must be of length ", p.svc, " or 1", + sep = "")) + } + if (length(phi.inits) != p.svc) { + phi.inits <- rep(phi.inits, p.svc) + } + } else { + phi.inits <- runif(p.svc, phi.a, phi.b) + if (verbose) { + message("phi is not specified in initial values.\nSetting initial value to random values from the prior distribution\n") + } } - } else { - fix.inits <- FALSE - } - if (verbose & fix.inits & (n.chains > 1)) { - message("Fixing initial values across all chains\n") - } - # Covariance Model ---------------------------------------------------- - # Order must match util.cpp spCor. - cov.model.names <- c("exponential", "spherical", "matern", "gaussian") - if(! cov.model %in% cov.model.names){ - stop("error: specified cov.model '",cov.model,"' is not a valid option; choose from ", - paste(cov.model.names, collapse=", ", sep="") ,".")} - # Obo for cov model lookup on c side - cov.model.indx <- which(cov.model == cov.model.names) - 1 - storage.mode(cov.model.indx) <- "integer" - - # Prep for SVCs --------------------------------------------------------- - X.w <- X[, svc.cols, drop = FALSE] - - # Get tuning values --------------------------------------------------- - # Not accessed, but necessary to keep things in line. - sigma.sq.tuning <- rep(0, p.svc) - phi.tuning <- rep(0, p.svc) - nu.tuning <- rep(0, p.svc) - if (missing(tuning)) { - phi.tuning <- rep(1, p.svc) - if (cov.model == 'matern') { - nu.tuning <- rep(1, p.svc) + # sigma.sq ------------------------ + if ("sigma.sq" %in% names(inits)) { + sigma.sq.inits <- inits[["sigma.sq"]] + if (length(sigma.sq.inits) != p.svc & length(sigma.sq.inits) != 1) { + stop(paste("error: initial values for sigma.sq must be of length ", p.svc, " or 1", + sep = "")) + } + if (length(sigma.sq.inits) != p.svc) { + sigma.sq.inits <- rep(sigma.sq.inits, p.svc) + } + } else { + sigma.sq.inits <- rigamma(p.svc, sigma.sq.a, sigma.sq.b) + if (verbose) { + message("sigma.sq is not specified in initial values.\nSetting initial values to random values from the prior distribution\n") + } } - } else { - names(tuning) <- tolower(names(tuning)) - # phi --------------------------- - if(!"phi" %in% names(tuning)) { - stop("error: phi must be specified in tuning value list") - } - phi.tuning <- tuning$phi - if (length(phi.tuning) == 1) { - phi.tuning <- rep(tuning$phi, p.svc) - } else if (length(phi.tuning) != p.svc) { - stop(paste("error: phi tuning must be either a single value or a vector of length ", - p.svc, sep = "")) - } - if (cov.model == 'matern') { - # nu -------------------------- - if(!"nu" %in% names(tuning)) { - stop("error: nu must be specified in tuning value list") - } - nu.tuning <- tuning$nu - if (length(nu.tuning) == 1) { - nu.tuning <- rep(tuning$nu, p.svc) - } else if (length(nu.tuning) != p.svc) { - stop(paste("error: nu tuning must be either a single value or a vector of length ", - p.svc, sep = "")) + # w ----------------------------- + if ("w" %in% names(inits)) { + w.inits <- inits[["w"]] + if (!is.matrix(w.inits)) { + stop(paste("error: initial values for w must be a matrix with dimensions ", + p.svc, " x ", J, sep = "")) + } + if (nrow(w.inits) != p.svc | ncol(w.inits) != J) { + stop(paste("error: initial values for w must be a matrix with dimensions ", + p.svc, " x ", J, sep = "")) + } + if (NNGP) { + w.inits <- w.inits[, ord, drop = FALSE] + } + } else { + w.inits <- matrix(0, p.svc, J) + if (verbose) { + message("w is not specified in initial values.\nSetting initial value to 0\n") } } - } - tuning.c <- log(c(sigma.sq.tuning, phi.tuning, nu.tuning)) - # Set model.deviance to NA for returning when no cross-validation - model.deviance <- NA - curr.chain <- 1 + # nu ------------------------ + if ("nu" %in% names(inits)) { + nu.inits <- inits[["nu"]] + if (length(nu.inits) != p.svc & length(nu.inits) != 1) { + stop(paste("error: initial values for nu must be of length ", p.svc, " or 1", + sep = "")) + } + if (length(nu.inits) != p.svc) { + nu.inits <- rep(nu.inits, p.svc) + } + } else { + if (cov.model == 'matern') { + if (verbose) { + message("nu is not specified in initial values.\nSetting initial values to random values from the prior distribution\n") + } + nu.inits <- runif(p.svc, nu.a, nu.b) + } else { + nu.inits <- rep(0, p.svc) + } + } + # Should initial values be fixed -- + if ("fix" %in% names(inits)) { + fix.inits <- inits[["fix"]] + if ((fix.inits != TRUE) & (fix.inits != FALSE)) { + stop(paste("error: inits$fix must take value TRUE or FALSE")) + } + } else { + fix.inits <- FALSE + } + if (verbose & fix.inits & (n.chains > 1)) { + message("Fixing initial values across all chains\n") + } - if (!NNGP) { - stop("error: svcAbund is currently only implemented for NNGPs, not full Gaussian Processes. Please set NNGP = TRUE.") + # Prep for SVCs --------------------------------------------------------- + X.w <- X[, svc.cols, drop = FALSE] - } else { + # Covariance Model ---------------------------------------------------- + # Order must match util.cpp spCor. + cov.model.names <- c("exponential", "spherical", "matern", "gaussian") + if(! cov.model %in% cov.model.names){ + stop("error: specified cov.model '",cov.model,"' is not a valid option; choose from ", + paste(cov.model.names, collapse=", ", sep="") ,".")} + # Obo for cov model lookup on c side + cov.model.indx <- which(cov.model == cov.model.names) - 1 + storage.mode(cov.model.indx) <- "integer" - # Nearest Neighbor Search --------------------------------------------- - if(verbose){ - cat("----------------------------------------\n"); - cat("\tBuilding the neighbor list\n"); - cat("----------------------------------------\n"); + # Get tuning values --------------------------------------------------- + sigma.sq.tuning <- rep(0, p.svc) + beta.tuning <- 0 + w.tuning <- 0 + phi.tuning <- 0 + nu.tuning <- 0 + kappa.tuning <- 0 + beta.star.tuning <- 0 + if (missing(tuning)) { + phi.tuning <- rep(1, p.svc) + kappa.tuning <- 1 + beta.tuning <- rep(1, p.abund) + beta.star.tuning <- rep(1, n.abund.re) + w.tuning <- rep(1, J * p.svc) + if (cov.model == 'matern') { + nu.tuning <- rep(1, p.svc) + } + } else { + names(tuning) <- tolower(names(tuning)) + # phi --------------------------- + if(!"phi" %in% names(tuning)) { + stop("error: phi must be specified in tuning value list") + } + phi.tuning <- tuning$phi + if (length(phi.tuning) == 1) { + phi.tuning <- rep(tuning$phi, p.svc) + } else if (length(phi.tuning) != p.svc) { + stop(paste("error: phi tuning must be either a single value or a vector of length ", + p.svc, sep = "")) + } + if (family == 'NB') { + # kappa --------------------------- + if(!"kappa" %in% names(tuning)) { + stop("error: kappa must be specified in tuning value list") + } + kappa.tuning <- tuning$kappa + if (length(kappa.tuning) != 1) { + stop("error: kappa tuning must be a single value") + } + } + if (cov.model == 'matern') { + # nu -------------------------- + if(!"nu" %in% names(tuning)) { + stop("error: nu must be specified in tuning value list") + } + nu.tuning <- tuning$nu + if (length(nu.tuning) == 1) { + nu.tuning <- rep(tuning$nu, p.svc) + } else if (length(nu.tuning) != p.svc) { + stop(paste("error: nu tuning must be either a single value or a vector of length ", + p.svc, sep = "")) + } + } else { + nu.tuning <- NULL + } + # beta --------------------------- + if(!"beta" %in% names(tuning)) { + stop("error: beta must be specified in tuning value list") + } + beta.tuning <- tuning$beta + if (length(beta.tuning) != 1 & length(beta.tuning) != p.abund) { + stop(paste("error: beta tuning must be a single value or a vector of length ", + p.abund, sep = '')) + } + if (length(beta.tuning) == 1) { + beta.tuning <- rep(beta.tuning, p.abund) + } + # w --------------------------- + if(!"w" %in% names(tuning)) { + stop("error: w must be specified in tuning value list") + } + w.tuning <- tuning$w + if (length(w.tuning) != 1 & length(w.tuning) != (J * p.svc)) { + stop(paste("error: w tuning must be a single value or a vector of length ", + J * p.svc, sep = '')) + } + if (length(w.tuning) == 1) { + w.tuning <- rep(w.tuning, J * p.svc) + } + if (p.abund.re > 0) { + # beta.star --------------------------- + if(!"beta.star" %in% names(tuning)) { + stop("error: beta.star must be specified in tuning value list") + } + beta.star.tuning <- tuning$beta.star + if (length(beta.star.tuning) != 1) { + stop("error: beta.star tuning must be a single value") + } + beta.star.tuning <- rep(beta.star.tuning, n.abund.re) + } else { + beta.star.tuning <- NULL + } } + # Log the tuning values since they are used in the AMCMC. + tuning.c <- log(c(beta.tuning, sigma.sq.tuning, phi.tuning, + nu.tuning, w.tuning, beta.star.tuning, + kappa.tuning)) + curr.chain <- 1 + + if (!NNGP) { + stop("svcAbund is currently only implemented with NNGPs. Please set NNGP = TRUE") + } else { + # Nearest Neighbor Search --------------------------------------------- + if(verbose){ + cat("----------------------------------------\n"); + cat("\tBuilding the neighbor list\n"); + cat("----------------------------------------\n"); + } - search.type.names <- c("brute", "cb") + search.type.names <- c("brute", "cb") - if(!search.type %in% search.type.names){ - stop("error: specified search.type '",search.type, - "' is not a valid option; choose from ", - paste(search.type.names, collapse=", ", sep="") ,".") - } + if(!search.type %in% search.type.names){ + stop("error: specified search.type '",search.type, + "' is not a valid option; choose from ", + paste(search.type.names, collapse=", ", sep="") ,".") + } - storage.mode(n.neighbors) <- "integer" - storage.mode(n.omp.threads) <- "integer" - ## Indexes - if(search.type == "brute"){ - indx <- mkNNIndx(coords, n.neighbors, n.omp.threads) - } else{ - indx <- mkNNIndxCB(coords, n.neighbors, n.omp.threads) - } + storage.mode(n.neighbors) <- "integer" + storage.mode(n.omp.threads) <- "integer" + ## Indexes + if(search.type == "brute"){ + indx <- mkNNIndx(coords, n.neighbors, n.omp.threads) + } else{ + indx <- mkNNIndxCB(coords, n.neighbors, n.omp.threads) + } - nn.indx <- indx$nnIndx - nn.indx.lu <- indx$nnIndxLU - nn.indx.run.time <- indx$run.time + nn.indx <- indx$nnIndx + nn.indx.lu <- indx$nnIndxLU + nn.indx.run.time <- indx$run.time - storage.mode(nn.indx) <- "integer" - storage.mode(nn.indx.lu) <- "integer" - storage.mode(u.search.type) <- "integer" - storage.mode(J.est) <- "integer" + storage.mode(nn.indx) <- "integer" + storage.mode(nn.indx.lu) <- "integer" + storage.mode(u.search.type) <- "integer" + storage.mode(J) <- "integer" - if(verbose){ - cat("----------------------------------------\n"); - cat("Building the neighbors of neighbors list\n"); - cat("----------------------------------------\n"); - } - indx <- mkUIndx(J.est, n.neighbors, nn.indx, nn.indx.lu, u.search.type) - - u.indx <- indx$u.indx - u.indx.lu <- indx$u.indx.lu - ui.indx <- indx$ui.indx - u.indx.run.time <- indx$run.time - - # Other miscellaneous --------------------------------------------------- - # For prediction with random slopes - re.cols <- list() - if (p.re > 0) { - split.names <- strsplit(x.re.names, "[-]") - for (j in 1:p.re) { - re.cols[[j]] <- split.names[[j]][1] - names(re.cols)[j] <- split.names[[j]][2] - } - } - - # Set storage for all variables --------------------------------------- - storage.mode(y) <- "double" - storage.mode(X) <- "double" - storage.mode(X.w) <- "double" - consts <- c(J.est, p, p.re, n.re, p.svc, J.zero) - storage.mode(consts) <- "integer" - storage.mode(coords) <- "double" - storage.mode(beta.inits) <- "double" - storage.mode(tau.sq.inits) <- "double" - storage.mode(phi.inits) <- "double" - storage.mode(sigma.sq.inits) <- "double" - storage.mode(nu.inits) <- "double" - storage.mode(w.inits) <- "double" - storage.mode(mu.beta) <- "double" - storage.mode(Sigma.beta) <- "double" - storage.mode(phi.a) <- "double" - storage.mode(phi.b) <- "double" - storage.mode(tau.sq.a) <- "double" - storage.mode(tau.sq.b) <- "double" - storage.mode(nu.a) <- "double" - storage.mode(nu.b) <- "double" - storage.mode(sigma.sq.a) <- "double" - storage.mode(sigma.sq.b) <- "double" - storage.mode(tuning.c) <- "double" - storage.mode(n.batch) <- "integer" - storage.mode(batch.length) <- "integer" - storage.mode(accept.rate) <- "double" - storage.mode(n.omp.threads) <- "integer" - storage.mode(verbose) <- "integer" - storage.mode(n.report) <- "integer" - storage.mode(nn.indx) <- "integer" - storage.mode(nn.indx.lu) <- "integer" - storage.mode(u.indx) <- "integer" - storage.mode(u.indx.lu) <- "integer" - storage.mode(ui.indx) <- "integer" - storage.mode(n.neighbors) <- "integer" - storage.mode(cov.model.indx) <- "integer" - chain.info <- c(curr.chain, n.chains) - storage.mode(chain.info) <- "integer" - n.post.samples <- length(seq(from = n.burn + 1, - to = n.samples, - by = as.integer(n.thin))) - storage.mode(n.post.samples) <- "integer" - samples.info <- c(n.burn, n.thin, n.post.samples) - storage.mode(samples.info) <- "integer" - # For random effects - storage.mode(X.re) <- "integer" - storage.mode(X.random) <- "double" - beta.level.indx <- sort(unique(c(X.re))) - storage.mode(beta.level.indx) <- "integer" - storage.mode(sigma.sq.mu.inits) <- "double" - storage.mode(sigma.sq.mu.a) <- "double" - storage.mode(sigma.sq.mu.b) <- "double" - storage.mode(beta.star.inits) <- "double" - storage.mode(beta.star.indx) <- "integer" - if (two.stage) { - storage.mode(z) <- 'double' - } - - # Fit the model ------------------------------------------------------- - out.tmp <- list() - # Random seed information for each chain of the model - seeds.list <- list() - out <- list() - for (i in 1:n.chains) { - # Change initial values if i > 1 - if ((i > 1) & (!fix.inits)) { - beta.inits <- rnorm(p, mu.beta, sqrt(sigma.beta)) - sigma.sq.inits <- rigamma(p.svc, sigma.sq.a, sigma.sq.b) - sigma.sq.inits <- runif(p.svc, 0.05, 10) - phi.inits <- runif(p.svc, phi.a, phi.b) - if (cov.model == 'matern') { - nu.inits <- runif(p.svc, nu.a, nu.b) - } - if (p.re > 0) { - sigma.sq.mu.inits <- runif(p.re, 0.5, 10) - beta.star.inits <- rnorm(n.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) - } - tau.sq.inits <- runif(1, 0.1, 10) + # Other miscellaneous --------------------------------------------------- + # For prediction with random slopes + re.cols <- list() + if (p.abund.re > 0) { + split.names <- strsplit(x.re.names, "[-]") + for (j in 1:p.abund.re) { + re.cols[[j]] <- split.names[[j]][1] + names(re.cols)[j] <- split.names[[j]][2] + } + } + + if(verbose){ + cat("----------------------------------------\n"); + cat("Building the neighbors of neighbors list\n"); + cat("----------------------------------------\n"); } + + indx <- mkUIndx(J, n.neighbors, nn.indx, nn.indx.lu, u.search.type) + + u.indx <- indx$u.indx + u.indx.lu <- indx$u.indx.lu + ui.indx <- indx$ui.indx + u.indx.run.time <- indx$run.time + + # Set storage for all variables --------------------------------------- + storage.mode(y) <- "double" + storage.mode(X) <- "double" + storage.mode(X.w) <- 'double' + storage.mode(offset) <- "double" + consts <- c(J, n.obs, p.abund, p.abund.re, n.abund.re, save.fitted, p.svc) + storage.mode(consts) <- "integer" + storage.mode(coords) <- "double" + storage.mode(K) <- "double" + storage.mode(beta.inits) <- "double" + storage.mode(kappa.inits) <- "double" + storage.mode(phi.inits) <- "double" + storage.mode(sigma.sq.inits) <- "double" + storage.mode(nu.inits) <- "double" + storage.mode(w.inits) <- "double" + storage.mode(site.indx) <- "integer" + storage.mode(mu.beta) <- "double" + storage.mode(Sigma.beta) <- "double" + storage.mode(kappa.a) <- "double" + storage.mode(kappa.b) <- "double" + storage.mode(phi.a) <- "double" + storage.mode(phi.b) <- "double" + storage.mode(nu.a) <- "double" + storage.mode(nu.b) <- "double" + storage.mode(sigma.sq.a) <- "double" + storage.mode(sigma.sq.b) <- "double" + storage.mode(n.batch) <- "integer" + storage.mode(batch.length) <- "integer" + storage.mode(accept.rate) <- "double" + storage.mode(tuning.c) <- "double" + storage.mode(n.omp.threads) <- "integer" + storage.mode(verbose) <- "integer" + storage.mode(n.report) <- "integer" + storage.mode(nn.indx) <- "integer" + storage.mode(nn.indx.lu) <- "integer" + storage.mode(u.indx) <- "integer" + storage.mode(u.indx.lu) <- "integer" + storage.mode(ui.indx) <- "integer" + storage.mode(n.neighbors) <- "integer" + storage.mode(cov.model.indx) <- "integer" + chain.info <- c(curr.chain, n.chains) storage.mode(chain.info) <- "integer" - # Run the model in C - out.tmp[[i]] <- .Call("svcAbundNNGP", y, X, - X.w, coords, - X.re, X.random, - consts, n.re.long, - n.neighbors, nn.indx, nn.indx.lu, u.indx, u.indx.lu, ui.indx, - beta.inits, tau.sq.inits, sigma.sq.mu.inits, beta.star.inits, - w.inits, phi.inits, sigma.sq.inits, nu.inits, - beta.star.indx, beta.level.indx, mu.beta, - Sigma.beta, tau.sq.a, tau.sq.b, phi.a, phi.b, - sigma.sq.a, sigma.sq.b, nu.a, nu.b, - sigma.sq.mu.a, sigma.sq.mu.b, - tuning.c, cov.model.indx, - n.batch, batch.length, - accept.rate, n.omp.threads, verbose, n.report, - samples.info, chain.info) - chain.info[1] <- chain.info[1] + 1 - seeds.list[[i]] <- .Random.seed - } - # Calculate R-Hat --------------- - out$rhat <- list() - if (n.chains > 1) { - # as.vector removes the "Upper CI" when there is only 1 variable. - out$rhat$beta <- as.vector(gelman.diag(mcmc.list(lapply(out.tmp, function(a) - mcmc(t(a$beta.samples)))), - autoburnin = FALSE, multivariate = FALSE)$psrf[, 2]) - out$rhat$tau.sq <- as.vector(gelman.diag(mcmc.list(lapply(out.tmp, function(a) - mcmc(t(a$tau.sq.samples)))), - autoburnin = FALSE, multivariate = FALSE)$psrf[, 2]) - out$rhat$theta <- gelman.diag(mcmc.list(lapply(out.tmp, function(a) - mcmc(t(a$theta.samples)))), - autoburnin = FALSE, multivariate = FALSE)$psrf[, 2] - if (p.re > 0) { - out$rhat$sigma.sq.mu <- as.vector(gelman.diag(mcmc.list(lapply(out.tmp, function(a) - mcmc(t(a$sigma.sq.mu.samples)))), - autoburnin = FALSE, multivariate = FALSE)$psrf[, 2]) + n.post.samples <- length(seq(from = n.burn + 1, + to = n.samples, + by = as.integer(n.thin))) + storage.mode(n.post.samples) <- "integer" + samples.info <- c(n.burn, n.thin, n.post.samples) + storage.mode(samples.info) <- "integer" + # For abundance random effects + storage.mode(X.re) <- "integer" + storage.mode(X.random) <- "double" + beta.level.indx <- sort(unique(c(X.re))) + storage.mode(beta.level.indx) <- "integer" + storage.mode(sigma.sq.mu.inits) <- "double" + storage.mode(sigma.sq.mu.a) <- "double" + storage.mode(sigma.sq.mu.b) <- "double" + storage.mode(beta.star.inits) <- "double" + storage.mode(beta.star.indx) <- "integer" + # NB = 1, Poisson = 0 + family.c <- ifelse(family == 'NB', 1, 0) + storage.mode(family.c) <- "integer" + + # Fit the model ------------------------------------------------------- + out.tmp <- list() + out <- list() + for (i in 1:n.chains) { + # Change initial values if i > 1 + if ((i > 1) & (!fix.inits)) { + beta.inits <- rnorm(p.abund, 0, 1) + if (p.abund.re > 0) { + sigma.sq.mu.inits <- runif(p.abund.re, 0.05, 1) + beta.star.inits <- rnorm(n.abund.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + } + if (family == 'NB') { + kappa.inits <- runif(1, kappa.a, kappa.b) + } + sigma.sq.inits <- runif(p.svc, 0.05, 3) + phi.inits <- runif(p.svc, phi.a, phi.b) + if (cov.model == 'matern') { + nu.inits <- runif(p.svc, nu.a, nu.b) + } + } + storage.mode(chain.info) <- "integer" + # Run the model in C + out.tmp[[i]] <- .Call("svcAbundNNGP", y, X, X.w, coords, X.re, X.random, + consts, n.abund.re.long, + n.neighbors, nn.indx, nn.indx.lu, u.indx, u.indx.lu, + beta.inits, kappa.inits, + sigma.sq.mu.inits, beta.star.inits, w.inits, phi.inits, + sigma.sq.inits, nu.inits, site.indx, beta.star.indx, + beta.level.indx, mu.beta, Sigma.beta, + kappa.a, kappa.b, + sigma.sq.mu.a, sigma.sq.mu.b, + phi.a, phi.b, sigma.sq.a, sigma.sq.b, nu.a, nu.b, + tuning.c, cov.model.indx, n.batch, batch.length, accept.rate, + n.omp.threads, verbose, n.report, samples.info, chain.info, + family.c, offset) + chain.info[1] <- chain.info[1] + 1 + } # i + + # Calculate R-Hat --------------- + out <- list() + out$rhat <- list() + if (n.chains > 1) { + # as.vector removes the "Upper CI" when there is only 1 variable. + out$rhat$beta <- as.vector(gelman.diag(mcmc.list(lapply(out.tmp, function(a) + mcmc(t(a$beta.samples)))), + autoburnin = FALSE, multivariate = FALSE)$psrf[, 2]) + if (p.abund.re > 0) { + out$rhat$sigma.sq.mu <- as.vector(gelman.diag(mcmc.list(lapply(out.tmp, function(a) + mcmc(t(a$sigma.sq.mu.samples)))), + autoburnin = FALSE, multivariate = FALSE)$psrf[, 2]) + } + if (family == 'NB') { + out$rhat$kappa <- as.vector(gelman.diag(mcmc.list(lapply(out.tmp, function(a) + mcmc(t(a$kappa.samples)))), + autoburnin = FALSE, multivariate = FALSE)$psrf[, 2]) + } + out$rhat$theta <- gelman.diag(mcmc.list(lapply(out.tmp, function(a) + mcmc(t(a$theta.samples)))), + autoburnin = FALSE, multivariate = FALSE)$psrf[, 2] + } else { + out$rhat$beta <- rep(NA, p.abund) + out$rhat$kappa <- NA + out$rhat$theta <- rep(NA, ifelse(cov.model == 'matern', 3 * p.svc, 2 * p.svc)) + if (p.abund.re > 0) { + out$rhat$sigma.sq.mu <- rep(NA, p.abund.re) + } } - } else { - out$rhat$beta <- rep(NA, p) - out$rhat$tau.sq <- NA - out$rhat$theta <- rep(NA, ifelse(cov.model == 'matern', 3 * p.svc, 2 * p.svc)) - if (p.re > 0) { - out$rhat$sigma.sq.mu <- rep(NA, p.re) - } - } - out$beta.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$beta.samples)))) - colnames(out$beta.samples) <- x.names - out$theta.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$theta.samples)))) - if (cov.model != 'matern') { - theta.names <- paste(rep(c('sigma.sq', 'phi'), each = p.svc), x.names[svc.cols], sep = '-') - } else { - theta.names <- paste(rep(c('sigma.sq', 'phi', 'nu'), each = p.svc), x.names[svc.cols], sep = '-') - } - colnames(out$theta.samples) <- theta.names - out$tau.sq.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$tau.sq.samples)))) - # Get everything back in the original order - out$coords <- coords[order(ord), ] - if (!two.stage) { - out$y.rep.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$y.rep.samples)))) - out$y.rep.samples <- mcmc(out$y.rep.samples[, order(ord), drop = FALSE]) - out$like.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$like.samples)))) - out$like.samples <- mcmc(out$like.samples[, order(ord), drop = FALSE]) - } else { - y.rep.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$y.rep.samples)))) - y.rep.samples <- mcmc(y.rep.samples[, order(ord), drop = FALSE]) - like.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$like.samples)))) - like.samples <- mcmc(like.samples[, order(ord), drop = FALSE]) - y.rep.zero.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$y.rep.zero.samples)))) - out$y.rep.samples <- matrix(NA, n.post.samples * n.chains, J.est + J.zero) - out$y.rep.samples[, z.indx] <- y.rep.samples - out$y.rep.samples[, -z.indx] <- y.rep.zero.samples - out$y.rep.samples <- mcmc(out$y.rep.samples) - out$like.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$like.samples)))) - out$like.samples <- mcmc(out$like.samples[, order(ord), drop = FALSE]) - } - out$X <- X[order(ord), , drop = FALSE] - out$X.re <- X.re[order(ord), , drop = FALSE] - out$X.w <- X.w[order(ord), , drop = FALSE] - # Account for case when intercept only spatial model. - if (p.svc == 1) { - tmp <- do.call(rbind, lapply(out.tmp, function(a) t(a$w.samples))) - tmp <- tmp[, order(ord), drop = FALSE] - out$w.samples <- array(NA, dim = c(p.svc, J.est, n.post.samples * n.chains)) - out$w.samples[1, , ] <- t(tmp) - } else { - out$w.samples <- do.call(abind, lapply(out.tmp, function(a) array(a$w.samples, - dim = c(p.svc, J.est, n.post.samples)))) - out$w.samples <- out$w.samples[, order(ord), ] - } - out$w.samples <- aperm(out$w.samples, c(3, 1, 2)) - out$mu.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$mu.samples)))) - out$mu.samples <- mcmc(out$mu.samples[, order(ord), drop = FALSE]) - out$y <- y.orig - if (p.re > 0) { - out$sigma.sq.mu.samples <- mcmc( - do.call(rbind, lapply(out.tmp, function(a) t(a$sigma.sq.mu.samples)))) - colnames(out$sigma.sq.mu.samples) <- x.re.names - out$beta.star.samples <- mcmc( - do.call(rbind, lapply(out.tmp, function(a) t(a$beta.star.samples)))) - tmp.names <- unlist(re.level.names) - beta.star.names <- paste(rep(x.re.names, n.re.long), tmp.names, sep = '-') - colnames(out$beta.star.samples) <- beta.star.names - out$re.level.names <- re.level.names - } - # Calculate effective sample sizes - out$ESS <- list() - out$ESS$beta <- effectiveSize(out$beta.samples) - out$ESS$tau.sq <- effectiveSize(out$tau.sq.samples) - out$ESS$theta <- effectiveSize(out$theta.samples) - if (p.re > 0) { - out$ESS$sigma.sq.mu <- effectiveSize(out$sigma.sq.mu.samples) - } - out$call <- cl - out$n.samples <- batch.length * n.batch - out$n.neighbors <- n.neighbors - out$cov.model.indx <- cov.model.indx - out$svc.cols <- svc.cols - out$type <- "NNGP" - out$n.post <- n.post.samples - out$n.thin <- n.thin - out$n.burn <- n.burn - out$n.chains <- n.chains - out$re.cols <- re.cols - out$dist <- family - if (p.re > 0) { - out$muRE <- TRUE - } else { - out$muRE <- FALSE - } - } # NNGP or GP - class(out) <- "svcAbund" - out$run.time <- proc.time() - ptm - return(out) + # Put everything into MCMC objects + out$beta.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$beta.samples)))) + colnames(out$beta.samples) <- x.names + if (family == 'NB') { + out$kappa.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$kappa.samples)))) + colnames(out$kappa.samples) <- c("kappa") + } + out$theta.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$theta.samples)))) + if (cov.model != 'matern') { + theta.names <- paste(rep(c('sigma.sq', 'phi'), each = p.svc), x.names[svc.cols], sep = '-') + } else { + theta.names <- paste(rep(c('sigma.sq', 'phi', 'nu'), each = p.svc), x.names[svc.cols], sep = '-') + } + colnames(out$theta.samples) <- theta.names + y.non.miss.indx <- which(!is.na(y.mat), arr.ind = TRUE) + if (save.fitted) { + out$y.rep.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$y.rep.samples)))) + tmp <- array(NA, dim = c(n.post.samples * n.chains, J, ncol(y.mat))) + for (j in 1:n.obs) { + curr.indx <- y.non.miss.indx[j, ] + tmp[, curr.indx[1], curr.indx[2]] <- out$y.rep.samples[, j] + } + out$y.rep.samples <- tmp[, order(ord), , drop = FALSE] + out$mu.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$mu.samples)))) + tmp <- array(NA, dim = c(n.post.samples * n.chains, J, ncol(y.mat))) + for (j in 1:n.obs) { + curr.indx <- y.non.miss.indx[j, ] + tmp[, curr.indx[1], curr.indx[2]] <- out$mu.samples[, j] + } + out$mu.samples <- tmp[, order(ord), , drop = FALSE] + out$like.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$like.samples)))) + tmp <- array(NA, dim = c(n.post.samples * n.chains, J, ncol(y.mat))) + for (j in 1:n.obs) { + curr.indx <- y.non.miss.indx[j, ] + tmp[, curr.indx[1], curr.indx[2]] <- out$like.samples[, j] + } + out$like.samples <- tmp[, order(ord), , drop = FALSE] + } + # Account for case when intercept only spatial model. + if (p.svc == 1) { + tmp <- do.call(rbind, lapply(out.tmp, function(a) t(a$w.samples))) + tmp <- tmp[, order(ord), drop = FALSE] + out$w.samples <- array(NA, dim = c(p.svc, J, n.post.samples * n.chains)) + out$w.samples[1, , ] <- t(tmp) + } else { + out$w.samples <- do.call(abind, lapply(out.tmp, function(a) array(a$w.samples, + dim = c(p.svc, J, n.post.samples)))) + out$w.samples <- out$w.samples[, order(ord), ] + } + out$w.samples <- aperm(out$w.samples, c(3, 1, 2)) + if (p.abund.re > 0) { + out$sigma.sq.mu.samples <- mcmc( + do.call(rbind, lapply(out.tmp, function(a) t(a$sigma.sq.mu.samples)))) + colnames(out$sigma.sq.mu.samples) <- x.re.names + out$beta.star.samples <- mcmc( + do.call(rbind, lapply(out.tmp, function(a) t(a$beta.star.samples)))) + tmp.names <- unlist(re.level.names) + beta.star.names <- paste(rep(x.re.names, n.abund.re.long), tmp.names, sep = '-') + colnames(out$beta.star.samples) <- beta.star.names + out$re.level.names <- re.level.names + } + # Calculate effective sample sizes + out$ESS <- list() + out$ESS$beta <- effectiveSize(out$beta.samples) + if (family == 'NB') { + out$ESS$kappa <- effectiveSize(out$kappa.samples) + } + out$ESS$theta <- effectiveSize(out$theta.samples) + if (p.abund.re > 0) { + out$ESS$sigma.sq.mu <- effectiveSize(out$sigma.sq.mu.samples) + } + out$X <- array(NA, dim = c(J, ncol(y.mat), p.abund)) + out$X.re <- array(NA, dim = c(J, ncol(y.mat), p.abund.re)) + out$X.w <- array(NA, dim = c(J, ncol(y.mat), p.svc)) + for (j in 1:n.obs) { + curr.indx <- y.non.miss.indx[j, ] + out$X[curr.indx[1], curr.indx[2], ] <- X[j, ] + out$X.w[curr.indx[1], curr.indx[2], ] <- X.w[j, ] + if (p.abund.re > 0) { + out$X.re[curr.indx[1], curr.indx[2], ] <- X.re[j, ] + } + } + dimnames(out$X)[[3]] <- x.names + dimnames(out$X.w)[[3]] <- x.names[svc.cols] + dimnames(out$X.re)[[3]] <- colnames(X.re) + out$X <- out$X[order(ord), , , drop = FALSE] + out$X.w <- out$X.w[order(ord), , , drop = FALSE] + out$X.re <- out$X.re[order(ord), , , drop = FALSE] + out$coords <- coords[order(ord), ] + out$y <- y.mat[order(ord), , drop = FALSE] + out$offset <- offset.mat[order(ord), , drop = FALSE] + out$n.samples <- n.samples + out$call <- cl + out$n.post <- n.post.samples + out$n.neighbors <- n.neighbors + out$cov.model.indx <- cov.model.indx + out$svc.cols <- svc.cols + out$type <- "NNGP" + out$n.thin <- n.thin + out$n.burn <- n.burn + out$n.chains <- n.chains + out$dist <- family + out$re.cols <- re.cols + if (p.abund.re > 0) { + out$muRE <- TRUE + } else { + out$muRE <- FALSE + } + } # NNGP + class(out) <- "svcAbund" + out$run.time <- proc.time() - ptm + out + } } diff --git a/R/svcAbundGaussian.R b/R/svcAbundGaussian.R new file mode 100644 index 0000000..c506c8b --- /dev/null +++ b/R/svcAbundGaussian.R @@ -0,0 +1,915 @@ +svcAbundGaussian <- function(formula, data, inits, priors, tuning, + svc.cols = 1, cov.model = 'exponential', NNGP = TRUE, + n.neighbors = 15, search.type = 'cb', n.batch, + batch.length, accept.rate = 0.43, family = 'Gaussian', + n.omp.threads = 1, verbose = TRUE, n.report = 100, + n.burn = round(.10 * n.batch * batch.length), + n.thin = 1, n.chains = 1, ...){ + + ptm <- proc.time() + + # Make it look nice + if (verbose) { + cat("----------------------------------------\n"); + cat("\tPreparing to run the model\n"); + cat("----------------------------------------\n"); + } + + # Functions --------------------------------------------------------------- + logit <- function(theta, a = 0, b = 1) {log((theta-a)/(b-theta))} + logit.inv <- function(z, a = 0, b = 1) {b-(b-a)/(1+exp(z))} + rigamma <- function(n, a, b){ + 1/rgamma(n = n, shape = a, rate = b) + } + + # Check for unused arguments ------------------------------------------ + formal.args <- names(formals(sys.function(sys.parent()))) + elip.args <- names(list(...)) + for(i in elip.args){ + if(! i %in% formal.args) + warning("'",i, "' is not an argument") + } + # Call ---------------------------------------------------------------- + # Returns a call in which all of the specified arguments are + # specified by their full names. + cl <- match.call() + + # Some initial checks ------------------------------------------------- + if (missing(data)) { + stop("error: data must be specified") + } + if (!is.list(data)) { + stop("error: data must be a list") + } + names(data) <- tolower(names(data)) + if (missing(formula)) { + stop("error: formula must be specified") + } + if (!'y' %in% names(data)) { + stop("error: detection-nondetection data y must be specified in data") + } + y <- c(data$y) + if (!'covs' %in% names(data)) { + if (formula == ~ 1) { + if (verbose) { + message("covariates (covs) not specified in data.\nAssuming intercept only model.\n") + } + data$covs <- matrix(1, length(y), 1) + } else { + stop("error: covs must be specified in data for a model with covariates") + } + } + if (!is.list(data$covs)) { + if (is.matrix(data$covs)) { + data$covs <- data.frame(data$covs) + } else { + stop("error: covs must be a list, data frame, or matrix") + } + } + if (!'coords' %in% names(data)) { + stop("error: coords must be specified in data for a spatial model.") + } + if (!is.matrix(data$coords) & !is.data.frame(data$coords)) { + stop("error: coords must be a matrix or data frame") + } + coords <- as.matrix(data$coords) + + if (!(family) %in% c('Gaussian', 'zi-Gaussian')) { + stop("svcAbund currently only supports family = 'Gaussian' or 'zi-Gaussian'") + } + if (family == 'zi-Gaussian') { + two.stage <- TRUE + } else { + two.stage <- FALSE + } + if (two.stage) { + if (!'z' %in% names(data)) { + stop("error: z must be specified in data for a two stage model") + } + z <- data$z + } else { + z <- rep(1, length(y)) + } + + # First subset covariates to only use those that are included in the analysis. + # Get occurrence covariates in proper format + # Subset covariates to only use those that are included in the analysis + data$covs <- data$covs[names(data$covs) %in% all.vars(formula)] + # Null model support + if (length(data$covs) == 0) { + data$covs <- list(int = rep(1, length(y))) + } + # Ordered by rep, then site within rep + data$covs <- data.frame(lapply(data$covs, function(a) unlist(c(a)))) + + # Check first-stage sample ---------------------------------------------- + if (length(z) != length(y)) { + stop(paste("z must be a vector of length ", length(y), ".", sep = '')) + } + # Number of points where z == 1 + J.est <- sum(z == 1) + # Number of points where z != 1 + J.zero <- sum(z == 0) + # Index for the sites where z == 1 + z.indx <- which(z == 1) + + # Filter all objects to only use sites with z == 1 + y.orig <- y + y <- y[z.indx] + coords <- coords[z.indx, ] + data$covs <- data$covs[z.indx, , drop = FALSE] + + # Neighbors and Ordering ---------------------------------------------- + if (NNGP) { + u.search.type <- 2 + ## Order by x column. Could potentially allow this to be user defined. + ord <- order(coords[,1]) + # Reorder everything to align with NN ordering + y <- y[ord, drop = FALSE] + coords <- coords[ord, , drop = FALSE] + # Occupancy covariates + data$covs <- data$covs[ord, , drop = FALSE] + } + + data$covs <- as.data.frame(data$covs) + + # Checking missing values --------------------------------------------- + # y ------------------------------- + if (sum(is.na(y) > 0)) { + stop("error: some sites in y have missing values. Remove these sites from all objects in the 'data' argument, then use 'predict' to obtain predictions at these locations if desired.") + } + # covs ------------------------ + if (sum(is.na(data$covs)) != 0) { + stop("error: missing values in covs. Please remove these sites from all objects in data or somehow replace the NA values with non-missing values (e.g., mean imputation).") + } + + # Check whether random effects are sent in as numeric, and + # return error if they are. + # Occurrence ---------------------- + if (!is.null(findbars(formula))) { + re.names <- unique(unlist(sapply(findbars(formula), all.vars))) + for (i in 1:length(re.names)) { + if (is(data$covs[, re.names[i]], 'factor')) { + stop(paste("error: random effect variable ", re.names[i], " specified as a factor. Random effect variables must be specified as numeric.", sep = '')) + } + if (is(data$covs[, re.names[i]], 'character')) { + stop(paste("error: random effect variable ", re.names[i], " specified as character. Random effect variables must be specified as numeric.", sep = '')) + } + } + } + + # Formula ------------------------------------------------------------- + # Occupancy ----------------------- + if (is(formula, 'formula')) { + tmp <- parseFormula(formula, data$covs) + X <- as.matrix(tmp[[1]]) + X.re <- as.matrix(tmp[[4]]) + x.re.names <- colnames(X.re) + x.names <- tmp[[2]] + X.random <- as.matrix(tmp[[5]]) + x.random.names <- colnames(X.random) + } else { + stop("error: formula is misspecified") + } + # Get RE level names + re.level.names <- lapply(data$covs[, x.re.names, drop = FALSE], + function (a) sort(unique(a))) + x.re.names <- x.random.names + + # Get basic info from inputs ------------------------------------------ + # Number of sites + J <- nrow(coords) + # Number of parameters + p <- ncol(X) + # Number of random effect parameters + p.re <- ncol(X.re) + # Number of latent random effect values + n.re <- length(unlist(apply(X.re, 2, unique))) + n.re.long <- apply(X.re, 2, function(a) length(unique(a))) + if (missing(n.batch)) { + stop("error: must specify number of MCMC batches") + } + if (missing(batch.length)) { + stop("error: must specify length of each MCMC batch") + } + n.samples <- n.batch * batch.length + if (n.burn > n.samples) { + stop("error: n.burn must be less than n.samples") + } + if (n.thin > n.samples) { + stop("error: n.thin must be less than n.samples") + } + # Check if n.burn, n.thin, and n.samples result in an integer and error if otherwise. + if (((n.samples - n.burn) / n.thin) %% 1 != 0) { + stop("the number of posterior samples to save ((n.samples - n.burn) / n.thin) is not a whole number. Please respecify the MCMC criteria such that the number of posterior samples saved is a whole number.") + } + n.post.samples <- length(seq(from = n.burn + 1, + to = n.samples, + by = as.integer(n.thin))) + + # Check SVC columns ----------------------------------------------------- + if (is.character(svc.cols)) { + # Check if all column names in svc are in covs + if (!all(svc.cols %in% x.names)) { + missing.cols <- svc.cols[!(svc.cols %in% x.names)] + stop(paste("error: variable name ", paste(missing.cols, collapse=" and "), " not inurrence covariates", sep="")) + } + # Convert desired column names into the numeric column index + svc.cols <- (1:p)[x.names %in% svc.cols] + + } else if (is.numeric(svc.cols)) { + # Check if all column indices are in 1:p + if (!all(svc.cols %in% 1:p)) { + missing.cols <- svc.cols[!(svc.cols %in% (1:p))] + stop(paste("error: column index ", paste(missing.cols, collapse=" "), " not in design matrix columns", sep="")) + } + } + p.svc <- length(svc.cols) + + # Get random effect matrices all set ---------------------------------- + X.re <- X.re - 1 + if (p.re > 1) { + for (j in 2:p.re) { + X.re[, j] <- X.re[, j] + max(X.re[, j - 1]) + 1 + } + } + + # Priors -------------------------------------------------------------- + if (missing(priors)) { + priors <- list() + } + names(priors) <- tolower(names(priors)) + # beta ----------------------- + if ("beta.normal" %in% names(priors)) { + if (!is.list(priors$beta.normal) | length(priors$beta.normal) != 2) { + stop("error: beta.normal must be a list of length 2") + } + mu.beta <- priors$beta.normal[[1]] + sigma.beta <- priors$beta.normal[[2]] + if (length(mu.beta) != p & length(mu.beta) != 1) { + if (p == 1) { + stop(paste("error: beta.normal[[1]] must be a vector of length ", + p, " with elements corresponding to betas' mean", sep = "")) + } else { + stop(paste("error: beta.normal[[1]] must be a vector of length ", + p, " or 1 with elements corresponding to betas' mean", sep = "")) + } + } + if (length(sigma.beta) != p & length(sigma.beta) != 1) { + if (p == 1) { + stop(paste("error: beta.normal[[2]] must be a vector of length ", + p, " with elements corresponding to betas' variance", sep = "")) + } else { + stop(paste("error: beta.normal[[2]] must be a vector of length ", + p, " or 1 with elements corresponding to betas' variance", sep = "")) + } + } + if (length(sigma.beta) != p) { + sigma.beta <- rep(sigma.beta, p) + } + if (length(mu.beta) != p) { + mu.beta <- rep(mu.beta, p) + } + Sigma.beta <- sigma.beta * diag(p) + } else { + if (verbose) { + message("No prior specified for beta.normal.\nSetting prior mean to 0 and prior variance to 100\n") + } + mu.beta <- rep(0, p) + sigma.beta <- rep(100, p) + Sigma.beta <- diag(p) * 100 + } + # phi ----------------------------- + # Get distance matrix which is used if priors are not specified + if ("phi.unif" %in% names(priors)) { + if (!is.list(priors$phi.unif) | length(priors$phi.unif) != 2) { + stop("error: phi.unif must be a list of length 2") + } + phi.a <- priors$phi.unif[[1]] + phi.b <- priors$phi.unif[[2]] + if (length(phi.a) != p.svc & length(phi.a) != 1) { + stop(paste("error: phi.unif[[1]] must be a vector of length ", + p.svc, + " or 1 with elements corresponding to phis' lower bound for each covariate with spatially-varying coefficients", + sep = "")) + } + if (length(phi.b) != p.svc & length(phi.b) != 1) { + stop(paste("error: phi.unif[[2]] must be a vector of length ", + p.svc, + " or 1 with elements corresponding to phis' upper bound for each covariate with spatially-varying coefficients", sep = "")) + } + if (length(phi.a) != p.svc) { + phi.a <- rep(phi.a, p.svc) + } + if (length(phi.b) != p.svc) { + phi.b <- rep(phi.b, p.svc) + } + } else { + if (verbose) { + message("No prior specified for phi.unif.\nSetting uniform bounds based on the range of observed spatial coordinates.\n") + } + coords.D <- iDist(coords) + phi.a <- rep(3 / max(coords.D), p.svc) + phi.b <- rep(3 / sort(unique(c(coords.D)))[2], p.svc) + } + # tau.sq.t ---------------------- + if ("tau.sq.ig" %in% names(priors)) { + if (!is.vector(priors$tau.sq.ig) | !is.atomic(priors$tau.sq.ig) | length(priors$tau.sq.ig) != 2) { + stop("error: tau.sq.ig must be a vector of length 2 with elements corresponding to tau.sq's shape and scale parameters") + } + tau.sq.a <- priors$tau.sq.ig[1] + tau.sq.b <- priors$tau.sq.ig[2] + } else { + if (verbose) { + message("No prior specified for tau.sq.\nUsing an inverse-Gamma prior with the shape parameter set to 2 and scale parameter to 0.5.\n") + } + tau.sq.a <- 2 + tau.sq.b <- 0.5 + } + # sigma.sq ----------------------------- + if ("sigma.sq.ig" %in% names(priors)) { + if (!is.list(priors$sigma.sq.ig) | length(priors$sigma.sq.ig) != 2) { + stop("error: sigma.sq.ig must be a list of length 2") + } + sigma.sq.a <- priors$sigma.sq.ig[[1]] + sigma.sq.b <- priors$sigma.sq.ig[[2]] + if (length(sigma.sq.a) != p.svc & length(sigma.sq.a) != 1) { + stop(paste("error: sigma.sq.ig[[1]] must be a vector of length ", + p.svc, " or 1 with elements corresponding to sigma.sqs' shape for each covariate with spatially-varying coefficients", sep = "")) + } + if (length(sigma.sq.b) != p.svc & length(sigma.sq.b) != 1) { + stop(paste("error: sigma.sq.ig[[2]] must be a vector of length ", + p.svc, " or 1 with elements corresponding to sigma.sqs' scale for each covariate with spatially-varying coefficients", sep = "")) + } + if (length(sigma.sq.a) != p.svc) { + sigma.sq.a <- rep(sigma.sq.a, p.svc) + } + if (length(sigma.sq.b) != p.svc) { + sigma.sq.b <- rep(sigma.sq.b, p.svc) + } + } else { + if (verbose) { + message("No prior specified for sigma.sq.ig.\nSetting the shape parameter to 2 and scale parameter to 1.\n") + } + sigma.sq.a <- rep(2, p.svc) + sigma.sq.b <- rep(1, p.svc) + } + + # nu ----------------------------- + if (cov.model == "matern") { + if (!"nu.unif" %in% names(priors)) { + stop("error: nu.unif must be specified in priors value list") + } + nu.a <- priors$nu.unif[[1]] + nu.b <- priors$nu.unif[[2]] + if (!is.list(priors$nu.unif) | length(priors$nu.unif) != 2) { + stop("error: nu.unif must be a list of length 2") + } + if (length(nu.a) != p.svc & length(nu.a) != 1) { + stop(paste("error: nu.unif[[1]] must be a vector of length ", + p.svc, " or 1 with elements corresponding to nus' lower bound for each covariate with spatially-varying coefficients", sep = "")) + } + if (length(nu.b) != p.svc & length(nu.b) != 1) { + stop(paste("error: nu.unif[[2]] must be a vector of length ", + p.svc, " or 1 with elements corresponding to nus' upper bound for each covariate with spatially-varying coefficients", sep = "")) + } + if (length(nu.a) != p.svc) { + nu.a <- rep(nu.a, p.svc) + } + if (length(nu.b) != p.svc) { + nu.b <- rep(nu.b, p.svc) + } + } else { + nu.a <- rep(0, p.svc) + nu.b <- rep(0, p.svc) + } + + # sigma.sq.mu -------------------- + if (p.re > 0) { + if ("sigma.sq.mu.ig" %in% names(priors)) { + if (!is.list(priors$sigma.sq.mu.ig) | length(priors$sigma.sq.mu.ig) != 2) { + stop("error: sigma.sq.mu.ig must be a list of length 2") + } + sigma.sq.mu.a <- priors$sigma.sq.mu.ig[[1]] + sigma.sq.mu.b <- priors$sigma.sq.mu.ig[[2]] + if (length(sigma.sq.mu.a) != p.re & length(sigma.sq.mu.a) != 1) { + if (p.re == 1) { + stop(paste("error: sigma.sq.mu.ig[[1]] must be a vector of length ", + p.re, " with elements corresponding to sigma.sq.mus' shape", sep = "")) + } else { + stop(paste("error: sigma.sq.mu.ig[[1]] must be a vector of length ", + p.re, " or 1 with elements corresponding to sigma.sq.mus' shape", sep = "")) + } + } + if (length(sigma.sq.mu.b) != p.re & length(sigma.sq.mu.b) != 1) { + if (p.re == 1) { + stop(paste("error: sigma.sq.mu.ig[[2]] must be a vector of length ", + p.re, " with elements corresponding to sigma.sq.mus' scale", sep = "")) + } else { + stop(paste("error: sigma.sq.mu.ig[[2]] must be a vector of length ", + p.re, " or 1with elements corresponding to sigma.sq.mus' scale", sep = "")) + } + } + if (length(sigma.sq.mu.a) != p.re) { + sigma.sq.mu.a <- rep(sigma.sq.mu.a, p.re) + } + if (length(sigma.sq.mu.b) != p.re) { + sigma.sq.mu.b <- rep(sigma.sq.mu.b, p.re) + } + } else { + if (verbose) { + message("No prior specified for sigma.sq.mu.ig.\nSetting prior shape to 0.1 and prior scale to 0.1\n") + } + sigma.sq.mu.a <- rep(0.1, p.re) + sigma.sq.mu.b <- rep(0.1, p.re) + } + } else { + sigma.sq.mu.a <- 0 + sigma.sq.mu.b <- 0 + } + + # Starting values ----------------------------------------------------- + if (missing(inits)) { + inits <- list() + } + names(inits) <- tolower(names(inits)) + # beta ----------------------- + if ("beta" %in% names(inits)) { + beta.inits <- inits[["beta"]] + if (length(beta.inits) != p & length(beta.inits) != 1) { + if (p == 1) { + stop(paste("error: initial values for beta must be of length ", p, + sep = "")) + + } else { + stop(paste("error: initial values for beta must be of length ", p, " or 1", + sep = "")) + } + } + if (length(beta.inits) != p) { + beta.inits <- rep(beta.inits, p) + } + } else { + beta.inits <- rnorm(p, mu.beta, sqrt(sigma.beta)) + if (verbose) { + message('beta is not specified in initial values.\nSetting initial values to random values from the prior distribution\n') + } + } + # phi ----------------------------- + if ("phi" %in% names(inits)) { + phi.inits <- inits[["phi"]] + if (length(phi.inits) != p.svc & length(phi.inits) != 1) { + stop(paste("error: initial values for phi must be of length ", p.svc, " or 1", + sep = "")) + } + if (length(phi.inits) != p.svc) { + phi.inits <- rep(phi.inits, p.svc) + } + } else { + phi.inits <- runif(p.svc, phi.a, phi.b) + if (verbose) { + message("phi is not specified in initial values.\nSetting initial value to random values from the prior distribution\n") + } + } + # tau.sq ------------------------ + if ("tau.sq" %in% names(inits)) { + tau.sq.inits <- inits[["tau.sq"]] + if (length(tau.sq.inits) != 1) { + stop("error: initial values for tau.sq must be of length 1") + } + } else { + tau.sq.inits <- runif(1, 0.5, 10) + if (verbose) { + message("tau.sq is not specified in initial values.\nSetting initial value to random value between 0.5 and 10\n") + } + } + # sigma.sq ------------------------ + if ("sigma.sq" %in% names(inits)) { + sigma.sq.inits <- inits[["sigma.sq"]] + if (length(sigma.sq.inits) != p.svc & length(sigma.sq.inits) != 1) { + stop(paste("error: initial values for sigma.sq must be of length ", p.svc, " or 1", + sep = "")) + } + if (length(sigma.sq.inits) != p.svc) { + sigma.sq.inits <- rep(sigma.sq.inits, p.svc) + } + } else { + sigma.sq.inits <- rigamma(p.svc, sigma.sq.a, sigma.sq.b) + if (verbose) { + message("sigma.sq is not specified in initial values.\nSetting initial values to random values from the prior distribution\n") + } + } + # w ----------------------------- + if ("w" %in% names(inits)) { + w.inits <- inits[["w"]] + if (!is.matrix(w.inits)) { + stop(paste("error: initial values for w must be a matrix with dimensions ", + p.svc, " x ", J.est, sep = "")) + } + if (nrow(w.inits) != p.svc | ncol(w.inits) != J.est) { + stop(paste("error: initial values for w must be a matrix with dimensions ", + p.svc, " x ", J.est, sep = "")) + } + if (NNGP) { + w.inits <- w.inits[, ord, drop = FALSE] + } + } else { + w.inits <- matrix(0, p.svc, J.est) + if (verbose) { + message("w is not specified in initial values.\nSetting initial value to 0\n") + } + } + # nu ------------------------ + if ("nu" %in% names(inits)) { + nu.inits <- inits[["nu"]] + if (length(nu.inits) != p.svc & length(nu.inits) != 1) { + stop(paste("error: initial values for nu must be of length ", p.svc, " or 1", + sep = "")) + } + if (length(nu.inits) != p.svc) { + nu.inits <- rep(nu.inits, p.svc) + } + } else { + if (cov.model == 'matern') { + if (verbose) { + message("nu is not specified in initial values.\nSetting initial values to random values from the prior distribution\n") + } + nu.inits <- runif(p.svc, nu.a, nu.b) + } else { + nu.inits <- rep(0, p.svc) + } + } + # sigma.sq.mu ------------------- + if (p.re > 0) { + if ("sigma.sq.mu" %in% names(inits)) { + sigma.sq.mu.inits <- inits[["sigma.sq.mu"]] + if (length(sigma.sq.mu.inits) != p.re & length(sigma.sq.mu.inits) != 1) { + if (p.re == 1) { + stop(paste("error: initial values for sigma.sq.mu must be of length ", p.re, + sep = "")) + } else { + stop(paste("error: initial values for sigma.sq.mu must be of length ", p.re, + " or 1", sep = "")) + } + } + if (length(sigma.sq.mu.inits) != p.re) { + sigma.sq.mu.inits <- rep(sigma.sq.mu.inits, p.re) + } + } else { + sigma.sq.mu.inits <- runif(p.re, 0.5, 10) + if (verbose) { + message("sigma.sq.mu is not specified in initial values.\nSetting initial values to random values between 0.5 and 10\n") + } + } + beta.star.indx <- rep(0:(p.re - 1), n.re.long) + beta.star.inits <- rnorm(n.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + } else { + sigma.sq.mu.inits <- 0 + beta.star.indx <- 0 + beta.star.inits <- 0 + } + # Should initial values be fixed -- + if ("fix" %in% names(inits)) { + fix.inits <- inits[["fix"]] + if ((fix.inits != TRUE) & (fix.inits != FALSE)) { + stop(paste("error: inits$fix must take value TRUE or FALSE")) + } + } else { + fix.inits <- FALSE + } + if (verbose & fix.inits & (n.chains > 1)) { + message("Fixing initial values across all chains\n") + } + # Covariance Model ---------------------------------------------------- + # Order must match util.cpp spCor. + cov.model.names <- c("exponential", "spherical", "matern", "gaussian") + if(! cov.model %in% cov.model.names){ + stop("error: specified cov.model '",cov.model,"' is not a valid option; choose from ", + paste(cov.model.names, collapse=", ", sep="") ,".")} + # Obo for cov model lookup on c side + cov.model.indx <- which(cov.model == cov.model.names) - 1 + storage.mode(cov.model.indx) <- "integer" + + # Prep for SVCs --------------------------------------------------------- + X.w <- X[, svc.cols, drop = FALSE] + + # Get tuning values --------------------------------------------------- + # Not accessed, but necessary to keep things in line. + sigma.sq.tuning <- rep(0, p.svc) + phi.tuning <- rep(0, p.svc) + nu.tuning <- rep(0, p.svc) + if (missing(tuning)) { + phi.tuning <- rep(1, p.svc) + if (cov.model == 'matern') { + nu.tuning <- rep(1, p.svc) + } + } else { + names(tuning) <- tolower(names(tuning)) + # phi --------------------------- + if(!"phi" %in% names(tuning)) { + stop("error: phi must be specified in tuning value list") + } + phi.tuning <- tuning$phi + if (length(phi.tuning) == 1) { + phi.tuning <- rep(tuning$phi, p.svc) + } else if (length(phi.tuning) != p.svc) { + stop(paste("error: phi tuning must be either a single value or a vector of length ", + p.svc, sep = "")) + } + if (cov.model == 'matern') { + # nu -------------------------- + if(!"nu" %in% names(tuning)) { + stop("error: nu must be specified in tuning value list") + } + nu.tuning <- tuning$nu + if (length(nu.tuning) == 1) { + nu.tuning <- rep(tuning$nu, p.svc) + } else if (length(nu.tuning) != p.svc) { + stop(paste("error: nu tuning must be either a single value or a vector of length ", + p.svc, sep = "")) + } + } + } + tuning.c <- log(c(sigma.sq.tuning, phi.tuning, nu.tuning)) + # Set model.deviance to NA for returning when no cross-validation + model.deviance <- NA + curr.chain <- 1 + + if (!NNGP) { + stop("error: svcAbund is currently only implemented for NNGPs, not full Gaussian Processes. Please set NNGP = TRUE.") + + } else { + + # Nearest Neighbor Search --------------------------------------------- + if(verbose){ + cat("----------------------------------------\n"); + cat("\tBuilding the neighbor list\n"); + cat("----------------------------------------\n"); + } + + search.type.names <- c("brute", "cb") + + if(!search.type %in% search.type.names){ + stop("error: specified search.type '",search.type, + "' is not a valid option; choose from ", + paste(search.type.names, collapse=", ", sep="") ,".") + } + + storage.mode(n.neighbors) <- "integer" + storage.mode(n.omp.threads) <- "integer" + ## Indexes + if(search.type == "brute"){ + indx <- mkNNIndx(coords, n.neighbors, n.omp.threads) + } else{ + indx <- mkNNIndxCB(coords, n.neighbors, n.omp.threads) + } + + nn.indx <- indx$nnIndx + nn.indx.lu <- indx$nnIndxLU + nn.indx.run.time <- indx$run.time + + storage.mode(nn.indx) <- "integer" + storage.mode(nn.indx.lu) <- "integer" + storage.mode(u.search.type) <- "integer" + storage.mode(J.est) <- "integer" + + if(verbose){ + cat("----------------------------------------\n"); + cat("Building the neighbors of neighbors list\n"); + cat("----------------------------------------\n"); + } + + indx <- mkUIndx(J.est, n.neighbors, nn.indx, nn.indx.lu, u.search.type) + + u.indx <- indx$u.indx + u.indx.lu <- indx$u.indx.lu + ui.indx <- indx$ui.indx + u.indx.run.time <- indx$run.time + + # Other miscellaneous --------------------------------------------------- + # For prediction with random slopes + re.cols <- list() + if (p.re > 0) { + split.names <- strsplit(x.re.names, "[-]") + for (j in 1:p.re) { + re.cols[[j]] <- split.names[[j]][1] + names(re.cols)[j] <- split.names[[j]][2] + } + } + + # Set storage for all variables --------------------------------------- + storage.mode(y) <- "double" + storage.mode(X) <- "double" + storage.mode(X.w) <- "double" + consts <- c(J.est, p, p.re, n.re, p.svc, J.zero) + storage.mode(consts) <- "integer" + storage.mode(coords) <- "double" + storage.mode(beta.inits) <- "double" + storage.mode(tau.sq.inits) <- "double" + storage.mode(phi.inits) <- "double" + storage.mode(sigma.sq.inits) <- "double" + storage.mode(nu.inits) <- "double" + storage.mode(w.inits) <- "double" + storage.mode(mu.beta) <- "double" + storage.mode(Sigma.beta) <- "double" + storage.mode(phi.a) <- "double" + storage.mode(phi.b) <- "double" + storage.mode(tau.sq.a) <- "double" + storage.mode(tau.sq.b) <- "double" + storage.mode(nu.a) <- "double" + storage.mode(nu.b) <- "double" + storage.mode(sigma.sq.a) <- "double" + storage.mode(sigma.sq.b) <- "double" + storage.mode(tuning.c) <- "double" + storage.mode(n.batch) <- "integer" + storage.mode(batch.length) <- "integer" + storage.mode(accept.rate) <- "double" + storage.mode(n.omp.threads) <- "integer" + storage.mode(verbose) <- "integer" + storage.mode(n.report) <- "integer" + storage.mode(nn.indx) <- "integer" + storage.mode(nn.indx.lu) <- "integer" + storage.mode(u.indx) <- "integer" + storage.mode(u.indx.lu) <- "integer" + storage.mode(ui.indx) <- "integer" + storage.mode(n.neighbors) <- "integer" + storage.mode(cov.model.indx) <- "integer" + chain.info <- c(curr.chain, n.chains) + storage.mode(chain.info) <- "integer" + n.post.samples <- length(seq(from = n.burn + 1, + to = n.samples, + by = as.integer(n.thin))) + storage.mode(n.post.samples) <- "integer" + samples.info <- c(n.burn, n.thin, n.post.samples) + storage.mode(samples.info) <- "integer" + # For random effects + storage.mode(X.re) <- "integer" + storage.mode(X.random) <- "double" + beta.level.indx <- sort(unique(c(X.re))) + storage.mode(beta.level.indx) <- "integer" + storage.mode(sigma.sq.mu.inits) <- "double" + storage.mode(sigma.sq.mu.a) <- "double" + storage.mode(sigma.sq.mu.b) <- "double" + storage.mode(beta.star.inits) <- "double" + storage.mode(beta.star.indx) <- "integer" + if (two.stage) { + storage.mode(z) <- 'double' + } + + # Fit the model ------------------------------------------------------- + out.tmp <- list() + # Random seed information for each chain of the model + seeds.list <- list() + out <- list() + for (i in 1:n.chains) { + # Change initial values if i > 1 + if ((i > 1) & (!fix.inits)) { + beta.inits <- rnorm(p, mu.beta, sqrt(sigma.beta)) + sigma.sq.inits <- rigamma(p.svc, sigma.sq.a, sigma.sq.b) + sigma.sq.inits <- runif(p.svc, 0.05, 10) + phi.inits <- runif(p.svc, phi.a, phi.b) + if (cov.model == 'matern') { + nu.inits <- runif(p.svc, nu.a, nu.b) + } + if (p.re > 0) { + sigma.sq.mu.inits <- runif(p.re, 0.5, 10) + beta.star.inits <- rnorm(n.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + } + tau.sq.inits <- runif(1, 0.1, 10) + } + storage.mode(chain.info) <- "integer" + # Run the model in C + out.tmp[[i]] <- .Call("svcAbundGaussianNNGP", y, X, + X.w, coords, + X.re, X.random, + consts, n.re.long, + n.neighbors, nn.indx, nn.indx.lu, u.indx, u.indx.lu, ui.indx, + beta.inits, tau.sq.inits, sigma.sq.mu.inits, beta.star.inits, + w.inits, phi.inits, sigma.sq.inits, nu.inits, + beta.star.indx, beta.level.indx, mu.beta, + Sigma.beta, tau.sq.a, tau.sq.b, phi.a, phi.b, + sigma.sq.a, sigma.sq.b, nu.a, nu.b, + sigma.sq.mu.a, sigma.sq.mu.b, + tuning.c, cov.model.indx, + n.batch, batch.length, + accept.rate, n.omp.threads, verbose, n.report, + samples.info, chain.info) + chain.info[1] <- chain.info[1] + 1 + seeds.list[[i]] <- .Random.seed + } + # Calculate R-Hat --------------- + out$rhat <- list() + if (n.chains > 1) { + # as.vector removes the "Upper CI" when there is only 1 variable. + out$rhat$beta <- as.vector(gelman.diag(mcmc.list(lapply(out.tmp, function(a) + mcmc(t(a$beta.samples)))), + autoburnin = FALSE, multivariate = FALSE)$psrf[, 2]) + out$rhat$tau.sq <- as.vector(gelman.diag(mcmc.list(lapply(out.tmp, function(a) + mcmc(t(a$tau.sq.samples)))), + autoburnin = FALSE, multivariate = FALSE)$psrf[, 2]) + out$rhat$theta <- gelman.diag(mcmc.list(lapply(out.tmp, function(a) + mcmc(t(a$theta.samples)))), + autoburnin = FALSE, multivariate = FALSE)$psrf[, 2] + if (p.re > 0) { + out$rhat$sigma.sq.mu <- as.vector(gelman.diag(mcmc.list(lapply(out.tmp, function(a) + mcmc(t(a$sigma.sq.mu.samples)))), + autoburnin = FALSE, multivariate = FALSE)$psrf[, 2]) + } + } else { + out$rhat$beta <- rep(NA, p) + out$rhat$tau.sq <- NA + out$rhat$theta <- rep(NA, ifelse(cov.model == 'matern', 3 * p.svc, 2 * p.svc)) + if (p.re > 0) { + out$rhat$sigma.sq.mu <- rep(NA, p.re) + } + } + out$beta.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$beta.samples)))) + colnames(out$beta.samples) <- x.names + out$theta.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$theta.samples)))) + if (cov.model != 'matern') { + theta.names <- paste(rep(c('sigma.sq', 'phi'), each = p.svc), x.names[svc.cols], sep = '-') + } else { + theta.names <- paste(rep(c('sigma.sq', 'phi', 'nu'), each = p.svc), x.names[svc.cols], sep = '-') + } + colnames(out$theta.samples) <- theta.names + out$tau.sq.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$tau.sq.samples)))) + # Get everything back in the original order + out$coords <- coords[order(ord), ] + if (!two.stage) { + out$y.rep.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$y.rep.samples)))) + out$y.rep.samples <- mcmc(out$y.rep.samples[, order(ord), drop = FALSE]) + out$like.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$like.samples)))) + out$like.samples <- mcmc(out$like.samples[, order(ord), drop = FALSE]) + } else { + y.rep.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$y.rep.samples)))) + y.rep.samples <- mcmc(y.rep.samples[, order(ord), drop = FALSE]) + like.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$like.samples)))) + like.samples <- mcmc(like.samples[, order(ord), drop = FALSE]) + y.rep.zero.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$y.rep.zero.samples)))) + out$y.rep.samples <- matrix(NA, n.post.samples * n.chains, J.est + J.zero) + out$y.rep.samples[, z.indx] <- y.rep.samples + out$y.rep.samples[, -z.indx] <- y.rep.zero.samples + out$y.rep.samples <- mcmc(out$y.rep.samples) + out$like.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$like.samples)))) + out$like.samples <- mcmc(out$like.samples[, order(ord), drop = FALSE]) + } + out$X <- X[order(ord), , drop = FALSE] + out$X.re <- X.re[order(ord), , drop = FALSE] + out$X.w <- X.w[order(ord), , drop = FALSE] + # Account for case when intercept only spatial model. + if (p.svc == 1) { + tmp <- do.call(rbind, lapply(out.tmp, function(a) t(a$w.samples))) + tmp <- tmp[, order(ord), drop = FALSE] + out$w.samples <- array(NA, dim = c(p.svc, J.est, n.post.samples * n.chains)) + out$w.samples[1, , ] <- t(tmp) + } else { + out$w.samples <- do.call(abind, lapply(out.tmp, function(a) array(a$w.samples, + dim = c(p.svc, J.est, n.post.samples)))) + out$w.samples <- out$w.samples[, order(ord), ] + } + out$w.samples <- aperm(out$w.samples, c(3, 1, 2)) + out$mu.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$mu.samples)))) + out$mu.samples <- mcmc(out$mu.samples[, order(ord), drop = FALSE]) + out$y <- y.orig + if (p.re > 0) { + out$sigma.sq.mu.samples <- mcmc( + do.call(rbind, lapply(out.tmp, function(a) t(a$sigma.sq.mu.samples)))) + colnames(out$sigma.sq.mu.samples) <- x.re.names + out$beta.star.samples <- mcmc( + do.call(rbind, lapply(out.tmp, function(a) t(a$beta.star.samples)))) + tmp.names <- unlist(re.level.names) + beta.star.names <- paste(rep(x.re.names, n.re.long), tmp.names, sep = '-') + colnames(out$beta.star.samples) <- beta.star.names + out$re.level.names <- re.level.names + } + # Calculate effective sample sizes + out$ESS <- list() + out$ESS$beta <- effectiveSize(out$beta.samples) + out$ESS$tau.sq <- effectiveSize(out$tau.sq.samples) + out$ESS$theta <- effectiveSize(out$theta.samples) + if (p.re > 0) { + out$ESS$sigma.sq.mu <- effectiveSize(out$sigma.sq.mu.samples) + } + out$call <- cl + out$n.samples <- batch.length * n.batch + out$n.neighbors <- n.neighbors + out$cov.model.indx <- cov.model.indx + out$svc.cols <- svc.cols + out$type <- "NNGP" + out$n.post <- n.post.samples + out$n.thin <- n.thin + out$n.burn <- n.burn + out$n.chains <- n.chains + out$re.cols <- re.cols + out$dist <- family + if (p.re > 0) { + out$muRE <- TRUE + } else { + out$muRE <- FALSE + } + } # NNGP or GP + class(out) <- "svcAbund" + out$run.time <- proc.time() - ptm + return(out) +} + diff --git a/R/svcMsAbund.R b/R/svcMsAbund.R index 270938e..0280f20 100644 --- a/R/svcMsAbund.R +++ b/R/svcMsAbund.R @@ -8,1073 +8,15 @@ svcMsAbund <- function(formula, data, inits, priors, tuning, ptm <- proc.time() - # Make it look nice - if (verbose) { - cat("----------------------------------------\n"); - cat("\tPreparing to run the model\n"); - cat("----------------------------------------\n"); + if (!(family) %in% c('Poisson', 'NB', 'Gaussian', 'zi-Gaussian')) { + stop("family must be either 'Poisson', 'NB', 'Gaussian', or 'zi-Gaussian'") } - # Check for unused arguments ------------------------------------------ - formal.args <- names(formals(sys.function(sys.parent()))) - elip.args <- names(list(...)) - for(i in elip.args){ - if(! i %in% formal.args) - warning("'",i, "' is not an argument") - } - # Call ---------------------------------------------------------------- - # Returns a call in which all of the specified arguments are - # specified by their full names. - cl <- match.call() - - # Some initial checks ------------------------------------------------- - # Only implemented for NNGP - if (!NNGP) { - stop("error: svcMsAbundGaussian is currently only implemented for NNGPs, not full Gaussian Processes. Please set NNGP = TRUE.") - } - if (missing(data)) { - stop("error: data must be specified") - } - if (!is.list(data)) { - stop("error: data must be a list") - } - names(data) <- tolower(names(data)) - if (!'y' %in% names(data)) { - stop("error: y must be specified in data") - } - if (length(dim(data$y)) != 2) { - stop("error: data y must be a matrix or data frame with rows corresponding to species and sites corresponding to columns") - } - y <- as.matrix(data$y) - sp.names <- attr(y, 'dimnames')[[1]] - if (!'covs' %in% names(data)) { - if (formula == ~ 1) { - if (verbose) { - message("covariates (covs) not specified in data.\nAssuming intercept only model.\n") - } - data$covs <- list(int = rep(1, dim(y)[2])) - } else { - stop("error: covs must be specified in data for a model with covariates") - } - } - if (!is.list(data$covs)) { - if (is.matrix(data$covs)) { - data$covs <- data.frame(data$covs) - } else { - stop("error: covs must be a list, data frame, or matrix") - } - } - if (!'coords' %in% names(data)) { - stop("error: coords must be specified in data for a spatial occupancy model.") - } - coords <- as.matrix(data$coords) - if (missing(n.factors)) { - stop("error: n.factors must be specified for a spatial factor model") - } - - if (family == 'zi-Gaussian') { - two.stage <- TRUE + if (family %in% c('Gaussian', 'zi-Gaussian')) { + svcMsAbundGaussian(formula, data, inits, priors, tuning, svc.cols, cov.model, + NNGP, n.neighbors, search.type, n.factors, n.batch, + batch.length, accept.rate, family, n.omp.threads, + verbose, n.report, n.burn, n.thin, n.chains) } else { - two.stage <- FALSE - } - if (two.stage) { - if (!'z' %in% names(data)) { - stop("error: z must be specified in data for a two stage model") - } - z <- data$z - if (!is.matrix(z)) { - stop(paste0("z must be a matrix with ", nrow(y), " rows and ", ncol(y), " columns.")) - } - if (nrow(z) != nrow(y) | ncol(z) != ncol(y)) { - stop(paste0("z must be a matrix with ", nrow(y), " rows and ", ncol(y), " columns.")) - } - } else { - z <- matrix(1, nrow(y), ncol(y)) - } - - # First subset covariates to only use those that are included in the analysis. - # Get occurrence covariates in proper format - # Subset covariates to only use those that are included in the analysis - data$covs <- data$covs[names(data$covs) %in% all.vars(formula)] - # Null model support - if (length(data$covs) == 0) { - data$covs <- list(int = rep(1, dim(y)[2])) - } - # Ordered by rep, then site within rep - data$covs <- data.frame(lapply(data$covs, function(a) unlist(c(a)))) - - # Neighbors and Ordering ---------------------------------------------- - if (NNGP) { - u.search.type <- 2 - ## Order by x column. Could potentially allow this to be user defined. - ord <- order(coords[,1]) - # Reorder everything to align with NN ordering - y <- y[, ord, drop = FALSE] - z <- z[, ord, drop = FALSE] - coords <- coords[ord, , drop = FALSE] - # Covariates - data$covs <- data$covs[ord, , drop = FALSE] - } - - # Checking missing values --------------------------------------------- - # covs ------------------------ - if (sum(is.na(data$covs)) != 0) { - stop("error: missing values in covs. Please remove these sites from all objects in data or somehow replace the NA values with non-missing values (e.g., mean imputation).") - } - - # Check whether random effects are sent in as numeric, and - # return error if they are. - # Abundance ------------------------- - if (!is.null(findbars(formula))) { - abund.re.names <- unique(unlist(sapply(findbars(formula), all.vars))) - for (i in 1:length(abund.re.names)) { - if (is(data$covs[, abund.re.names[i]], 'factor')) { - stop(paste("error: random effect variable ", abund.re.names[i], " specified as a factor. Random effect variables must be specified as numeric.", sep = '')) - } - if (is(data$covs[, abund.re.names[i]], 'character')) { - stop(paste("error: random effect variable ", abund.re.names[i], " specified as character. Random effect variables must be specified as numeric.", sep = '')) - } - } - } - - # Formula ------------------------------------------------------------- - if (missing(formula)) { - stop("error: formula must be specified") - } - - if (is(formula, 'formula')) { - tmp <- parseFormula(formula, data$covs) - X <- as.matrix(tmp[[1]]) - X.re <- as.matrix(tmp[[4]]) - x.re.names <- colnames(X.re) - x.names <- tmp[[2]] - X.random <- as.matrix(tmp[[5]]) - x.random.names <- colnames(X.random) - } else { - stop("error: formula is misspecified") - } - # Get RE level names - re.level.names <- lapply(data$covs[, x.re.names, drop = FALSE], - function (a) sort(unique(a))) - x.re.names <- x.random.names - - # Extract data from inputs -------------------------------------------- - # Number of species - N <- dim(y)[1] - # Number of latent factors - q <- n.factors - # Number of fixed effects - p <- ncol(X) - # Number of random effect parameters - p.re <- ncol(X.re) - # Number of latent occupancy random effect values - n.re <- length(unlist(apply(X.re, 2, unique))) - n.re.long <- apply(X.re, 2, function(a) length(unique(a))) - # Number of sites - J <- nrow(X) - if (missing(n.batch)) { - stop("error: must specify number of MCMC batches") + stop("svcMsAbund is currently only supported for Gaussian and zi-Gaussian") } - if (missing(batch.length)) { - stop("error: must specify length of each MCMC batch") - } - n.samples <- n.batch * batch.length - if (n.burn > n.samples) { - stop("error: n.burn must be less than n.samples") - } - if (n.thin > n.samples) { - stop("error: n.thin must be less than n.samples") - } - # Check if n.burn, n.thin, and n.samples result in an integer and error if otherwise. - if (((n.samples - n.burn) / n.thin) %% 1 != 0) { - stop("the number of posterior samples to save ((n.samples - n.burn) / n.thin) is not a whole number. Please respecify the MCMC criteria such that the number of posterior samples saved is a whole number.") - } - - # y is ordered by site, then species within site. - y.orig <- y - y <- c(y) - - # Check SVC columns ----------------------------------------------------- - if (is.character(svc.cols)) { - # Check if all column names in svc are in occ.covs - if (!all(svc.cols %in% x.names)) { - missing.cols <- svc.cols[!(svc.cols %in% x.names)] - stop(paste("error: variable name ", paste(missing.cols, collapse=" and "), " not in occurrence covariates", sep="")) - } - # Convert desired column names into the numeric column index - svc.cols <- (1:p)[x.names %in% svc.cols] - - } else if (is.numeric(svc.cols)) { - # Check if all column indices are in 1:p - if (!all(svc.cols %in% 1:p)) { - missing.cols <- svc.cols[!(svc.cols %in% (1:p))] - stop(paste("error: column index ", paste(missing.cols, collapse=" "), " not in design matrix columns", sep="")) - } - } - p.svc <- length(svc.cols) - q.p.svc <- q * p.svc - - # Get random effect matrices all set ---------------------------------- - if (p.re > 1) { - for (j in 2:p.re) { - X.re[, j] <- X.re[, j] + max(X.re[, j - 1]) + 1 - } - } - # Priors -------------------------------------------------------------- - if (missing(priors)) { - priors <- list() - } - names(priors) <- tolower(names(priors)) - - # Independent beta parameters ----- - if ('independent.betas' %in% names(priors)) { - if (priors$independent.betas == TRUE) { - message("Beta parameters will be estimated independently\n") - ind.betas <- TRUE - } else if (priors$independent.betas == FALSE) { - ind.betas <- FALSE - } - } else { - ind.betas <- FALSE - } - # beta.comm ----------------------- - if ("beta.comm.normal" %in% names(priors)) { - if (!is.list(priors$beta.comm.normal) | length(priors$beta.comm.normal) != 2) { - stop("error: beta.comm.normal must be a list of length 2") - } - mu.beta.comm <- priors$beta.comm.normal[[1]] - sigma.beta.comm <- priors$beta.comm.normal[[2]] - if (length(mu.beta.comm) != p & length(mu.beta.comm) != 1) { - if (p == 1) { - stop(paste("error: beta.comm.normal[[1]] must be a vector of length ", - p, " with elements corresponding to beta.comms' mean", sep = "")) - } else { - stop(paste("error: beta.comm.normal[[1]] must be a vector of length ", - p, " or 1 with elements corresponding to beta.comms' mean", sep = "")) - } - } - if (length(sigma.beta.comm) != p & length(sigma.beta.comm) != 1) { - if (p == 1) { - stop(paste("error: beta.comm.normal[[2]] must be a vector of length ", - p, " with elements corresponding to beta.comms' variance", sep = "")) - } else { - stop(paste("error: beta.comm.normal[[2]] must be a vector of length ", - p, " or 1 with elements corresponding to beta.comms' variance", sep = "")) - } - } - if (length(sigma.beta.comm) != p) { - sigma.beta.comm <- rep(sigma.beta.comm, p) - } - if (length(mu.beta.comm) != p) { - mu.beta.comm <- rep(mu.beta.comm, p) - } - Sigma.beta.comm <- sigma.beta.comm * diag(p) - } else { - if (verbose & !ind.betas) { - message("No prior specified for beta.comm.normal.\nSetting prior mean to 0 and prior variance to 1000\n") - } - mu.beta.comm <- rep(0, p) - sigma.beta.comm <- rep(1000, p) - Sigma.beta.comm <- diag(p) * 1000 - } - - # tau.sq.beta ----------------------- - if ("tau.sq.beta.ig" %in% names(priors)) { - if (!is.list(priors$tau.sq.beta.ig) | length(priors$tau.sq.beta.ig) != 2) { - stop("error: tau.sq.beta.ig must be a list of length 2") - } - tau.sq.beta.a <- priors$tau.sq.beta.ig[[1]] - tau.sq.beta.b <- priors$tau.sq.beta.ig[[2]] - if (length(tau.sq.beta.a) != p & length(tau.sq.beta.a) != 1) { - if (p == 1) { - stop(paste("error: tau.sq.beta.ig[[1]] must be a vector of length ", - p, " with elements corresponding to tau.sq.betas' shape", sep = "")) - } else { - stop(paste("error: tau.sq.beta.ig[[1]] must be a vector of length ", - p, " or 1 with elements corresponding to tau.sq.betas' shape", sep = "")) - } - } - if (length(tau.sq.beta.b) != p & length(tau.sq.beta.b) != 1) { - if (p == 1) { - stop(paste("error: tau.sq.beta.ig[[2]] must be a vector of length ", - p, " with elements corresponding to tau.sq.betas' scale", sep = "")) - } else { - stop(paste("error: tau.sq.beta.ig[[2]] must be a vector of length ", - p, " or 1 with elements corresponding to tau.sq.betas' scale", sep = "")) - } - } - if (length(tau.sq.beta.a) != p) { - tau.sq.beta.a <- rep(tau.sq.beta.a, p) - } - if (length(tau.sq.beta.b) != p) { - tau.sq.beta.b <- rep(tau.sq.beta.b, p) - } - } else { - if (verbose & !ind.betas) { - message("No prior specified for tau.sq.beta.ig.\nSetting prior shape to 0.1 and prior scale to 0.1\n") - } - tau.sq.beta.a <- rep(0.1, p) - tau.sq.beta.b <- rep(0.1, p) - } - - # tau.sq ----------------------- - if ("tau.sq.ig" %in% names(priors)) { - if (!is.list(priors$tau.sq.ig) | length(priors$tau.sq.ig) != 2) { - stop("error: tau.sq.ig must be a list of length 2") - } - tau.sq.a <- priors$tau.sq.ig[[1]] - tau.sq.b <- priors$tau.sq.ig[[2]] - if (length(tau.sq.a) != N & length(tau.sq.a) != 1) { - stop(paste("error: tau.sq.ig[[1]] must be a vector of length ", - N, " or 1 with elements corresponding to tau.sqs' shape", sep = "")) - } - if (length(tau.sq.b) != N & length(tau.sq.b) != 1) { - stop(paste("error: tau.sq.ig[[2]] must be a vector of length ", - p, " or 1 with elements corresponding to tau.sqs' scale", sep = "")) - } - if (length(tau.sq.a) != N) { - tau.sq.a <- rep(tau.sq.a, N) - } - if (length(tau.sq.b) != N) { - tau.sq.b <- rep(tau.sq.b, N) - } - } else { - if (verbose) { - message("No prior specified for tau.sq.ig.\nSetting prior shape to 0.1 and prior scale to 0.1\n") - } - tau.sq.a <- rep(0.1, N) - tau.sq.b <- rep(0.1, N) - } - - # phi ----------------------------- - if ("phi.unif" %in% names(priors)) { - if (!is.list(priors$phi.unif) | length(priors$phi.unif) != 2) { - stop("error: phi.unif must be a list of length 2") - } - phi.a <- priors$phi.unif[[1]] - phi.b <- priors$phi.unif[[2]] - if (length(phi.a) != q.p.svc & length(phi.a) != 1) { - stop(paste("error: phi.unif[[1]] must be a vector of length ", - q.p.svc, ", a matrix with ", q, " rows and ", p.svc, - " columns, or a vector of length 1 with elements corresponding to phis' lower bound for each latent factor and spatially-varying coefficient", sep = "")) - } - if (length(phi.b) != q.p.svc & length(phi.b) != 1) { - stop(paste("error: phi.unif[[2]] must be a vector of length ", - q.p.svc, ", a matrix with ", q, " rows and ", p.svc, - " columns, or a vector of length 1 with elements corresponding to phis' upper bound for each latent factor and spatially-varying coefficient", sep = "")) - } - if (length(phi.a) != q.p.svc) { - phi.a <- rep(phi.a, q.p.svc) - } - if (length(phi.b) != q.p.svc) { - phi.b <- rep(phi.b, q.p.svc) - } - } else { - if (verbose) { - message("No prior specified for phi.unif.\nSetting uniform bounds based on the range of observed spatial coordinates.\n") - } - coords.D <- iDist(coords) - phi.a <- rep(3 / max(coords.D), q.p.svc) - phi.b <- rep(3 / sort(unique(c(coords.D)))[2], q.p.svc) - } - # nu ----------------------------- - if (cov.model == "matern") { - if (!"nu.unif" %in% names(priors)) { - stop("error: nu.unif must be specified in priors value list") - } - nu.a <- priors$nu.unif[[1]] - nu.b <- priors$nu.unif[[2]] - if (!is.list(priors$nu.unif) | length(priors$nu.unif) != 2) { - stop("error: nu.unif must be a list of length 2") - } - if (length(nu.a) != q.p.svc & length(nu.a) != 1) { - stop(paste("error: nu.unif[[1]] must be a vector of length ", - q.p.svc, ", a matrix with ", q, " rows and ", p.svc, - " columns, or a vector of length 1 with elements corresponding to nus' lower bound for each latent factor and spatially-varying coefficient", sep = "")) - } - if (length(nu.b) != q & length(nu.b) != 1) { - stop(paste("error: nu.unif[[2]] must be a vector of length ", - q.p.svc, ", a matrix with ", q, " rows and ", p.svc, - " columns, or a vector of length 1 with elements corresponding to nus' upper bound for each latent factor and spatially-varying coefficient", sep = "")) - } - if (length(nu.a) != q.p.svc) { - nu.a <- rep(nu.a, q.p.svc) - } - if (length(nu.b) != q.p.svc) { - nu.b <- rep(nu.b, q.p.svc) - } - } else { - nu.a <- rep(0, q.p.svc) - nu.b <- rep(0, q.p.svc) - } - - # sigma.sq.mu -------------------- - if (p.re > 0) { - if ("sigma.sq.mu.ig" %in% names(priors)) { - if (!is.list(priors$sigma.sq.mu.ig) | length(priors$sigma.sq.mu.ig) != 2) { - stop("error: sigma.sq.mu.ig must be a list of length 2") - } - sigma.sq.mu.a <- priors$sigma.sq.mu.ig[[1]] - sigma.sq.mu.b <- priors$sigma.sq.mu.ig[[2]] - if (length(sigma.sq.mu.a) != p.re & length(sigma.sq.mu.a) != 1) { - if (p.re == 1) { - stop(paste("error: sigma.sq.mu.ig[[1]] must be a vector of length ", - p.re, " with elements corresponding to sigma.sq.mus' shape", sep = "")) - } else { - stop(paste("error: sigma.sq.mu.ig[[1]] must be a vector of length ", - p.re, " or 1 with elements corresponding to sigma.sq.mus' shape", sep = "")) - } - } - if (length(sigma.sq.mu.b) != p.re & length(sigma.sq.mu.b) != 1) { - if (p.re == 1) { - stop(paste("error: sigma.sq.mu.ig[[2]] must be a vector of length ", - p.re, " with elements corresponding to sigma.sq.mus' scale", sep = "")) - } else { - stop(paste("error: sigma.sq.mu.ig[[2]] must be a vector of length ", - p.re, " or 1with elements corresponding to sigma.sq.mus' scale", sep = "")) - } - } - if (length(sigma.sq.mu.a) != p.re) { - sigma.sq.mu.a <- rep(sigma.sq.mu.a, p.re) - } - if (length(sigma.sq.mu.b) != p.re) { - sigma.sq.mu.b <- rep(sigma.sq.mu.b, p.re) - } - } else { - if (verbose) { - message("No prior specified for sigma.sq.mu.ig.\nSetting prior shape to 0.1 and prior scale to 0.1\n") - } - sigma.sq.mu.a <- rep(0.1, p.re) - sigma.sq.mu.b <- rep(0.1, p.re) - } - } else { - sigma.sq.mu.a <- 0 - sigma.sq.mu.b <- 0 - } - - # Initial values -------------------------------------------------------- - if (missing(inits)) { - inits <- list() - } - names(inits) <- tolower(names(inits)) - # beta.comm ----------------------- - # ORDER: a p vector ordered by the effects in the formula. - if ("beta.comm" %in% names(inits)) { - beta.comm.inits <- inits[["beta.comm"]] - if (length(beta.comm.inits) != p & length(beta.comm.inits) != 1) { - if (p == 1) { - stop(paste("error: initial values for beta.comm must be of length ", p, - sep = "")) - } else { - stop(paste("error: initial values for beta.comm must be of length ", p, - , " or 1", sep = "")) - } - } - if (length(beta.comm.inits) != p) { - beta.comm.inits <- rep(beta.comm.inits, p) - } - } else { - beta.comm.inits <- rnorm(p, mu.beta.comm, sqrt(sigma.beta.comm)) - if (verbose) { - message('beta.comm is not specified in initial values.\nSetting initial values to random values from the prior distribution\n') - } - } - # tau.sq.beta ------------------------ - # ORDER: a p vector ordered by the effects in the occurrence formula - if ("tau.sq.beta" %in% names(inits)) { - tau.sq.beta.inits <- inits[["tau.sq.beta"]] - if (length(tau.sq.beta.inits) != p & length(tau.sq.beta.inits) != 1) { - if (p == 1) { - stop(paste("error: initial values for tau.sq.beta must be of length ", p, - sep = "")) - } else { - stop(paste("error: initial values for tau.sq.beta must be of length ", p, - " or 1", sep = "")) - } - } - if (length(tau.sq.beta.inits) != p) { - tau.sq.beta.inits <- rep(tau.sq.beta.inits, p) - } - } else { - tau.sq.beta.inits <- runif(p, 0.5, 10) - if (verbose) { - message('tau.sq.beta is not specified in initial values.\nSetting initial values to random values between 0.5 and 10\n') - } - } - # tau.sq ------------------------ - # ORDER: a length N vector - if ("tau.sq" %in% names(inits)) { - tau.sq.inits <- inits[["tau.sq"]] - if (length(tau.sq.inits) != N & length(tau.sq.inits) != 1) { - stop(paste("error: initial values for tau.sq must be of length ", N, - " or 1", sep = "")) - } - if (length(tau.sq.inits) != N) { - tau.sq.inits <- rep(tau.sq.inits, N) - } - } else { - tau.sq.inits <- runif(N, 0.01, 3) - if (verbose) { - message('tau.sq is not specified in initial values.\nSetting initial values to random values between 0.01 and 3\n') - } - } - # beta ---------------------------- - # ORDER: N x p matrix sent in as a column-major vector ordered by - # parameter then species within parameter. - if ("beta" %in% names(inits)) { - beta.inits <- inits[["beta"]] - if (is.matrix(beta.inits)) { - if (ncol(beta.inits) != p | nrow(beta.inits) != N) { - stop(paste("error: initial values for beta must be a matrix with dimensions ", - N, "x", p, " or a single numeric value", sep = "")) - } - } - if (!is.matrix(beta.inits) & length(beta.inits) != 1) { - stop(paste("error: initial values for beta must be a matrix with dimensions ", - N, " x ", p, " or a single numeric value", sep = "")) - } - if (length(beta.inits) == 1) { - beta.inits <- matrix(beta.inits, N, p) - } - } else { - beta.inits <- matrix(rnorm(N * p, beta.comm.inits, sqrt(tau.sq.beta.inits)), N, p) - if (verbose) { - message('beta is not specified in initial values.\nSetting initial values to random values from the community-level normal distribution\n') - } - } - # Create a N * p x 1 matrix of the species-level regression coefficients. - # This is ordered by parameter, then species within a parameter. - beta.inits <- c(beta.inits) - # phi ----------------------------- - # ORDER: a q x p.svc matrix sent in as a column-major vector sorted first by - # the spatially-varying coefficient, then latent factor within svc. - if ("phi" %in% names(inits)) { - phi.inits <- inits[["phi"]] - if (length(phi.inits) != q.p.svc & length(phi.inits) != 1) { - stop(paste("error: initial values for phi must be of length ", q.p.svc, " or 1", - sep = "")) - } - if (length(phi.inits) != q.p.svc) { - phi.inits <- rep(phi.inits, q.p.svc) - } - } else { - phi.inits <- runif(q.p.svc, phi.a, phi.b) - if (verbose) { - message("phi is not specified in initial values.\nSetting initial value to random values from the prior distribution\n") - } - } - # nu ------------------------ - if ("nu" %in% names(inits)) { - nu.inits <- inits[["nu"]] - if (length(nu.inits) != q.p.svc & length(nu.inits) != 1) { - stop(paste("error: initial values for nu must be of length ", q.p.svc, " or 1", - sep = "")) - } - if (length(nu.inits) != q.p.svc) { - nu.inits <- rep(nu.inits, q.p.svc) - } - } else { - if (cov.model == 'matern') { - if (verbose) { - message("nu is not specified in initial values.\nSetting initial values to random values from the prior distribution\n") - } - nu.inits <- runif(q.p.svc, nu.a, nu.b) - } else { - nu.inits <- rep(0, q.p.svc) - } - } - # lambda ---------------------------- - # ORDER: an p.svc N x q matrices sent in as a list, each in - # column-major vector, which is ordered by factor, - # then species within factor. Eventually sent into - # C++ as a stacked p.svc x N x q matrix, ordered by - # svc, then factor within svc, then species within factor. - if ("lambda" %in% names(inits)) { - lambda.inits <- inits[["lambda"]] - if (!is.list(lambda.inits)) { - stop(paste("error: initial values for lambda must be a list comprised of ", - p.svc, " matrices, each with dimensions ", N, " x ", q, sep = "")) - } - for (i in 1:p.svc) { - if (nrow(lambda.inits[[i]]) != N | ncol(lambda.inits[[i]]) != q) { - stop(paste("error: initial values for lambda[[", i, - "]] must be a matrix with dimensions ", N, " x ", q, sep = "")) - } - if (!all.equal(diag(lambda.inits[[i]]), rep(1, q))) { - stop("error: diagonal of inits$lambda[[", i, "]] matrix must be all 1s") - } - if (sum(lambda.inits[[i]][upper.tri(lambda.inits[[i]])]) != 0) { - stop("error: upper triangle of inits$lambda[[", i, "]] must be all 0s") - } - } - lambda.inits <- unlist(lambda.inits) - } else { - lambda.inits <- list() - for (i in 1:p.svc) { - lambda.inits[[i]] <- matrix(0, N, q) - diag(lambda.inits[[i]]) <- 1 - lambda.inits[[i]][lower.tri(lambda.inits[[i]])] <- rnorm(sum(lower.tri(lambda.inits[[i]]))) - } - if (verbose) { - message("lambda is not specified in initial values.\nSetting initial values of the lower triangle to random values from a standard normal\n") - } - lambda.inits <- unlist(lambda.inits) - } - # w ----------------------------- - if ("w" %in% names(inits)) { - w.inits <- inits[["w"]] - if (!is.list(w.inits)) { - stop(paste("error: initial values for w must be a list comprised of ", - p.svc, " matrices, each with dimensions ", q, " x ", J, sep = "")) - } - for (i in 1:p.svc) { - if (!is.matrix(w.inits[[i]])) { - stop(paste("error: initial values for w must be a matrix with dimensions ", - q, " x ", J, sep = "")) - } - if (nrow(w.inits[[i]]) != q | ncol(w.inits[[i]]) != J) { - stop(paste("error: initial values for w must be a matrix with dimensions ", - q, " x ", J, sep = "")) - } - if (NNGP) { - w.inits[[i]] <- w.inits[[i]][, ord] - } - } - w.inits <- unlist(w.inits) - } else { - w.inits <- list() - for (i in 1:p.svc) { - w.inits[[i]] <- matrix(0, q, J) - } - if (verbose) { - message("w is not specified in initial values.\nSetting initial value to 0\n") - } - w.inits <- unlist(w.inits) - } - # sigma.sq.mu ------------------ - # ORDER: a length p.re vector ordered by the random effects in the formula. - if (p.re > 0) { - if ("sigma.sq.mu" %in% names(inits)) { - sigma.sq.mu.inits <- inits[["sigma.sq.mu"]] - if (length(sigma.sq.mu.inits) != p.re & length(sigma.sq.mu.inits) != 1) { - if (p.re == 1) { - stop(paste("error: initial values for sigma.sq.mu must be of length ", p.re, - sep = "")) - } else { - stop(paste("error: initial values for sigma.sq.mu must be of length ", p.re, - " or 1", sep = "")) - } - } - if (length(sigma.sq.mu.inits) != p.re) { - sigma.sq.mu.inits <- rep(sigma.sq.mu.inits, p.re) - } - } else { - sigma.sq.mu.inits <- runif(p.re, 0.5, 10) - if (verbose) { - message("sigma.sq.mu is not specified in initial values.\nSetting initial values to random values between 0.5 and 10\n") - } - } - beta.star.indx <- rep(0:(p.re - 1), n.re.long) - beta.star.inits <- rnorm(n.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) - beta.star.inits <- rep(beta.star.inits, N) - } else { - sigma.sq.mu.inits <- 0 - beta.star.indx <- 0 - beta.star.inits <- 0 - } - - # Should initial values be fixed -- - if ("fix" %in% names(inits)) { - fix.inits <- inits[["fix"]] - if ((fix.inits != TRUE) & (fix.inits != FALSE)) { - stop(paste("error: inits$fix must take value TRUE or FALSE")) - } - } else { - fix.inits <- FALSE - } - if (verbose & fix.inits & (n.chains > 1)) { - message("Fixing initial values across all chains\n") - } - # Covariance Model ---------------------------------------------------- - # Order must match util.cpp spCor. - cov.model.names <- c("exponential", "spherical", "matern", "gaussian") - if(! cov.model %in% cov.model.names){ - stop("error: specified cov.model '",cov.model,"' is not a valid option; choose from ", - paste(cov.model.names, collapse=", ", sep="") ,".")} - # Obo for cov model lookup on c side - cov.model.indx <- which(cov.model == cov.model.names) - 1 - - # Prep for SVCs --------------------------------------------------------- - X.w <- X[, svc.cols, drop = FALSE] - x.w.names <- colnames(X.w) - - # Get tuning values --------------------------------------------------- - # Not accessed, but necessary to keep things in line with the underlying functions. - sigma.sq.tuning <- rep(0, q.p.svc) - phi.tuning <- rep(0, q.p.svc) - nu.tuning <- rep(0, q.p.svc) - if (missing(tuning)) { - phi.tuning <- rep(1, q.p.svc) - if (cov.model == 'matern') { - nu.tuning <- rep(1, q.p.svc) - } - } else { - names(tuning) <- tolower(names(tuning)) - # phi --------------------------- - if(!"phi" %in% names(tuning)) { - stop("error: phi must be specified in tuning value list") - } - phi.tuning <- tuning$phi - if (length(phi.tuning) == 1) { - phi.tuning <- rep(tuning$phi, q.p.svc) - } else if (length(phi.tuning) != q.p.svc) { - stop(paste("error: phi tuning must be either a single value or a vector of length ", - q.p.svc, sep = "")) - } - if (cov.model == 'matern') { - # nu -------------------------- - if(!"nu" %in% names(tuning)) { - stop("error: nu must be specified in tuning value list") - } - nu.tuning <- tuning$nu - if (length(nu.tuning) == 1) { - nu.tuning <- rep(tuning$nu, q.p.svc) - } else if (length(nu.tuning) != q.p.svc) { - stop(paste("error: nu tuning must be either a single value or a vector of length ", - q.p.svc, sep = "")) - } - } - } - tuning.c <- log(c(sigma.sq.tuning, phi.tuning, nu.tuning)) - # Set model.deviance to NA for returning when no cross-validation - model.deviance <- NA - curr.chain <- 1 - - # Names for spatial parameters - if (cov.model != 'matern') { - theta.names <- paste(rep(c('phi'), each = q), 1:q, sep = '-') - theta.names <- paste(rep(theta.names, times = p.svc), - rep(x.w.names, each = q), sep = '-') - } else { - theta.names <- paste(rep(c('phi', 'nu'), each = q), 1:q, sep = '-') - theta.names <- paste(rep(theta.names, times = p.svc), - rep(x.w.names, each = 2 * q), sep = '-') - } - - # Other miscellaneous --------------------------------------------------- - # For prediction with random slopes - re.cols <- list() - if (p.re > 0) { - split.names <- strsplit(x.re.names, "[-]") - for (j in 1:p.re) { - re.cols[[j]] <- split.names[[j]][1] - names(re.cols)[j] <- split.names[[j]][2] - } - } - - if (!NNGP) { - - stop("error: svcMsAbund is currently only implemented for NNGPs, not full Gaussian Processes. Please set NNGP = TRUE.") - - } else { - - # Nearest Neighbor Search --------------------------------------------- - if(verbose){ - cat("----------------------------------------\n"); - cat("\tBuilding the neighbor list\n"); - cat("----------------------------------------\n"); - } - - search.type.names <- c("brute", "cb") - - if(!search.type %in% search.type.names){ - stop("error: specified search.type '",search.type, - "' is not a valid option; choose from ", - paste(search.type.names, collapse=", ", sep="") ,".") - } - - ## Indexes - if(search.type == "brute"){ - indx <- mkNNIndx(coords, n.neighbors, n.omp.threads) - } else{ - indx <- mkNNIndxCB(coords, n.neighbors, n.omp.threads) - } - - nn.indx <- indx$nnIndx - nn.indx.lu <- indx$nnIndxLU - nn.indx.run.time <- indx$run.time - - if(verbose){ - cat("----------------------------------------\n"); - cat("Building the neighbors of neighbors list\n"); - cat("----------------------------------------\n"); - } - - indx <- mkUIndx(J, n.neighbors, nn.indx, nn.indx.lu, u.search.type) - - u.indx <- indx$u.indx - u.indx.lu <- indx$u.indx.lu - ui.indx <- indx$ui.indx - u.indx.run.time <- indx$run.time - - # Set storage for all variables --------------------------------------- - storage.mode(y) <- "double" - storage.mode(X) <- "double" - storage.mode(X.w) <- "double" - storage.mode(z) <- 'double' - storage.mode(coords) <- "double" - consts <- c(N, J, p, p.re, n.re, q, p.svc, ind.betas) - storage.mode(consts) <- "integer" - storage.mode(beta.inits) <- "double" - storage.mode(beta.comm.inits) <- "double" - storage.mode(tau.sq.inits) <- "double" - storage.mode(tau.sq.beta.inits) <- "double" - storage.mode(phi.inits) <- "double" - storage.mode(lambda.inits) <- "double" - storage.mode(nu.inits) <- "double" - storage.mode(w.inits) <- "double" - storage.mode(mu.beta.comm) <- "double" - storage.mode(Sigma.beta.comm) <- "double" - storage.mode(tau.sq.beta.a) <- "double" - storage.mode(tau.sq.beta.b) <- "double" - storage.mode(tau.sq.a) <- "double" - storage.mode(tau.sq.b) <- "double" - storage.mode(phi.a) <- "double" - storage.mode(phi.b) <- "double" - storage.mode(nu.a) <- "double" - storage.mode(nu.b) <- "double" - storage.mode(tuning.c) <- "double" - storage.mode(n.batch) <- "integer" - storage.mode(batch.length) <- "integer" - storage.mode(accept.rate) <- "double" - storage.mode(n.omp.threads) <- "integer" - storage.mode(verbose) <- "integer" - storage.mode(n.report) <- "integer" - storage.mode(nn.indx) <- "integer" - storage.mode(nn.indx.lu) <- "integer" - storage.mode(u.indx) <- "integer" - storage.mode(u.indx.lu) <- "integer" - storage.mode(ui.indx) <- "integer" - storage.mode(n.neighbors) <- "integer" - storage.mode(cov.model.indx) <- "integer" - # chain.info order: current chain, total number of chains - chain.info <- c(curr.chain, n.chains) - storage.mode(chain.info) <- "integer" - n.post.samples <- length(seq(from = n.burn + 1, - to = n.samples, - by = as.integer(n.thin))) - # samples.info order: burn-in, thinning rate, number of posterior samples - samples.info <- c(n.burn, n.thin, n.post.samples) - storage.mode(samples.info) <- "integer" - # For random effects - storage.mode(X.re) <- "integer" - storage.mode(X.random) <- "double" - beta.level.indx <- sort(unique(c(X.re))) - storage.mode(beta.level.indx) <- "integer" - storage.mode(sigma.sq.mu.inits) <- "double" - storage.mode(sigma.sq.mu.a) <- "double" - storage.mode(sigma.sq.mu.b) <- "double" - storage.mode(beta.star.inits) <- "double" - storage.mode(beta.star.indx) <- "integer" - # Gaussian = 2, zi-Gaussian = 3 - family.c <- ifelse(family == 'Gaussian', 2, 3) - storage.mode(family.c) <- 'integer' - - # Fit the model ------------------------------------------------------- - out.tmp <- list() - out <- list() - for (i in 1:n.chains) { - # Change initial values if i > 1 - if ((i > 1) & (!fix.inits)) { - if (!ind.betas) { - beta.comm.inits <- rnorm(p, mu.beta.comm, sqrt(sigma.beta.comm)) - tau.sq.beta.inits <- runif(p, 0.5, 10) - } - beta.inits <- matrix(rnorm(N * p, beta.comm.inits, - sqrt(tau.sq.beta.inits)), N, p) - beta.inits <- c(beta.inits) - tau.sq.inits <- runif(N, 0.01, 3) - lambda.inits <- list() - for (j in 1:p.svc) { - lambda.inits[[j]] <- matrix(0, N, q) - diag(lambda.inits[[j]]) <- 1 - lambda.inits[[j]][lower.tri(lambda.inits[[j]])] <- rnorm(sum(lower.tri(lambda.inits[[j]]))) - } - lambda.inits <- unlist(lambda.inits) - phi.inits <- runif(q.p.svc, phi.a, phi.b) - if (cov.model == 'matern') { - nu.inits <- runif(q.p.svc, nu.a, nu.b) - } - if (p.re > 0) { - sigma.sq.mu.inits <- runif(p.re, 0.5, 10) - beta.star.inits <- rnorm(n.re, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) - beta.star.inits <- rep(beta.star.inits, N) - } - } - - storage.mode(chain.info) <- "integer" - # Run the model in C - out.tmp[[i]] <- .Call("svcMsAbundGaussianNNGP", y, X, X.w, coords, X.re, - X.random, consts, n.re.long, - n.neighbors, nn.indx, nn.indx.lu, u.indx, u.indx.lu, ui.indx, - beta.inits, beta.comm.inits, tau.sq.beta.inits, tau.sq.inits, - phi.inits, lambda.inits, nu.inits, w.inits, sigma.sq.mu.inits, - beta.star.inits, beta.star.indx, beta.level.indx, mu.beta.comm, - Sigma.beta.comm, - tau.sq.beta.a, tau.sq.beta.b, tau.sq.a, tau.sq.b, phi.a, phi.b, - nu.a, nu.b, sigma.sq.mu.a, sigma.sq.mu.b, - tuning.c, cov.model.indx, n.batch, - batch.length, accept.rate, n.omp.threads, verbose, n.report, - samples.info, chain.info, z, family.c) - chain.info[1] <- chain.info[1] + 1 - } - # Calculate R-Hat --------------- - out$rhat <- list() - if (n.chains > 1) { - if (!ind.betas) { - out$rhat$beta.comm <- as.vector(gelman.diag(mcmc.list(lapply(out.tmp, function(a) - mcmc(t(a$beta.comm.samples)))), - autoburnin = FALSE, multivariate = FALSE)$psrf[, 2]) - out$rhat$tau.sq.beta <- as.vector(gelman.diag(mcmc.list(lapply(out.tmp, function(a) - mcmc(t(a$tau.sq.beta.samples)))), - autoburnin = FALSE, multivariate = FALSE)$psrf[, 2]) - } else { - out$rhat$beta.comm <- rep(NA, p) - out$rhat$tau.sq.beta <- rep(NA, p) - } - out$rhat$tau.sq <- as.vector(gelman.diag(mcmc.list(lapply(out.tmp, function(a) - mcmc(t(a$tau.sq.samples)))), - autoburnin = FALSE, multivariate = FALSE)$psrf[, 2]) - out$rhat$beta <- as.vector(gelman.diag(mcmc.list(lapply(out.tmp, function(a) - mcmc(t(a$beta.samples)))), - autoburnin = FALSE, multivariate = FALSE)$psrf[, 2]) - out$rhat$theta <- gelman.diag(mcmc.list(lapply(out.tmp, function(a) - mcmc(t(a$theta.samples)))), - autoburnin = FALSE, multivariate = FALSE)$psrf[, 2] - out$rhat$lambda.lower.tri <- list() - for (j in 1:p.svc) { - lambda.mat <- matrix(0, N, q) - indx <- (((j - 1) * N * q + 1):(j * N * q))[c(lower.tri(lambda.mat))] - out$rhat$lambda.lower.tri[[j]] <- as.vector(gelman.diag(mcmc.list(lapply(out.tmp, function(a) - mcmc(t(a$lambda.samples[indx, ])))), - autoburnin = FALSE, multivariate = FALSE)$psrf[, 2]) - } - if (p.re > 0) { - out$rhat$sigma.sq.mu <- as.vector(gelman.diag(mcmc.list(lapply(out.tmp, function(a) - mcmc(t(a$sigma.sq.mu.samples)))), - autoburnin = FALSE, multivariate = FALSE)$psrf[, 2]) - } - } else { - out$rhat$beta.comm <- rep(NA, p) - out$rhat$tau.sq.beta <- rep(NA, p) - out$rhat$tau.sq <- rep(NA, N) - out$rhat$beta <- rep(NA, p * N) - out$rhat$theta <- rep(NA, ifelse(cov.model == 'matern', 2 * q.p.svc, q.p.svc)) - if (p.re > 0) { - out$rhat$sigma.sq.mu <- rep(NA, p.re) - } - } - - # Put everything into MCMC objects - out$beta.comm.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$beta.comm.samples)))) - colnames(out$beta.comm.samples) <- x.names - out$tau.sq.beta.samples <- mcmc(do.call(rbind, - lapply(out.tmp, function(a) t(a$tau.sq.beta.samples)))) - colnames(out$tau.sq.beta.samples) <- x.names - - if (is.null(sp.names)) { - sp.names <- paste('sp', 1:N, sep = '') - } - coef.names <- paste(rep(x.names, each = N), sp.names, sep = '-') - out$beta.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$beta.samples)))) - colnames(out$beta.samples) <- coef.names - out$tau.sq.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$tau.sq.samples)))) - colnames(out$tau.sq.samples) <- sp.names - if (p.re > 0) { - out$sigma.sq.mu.samples <- mcmc( - do.call(rbind, lapply(out.tmp, function(a) t(a$sigma.sq.mu.samples)))) - colnames(out$sigma.sq.mu.samples) <- x.re.names - out$beta.star.samples <- mcmc( - do.call(rbind, lapply(out.tmp, function(a) t(a$beta.star.samples)))) - tmp.names <- unlist(re.level.names) - beta.star.names <- paste(rep(x.re.names, n.re.long), tmp.names, sep = '-') - beta.star.names <- paste(beta.star.names, rep(sp.names, each = n.re), sep = '-') - colnames(out$beta.star.samples) <- beta.star.names - out$re.level.names <- re.level.names - } - loadings.names <- paste(rep(sp.names, times = q), rep(1:q, each = N), sep = '-') - loadings.names <- paste(rep(loadings.names, times = p.svc), - rep(x.w.names, each = N * q), sep = '-') - out$lambda.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$lambda.samples)))) - colnames(out$lambda.samples) <- loadings.names - out$theta.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$theta.samples)))) - colnames(out$theta.samples) <- theta.names - - # Account for case when there is only 1 svc. - if (p.svc == 1) { - tmp <- do.call(abind, lapply(out.tmp, function(a) array(a$w.samples, - dim = c(q, J, n.post.samples)))) - tmp <- tmp[, order(ord), , drop = FALSE] - out$w.samples <- array(NA, dim = c(q, J, p.svc, n.post.samples * n.chains)) - out$w.samples[, , 1, ] <- tmp - } else { - out$w.samples <- do.call(abind, lapply(out.tmp, function(a) array(a$w.samples, - dim = c(q, J, p.svc, n.post.samples)))) - out$w.samples <- out$w.samples[, order(ord), , , drop = FALSE] - } - out$w.samples <- aperm(out$w.samples, c(4, 1, 2, 3)) - out$mu.samples <- do.call(abind, lapply(out.tmp, function(a) array(a$mu.samples, - dim = c(N, J, n.post.samples)))) - out$mu.samples <- out$mu.samples[, order(ord), ] - out$mu.samples <- aperm(out$mu.samples, c(3, 1, 2)) - out$like.samples <- do.call(abind, lapply(out.tmp, function(a) array(a$like.samples, - dim = c(N, J, n.post.samples)))) - out$like.samples <- out$like.samples[, order(ord), ] - out$like.samples <- aperm(out$like.samples, c(3, 1, 2)) - out$y.rep.samples <- do.call(abind, lapply(out.tmp, function(a) array(a$y.rep.samples, - dim = c(N, J, n.post.samples)))) - out$y.rep.samples <- out$y.rep.samples[, order(ord), ] - out$y.rep.samples <- aperm(out$y.rep.samples, c(3, 1, 2)) - - out$X.re <- X.re[order(ord), , drop = FALSE] - # Calculate effective sample sizes - out$ESS <- list() - out$ESS$beta.comm <- effectiveSize(out$beta.comm.samples) - out$ESS$tau.sq.beta <- effectiveSize(out$tau.sq.beta.samples) - out$ESS$tau.sq <- effectiveSize(out$tau.sq.samples) - out$ESS$beta <- effectiveSize(out$beta.samples) - out$ESS$theta <- effectiveSize(out$theta.samples) - out$ESS$lambda <- effectiveSize(out$lambda.samples) - if (p.re > 0) { - out$ESS$sigma.sq.mu <- effectiveSize(out$sigma.sq.mu.samples) - } - out$X <- X[order(ord), , drop = FALSE] - out$X.w <- X.w[order(ord), , drop = FALSE] - out$y <- y.orig[, order(ord), drop = FALSE] - out$call <- cl - out$n.samples <- n.samples - out$x.names <- x.names - out$sp.names <- sp.names - out$theta.names <- theta.names - out$type <- "NNGP" - out$coords <- coords[order(ord), ] - out$cov.model.indx <- cov.model.indx - out$svc.cols <- svc.cols - out$n.neighbors <- n.neighbors - out$q <- q - out$n.post <- n.post.samples - out$n.thin <- n.thin - out$n.burn <- n.burn - out$n.chains <- n.chains - out$dist <- family - out$re.cols <- re.cols - if (p.re > 0) { - out$muRE <- TRUE - } else { - out$muRE <- FALSE - } - class(out) <- "svcMsAbund" - } - - out$run.time <- proc.time() - ptm - return(out) } diff --git a/R/svcMsAbundGaussian.R b/R/svcMsAbundGaussian.R new file mode 100644 index 0000000..8e3b437 --- /dev/null +++ b/R/svcMsAbundGaussian.R @@ -0,0 +1,1080 @@ +svcMsAbundGaussian <- function(formula, data, inits, priors, tuning, + svc.cols = 1, cov.model = 'exponential', NNGP = TRUE, + n.neighbors = 15, search.type = "cb", n.factors, + n.batch, batch.length, accept.rate = 0.43, family = 'Gaussian', + n.omp.threads = 1, verbose = TRUE, n.report = 100, + n.burn = round(.10 * n.batch * batch.length), + n.thin = 1, n.chains = 1, ...){ + + ptm <- proc.time() + + # Make it look nice + if (verbose) { + cat("----------------------------------------\n"); + cat("\tPreparing to run the model\n"); + cat("----------------------------------------\n"); + } + # Check for unused arguments ------------------------------------------ + formal.args <- names(formals(sys.function(sys.parent()))) + elip.args <- names(list(...)) + for(i in elip.args){ + if(! i %in% formal.args) + warning("'",i, "' is not an argument") + } + # Call ---------------------------------------------------------------- + # Returns a call in which all of the specified arguments are + # specified by their full names. + cl <- match.call() + + # Some initial checks ------------------------------------------------- + # Only implemented for NNGP + if (!NNGP) { + stop("error: svcMsAbund is currently only implemented for NNGPs, not full Gaussian Processes. Please set NNGP = TRUE.") + } + if (missing(data)) { + stop("error: data must be specified") + } + if (!is.list(data)) { + stop("error: data must be a list") + } + names(data) <- tolower(names(data)) + if (!'y' %in% names(data)) { + stop("error: y must be specified in data") + } + if (length(dim(data$y)) != 2) { + stop("error: data y must be a matrix or data frame with rows corresponding to species and sites corresponding to columns") + } + y <- as.matrix(data$y) + sp.names <- attr(y, 'dimnames')[[1]] + if (!'covs' %in% names(data)) { + if (formula == ~ 1) { + if (verbose) { + message("covariates (covs) not specified in data.\nAssuming intercept only model.\n") + } + data$covs <- list(int = rep(1, dim(y)[2])) + } else { + stop("error: covs must be specified in data for a model with covariates") + } + } + if (!is.list(data$covs)) { + if (is.matrix(data$covs)) { + data$covs <- data.frame(data$covs) + } else { + stop("error: covs must be a list, data frame, or matrix") + } + } + if (!'coords' %in% names(data)) { + stop("error: coords must be specified in data for a spatial occupancy model.") + } + coords <- as.matrix(data$coords) + if (missing(n.factors)) { + stop("error: n.factors must be specified for a spatial factor model") + } + + if (family == 'zi-Gaussian') { + two.stage <- TRUE + } else { + two.stage <- FALSE + } + if (two.stage) { + if (!'z' %in% names(data)) { + stop("error: z must be specified in data for a two stage model") + } + z <- data$z + if (!is.matrix(z)) { + stop(paste0("z must be a matrix with ", nrow(y), " rows and ", ncol(y), " columns.")) + } + if (nrow(z) != nrow(y) | ncol(z) != ncol(y)) { + stop(paste0("z must be a matrix with ", nrow(y), " rows and ", ncol(y), " columns.")) + } + } else { + z <- matrix(1, nrow(y), ncol(y)) + } + + # First subset covariates to only use those that are included in the analysis. + # Get occurrence covariates in proper format + # Subset covariates to only use those that are included in the analysis + data$covs <- data$covs[names(data$covs) %in% all.vars(formula)] + # Null model support + if (length(data$covs) == 0) { + data$covs <- list(int = rep(1, dim(y)[2])) + } + # Ordered by rep, then site within rep + data$covs <- data.frame(lapply(data$covs, function(a) unlist(c(a)))) + + # Neighbors and Ordering ---------------------------------------------- + if (NNGP) { + u.search.type <- 2 + ## Order by x column. Could potentially allow this to be user defined. + ord <- order(coords[,1]) + # Reorder everything to align with NN ordering + y <- y[, ord, drop = FALSE] + z <- z[, ord, drop = FALSE] + coords <- coords[ord, , drop = FALSE] + # Covariates + data$covs <- data$covs[ord, , drop = FALSE] + } + + # Checking missing values --------------------------------------------- + # covs ------------------------ + if (sum(is.na(data$covs)) != 0) { + stop("error: missing values in covs. Please remove these sites from all objects in data or somehow replace the NA values with non-missing values (e.g., mean imputation).") + } + + # Check whether random effects are sent in as numeric, and + # return error if they are. + # Abundance ------------------------- + if (!is.null(findbars(formula))) { + abund.re.names <- unique(unlist(sapply(findbars(formula), all.vars))) + for (i in 1:length(abund.re.names)) { + if (is(data$covs[, abund.re.names[i]], 'factor')) { + stop(paste("error: random effect variable ", abund.re.names[i], " specified as a factor. Random effect variables must be specified as numeric.", sep = '')) + } + if (is(data$covs[, abund.re.names[i]], 'character')) { + stop(paste("error: random effect variable ", abund.re.names[i], " specified as character. Random effect variables must be specified as numeric.", sep = '')) + } + } + } + + # Formula ------------------------------------------------------------- + if (missing(formula)) { + stop("error: formula must be specified") + } + + if (is(formula, 'formula')) { + tmp <- parseFormula(formula, data$covs) + X <- as.matrix(tmp[[1]]) + X.re <- as.matrix(tmp[[4]]) + x.re.names <- colnames(X.re) + x.names <- tmp[[2]] + X.random <- as.matrix(tmp[[5]]) + x.random.names <- colnames(X.random) + } else { + stop("error: formula is misspecified") + } + # Get RE level names + re.level.names <- lapply(data$covs[, x.re.names, drop = FALSE], + function (a) sort(unique(a))) + x.re.names <- x.random.names + + # Extract data from inputs -------------------------------------------- + # Number of species + N <- dim(y)[1] + # Number of latent factors + q <- n.factors + # Number of fixed effects + p <- ncol(X) + # Number of random effect parameters + p.re <- ncol(X.re) + # Number of latent occupancy random effect values + n.re <- length(unlist(apply(X.re, 2, unique))) + n.re.long <- apply(X.re, 2, function(a) length(unique(a))) + # Number of sites + J <- nrow(X) + if (missing(n.batch)) { + stop("error: must specify number of MCMC batches") + } + if (missing(batch.length)) { + stop("error: must specify length of each MCMC batch") + } + n.samples <- n.batch * batch.length + if (n.burn > n.samples) { + stop("error: n.burn must be less than n.samples") + } + if (n.thin > n.samples) { + stop("error: n.thin must be less than n.samples") + } + # Check if n.burn, n.thin, and n.samples result in an integer and error if otherwise. + if (((n.samples - n.burn) / n.thin) %% 1 != 0) { + stop("the number of posterior samples to save ((n.samples - n.burn) / n.thin) is not a whole number. Please respecify the MCMC criteria such that the number of posterior samples saved is a whole number.") + } + + # y is ordered by site, then species within site. + y.orig <- y + y <- c(y) + + # Check SVC columns ----------------------------------------------------- + if (is.character(svc.cols)) { + # Check if all column names in svc are in occ.covs + if (!all(svc.cols %in% x.names)) { + missing.cols <- svc.cols[!(svc.cols %in% x.names)] + stop(paste("error: variable name ", paste(missing.cols, collapse=" and "), " not in occurrence covariates", sep="")) + } + # Convert desired column names into the numeric column index + svc.cols <- (1:p)[x.names %in% svc.cols] + + } else if (is.numeric(svc.cols)) { + # Check if all column indices are in 1:p + if (!all(svc.cols %in% 1:p)) { + missing.cols <- svc.cols[!(svc.cols %in% (1:p))] + stop(paste("error: column index ", paste(missing.cols, collapse=" "), " not in design matrix columns", sep="")) + } + } + p.svc <- length(svc.cols) + q.p.svc <- q * p.svc + + # Get random effect matrices all set ---------------------------------- + if (p.re > 1) { + for (j in 2:p.re) { + X.re[, j] <- X.re[, j] + max(X.re[, j - 1]) + 1 + } + } + # Priors -------------------------------------------------------------- + if (missing(priors)) { + priors <- list() + } + names(priors) <- tolower(names(priors)) + + # Independent beta parameters ----- + if ('independent.betas' %in% names(priors)) { + if (priors$independent.betas == TRUE) { + message("Beta parameters will be estimated independently\n") + ind.betas <- TRUE + } else if (priors$independent.betas == FALSE) { + ind.betas <- FALSE + } + } else { + ind.betas <- FALSE + } + # beta.comm ----------------------- + if ("beta.comm.normal" %in% names(priors)) { + if (!is.list(priors$beta.comm.normal) | length(priors$beta.comm.normal) != 2) { + stop("error: beta.comm.normal must be a list of length 2") + } + mu.beta.comm <- priors$beta.comm.normal[[1]] + sigma.beta.comm <- priors$beta.comm.normal[[2]] + if (length(mu.beta.comm) != p & length(mu.beta.comm) != 1) { + if (p == 1) { + stop(paste("error: beta.comm.normal[[1]] must be a vector of length ", + p, " with elements corresponding to beta.comms' mean", sep = "")) + } else { + stop(paste("error: beta.comm.normal[[1]] must be a vector of length ", + p, " or 1 with elements corresponding to beta.comms' mean", sep = "")) + } + } + if (length(sigma.beta.comm) != p & length(sigma.beta.comm) != 1) { + if (p == 1) { + stop(paste("error: beta.comm.normal[[2]] must be a vector of length ", + p, " with elements corresponding to beta.comms' variance", sep = "")) + } else { + stop(paste("error: beta.comm.normal[[2]] must be a vector of length ", + p, " or 1 with elements corresponding to beta.comms' variance", sep = "")) + } + } + if (length(sigma.beta.comm) != p) { + sigma.beta.comm <- rep(sigma.beta.comm, p) + } + if (length(mu.beta.comm) != p) { + mu.beta.comm <- rep(mu.beta.comm, p) + } + Sigma.beta.comm <- sigma.beta.comm * diag(p) + } else { + if (verbose & !ind.betas) { + message("No prior specified for beta.comm.normal.\nSetting prior mean to 0 and prior variance to 1000\n") + } + mu.beta.comm <- rep(0, p) + sigma.beta.comm <- rep(1000, p) + Sigma.beta.comm <- diag(p) * 1000 + } + + # tau.sq.beta ----------------------- + if ("tau.sq.beta.ig" %in% names(priors)) { + if (!is.list(priors$tau.sq.beta.ig) | length(priors$tau.sq.beta.ig) != 2) { + stop("error: tau.sq.beta.ig must be a list of length 2") + } + tau.sq.beta.a <- priors$tau.sq.beta.ig[[1]] + tau.sq.beta.b <- priors$tau.sq.beta.ig[[2]] + if (length(tau.sq.beta.a) != p & length(tau.sq.beta.a) != 1) { + if (p == 1) { + stop(paste("error: tau.sq.beta.ig[[1]] must be a vector of length ", + p, " with elements corresponding to tau.sq.betas' shape", sep = "")) + } else { + stop(paste("error: tau.sq.beta.ig[[1]] must be a vector of length ", + p, " or 1 with elements corresponding to tau.sq.betas' shape", sep = "")) + } + } + if (length(tau.sq.beta.b) != p & length(tau.sq.beta.b) != 1) { + if (p == 1) { + stop(paste("error: tau.sq.beta.ig[[2]] must be a vector of length ", + p, " with elements corresponding to tau.sq.betas' scale", sep = "")) + } else { + stop(paste("error: tau.sq.beta.ig[[2]] must be a vector of length ", + p, " or 1 with elements corresponding to tau.sq.betas' scale", sep = "")) + } + } + if (length(tau.sq.beta.a) != p) { + tau.sq.beta.a <- rep(tau.sq.beta.a, p) + } + if (length(tau.sq.beta.b) != p) { + tau.sq.beta.b <- rep(tau.sq.beta.b, p) + } + } else { + if (verbose & !ind.betas) { + message("No prior specified for tau.sq.beta.ig.\nSetting prior shape to 0.1 and prior scale to 0.1\n") + } + tau.sq.beta.a <- rep(0.1, p) + tau.sq.beta.b <- rep(0.1, p) + } + + # tau.sq ----------------------- + if ("tau.sq.ig" %in% names(priors)) { + if (!is.list(priors$tau.sq.ig) | length(priors$tau.sq.ig) != 2) { + stop("error: tau.sq.ig must be a list of length 2") + } + tau.sq.a <- priors$tau.sq.ig[[1]] + tau.sq.b <- priors$tau.sq.ig[[2]] + if (length(tau.sq.a) != N & length(tau.sq.a) != 1) { + stop(paste("error: tau.sq.ig[[1]] must be a vector of length ", + N, " or 1 with elements corresponding to tau.sqs' shape", sep = "")) + } + if (length(tau.sq.b) != N & length(tau.sq.b) != 1) { + stop(paste("error: tau.sq.ig[[2]] must be a vector of length ", + p, " or 1 with elements corresponding to tau.sqs' scale", sep = "")) + } + if (length(tau.sq.a) != N) { + tau.sq.a <- rep(tau.sq.a, N) + } + if (length(tau.sq.b) != N) { + tau.sq.b <- rep(tau.sq.b, N) + } + } else { + if (verbose) { + message("No prior specified for tau.sq.ig.\nSetting prior shape to 0.1 and prior scale to 0.1\n") + } + tau.sq.a <- rep(0.1, N) + tau.sq.b <- rep(0.1, N) + } + + # phi ----------------------------- + if ("phi.unif" %in% names(priors)) { + if (!is.list(priors$phi.unif) | length(priors$phi.unif) != 2) { + stop("error: phi.unif must be a list of length 2") + } + phi.a <- priors$phi.unif[[1]] + phi.b <- priors$phi.unif[[2]] + if (length(phi.a) != q.p.svc & length(phi.a) != 1) { + stop(paste("error: phi.unif[[1]] must be a vector of length ", + q.p.svc, ", a matrix with ", q, " rows and ", p.svc, + " columns, or a vector of length 1 with elements corresponding to phis' lower bound for each latent factor and spatially-varying coefficient", sep = "")) + } + if (length(phi.b) != q.p.svc & length(phi.b) != 1) { + stop(paste("error: phi.unif[[2]] must be a vector of length ", + q.p.svc, ", a matrix with ", q, " rows and ", p.svc, + " columns, or a vector of length 1 with elements corresponding to phis' upper bound for each latent factor and spatially-varying coefficient", sep = "")) + } + if (length(phi.a) != q.p.svc) { + phi.a <- rep(phi.a, q.p.svc) + } + if (length(phi.b) != q.p.svc) { + phi.b <- rep(phi.b, q.p.svc) + } + } else { + if (verbose) { + message("No prior specified for phi.unif.\nSetting uniform bounds based on the range of observed spatial coordinates.\n") + } + coords.D <- iDist(coords) + phi.a <- rep(3 / max(coords.D), q.p.svc) + phi.b <- rep(3 / sort(unique(c(coords.D)))[2], q.p.svc) + } + # nu ----------------------------- + if (cov.model == "matern") { + if (!"nu.unif" %in% names(priors)) { + stop("error: nu.unif must be specified in priors value list") + } + nu.a <- priors$nu.unif[[1]] + nu.b <- priors$nu.unif[[2]] + if (!is.list(priors$nu.unif) | length(priors$nu.unif) != 2) { + stop("error: nu.unif must be a list of length 2") + } + if (length(nu.a) != q.p.svc & length(nu.a) != 1) { + stop(paste("error: nu.unif[[1]] must be a vector of length ", + q.p.svc, ", a matrix with ", q, " rows and ", p.svc, + " columns, or a vector of length 1 with elements corresponding to nus' lower bound for each latent factor and spatially-varying coefficient", sep = "")) + } + if (length(nu.b) != q & length(nu.b) != 1) { + stop(paste("error: nu.unif[[2]] must be a vector of length ", + q.p.svc, ", a matrix with ", q, " rows and ", p.svc, + " columns, or a vector of length 1 with elements corresponding to nus' upper bound for each latent factor and spatially-varying coefficient", sep = "")) + } + if (length(nu.a) != q.p.svc) { + nu.a <- rep(nu.a, q.p.svc) + } + if (length(nu.b) != q.p.svc) { + nu.b <- rep(nu.b, q.p.svc) + } + } else { + nu.a <- rep(0, q.p.svc) + nu.b <- rep(0, q.p.svc) + } + + # sigma.sq.mu -------------------- + if (p.re > 0) { + if ("sigma.sq.mu.ig" %in% names(priors)) { + if (!is.list(priors$sigma.sq.mu.ig) | length(priors$sigma.sq.mu.ig) != 2) { + stop("error: sigma.sq.mu.ig must be a list of length 2") + } + sigma.sq.mu.a <- priors$sigma.sq.mu.ig[[1]] + sigma.sq.mu.b <- priors$sigma.sq.mu.ig[[2]] + if (length(sigma.sq.mu.a) != p.re & length(sigma.sq.mu.a) != 1) { + if (p.re == 1) { + stop(paste("error: sigma.sq.mu.ig[[1]] must be a vector of length ", + p.re, " with elements corresponding to sigma.sq.mus' shape", sep = "")) + } else { + stop(paste("error: sigma.sq.mu.ig[[1]] must be a vector of length ", + p.re, " or 1 with elements corresponding to sigma.sq.mus' shape", sep = "")) + } + } + if (length(sigma.sq.mu.b) != p.re & length(sigma.sq.mu.b) != 1) { + if (p.re == 1) { + stop(paste("error: sigma.sq.mu.ig[[2]] must be a vector of length ", + p.re, " with elements corresponding to sigma.sq.mus' scale", sep = "")) + } else { + stop(paste("error: sigma.sq.mu.ig[[2]] must be a vector of length ", + p.re, " or 1with elements corresponding to sigma.sq.mus' scale", sep = "")) + } + } + if (length(sigma.sq.mu.a) != p.re) { + sigma.sq.mu.a <- rep(sigma.sq.mu.a, p.re) + } + if (length(sigma.sq.mu.b) != p.re) { + sigma.sq.mu.b <- rep(sigma.sq.mu.b, p.re) + } + } else { + if (verbose) { + message("No prior specified for sigma.sq.mu.ig.\nSetting prior shape to 0.1 and prior scale to 0.1\n") + } + sigma.sq.mu.a <- rep(0.1, p.re) + sigma.sq.mu.b <- rep(0.1, p.re) + } + } else { + sigma.sq.mu.a <- 0 + sigma.sq.mu.b <- 0 + } + + # Initial values -------------------------------------------------------- + if (missing(inits)) { + inits <- list() + } + names(inits) <- tolower(names(inits)) + # beta.comm ----------------------- + # ORDER: a p vector ordered by the effects in the formula. + if ("beta.comm" %in% names(inits)) { + beta.comm.inits <- inits[["beta.comm"]] + if (length(beta.comm.inits) != p & length(beta.comm.inits) != 1) { + if (p == 1) { + stop(paste("error: initial values for beta.comm must be of length ", p, + sep = "")) + } else { + stop(paste("error: initial values for beta.comm must be of length ", p, + , " or 1", sep = "")) + } + } + if (length(beta.comm.inits) != p) { + beta.comm.inits <- rep(beta.comm.inits, p) + } + } else { + beta.comm.inits <- rnorm(p, mu.beta.comm, sqrt(sigma.beta.comm)) + if (verbose) { + message('beta.comm is not specified in initial values.\nSetting initial values to random values from the prior distribution\n') + } + } + # tau.sq.beta ------------------------ + # ORDER: a p vector ordered by the effects in the occurrence formula + if ("tau.sq.beta" %in% names(inits)) { + tau.sq.beta.inits <- inits[["tau.sq.beta"]] + if (length(tau.sq.beta.inits) != p & length(tau.sq.beta.inits) != 1) { + if (p == 1) { + stop(paste("error: initial values for tau.sq.beta must be of length ", p, + sep = "")) + } else { + stop(paste("error: initial values for tau.sq.beta must be of length ", p, + " or 1", sep = "")) + } + } + if (length(tau.sq.beta.inits) != p) { + tau.sq.beta.inits <- rep(tau.sq.beta.inits, p) + } + } else { + tau.sq.beta.inits <- runif(p, 0.5, 10) + if (verbose) { + message('tau.sq.beta is not specified in initial values.\nSetting initial values to random values between 0.5 and 10\n') + } + } + # tau.sq ------------------------ + # ORDER: a length N vector + if ("tau.sq" %in% names(inits)) { + tau.sq.inits <- inits[["tau.sq"]] + if (length(tau.sq.inits) != N & length(tau.sq.inits) != 1) { + stop(paste("error: initial values for tau.sq must be of length ", N, + " or 1", sep = "")) + } + if (length(tau.sq.inits) != N) { + tau.sq.inits <- rep(tau.sq.inits, N) + } + } else { + tau.sq.inits <- runif(N, 0.01, 3) + if (verbose) { + message('tau.sq is not specified in initial values.\nSetting initial values to random values between 0.01 and 3\n') + } + } + # beta ---------------------------- + # ORDER: N x p matrix sent in as a column-major vector ordered by + # parameter then species within parameter. + if ("beta" %in% names(inits)) { + beta.inits <- inits[["beta"]] + if (is.matrix(beta.inits)) { + if (ncol(beta.inits) != p | nrow(beta.inits) != N) { + stop(paste("error: initial values for beta must be a matrix with dimensions ", + N, "x", p, " or a single numeric value", sep = "")) + } + } + if (!is.matrix(beta.inits) & length(beta.inits) != 1) { + stop(paste("error: initial values for beta must be a matrix with dimensions ", + N, " x ", p, " or a single numeric value", sep = "")) + } + if (length(beta.inits) == 1) { + beta.inits <- matrix(beta.inits, N, p) + } + } else { + beta.inits <- matrix(rnorm(N * p, beta.comm.inits, sqrt(tau.sq.beta.inits)), N, p) + if (verbose) { + message('beta is not specified in initial values.\nSetting initial values to random values from the community-level normal distribution\n') + } + } + # Create a N * p x 1 matrix of the species-level regression coefficients. + # This is ordered by parameter, then species within a parameter. + beta.inits <- c(beta.inits) + # phi ----------------------------- + # ORDER: a q x p.svc matrix sent in as a column-major vector sorted first by + # the spatially-varying coefficient, then latent factor within svc. + if ("phi" %in% names(inits)) { + phi.inits <- inits[["phi"]] + if (length(phi.inits) != q.p.svc & length(phi.inits) != 1) { + stop(paste("error: initial values for phi must be of length ", q.p.svc, " or 1", + sep = "")) + } + if (length(phi.inits) != q.p.svc) { + phi.inits <- rep(phi.inits, q.p.svc) + } + } else { + phi.inits <- runif(q.p.svc, phi.a, phi.b) + if (verbose) { + message("phi is not specified in initial values.\nSetting initial value to random values from the prior distribution\n") + } + } + # nu ------------------------ + if ("nu" %in% names(inits)) { + nu.inits <- inits[["nu"]] + if (length(nu.inits) != q.p.svc & length(nu.inits) != 1) { + stop(paste("error: initial values for nu must be of length ", q.p.svc, " or 1", + sep = "")) + } + if (length(nu.inits) != q.p.svc) { + nu.inits <- rep(nu.inits, q.p.svc) + } + } else { + if (cov.model == 'matern') { + if (verbose) { + message("nu is not specified in initial values.\nSetting initial values to random values from the prior distribution\n") + } + nu.inits <- runif(q.p.svc, nu.a, nu.b) + } else { + nu.inits <- rep(0, q.p.svc) + } + } + # lambda ---------------------------- + # ORDER: an p.svc N x q matrices sent in as a list, each in + # column-major vector, which is ordered by factor, + # then species within factor. Eventually sent into + # C++ as a stacked p.svc x N x q matrix, ordered by + # svc, then factor within svc, then species within factor. + if ("lambda" %in% names(inits)) { + lambda.inits <- inits[["lambda"]] + if (!is.list(lambda.inits)) { + stop(paste("error: initial values for lambda must be a list comprised of ", + p.svc, " matrices, each with dimensions ", N, " x ", q, sep = "")) + } + for (i in 1:p.svc) { + if (nrow(lambda.inits[[i]]) != N | ncol(lambda.inits[[i]]) != q) { + stop(paste("error: initial values for lambda[[", i, + "]] must be a matrix with dimensions ", N, " x ", q, sep = "")) + } + if (!all.equal(diag(lambda.inits[[i]]), rep(1, q))) { + stop("error: diagonal of inits$lambda[[", i, "]] matrix must be all 1s") + } + if (sum(lambda.inits[[i]][upper.tri(lambda.inits[[i]])]) != 0) { + stop("error: upper triangle of inits$lambda[[", i, "]] must be all 0s") + } + } + lambda.inits <- unlist(lambda.inits) + } else { + lambda.inits <- list() + for (i in 1:p.svc) { + lambda.inits[[i]] <- matrix(0, N, q) + diag(lambda.inits[[i]]) <- 1 + lambda.inits[[i]][lower.tri(lambda.inits[[i]])] <- rnorm(sum(lower.tri(lambda.inits[[i]]))) + } + if (verbose) { + message("lambda is not specified in initial values.\nSetting initial values of the lower triangle to random values from a standard normal\n") + } + lambda.inits <- unlist(lambda.inits) + } + # w ----------------------------- + if ("w" %in% names(inits)) { + w.inits <- inits[["w"]] + if (!is.list(w.inits)) { + stop(paste("error: initial values for w must be a list comprised of ", + p.svc, " matrices, each with dimensions ", q, " x ", J, sep = "")) + } + for (i in 1:p.svc) { + if (!is.matrix(w.inits[[i]])) { + stop(paste("error: initial values for w must be a matrix with dimensions ", + q, " x ", J, sep = "")) + } + if (nrow(w.inits[[i]]) != q | ncol(w.inits[[i]]) != J) { + stop(paste("error: initial values for w must be a matrix with dimensions ", + q, " x ", J, sep = "")) + } + if (NNGP) { + w.inits[[i]] <- w.inits[[i]][, ord] + } + } + w.inits <- unlist(w.inits) + } else { + w.inits <- list() + for (i in 1:p.svc) { + w.inits[[i]] <- matrix(0, q, J) + } + if (verbose) { + message("w is not specified in initial values.\nSetting initial value to 0\n") + } + w.inits <- unlist(w.inits) + } + # sigma.sq.mu ------------------ + # ORDER: a length p.re vector ordered by the random effects in the formula. + if (p.re > 0) { + if ("sigma.sq.mu" %in% names(inits)) { + sigma.sq.mu.inits <- inits[["sigma.sq.mu"]] + if (length(sigma.sq.mu.inits) != p.re & length(sigma.sq.mu.inits) != 1) { + if (p.re == 1) { + stop(paste("error: initial values for sigma.sq.mu must be of length ", p.re, + sep = "")) + } else { + stop(paste("error: initial values for sigma.sq.mu must be of length ", p.re, + " or 1", sep = "")) + } + } + if (length(sigma.sq.mu.inits) != p.re) { + sigma.sq.mu.inits <- rep(sigma.sq.mu.inits, p.re) + } + } else { + sigma.sq.mu.inits <- runif(p.re, 0.5, 10) + if (verbose) { + message("sigma.sq.mu is not specified in initial values.\nSetting initial values to random values between 0.5 and 10\n") + } + } + beta.star.indx <- rep(0:(p.re - 1), n.re.long) + beta.star.inits <- rnorm(n.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rep(beta.star.inits, N) + } else { + sigma.sq.mu.inits <- 0 + beta.star.indx <- 0 + beta.star.inits <- 0 + } + + # Should initial values be fixed -- + if ("fix" %in% names(inits)) { + fix.inits <- inits[["fix"]] + if ((fix.inits != TRUE) & (fix.inits != FALSE)) { + stop(paste("error: inits$fix must take value TRUE or FALSE")) + } + } else { + fix.inits <- FALSE + } + if (verbose & fix.inits & (n.chains > 1)) { + message("Fixing initial values across all chains\n") + } + # Covariance Model ---------------------------------------------------- + # Order must match util.cpp spCor. + cov.model.names <- c("exponential", "spherical", "matern", "gaussian") + if(! cov.model %in% cov.model.names){ + stop("error: specified cov.model '",cov.model,"' is not a valid option; choose from ", + paste(cov.model.names, collapse=", ", sep="") ,".")} + # Obo for cov model lookup on c side + cov.model.indx <- which(cov.model == cov.model.names) - 1 + + # Prep for SVCs --------------------------------------------------------- + X.w <- X[, svc.cols, drop = FALSE] + x.w.names <- colnames(X.w) + + # Get tuning values --------------------------------------------------- + # Not accessed, but necessary to keep things in line with the underlying functions. + sigma.sq.tuning <- rep(0, q.p.svc) + phi.tuning <- rep(0, q.p.svc) + nu.tuning <- rep(0, q.p.svc) + if (missing(tuning)) { + phi.tuning <- rep(1, q.p.svc) + if (cov.model == 'matern') { + nu.tuning <- rep(1, q.p.svc) + } + } else { + names(tuning) <- tolower(names(tuning)) + # phi --------------------------- + if(!"phi" %in% names(tuning)) { + stop("error: phi must be specified in tuning value list") + } + phi.tuning <- tuning$phi + if (length(phi.tuning) == 1) { + phi.tuning <- rep(tuning$phi, q.p.svc) + } else if (length(phi.tuning) != q.p.svc) { + stop(paste("error: phi tuning must be either a single value or a vector of length ", + q.p.svc, sep = "")) + } + if (cov.model == 'matern') { + # nu -------------------------- + if(!"nu" %in% names(tuning)) { + stop("error: nu must be specified in tuning value list") + } + nu.tuning <- tuning$nu + if (length(nu.tuning) == 1) { + nu.tuning <- rep(tuning$nu, q.p.svc) + } else if (length(nu.tuning) != q.p.svc) { + stop(paste("error: nu tuning must be either a single value or a vector of length ", + q.p.svc, sep = "")) + } + } + } + tuning.c <- log(c(sigma.sq.tuning, phi.tuning, nu.tuning)) + # Set model.deviance to NA for returning when no cross-validation + model.deviance <- NA + curr.chain <- 1 + + # Names for spatial parameters + if (cov.model != 'matern') { + theta.names <- paste(rep(c('phi'), each = q), 1:q, sep = '-') + theta.names <- paste(rep(theta.names, times = p.svc), + rep(x.w.names, each = q), sep = '-') + } else { + theta.names <- paste(rep(c('phi', 'nu'), each = q), 1:q, sep = '-') + theta.names <- paste(rep(theta.names, times = p.svc), + rep(x.w.names, each = 2 * q), sep = '-') + } + + # Other miscellaneous --------------------------------------------------- + # For prediction with random slopes + re.cols <- list() + if (p.re > 0) { + split.names <- strsplit(x.re.names, "[-]") + for (j in 1:p.re) { + re.cols[[j]] <- split.names[[j]][1] + names(re.cols)[j] <- split.names[[j]][2] + } + } + + if (!NNGP) { + + stop("error: svcMsAbund is currently only implemented for NNGPs, not full Gaussian Processes. Please set NNGP = TRUE.") + + } else { + + # Nearest Neighbor Search --------------------------------------------- + if(verbose){ + cat("----------------------------------------\n"); + cat("\tBuilding the neighbor list\n"); + cat("----------------------------------------\n"); + } + + search.type.names <- c("brute", "cb") + + if(!search.type %in% search.type.names){ + stop("error: specified search.type '",search.type, + "' is not a valid option; choose from ", + paste(search.type.names, collapse=", ", sep="") ,".") + } + + ## Indexes + if(search.type == "brute"){ + indx <- mkNNIndx(coords, n.neighbors, n.omp.threads) + } else{ + indx <- mkNNIndxCB(coords, n.neighbors, n.omp.threads) + } + + nn.indx <- indx$nnIndx + nn.indx.lu <- indx$nnIndxLU + nn.indx.run.time <- indx$run.time + + if(verbose){ + cat("----------------------------------------\n"); + cat("Building the neighbors of neighbors list\n"); + cat("----------------------------------------\n"); + } + + indx <- mkUIndx(J, n.neighbors, nn.indx, nn.indx.lu, u.search.type) + + u.indx <- indx$u.indx + u.indx.lu <- indx$u.indx.lu + ui.indx <- indx$ui.indx + u.indx.run.time <- indx$run.time + + # Set storage for all variables --------------------------------------- + storage.mode(y) <- "double" + storage.mode(X) <- "double" + storage.mode(X.w) <- "double" + storage.mode(z) <- 'double' + storage.mode(coords) <- "double" + consts <- c(N, J, p, p.re, n.re, q, p.svc, ind.betas) + storage.mode(consts) <- "integer" + storage.mode(beta.inits) <- "double" + storage.mode(beta.comm.inits) <- "double" + storage.mode(tau.sq.inits) <- "double" + storage.mode(tau.sq.beta.inits) <- "double" + storage.mode(phi.inits) <- "double" + storage.mode(lambda.inits) <- "double" + storage.mode(nu.inits) <- "double" + storage.mode(w.inits) <- "double" + storage.mode(mu.beta.comm) <- "double" + storage.mode(Sigma.beta.comm) <- "double" + storage.mode(tau.sq.beta.a) <- "double" + storage.mode(tau.sq.beta.b) <- "double" + storage.mode(tau.sq.a) <- "double" + storage.mode(tau.sq.b) <- "double" + storage.mode(phi.a) <- "double" + storage.mode(phi.b) <- "double" + storage.mode(nu.a) <- "double" + storage.mode(nu.b) <- "double" + storage.mode(tuning.c) <- "double" + storage.mode(n.batch) <- "integer" + storage.mode(batch.length) <- "integer" + storage.mode(accept.rate) <- "double" + storage.mode(n.omp.threads) <- "integer" + storage.mode(verbose) <- "integer" + storage.mode(n.report) <- "integer" + storage.mode(nn.indx) <- "integer" + storage.mode(nn.indx.lu) <- "integer" + storage.mode(u.indx) <- "integer" + storage.mode(u.indx.lu) <- "integer" + storage.mode(ui.indx) <- "integer" + storage.mode(n.neighbors) <- "integer" + storage.mode(cov.model.indx) <- "integer" + # chain.info order: current chain, total number of chains + chain.info <- c(curr.chain, n.chains) + storage.mode(chain.info) <- "integer" + n.post.samples <- length(seq(from = n.burn + 1, + to = n.samples, + by = as.integer(n.thin))) + # samples.info order: burn-in, thinning rate, number of posterior samples + samples.info <- c(n.burn, n.thin, n.post.samples) + storage.mode(samples.info) <- "integer" + # For random effects + storage.mode(X.re) <- "integer" + storage.mode(X.random) <- "double" + beta.level.indx <- sort(unique(c(X.re))) + storage.mode(beta.level.indx) <- "integer" + storage.mode(sigma.sq.mu.inits) <- "double" + storage.mode(sigma.sq.mu.a) <- "double" + storage.mode(sigma.sq.mu.b) <- "double" + storage.mode(beta.star.inits) <- "double" + storage.mode(beta.star.indx) <- "integer" + # Gaussian = 2, zi-Gaussian = 3 + family.c <- ifelse(family == 'Gaussian', 2, 3) + storage.mode(family.c) <- 'integer' + + # Fit the model ------------------------------------------------------- + out.tmp <- list() + out <- list() + for (i in 1:n.chains) { + # Change initial values if i > 1 + if ((i > 1) & (!fix.inits)) { + if (!ind.betas) { + beta.comm.inits <- rnorm(p, mu.beta.comm, sqrt(sigma.beta.comm)) + tau.sq.beta.inits <- runif(p, 0.5, 10) + } + beta.inits <- matrix(rnorm(N * p, beta.comm.inits, + sqrt(tau.sq.beta.inits)), N, p) + beta.inits <- c(beta.inits) + tau.sq.inits <- runif(N, 0.01, 3) + lambda.inits <- list() + for (j in 1:p.svc) { + lambda.inits[[j]] <- matrix(0, N, q) + diag(lambda.inits[[j]]) <- 1 + lambda.inits[[j]][lower.tri(lambda.inits[[j]])] <- rnorm(sum(lower.tri(lambda.inits[[j]]))) + } + lambda.inits <- unlist(lambda.inits) + phi.inits <- runif(q.p.svc, phi.a, phi.b) + if (cov.model == 'matern') { + nu.inits <- runif(q.p.svc, nu.a, nu.b) + } + if (p.re > 0) { + sigma.sq.mu.inits <- runif(p.re, 0.5, 10) + beta.star.inits <- rnorm(n.re, 0, sqrt(sigma.sq.mu.inits[beta.star.indx + 1])) + beta.star.inits <- rep(beta.star.inits, N) + } + } + + storage.mode(chain.info) <- "integer" + # Run the model in C + out.tmp[[i]] <- .Call("svcMsAbundGaussianNNGP", y, X, X.w, coords, X.re, + X.random, consts, n.re.long, + n.neighbors, nn.indx, nn.indx.lu, u.indx, u.indx.lu, ui.indx, + beta.inits, beta.comm.inits, tau.sq.beta.inits, tau.sq.inits, + phi.inits, lambda.inits, nu.inits, w.inits, sigma.sq.mu.inits, + beta.star.inits, beta.star.indx, beta.level.indx, mu.beta.comm, + Sigma.beta.comm, + tau.sq.beta.a, tau.sq.beta.b, tau.sq.a, tau.sq.b, phi.a, phi.b, + nu.a, nu.b, sigma.sq.mu.a, sigma.sq.mu.b, + tuning.c, cov.model.indx, n.batch, + batch.length, accept.rate, n.omp.threads, verbose, n.report, + samples.info, chain.info, z, family.c) + chain.info[1] <- chain.info[1] + 1 + } + # Calculate R-Hat --------------- + out$rhat <- list() + if (n.chains > 1) { + if (!ind.betas) { + out$rhat$beta.comm <- as.vector(gelman.diag(mcmc.list(lapply(out.tmp, function(a) + mcmc(t(a$beta.comm.samples)))), + autoburnin = FALSE, multivariate = FALSE)$psrf[, 2]) + out$rhat$tau.sq.beta <- as.vector(gelman.diag(mcmc.list(lapply(out.tmp, function(a) + mcmc(t(a$tau.sq.beta.samples)))), + autoburnin = FALSE, multivariate = FALSE)$psrf[, 2]) + } else { + out$rhat$beta.comm <- rep(NA, p) + out$rhat$tau.sq.beta <- rep(NA, p) + } + out$rhat$tau.sq <- as.vector(gelman.diag(mcmc.list(lapply(out.tmp, function(a) + mcmc(t(a$tau.sq.samples)))), + autoburnin = FALSE, multivariate = FALSE)$psrf[, 2]) + out$rhat$beta <- as.vector(gelman.diag(mcmc.list(lapply(out.tmp, function(a) + mcmc(t(a$beta.samples)))), + autoburnin = FALSE, multivariate = FALSE)$psrf[, 2]) + out$rhat$theta <- gelman.diag(mcmc.list(lapply(out.tmp, function(a) + mcmc(t(a$theta.samples)))), + autoburnin = FALSE, multivariate = FALSE)$psrf[, 2] + out$rhat$lambda.lower.tri <- list() + for (j in 1:p.svc) { + lambda.mat <- matrix(0, N, q) + indx <- (((j - 1) * N * q + 1):(j * N * q))[c(lower.tri(lambda.mat))] + out$rhat$lambda.lower.tri[[j]] <- as.vector(gelman.diag(mcmc.list(lapply(out.tmp, function(a) + mcmc(t(a$lambda.samples[indx, ])))), + autoburnin = FALSE, multivariate = FALSE)$psrf[, 2]) + } + if (p.re > 0) { + out$rhat$sigma.sq.mu <- as.vector(gelman.diag(mcmc.list(lapply(out.tmp, function(a) + mcmc(t(a$sigma.sq.mu.samples)))), + autoburnin = FALSE, multivariate = FALSE)$psrf[, 2]) + } + } else { + out$rhat$beta.comm <- rep(NA, p) + out$rhat$tau.sq.beta <- rep(NA, p) + out$rhat$tau.sq <- rep(NA, N) + out$rhat$beta <- rep(NA, p * N) + out$rhat$theta <- rep(NA, ifelse(cov.model == 'matern', 2 * q.p.svc, q.p.svc)) + if (p.re > 0) { + out$rhat$sigma.sq.mu <- rep(NA, p.re) + } + } + + # Put everything into MCMC objects + out$beta.comm.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$beta.comm.samples)))) + colnames(out$beta.comm.samples) <- x.names + out$tau.sq.beta.samples <- mcmc(do.call(rbind, + lapply(out.tmp, function(a) t(a$tau.sq.beta.samples)))) + colnames(out$tau.sq.beta.samples) <- x.names + + if (is.null(sp.names)) { + sp.names <- paste('sp', 1:N, sep = '') + } + coef.names <- paste(rep(x.names, each = N), sp.names, sep = '-') + out$beta.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$beta.samples)))) + colnames(out$beta.samples) <- coef.names + out$tau.sq.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$tau.sq.samples)))) + colnames(out$tau.sq.samples) <- sp.names + if (p.re > 0) { + out$sigma.sq.mu.samples <- mcmc( + do.call(rbind, lapply(out.tmp, function(a) t(a$sigma.sq.mu.samples)))) + colnames(out$sigma.sq.mu.samples) <- x.re.names + out$beta.star.samples <- mcmc( + do.call(rbind, lapply(out.tmp, function(a) t(a$beta.star.samples)))) + tmp.names <- unlist(re.level.names) + beta.star.names <- paste(rep(x.re.names, n.re.long), tmp.names, sep = '-') + beta.star.names <- paste(beta.star.names, rep(sp.names, each = n.re), sep = '-') + colnames(out$beta.star.samples) <- beta.star.names + out$re.level.names <- re.level.names + } + loadings.names <- paste(rep(sp.names, times = q), rep(1:q, each = N), sep = '-') + loadings.names <- paste(rep(loadings.names, times = p.svc), + rep(x.w.names, each = N * q), sep = '-') + out$lambda.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$lambda.samples)))) + colnames(out$lambda.samples) <- loadings.names + out$theta.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$theta.samples)))) + colnames(out$theta.samples) <- theta.names + + # Account for case when there is only 1 svc. + if (p.svc == 1) { + tmp <- do.call(abind, lapply(out.tmp, function(a) array(a$w.samples, + dim = c(q, J, n.post.samples)))) + tmp <- tmp[, order(ord), , drop = FALSE] + out$w.samples <- array(NA, dim = c(q, J, p.svc, n.post.samples * n.chains)) + out$w.samples[, , 1, ] <- tmp + } else { + out$w.samples <- do.call(abind, lapply(out.tmp, function(a) array(a$w.samples, + dim = c(q, J, p.svc, n.post.samples)))) + out$w.samples <- out$w.samples[, order(ord), , , drop = FALSE] + } + out$w.samples <- aperm(out$w.samples, c(4, 1, 2, 3)) + out$mu.samples <- do.call(abind, lapply(out.tmp, function(a) array(a$mu.samples, + dim = c(N, J, n.post.samples)))) + out$mu.samples <- out$mu.samples[, order(ord), ] + out$mu.samples <- aperm(out$mu.samples, c(3, 1, 2)) + out$like.samples <- do.call(abind, lapply(out.tmp, function(a) array(a$like.samples, + dim = c(N, J, n.post.samples)))) + out$like.samples <- out$like.samples[, order(ord), ] + out$like.samples <- aperm(out$like.samples, c(3, 1, 2)) + out$y.rep.samples <- do.call(abind, lapply(out.tmp, function(a) array(a$y.rep.samples, + dim = c(N, J, n.post.samples)))) + out$y.rep.samples <- out$y.rep.samples[, order(ord), ] + out$y.rep.samples <- aperm(out$y.rep.samples, c(3, 1, 2)) + + out$X.re <- X.re[order(ord), , drop = FALSE] + # Calculate effective sample sizes + out$ESS <- list() + out$ESS$beta.comm <- effectiveSize(out$beta.comm.samples) + out$ESS$tau.sq.beta <- effectiveSize(out$tau.sq.beta.samples) + out$ESS$tau.sq <- effectiveSize(out$tau.sq.samples) + out$ESS$beta <- effectiveSize(out$beta.samples) + out$ESS$theta <- effectiveSize(out$theta.samples) + out$ESS$lambda <- effectiveSize(out$lambda.samples) + if (p.re > 0) { + out$ESS$sigma.sq.mu <- effectiveSize(out$sigma.sq.mu.samples) + } + out$X <- X[order(ord), , drop = FALSE] + out$X.w <- X.w[order(ord), , drop = FALSE] + out$y <- y.orig[, order(ord), drop = FALSE] + out$call <- cl + out$n.samples <- n.samples + out$x.names <- x.names + out$sp.names <- sp.names + out$theta.names <- theta.names + out$type <- "NNGP" + out$coords <- coords[order(ord), ] + out$cov.model.indx <- cov.model.indx + out$svc.cols <- svc.cols + out$n.neighbors <- n.neighbors + out$q <- q + out$n.post <- n.post.samples + out$n.thin <- n.thin + out$n.burn <- n.burn + out$n.chains <- n.chains + out$dist <- family + out$re.cols <- re.cols + if (p.re > 0) { + out$muRE <- TRUE + } else { + out$muRE <- FALSE + } + class(out) <- "svcMsAbund" + } + + out$run.time <- proc.time() - ptm + return(out) +} diff --git a/man/DS.Rd b/man/DS.Rd index b65bcc6..70fc52c 100644 --- a/man/DS.Rd +++ b/man/DS.Rd @@ -7,7 +7,7 @@ DS(abund.formula, det.formula, data, inits, priors, tuning, n.batch, batch.length, accept.rate = 0.43, family = 'Poisson', transect = 'line', det.func = 'halfnormal', n.omp.threads = 1, verbose = TRUE, - n.report = 100, n.burn = round(.10 * n.batch * batch.length), n.thin = 1, + n.report = 100, n.burn = round(.10 * n.batch * batch.length), n.thin = 1, n.chains = 1, ...) } @@ -28,70 +28,71 @@ DS(abund.formula, det.formula, data, inits, priors, tuning, \item{data}{a list containing data necessary for model fitting. Valid tags are \code{y}, \code{covs}, \code{dist.breaks}, and \code{offset}. \code{y} - is a matrix or data frame of the observed count values, - with first dimension equal to the number of - sites (\eqn{J}{J}) and second dimension equal to the number of + is a matrix or data frame of the observed count values, + with first dimension equal to the number of + sites (\eqn{J}{J}) and second dimension equal to the number of distance bins. \code{covs} is a matrix or data frame containing the variables used in the the abundance and/or the detection portion of the model, with - \eqn{J}{J} rows for each column (variable). \code{dist.breaks} is a vector of + \eqn{J}{J} rows for each column (variable). \code{dist.breaks} is a vector of distances that denote the breakpoints of the distance bands. \code{dist.breaks} should - have length equal to the number of columns in \code{y} plus one. \code{offset} is an - offset that can be used to scale estimates from abundance per transect to density per + have length equal to the number of columns in \code{y} plus one. \code{offset} is an + offset that can be used to scale estimates from abundance per transect to density per some desired unit of measure. This can be either a single value or a vector with an offset value for each site (e.g., if transects differ in length)} \item{inits}{a list with each tag corresponding to a parameter name. - Valid tags are \code{N}, \code{beta}, \code{alpha}, \code{kappa}, - \code{sigma.sq.mu}, and \code{sigma.sq.p}. The value portion of each tag is the - parameter's initial value. \code{sigma.sq.mu} and \code{sigma.sq.p} are - only relevant when including random effects in the abundance and - detection portion of the distance sampling model, respectively. \code{kappa} is - only relevant when \code{family = 'NB'}. See \code{priors} + Valid tags are \code{N}, \code{beta}, \code{alpha}, \code{kappa}, + \code{sigma.sq.mu}, and \code{sigma.sq.p}. The value portion of each tag is the + parameter's initial value. \code{sigma.sq.mu} and \code{sigma.sq.p} are + only relevant when including random effects in the abundance and + detection portion of the distance sampling model, respectively. \code{kappa} is + only relevant when \code{family = 'NB'}. See \code{priors} description for definition of each parameter name. - Additionally, the tag \code{fix} can be set to \code{TRUE} + Additionally, the tag \code{fix} can be set to \code{TRUE} to fix the starting values across all chains. If \code{fix} is not specified (the default), starting values are varied randomly across chains.} -\item{priors}{a list with each tag corresponding to a parameter name. - Valid tags are \code{beta.normal}, \code{alpha.normal}, \code{kappa.unif}, - \code{sigma.sq.mu.ig}, and \code{sigma.sq.p.ig}. - Abundance (\code{beta}) and detection (\code{alpha}) - regression coefficients are assumed to follow a normal distribution. - The hyperparameters of the normal distribution are passed as a list of - length two with the first and second elements corresponding to the mean - and variance of the normal distribution, which are each specified as vectors of +\item{priors}{a list with each tag corresponding to a parameter name. + Valid tags are \code{beta.normal}, \code{alpha.normal}, \code{kappa.unif}, + \code{sigma.sq.mu.ig}, and \code{sigma.sq.p.ig}. + Abundance (\code{beta}) and detection (\code{alpha}) + regression coefficients are assumed to follow a normal distribution. + The hyperparameters of the normal distribution are passed as a list of + length two with the first and second elements corresponding to the mean + and variance of the normal distribution, which are each specified as vectors of length equal to the number of coefficients to be estimated or of length one - if priors are the same for all coefficients. If not specified, prior means - are set to 0 and prior variances set to 100. \code{kappa} is the negative binomial - dispersion parameter and is assumed to follow a uniform distribution. The + if priors are the same for all coefficients. If not specified, prior means + are set to 0 and prior variances set to 100. \code{kappa} is the negative binomial + dispersion parameter and is assumed to follow a uniform distribution. The hyperparameters of the uniform distribution are passed as a vector of length two with the first and second elements corresponding to the lower and upper - bounds of the uniform distribution. \code{sigma.sq.mu} and - \code{sigma.sq.p} are the random effect variances for any abundance or + bounds of the uniform distribution. \code{sigma.sq.mu} and + \code{sigma.sq.p} are the random effect variances for any abundance or detection random effects, respectively, and are assumed to follow an inverse Gamma distribution. The hyperparameters of the inverse-Gamma distribution are passed as a list of length two with first and second elements corresponding to the shape and scale parameters, respectively, which are each specified as - vectors of length equal to the number of random intercepts/slopes or of length one + vectors of length equal to the number of random intercepts/slopes or of length one if priors are the same for all random effect variances.} -\item{tuning}{a single numeric value representing the initial variance of the - adaptive sampler for \code{beta}, \code{alpha}, \code{beta.star} (the abundance - random effect values), \code{alpha.star} (the detection random effect values), and +\item{tuning}{a list with each tag corresponding to a parameter name, whose value + defines the initial tuning variance of the adaptive sampler. Valid tags include + \code{beta}, \code{alpha}, \code{beta.star} (the abundance + random effect values), \code{alpha.star} (the detection random effect values), and \code{kappa}. See Roberts and Rosenthal (2009) for details.} -\item{n.batch}{the number of MCMC batches in each chain to run for the adaptive MCMC +\item{n.batch}{the number of MCMC batches in each chain to run for the adaptive MCMC sampler. See Roberts and Rosenthal (2009) for details.} -\item{batch.length}{the number of MCMC samples in each batch in each chain to run for the Adaptive +\item{batch.length}{the number of MCMC samples in each batch in each chain to run for the Adaptive MCMC sampler. See Roberts and Rosenthal (2009) for details.} -\item{accept.rate}{target acceptance rate for Adaptive MCMC. Default is +\item{accept.rate}{target acceptance rate for Adaptive MCMC. Default is 0.43. See Roberts and Rosenthal (2009) for details.} -\item{family}{the distribution to use for the latent abundance process. Currently - supports \code{'NB'} (negative binomial) and \code{'Poisson'}.} +\item{family}{the distribution to use for the latent abundance process. Currently + supports \code{'NB'} (negative binomial) and \code{'Poisson'}.} \item{transect}{the type of transect. Currently supports line transects (\code{'line'}) or circular transects (i.e., point counts; \code{'point'}).} @@ -102,23 +103,23 @@ DS(abund.formula, det.formula, data, inits, priors, tuning, (\code{'negexp'}).} \item{n.omp.threads}{a positive integer indicating the number of threads - to use for SMP parallel processing. The package must be compiled for - OpenMP support. For most Intel-based machines, we recommend setting - \code{n.omp.threads} up to the number of hypterthreaded cores. Note, - \code{n.omp.threads} > 1 might not work on some systems. Currently only + to use for SMP parallel processing. The package must be compiled for + OpenMP support. For most Intel-based machines, we recommend setting + \code{n.omp.threads} up to the number of hypterthreaded cores. Note, + \code{n.omp.threads} > 1 might not work on some systems. Currently only relevant for spatial models.} -\item{verbose}{if \code{TRUE}, messages about data preparation, - model specification, and progress of the sampler are printed to the screen. +\item{verbose}{if \code{TRUE}, messages about data preparation, + model specification, and progress of the sampler are printed to the screen. Otherwise, no messages are printed.} \item{n.report}{the interval to report MCMC progress.} -\item{n.burn}{the number of samples out of the total \code{n.samples} to +\item{n.burn}{the number of samples out of the total \code{n.samples} to discard as burn-in for each chain. By default, the first 10\% of samples is discarded.} \item{n.thin}{the thinning interval for collection of MCMC samples. The - thinning occurs after the \code{n.burn} samples are discarded. Default + thinning occurs after the \code{n.burn} samples are discarded. Default value is set to 1.} \item{n.chains}{the number of chains to run in sequence.} @@ -132,7 +133,7 @@ DS(abund.formula, det.formula, data, inits, priors, tuning, Fitting Linear Mixed-Effects Models Using lme4. Journal of Statistical Software, 67(1), 1-48. \doi{10.18637/jss.v067.i01}. - Royle, J. A., Dawson, D. K., & Bates, S. (2004). Modeling + Royle, J. A., Dawson, D. K., & Bates, S. (2004). Modeling abundance effects in distance sampling. Ecology, 85(6), 1591-1597. } @@ -141,47 +142,47 @@ DS(abund.formula, det.formula, data, inits, priors, tuning, } \value{ - An object of class \code{DS} that is a list comprised of: + An object of class \code{DS} that is a list comprised of: \item{beta.samples}{a \code{coda} object of posterior samples for the abundance regression coefficients.} \item{alpha.samples}{a \code{coda} object of posterior samples for the detection regression coefficients.} - + \item{kappa.samples}{a \code{coda} object of posterior samples for the abundance dispersion parameter. Only included when \code{family = 'NB'}.} - \item{N.samples}{a \code{coda} object of posterior samples + \item{N.samples}{a \code{coda} object of posterior samples for the latent abundance values. Note that these values always - represent transect-level abundance, even when an offset is + represent transect-level abundance, even when an offset is supplied.} \item{mu.samples}{a \code{coda} object of posterior samples - for the latent expected abundance values. When an offset is - supplied in the \code{data} object, these correspond to expected + for the latent expected abundance values. When an offset is + supplied in the \code{data} object, these correspond to expected abundance per unit area (i.e., density).} \item{sigma.sq.mu.samples}{a \code{coda} object of posterior samples for variances of random effects included in the abundance portion - of the model. Only included if random effects are specified in + of the model. Only included if random effects are specified in \code{abund.formula}.} \item{sigma.sq.p.samples}{a \code{coda} object of posterior samples - for variances of random effects included in the detection portion - of the model. Only included if random effects are specified in + for variances of random effects included in the detection portion + of the model. Only included if random effects are specified in \code{det.formula}.} \item{beta.star.samples}{a \code{coda} object of posterior samples - for the abundance random effects. Only included if random effects + for the abundance random effects. Only included if random effects are specified in \code{abund.formula}.} \item{alpha.star.samples}{a \code{coda} object of posterior samples - for the detection random effects. Only included if random effects + for the detection random effects. Only included if random effects are specified in \code{det.formula}.} - \item{y.rep.samples}{a three-dimensional array of fitted values. + \item{y.rep.samples}{a three-dimensional array of fitted values. Array dimensions correspond to MCMC samples, sites, and distance band.} \item{pi.samples}{a three-dimensional array of cell-specific detection @@ -194,16 +195,16 @@ DS(abund.formula, det.formula, data, inits, priors, tuning, \item{run.time}{execution time reported using \code{proc.time()}.} - The return object will include additional objects used for - subsequent prediction and/or model fit evaluation. + The return object will include additional objects used for + subsequent prediction and/or model fit evaluation. } \examples{ set.seed(123) J.x <- 10 -J.y <- 10 +J.y <- 10 J <- J.x * J.y -# Number of distance bins from which to simulate data. +# Number of distance bins from which to simulate data. n.bins <- 5 # Length of each bin. This should be of length n.bins bin.width <- c(.10, .10, .20, .3, .1) @@ -217,16 +218,16 @@ p.det <- length(alpha) det.func <- 'halfnormal' mu.RE <- list() p.RE <- list() -sp <- FALSE +sp <- FALSE family <- 'NB' kappa <- 0.1 offset <- 1.8 transect <- 'point' dat <- simDS(J.x = J.x, J.y = J.y, n.bins = n.bins, bin.width = bin.width, - beta = beta, alpha = alpha, det.func = det.func, kappa = kappa, + beta = beta, alpha = alpha, det.func = det.func, kappa = kappa, mu.RE = mu.RE, p.RE = p.RE, sp = sp, - sigma.sq = sigma.sq, phi = phi, nu = nu, family = family, + sigma.sq = sigma.sq, phi = phi, nu = nu, family = family, offset = offset, transect = transect) y <- dat$y @@ -237,44 +238,44 @@ X.p.re <- dat$X.p.re dist.breaks <- dat$dist.breaks covs <- cbind(X, X.p) -colnames(covs) <- c('int.abund', 'abund.cov.1', 'abund.cov.2', 'abund.cov.3', +colnames(covs) <- c('int.abund', 'abund.cov.1', 'abund.cov.2', 'abund.cov.3', 'int.det', 'det.cov.1') -data.list <- list(y = y, +data.list <- list(y = y, covs = covs, - dist.breaks = dist.breaks, + dist.breaks = dist.breaks, offset = offset) # Priors prior.list <- list(beta.normal = list(mean = 0, var = 10), alpha.normal = list(mean = 0, - var = 10), - kappa.unif = c(0, 100)) + var = 10), + kappa.unif = c(0, 100)) # Starting values inits.list <- list(alpha = 0, beta = 0, kappa = 1) # Tuning values -tuning <- list(beta = 0.1, alpha = 0.1, beta.star = 0.3, alpha.star = 0.1, - kappa = 0.2) +tuning <- list(beta = 0.1, alpha = 0.1, beta.star = 0.3, alpha.star = 0.1, + kappa = 0.2) out <- DS(abund.formula = ~ abund.cov.1 + abund.cov.2 + abund.cov.3, det.formula = ~ det.cov.1, - data = data.list, - n.batch = 10, - batch.length = 25, - inits = inits.list, + data = data.list, + n.batch = 10, + batch.length = 25, + inits = inits.list, family = 'NB', - det.func = 'halfnormal', - transect = 'point', + det.func = 'halfnormal', + transect = 'point', tuning = tuning, - priors = prior.list, - accept.rate = 0.43, - n.omp.threads = 1, - verbose = TRUE, + priors = prior.list, + accept.rate = 0.43, + n.omp.threads = 1, + verbose = TRUE, n.report = 100, n.burn = 100, n.thin = 1, - n.chains = 1) + n.chains = 1) summary(out) } diff --git a/man/predict.svcAbund.Rd b/man/predict.svcAbund.Rd index 3798c81..3721e9e 100644 --- a/man/predict.svcAbund.Rd +++ b/man/predict.svcAbund.Rd @@ -3,13 +3,13 @@ \title{Function for prediction at new locations for univariate Gaussian spatially-varying coefficient models} \description{ - The function \code{predict} collects posterior predictive samples for a set of new locations given an object of class `svcAbund`. + The function \code{predict} collects posterior predictive samples for a set of new locations given an object of class `svcAbund`. } \usage{ -\method{predict}{svcAbund}(object, X.0, coords.0, n.omp.threads = 1, - verbose = TRUE, n.report = 100, ignore.RE = FALSE, - z.0.samples, ...) +\method{predict}{svcAbund}(object, X.0, coords.0, n.omp.threads = 1, + verbose = TRUE, n.report = 100, ignore.RE = FALSE, + z.0.samples, include.sp = TRUE, ...) } \arguments{ @@ -18,30 +18,32 @@ \item{X.0}{the design matrix of covariates at the prediction locations. This should include a column of 1s for the intercept if an intercept is included in the model. If random effects are included in the model, the levels of the random effects at the new locations should be included as a column in the design matrix. The ordering of the levels should match the ordering used to fit the data in \code{svcAbund}. Columns should correspond to the order of how covariates were specified in the corresponding formula argument of \code{svcAbund}. Column names of all variables must match the names of variables used when fitting the model (for the intercept, use \code{'(Intercept)'}).} - \item{coords.0}{the spatial coordinates corresponding to \code{X.0}. Note that \code{spAbundance} assumes coordinates are specified + \item{coords.0}{the spatial coordinates corresponding to \code{X.0}. Note that \code{spAbundance} assumes coordinates are specified in a projected coordinate system.} \item{n.omp.threads}{a positive integer indicating the number of threads to use for SMP parallel processing. The package must be compiled for OpenMP support. For most Intel-based machines, we recommend setting - \code{n.omp.threads} up to the number of hyperthreaded cores. + \code{n.omp.threads} up to the number of hyperthreaded cores. Note, \code{n.omp.threads} > 1 might not work on some systems.} - \item{verbose}{if \code{TRUE}, model specification and progress of the + \item{verbose}{if \code{TRUE}, model specification and progress of the sampler is printed to the screen. Otherwise, nothing is printed to the screen.} - + \item{n.report}{the interval to report sampling progress.} \item{ignore.RE}{logical value that specifies whether or not to remove unstructured random effects from the subsequent predictions. If \code{TRUE}, random effects will be included. If \code{FALSE}, random effects will be set to 0 and predictions will only be generated from the fixed effects.} \item{z.0.samples}{a matrix with rows corresponding to MCMC samples and columns corresponding to prediction locations containing the full posterior samples of the predicted binary portion of a zero-inflated Gaussian model. In the context of abundance models, this typically corresponds to estimates of the presence or absence of the species at the location. When using \code{spOccupancy} to generate the first stage samples of the zero-inflated Gaussian model, this is the object contained in the \code{z.0.samples} object of the predition function for th spOccupancy object. Ignored for all model types other than zero-inflated Gaussian.} + \item{include.sp}{a logical value used to indicate whether spatial random effects should be included in the predictions. By default, this is set to \code{TRUE}. If set to \code{FALSE}, predictions are given using the covariates and any unstructured random effects in the model. If \code{FALSE}, the \code{coords.0} argument is not required.} + \item{...}{currently no additional arguments} } \note{ - When \code{ignore.RE = FALSE}, both sampled levels and non-sampled levels of random effects are supported for prediction. For sampled levels, the posterior distribution for the random intercept corresponding to that level of the random effect will be used in the prediction. For non-sampled levels, random values are drawn from a normal distribution using the posterior samples of the random effect variance, which results in fully propagated uncertainty in predictions with models that incorporate random effects. + When \code{ignore.RE = FALSE}, both sampled levels and non-sampled levels of random effects are supported for prediction. For sampled levels, the posterior distribution for the random intercept corresponding to that level of the random effect will be used in the prediction. For non-sampled levels, random values are drawn from a normal distribution using the posterior samples of the random effect variance, which results in fully propagated uncertainty in predictions with models that incorporate random effects. } \author{ @@ -50,7 +52,7 @@ } \value{ - A list object of class \code{predict.svcAbund}. When \code{type = 'abundance'}, the list consists of: + A list object of class \code{predict.svcAbund}. When \code{type = 'abundance'}, the list consists of: \item{mu.0.samples}{a \code{coda} object of posterior predictive samples for the expected abundance values.} @@ -59,17 +61,17 @@ abundance values.} \item{w.0.samples}{a three-dimensional array of posterior predictive samples - for the spatially-varying coefficients, with dimensions corresponding to MCMC iteration, + for the spatially-varying coefficients, with dimensions corresponding to MCMC iteration, coefficient, and site.} - The return object will include additional objects used for standard - extractor functions. + The return object will include additional objects used for standard + extractor functions. } \examples{ set.seed(1000) # Sites -J.x <- 10 +J.x <- 10 J.y <- 10 J <- J.x * J.y # Occurrence -------------------------- diff --git a/man/sfMsAbund.Rd b/man/sfMsAbund.Rd index 08db9f4..46c6689 100644 --- a/man/sfMsAbund.Rd +++ b/man/sfMsAbund.Rd @@ -3,15 +3,15 @@ \title{Function for Fitting Spatial Factor Multivariate Abundance GLMMs} \description{ - The function \code{sfMsAbund} fits multivariate spatial abundance GLMMs with species correlations (i.e., a spatially-explicit abundace-based joint species distribution model). We use a spatial factor modeling approach. Currently, models are implemented using a Nearest Neighbor Gaussian Process. Future development may allow for running the models using full Gaussian Processes. + The function \code{sfMsAbund} fits multivariate spatial abundance GLMMs with species correlations (i.e., a spatially-explicit abundace-based joint species distribution model). We use a spatial factor modeling approach. Currently, models are implemented using a Nearest Neighbor Gaussian Process. Future development may allow for running the models using full Gaussian Processes. } \usage{ -sfMsAbund(formula, data, inits, priors, - tuning, cov.model = 'exponential', NNGP = TRUE, +sfMsAbund(formula, data, inits, priors, + tuning, cov.model = 'exponential', NNGP = TRUE, n.neighbors = 15, search.type = 'cb', n.factors, n.batch, batch.length, accept.rate = 0.43, family = 'Poisson', - n.omp.threads = 1, verbose = TRUE, n.report = 100, + n.omp.threads = 1, verbose = TRUE, n.report = 100, n.burn = round(.10 * n.batch * batch.length), n.thin = 1, n.chains = 1, save.fitted = TRUE, ...) } @@ -24,95 +24,96 @@ sfMsAbund(formula, data, inits, priors, and slopes are allowed using lme4 syntax (Bates et al. 2015).} \item{data}{a list containing data necessary for model fitting. - Valid tags are \code{y}, \code{covs}, \code{z}, \code{coords}, and \code{offset}. + Valid tags are \code{y}, \code{covs}, \code{z}, \code{coords}, and \code{offset}. \code{y} is a two or three-dimensional array of observed count data. The - first dimension of the array is equal to the + first dimension of the array is equal to the number of species and the second dimension is equal to the number of sites. If - specified as a three-dimensional array, the third dimension corresponds to - replicate observations at each site (e.g., sub-samples, repeated sampling - over multiple seasons). \code{covs} is a list - containing the variables used in the model. If a data frame, each row - of \code{covs} is a site and each column is a variable. + specified as a three-dimensional array, the third dimension corresponds to + replicate observations at each site (e.g., sub-samples, repeated sampling + over multiple seasons). \code{covs} is a list + containing the variables used in the model. If a data frame, each row + of \code{covs} is a site and each column is a variable. If a list, each list element is a different covariate, which can be site-level or observation-level. Site-level covariates are specified as a vector of length \eqn{J}{J}, while observation-level covariates are specified as a matrix or data frame with the number of rows equal to \eqn{J}{J} - and number of columns equal to the maximum number of replicate observations at a - given site. \code{coords} is a - \eqn{J \times 2}{J x 2} matrix of the observation coordinates. Note that - \code{spAbundance} assumes coordinates are specified in a projected coordinate system. - For zero-inflated Gaussian models, the tag \code{z} is used to specify the - binary component of the model and should have the same dimensions as \code{y}. - \code{offset} is an offset to use in the abundance model (e.g., an area offset). - This can be either a single value, a vector with an offset for each site (e.g., if survey - area differed in size), or a site x replicate matrix if more than one count is available + and number of columns equal to the maximum number of replicate observations at a + given site. \code{coords} is a + \eqn{J \times 2}{J x 2} matrix of the observation coordinates. Note that + \code{spAbundance} assumes coordinates are specified in a projected coordinate system. + For zero-inflated Gaussian models, the tag \code{z} is used to specify the + binary component of the model and should have the same dimensions as \code{y}. + \code{offset} is an offset to use in the abundance model (e.g., an area offset). + This can be either a single value, a vector with an offset for each site (e.g., if survey + area differed in size), or a site x replicate matrix if more than one count is available at a given site.} \item{inits}{a list with each tag corresponding to a parameter name. - Valid tags are \code{beta.comm}, \code{beta}, + Valid tags are \code{beta.comm}, \code{beta}, \code{tau.sq.beta}, \code{sigma.sq.mu}, \code{kappa}, - \code{phi}, \code{lambda}, \code{nu}, and \code{tau.sq}. \code{nu} is only specified if - \code{cov.model = "matern"}, \code{kappa} is only specified if \code{family = 'NB'}, + \code{phi}, \code{lambda}, \code{nu}, and \code{tau.sq}. \code{nu} is only specified if + \code{cov.model = "matern"}, \code{kappa} is only specified if \code{family = 'NB'}, \code{tau.sq} is only specified for Gaussian and zero-inflated Gaussian models, - and \code{sigma.sq.mu} is only specified if random effects are included in \code{formula}. - The value portion of each tag is + and \code{sigma.sq.mu} is only specified if random effects are included in \code{formula}. + The value portion of each tag is the parameter's initial value. See \code{priors} description for definition - of each parameter name. Additionally, the tag \code{fix} can be set to \code{TRUE} + of each parameter name. Additionally, the tag \code{fix} can be set to \code{TRUE} to fix the starting values across all chains. If \code{fix} is not specified (the default), starting values are varied randomly across chains.} - \item{priors}{a list with each tag corresponding to a parameter name. - Valid tags are \code{beta.comm.normal}, \code{tau.sq.beta.ig}, \code{sigma.sq.mu}, - \code{kappa.unif}, \code{phi.unif}, \code{nu.unif}, and \code{tau.sq.ig}. - Community-level (\code{beta.comm}) regression coefficients are assumed to follow a + \item{priors}{a list with each tag corresponding to a parameter name. + Valid tags are \code{beta.comm.normal}, \code{tau.sq.beta.ig}, \code{sigma.sq.mu}, + \code{kappa.unif}, \code{phi.unif}, \code{nu.unif}, and \code{tau.sq.ig}. + Community-level (\code{beta.comm}) regression coefficients are assumed to follow a normal distribution. The hyperparameters of the normal distribution - are passed as a list of length two with the first and second elements - corresponding to the mean and variance of the normal distribution, - which are each specified as vectors of length equal to the number of - coefficients to be estimated or of length one if priors are the same for - all coefficients. If not specified, prior means are set - to 0 and prior variances to 100. Community-level variance parameters - (\code{tau.sq.beta}) are - assumed to follow an inverse Gamma distribution. The hyperparameters of - the inverse gamma distribution are passed as a list of length two with + are passed as a list of length two with the first and second elements + corresponding to the mean and variance of the normal distribution, + which are each specified as vectors of length equal to the number of + coefficients to be estimated or of length one if priors are the same for + all coefficients. If not specified, prior means are set + to 0 and prior variances to 100. Community-level variance parameters + (\code{tau.sq.beta}) are + assumed to follow an inverse Gamma distribution. The hyperparameters of + the inverse gamma distribution are passed as a list of length two with the first and second elements corresponding to the shape and scale parameters, - which are each specified as vectors of length equal to the number of - coefficients to be estimated or a single value if priors are the same for all - parameters. If not specified, prior shape and scale + which are each specified as vectors of length equal to the number of + coefficients to be estimated or a single value if priors are the same for all + parameters. If not specified, prior shape and scale parameters are set to 0.1. The spatial factor model fits \code{n.factors} independent - spatial processes. The spatial decay \code{phi} and smoothness \code{nu} parameters - for each latent factor are assumed to follow Uniform distributions. - The hyperparameters of the Uniform are passed as a list with two elements, - with both elements being vectors of length \code{n.factors} corresponding to the lower and + spatial processes. The spatial decay \code{phi} and smoothness \code{nu} parameters + for each latent factor are assumed to follow Uniform distributions. + The hyperparameters of the Uniform are passed as a list with two elements, + with both elements being vectors of length \code{n.factors} corresponding to the lower and upper support, respectively, or as a single value if the same value is assigned for all factors. The priors for the factor loadings matrix \code{lambda} are fixed - following the standard spatial factor model to ensure parameter + following the standard spatial factor model to ensure parameter identifiability (Christensen and Amemlya 2002). The - upper triangular elements of the \code{n.sp x n.factors} matrix are fixed at 0 and the - diagonal elements are fixed at 1. The lower triangular elements are assigned a + upper triangular elements of the \code{n.sp x n.factors} matrix are fixed at 0 and the + diagonal elements are fixed at 1. The lower triangular elements are assigned a standard normal prior (i.e., mean 0 and variance 1). - \code{sigma.sq.mu} are the random + \code{sigma.sq.mu} are the random effect variances random effects, respectively, and are assumed to follow an inverse Gamma distribution. The hyperparameters of the inverse-Gamma distribution are passed as a list of length two with first and second elements corresponding to the shape and scale parameters, respectively, which are each specified as - vectors of length equal to the number of random intercepts or of length one - if priors are the same for all random effect variances. \code{kappa} is the - negative binomial dispersion parameter for each species and is assumed to + vectors of length equal to the number of random intercepts or of length one + if priors are the same for all random effect variances. \code{kappa} is the + negative binomial dispersion parameter for each species and is assumed to follow a uniform distribution. The hyperparameters of the uniform distribution are passed as a list of length two with first and second elements corresponding to the - lower and upper bounds of the uniform distribution, respectively, which are each + lower and upper bounds of the uniform distribution, respectively, which are each specified as vectors of length equal to the number of species or of length one - if priors are the same for all species-specific dispersion parameters. \code{tau.sq} is the - species-specific residual variance for Gaussian (or zero-inflated Gaussian) models, and it is assigned - an inverse-Gamma prior. The hyperparameters of the inverse-Gamma are passed as a list - of length two, with the first and second element corresponding to the shape and + if priors are the same for all species-specific dispersion parameters. \code{tau.sq} is the + species-specific residual variance for Gaussian (or zero-inflated Gaussian) models, and it is assigned + an inverse-Gamma prior. The hyperparameters of the inverse-Gamma are passed as a list + of length two, with the first and second element corresponding to the shape and scale parameters, respectively, which are each specified as vectors of length equal to the number of species or a single value if priors are the same for all species.} -\item{tuning}{a single numeric value representing the initial variance of the - adaptive sampler for \code{beta}, \code{alpha}, \code{beta.star} (the abundance - random effect values), \code{kappa}, \code{phi}, \code{lambda}. +\item{tuning}{a list with each tag corresponding to a parameter name, whose value + defines the initial tuning variance of the adaptive sampler for the given parameter. + Valid tags include \code{beta}, \code{alpha}, \code{beta.star} (the abundance + random effect values), \code{kappa}, \code{phi}, \code{lambda}. See Roberts and Rosenthal (2009) for details. Note that only \code{phi} and \code{nu} are tuned for Gaussian or zero-inflated Gaussian models.} @@ -121,70 +122,70 @@ sfMsAbund(formula, data, inits, priors, observations. Supported covariance model key words are: \code{"exponential"}, \code{"matern"}, \code{"spherical"}, and \code{"gaussian"}.} - - \item{NNGP}{if \code{TRUE}, model is fit with an NNGP. If \code{FALSE}, - a full Gaussian process is used. See Datta et al. (2016) and - Finley et al. (2019) for more information. For spatial factor models, only + + \item{NNGP}{if \code{TRUE}, model is fit with an NNGP. If \code{FALSE}, + a full Gaussian process is used. See Datta et al. (2016) and + Finley et al. (2019) for more information. For spatial factor models, only \code{NNGP = TRUE} is currently supported.} - - \item{n.neighbors}{number of neighbors used in the NNGP. Only used if - \code{NNGP = TRUE}. Datta et al. (2016) showed that 15 neighbors is usually + + \item{n.neighbors}{number of neighbors used in the NNGP. Only used if + \code{NNGP = TRUE}. Datta et al. (2016) showed that 15 neighbors is usually sufficient, but that as few as 5 neighbors can be adequate for certain data sets, which can lead to even greater decreases in run time. We recommend starting with 15 neighbors (the default) and if additional gains in computation time are desired, subsequently compare the results with a smaller number of neighbors using WAIC.} - + \item{search.type}{a quoted keyword that specifies the type of nearest neighbor search algorithm. Supported method key words are: \code{"cb"} and \code{"brute"}. The \code{"cb"} should generally be much faster. If locations do not have identical coordinate values on - the axis used for the nearest neighbor ordering then \code{"cb"} - and \code{"brute"} should produce identical neighbor sets. - However, if there are identical coordinate values on the axis used - for nearest neighbor ordering, then \code{"cb"} and \code{"brute"} - might produce different, but equally valid, neighbor sets, + the axis used for the nearest neighbor ordering then \code{"cb"} + and \code{"brute"} should produce identical neighbor sets. + However, if there are identical coordinate values on the axis used + for nearest neighbor ordering, then \code{"cb"} and \code{"brute"} + might produce different, but equally valid, neighbor sets, e.g., if data are on a grid. } - \item{n.factors}{the number of factors to use in the spatial factor model approach. - Typically, the number of factors is set to be small (e.g., 4-5) relative to the - total number of species in the community, which will lead to substantial - decreases in computation time. However, the value can be anywhere + \item{n.factors}{the number of factors to use in the spatial factor model approach. + Typically, the number of factors is set to be small (e.g., 4-5) relative to the + total number of species in the community, which will lead to substantial + decreases in computation time. However, the value can be anywhere between 1 and the number of species in the modeled community.} - \item{n.batch}{the number of MCMC batches in each chain to run for the adaptive MCMC + \item{n.batch}{the number of MCMC batches in each chain to run for the adaptive MCMC sampler. See Roberts and Rosenthal (2009) for details.} - - \item{batch.length}{the length of each MCMC batch to run for the adaptive + + \item{batch.length}{the length of each MCMC batch to run for the adaptive MCMC sampler. See Roberts and Rosenthal (2009) for details.} - - \item{accept.rate}{target acceptance rate for adaptive MCMC. Defaul is + + \item{accept.rate}{target acceptance rate for adaptive MCMC. Defaul is 0.43. See Roberts and Rosenthal (2009) for details.} - \item{family}{the distribution to use for the abundance. Currently - supports \code{'NB'} (negative binomial), \code{'Poisson'} (Poisson), \code{'Gaussian'} (Gaussian), + \item{family}{the distribution to use for the abundance. Currently + supports \code{'NB'} (negative binomial), \code{'Poisson'} (Poisson), \code{'Gaussian'} (Gaussian), and \code{'zi-Gaussian'} (zero-inflated Gaussian).} - + \item{n.omp.threads}{a positive integer indicating the number of threads to use for SMP parallel processing. The package must be compiled for OpenMP support. For most Intel-based machines, we recommend setting \code{n.omp.threads} up to the number of hyperthreaded cores. Note, \code{n.omp.threads} > 1 might not work on some systems.} - - \item{verbose}{if \code{TRUE}, messages about data preparation, - model specification, and progress of the sampler are printed to the screen. + + \item{verbose}{if \code{TRUE}, messages about data preparation, + model specification, and progress of the sampler are printed to the screen. Otherwise, no messages are printed.} - + \item{n.report}{the interval to report Metropolis sampler acceptance and MCMC progress. Note this is specified in terms of batches and not overall samples for spatial models.} - \item{n.burn}{the number of samples out of the total \code{n.samples} to + \item{n.burn}{the number of samples out of the total \code{n.samples} to discard as burn-in for each chain. By default, the first 10\% of samples is discarded.} - + \item{n.thin}{the thinning interval for collection of MCMC samples. The - thinning occurs after the \code{n.burn} samples are discarded. Default + thinning occurs after the \code{n.burn} samples are discarded. Default value is set to 1.} \item{n.chains}{the number of chains to run in sequence.} @@ -194,8 +195,8 @@ sfMsAbund(formula, data, inits, priors, \code{y.rep.samples}, \code{mu.samples}, and \code{like.samples} will not be included in the model object, and subsequent functions for calculating WAIC, fitted values, and posterior predictive checks will not work, although they all can be calculated manually if - desired. Setting \code{save.fitted = FALSE} can be useful when working with very large - data sets to minimize the amount of RAM needed when fitting and storing the model object in + desired. Setting \code{save.fitted = FALSE} can be useful when working with very large + data sets to minimize the amount of RAM needed when fitting and storing the model object in memory.} \item{...}{currently no additional arguments} @@ -219,8 +220,8 @@ sfMsAbund(formula, data, inits, priors, Fitting Linear Mixed-Effects Models Using lme4. Journal of Statistical Software, 67(1), 1-48. \doi{10.18637/jss.v067.i01}. - Christensen, W. F., and Amemiya, Y. (2002). Latent variable analysis - of multivariate spatial data. \emph{Journal of the American Statistical Association}, + Christensen, W. F., and Amemiya, Y. (2002). Latent variable analysis + of multivariate spatial data. \emph{Journal of the American Statistical Association}, 97(457), 302-317. } @@ -231,11 +232,11 @@ sfMsAbund(formula, data, inits, priors, } \value{ - An object of class \code{sfMsAbund} that is a list comprised of: + An object of class \code{sfMsAbund} that is a list comprised of: \item{beta.comm.samples}{a \code{coda} object of posterior samples for the community level regression coefficients.} - + \item{tau.sq.beta.samples}{a \code{coda} object of posterior samples for the abundance community variance parameters.} @@ -264,21 +265,21 @@ sfMsAbund(formula, data, inits, priors, the expected abundance values for each species with dimensions corresponding to MCMC samples, species, site, and replicate.} - \item{w.samples}{a three-dimensional array of posterior samples for + \item{w.samples}{a three-dimensional array of posterior samples for the latent effects for each latent factor. Array dimensions correspond to MCMC sample, latent factor, then site.} \item{sigma.sq.mu.samples}{a \code{coda} object of posterior samples for variances of random effects included in the abundance portion - of the model. Only included if random effects are specified in + of the model. Only included if random effects are specified in \code{abund.formula}.} \item{beta.star.samples}{a \code{coda} object of posterior samples - for the abundance random effects. Only included if random effects + for the abundance random effects. Only included if random effects are specified in \code{abund.formula}.} \item{like.samples}{a three-dimensional array of posterior samples - for the likelihood value associated with each site and species. + for the likelihood value associated with each site and species. Used for calculating WAIC.} \item{rhat}{a list of Gelman-Rubin diagnostic values for some of the model @@ -288,8 +289,8 @@ sfMsAbund(formula, data, inits, priors, \item{run.time}{MCMC sampler execution time reported using \code{proc.time()}.} - The return object will include additional objects used for - subsequent prediction and/or model fit evaluation. + The return object will include additional objects used for + subsequent prediction and/or model fit evaluation. } \examples{ @@ -347,7 +348,7 @@ n.burn <- 20 n.thin <- 1 n.chains <- 1 -out <- sfMsAbund(formula = ~ abund.cov.1 + (1 | abund.factor.1) + +out <- sfMsAbund(formula = ~ abund.cov.1 + (1 | abund.factor.1) + (1 | abund.factor.2), data = data.list, n.batch = n.batch, diff --git a/man/simAbund.Rd b/man/simAbund.Rd index 10d12e9..847c46b 100644 --- a/man/simAbund.Rd +++ b/man/simAbund.Rd @@ -7,9 +7,9 @@ } \usage{ -simAbund(J.x, J.y, n.rep, n.rep.max, beta, kappa, tau.sq, mu.RE = list(), - offset = 1, sp = FALSE, svc.cols = 1, cov.model, sigma.sq, phi, nu, - family = 'Poisson', z, x.positive = FALSE, ...) +simAbund(J.x, J.y, n.rep, n.rep.max, beta, kappa, tau.sq, mu.RE = list(), + offset = 1, sp = FALSE, svc.cols = 1, cov.model, sigma.sq, phi, nu, + family = 'Poisson', z, trend = FALSE, x.positive = FALSE, ...) } \arguments{ @@ -44,7 +44,7 @@ simAbund(J.x, J.y, n.rep, n.rep.max, beta, kappa, tau.sq, mu.RE = list(), \item{phi}{a numeric value indicating the spatial decay parameter. Ignored when \code{sp = FALSE}. } -\item{nu}{a numeric value indicating the spatial smoothness parameter. Only used when \code{sp = TRUE} and \code{cov.model = "matern"}.} +\item{nu}{a numeric value indicating the spatial smoothness parameter. Only used when \code{sp = TRUE} and \code{cov.model = "matern"}.} \item{family}{the distribution to use for the data. Currently supports \code{'NB'} (negative binomial), \code{'Poisson'}, \code{'Gaussian'}, and @@ -52,6 +52,8 @@ simAbund(J.x, J.y, n.rep, n.rep.max, beta, kappa, tau.sq, mu.RE = list(), \item{z}{a vector of length \code{J} containing the binary presence/absence portion of a zero-inflated Gaussian model. Only relevant when \code{family = 'zi-Gaussian'}.} +\item{trend}{a logical value indicating whether a trend should be included when simulating relative abundance. If \code{TRUE}, the second covariate will be simulated as a trend over the replicate surveys for a given site. Only relevant when \code{n.rep} is not 1 at every site.} + \item{x.positive}{a logical value indicating whether the simulated covariates should be simulated as random standard normal covariates (\code{x.positive = FALSE}) or restricted to positive values using a uniform distribution with lower bound 0 and upper bound 1 (\code{x.positive = TRUE}).} \item{...}{currently no additional arguments} @@ -62,7 +64,7 @@ simAbund(J.x, J.y, n.rep, n.rep.max, beta, kappa, tau.sq, mu.RE = list(), } \value{ - A list comprised of: + A list comprised of: \item{X}{a three-dimensional numeric design array of covariates with dimensions corresponding to sites, replicates, and number of covariates (including an intercept) for the model.} \item{coords}{a \eqn{J \times 2}{J x 2} numeric matrix of coordinates of each site. Required for spatial models.} @@ -83,8 +85,8 @@ beta <- c(0, -1.5, 0.3, -0.8) p.abund <- length(beta) mu.RE <- list(levels = c(30), sigma.sq.mu = c(1.3)) kappa <- 0.5 -sp <- FALSE +sp <- FALSE family <- 'NB' -dat <- simAbund(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, +dat <- simAbund(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, kappa = kappa, mu.RE = mu.RE, sp = sp, family = 'NB') } diff --git a/man/spAbund.Rd b/man/spAbund.Rd index c50b199..f98f990 100644 --- a/man/spAbund.Rd +++ b/man/spAbund.Rd @@ -3,16 +3,16 @@ \title{Function for Fitting Univariate Spatial Abundance GLMs} \description{ - The function \code{spAbund} fits univariate spatial abundance GLMs. + The function \code{spAbund} fits univariate spatial abundance GLMs. } \usage{ spAbund(formula, data, inits, priors, tuning, - cov.model = 'exponential', NNGP = TRUE, + cov.model = 'exponential', NNGP = TRUE, n.neighbors = 15, search.type = 'cb', n.batch, batch.length, accept.rate = 0.43, family = 'Poisson', - n.omp.threads = 1, verbose = TRUE, n.report = 100, - n.burn = round(.10 * n.batch * batch.length), n.thin = 1, + n.omp.threads = 1, verbose = TRUE, n.report = 100, + n.burn = round(.10 * n.batch * batch.length), n.thin = 1, n.chains = 1, save.fitted = TRUE, ...) } @@ -22,125 +22,126 @@ spAbund(formula, data, inits, priors, tuning, for the model using R's model syntax. Only right-hand side of formula is specified. See example below. Random intercepts and slopes are allowed using lme4 syntax (Bates et al. 2015).} - + \item{data}{a list containing data necessary for model fitting. Valid tags are \code{y}, \code{covs}, \code{z}, \code{coords}, and \code{offset}. \code{y} - is a vector, matrix, or data frame of the observed count values. If a vector, + is a vector, matrix, or data frame of the observed count values. If a vector, the values represent the observed counts at each site. If multiple replicate observations are obtained at the sites (e.g., sub-samples, repeated sampling over - multiple seasons), \code{y} can be specified as a matrix or data frame - with first dimension equal to the number of - sites (\eqn{J}{J}) and second dimension equal to the maximum number of - replicates at a given site. \code{covs} is either a data frame or list - containing the variables used in the model. When only fitting a model with site-level - data, \code{covs} can be specified as a data frame, with each row corresponding to + multiple seasons), \code{y} can be specified as a matrix or data frame + with first dimension equal to the number of + sites (\eqn{J}{J}) and second dimension equal to the maximum number of + replicates at a given site. \code{covs} is either a data frame or list + containing the variables used in the model. When only fitting a model with site-level + data, \code{covs} can be specified as a data frame, with each row corresponding to site and each column corresponding to a variable. When multiple abundance values are available at a site, \code{covs} is specified as a list, where each list element is a different covariate, which can be site-level or observation-level. Site-level covariates are specified as a vector of length \eqn{J}{J}, while observation-level covariates are specified as a matrix or data frame with the number of rows equal to \eqn{J}{J} - and number of columns equal to the maximum number of replicate observations at a - given site. \code{coords} is a \eqn{J \times 2}{J x 2} matrix of the observation coordinates. - Note that \code{spAbundance} assumes coordinates are specified + and number of columns equal to the maximum number of replicate observations at a + given site. \code{coords} is a \eqn{J \times 2}{J x 2} matrix of the observation coordinates. + Note that \code{spAbundance} assumes coordinates are specified in a projected coordinate system. For zero-inflated Gaussian models, the tag \code{z} is used to specify the binary component of the zero-inflated model and should have the same - length as \code{y}. \code{offset} is an offset to use in the abundance model (e.g., an area offset). + length as \code{y}. \code{offset} is an offset to use in the abundance model (e.g., an area offset). This can be either a single value, a vector with an offset for each site (e.g., if survey area differed in size), or a site x replicate matrix if more than one count is available at a given site.} - + \item{inits}{a list with each tag corresponding to a parameter name. - Valid tags are \code{beta}, \code{sigma.sq}, - \code{phi}, \code{w}, \code{nu}, \code{kappa}, \code{sigma.sq.mu}, \code{tau.sq}. + Valid tags are \code{beta}, \code{sigma.sq}, + \code{phi}, \code{w}, \code{nu}, \code{kappa}, \code{sigma.sq.mu}, \code{tau.sq}. \code{nu} is only specified if \code{cov.model = "matern"}, \code{sigma.sq.mu} is only specified if there are random effects in \code{formula}, and - \code{kappa} is only specified when \code{family = 'NB'}. + \code{kappa} is only specified when \code{family = 'NB'}. \code{tau.sq} is only specified when \code{family = 'Gaussian'} or \code{family = 'zi-Gaussian'}. The value portion of each tag is the parameter's initial value. See \code{priors} description for definition of each parameter name. - Additionally, the tag \code{fix} can be set to \code{TRUE} + Additionally, the tag \code{fix} can be set to \code{TRUE} to fix the starting values across all chains. If \code{fix} is not specified (the default), starting values are varied randomly across chains.} - - \item{priors}{a list with each tag corresponding to a parameter name. - Valid tags are \code{beta.normal}, \code{phi.unif}, + + \item{priors}{a list with each tag corresponding to a parameter name. + Valid tags are \code{beta.normal}, \code{phi.unif}, \code{sigma.sq.ig}, \code{nu.unif}, \code{kappa.unif}, - \code{sigma.sq.mu.ig}, \code{tau.sq.ig}. Abundance (\code{beta}) regression coefficients - are assumed to follow a normal distribution. The hyperparameters of the + \code{sigma.sq.mu.ig}, \code{tau.sq.ig}. Abundance (\code{beta}) regression coefficients + are assumed to follow a normal distribution. The hyperparameters of the normal distribution are passed as a list of length two with the first and second elements corresponding to the mean and variance of the normal - distribution, which are each specified as vectors of + distribution, which are each specified as vectors of length equal to the number of coefficients to be estimated or of length one if priors are the same for all coefficients. If not - specified, prior means are set to 0 and prior variances are set to 100. The - spatial variance parameter, \code{sigma.sq}, is assumed to follow an - inverse-Gamma distribution. The spatial decay \code{phi}, spatial + specified, prior means are set to 0 and prior variances are set to 100. The + spatial variance parameter, \code{sigma.sq}, is assumed to follow an + inverse-Gamma distribution. The spatial decay \code{phi}, spatial smoothness \code{nu}, and negative binomial dispersion \code{kappa} - parameters are assumed to follow Uniform - distributions. The hyperparameters of the inverse-Gamma for \code{sigma.sq} - are passed as a vector of length two, with the first and second - elements corresponding to the \emph{shape} and \emph{scale}, respectively. - The hyperparameters of the Uniform are also passed as a vector of - length two with the first and second elements corresponding to + parameters are assumed to follow Uniform + distributions. The hyperparameters of the inverse-Gamma for \code{sigma.sq} + are passed as a vector of length two, with the first and second + elements corresponding to the \emph{shape} and \emph{scale}, respectively. + The hyperparameters of the Uniform are also passed as a vector of + length two with the first and second elements corresponding to the lower and upper support, respectively. \code{sigma.sq.mu} - are the random effect variances for any random effects, and are assumed to follow an + are the random effect variances for any random effects, and are assumed to follow an inverse-Gamma distribution. The hyperparameters of - the inverse-Gamma distribution are passed as a list of length two with the - first and second elements corresponding to the shape and scale parameters, - respectively, which are each specified as vectors of length equal to the + the inverse-Gamma distribution are passed as a list of length two with the + first and second elements corresponding to the shape and scale parameters, + respectively, which are each specified as vectors of length equal to the number of random effects or of length one if priors are the same for all - random effect variances. \code{tau.sq} is the residual variance - for Gaussian (or zero-inflated Gaussian) models, and it is assigned + random effect variances. \code{tau.sq} is the residual variance + for Gaussian (or zero-inflated Gaussian) models, and it is assigned an inverse-Gamma prior. The hyperparameters of the inverse-Gamma are passed as a vector - of length two, with the first and second element corresponding to the shape and + of length two, with the first and second element corresponding to the shape and scale parameters, respectively.} - + \item{cov.model}{a quoted keyword that specifies the covariance function used to model the spatial dependence structure among the observations. Supported covariance model key words are: \code{"exponential"}, \code{"matern"}, \code{"spherical"}, and \code{"gaussian"}.} - \item{tuning}{a single numeric value representing the initial variance of the - adaptive sampler for \code{beta}, \code{alpha}, \code{beta.star} (the abundance - random effect values), \code{kappa}, \code{phi}, - and \code{nu}. See Roberts and Rosenthal (2009) for details. Note that only \code{phi} - and \code{nu} are the only parameters that require tuning for a Gaussian or + \item{tuning}{a list with each tag corresponding to a parameter name, whose value defines + the initial variance of the adaptive sampler. Valid tags include + \code{beta}, \code{alpha}, \code{beta.star} (the abundance + random effect values), \code{kappa}, \code{phi}, + and \code{nu}. See Roberts and Rosenthal (2009) for details. Note that only \code{phi} + and \code{nu} are the only parameters that require tuning for a Gaussian or zero-inflated Gaussian model.} - \item{NNGP}{if \code{TRUE}, model is fit with an NNGP. See Datta et al. (2016) and + \item{NNGP}{if \code{TRUE}, model is fit with an NNGP. See Datta et al. (2016) and Finley et al. (2019) for more information. Currently only NNGP is supported, functionality for a full GP may be addded in future package development.} - - \item{n.neighbors}{number of neighbors used in the NNGP. Only used if - \code{NNGP = TRUE}. Datta et al. (2016) showed that 15 neighbors is usually + + \item{n.neighbors}{number of neighbors used in the NNGP. Only used if + \code{NNGP = TRUE}. Datta et al. (2016) showed that 15 neighbors is usually sufficient, but that as few as 5 neighbors can be adequate for certain data sets, which can lead to even greater decreases in run time. We recommend starting with 15 neighbors (the default) and if additional gains in computation time are desired, subsequently compare the results with a smaller number of neighbors using WAIC.} - + \item{search.type}{a quoted keyword that specifies the type of nearest neighbor search algorithm. Supported method key words are: \code{"cb"} and \code{"brute"}. The \code{"cb"} should generally be much faster. If locations do not have identical coordinate values on - the axis used for the nearest neighbor ordering then \code{"cb"} - and \code{"brute"} should produce identical neighbor sets. - However, if there are identical coordinate values on the axis used - for nearest neighbor ordering, then \code{"cb"} and \code{"brute"} - might produce different, but equally valid, neighbor sets, + the axis used for the nearest neighbor ordering then \code{"cb"} + and \code{"brute"} should produce identical neighbor sets. + However, if there are identical coordinate values on the axis used + for nearest neighbor ordering, then \code{"cb"} and \code{"brute"} + might produce different, but equally valid, neighbor sets, e.g., if data are on a grid. } - - \item{n.batch}{the number of MCMC batches in each chain to run for the adaptive MCMC + + \item{n.batch}{the number of MCMC batches in each chain to run for the adaptive MCMC sampler. See Roberts and Rosenthal (2009) for details.} - - \item{batch.length}{the length of each MCMC batch in each chain to run for the adaptive + + \item{batch.length}{the length of each MCMC batch in each chain to run for the adaptive MCMC sampler. See Roberts and Rosenthal (2009) for details.} - - \item{accept.rate}{target acceptance rate for adaptive MCMC. Default is + + \item{accept.rate}{target acceptance rate for adaptive MCMC. Default is 0.43. See Roberts and Rosenthal (2009) for details.} - \item{family}{the distribution to use for the latent abundance process. Currently - supports \code{'NB'} (negative binomial), \code{'Poisson'}, \code{'Gaussian'}, - and \code{'zi-Gaussian'}.} + \item{family}{the distribution to use for the latent abundance process. Currently + supports \code{'NB'} (negative binomial), \code{'Poisson'}, \code{'Gaussian'}, + and \code{'zi-Gaussian'}.} \item{n.omp.threads}{a positive integer indicating the number of threads to use for SMP parallel processing. The package must @@ -148,20 +149,20 @@ spAbund(formula, data, inits, priors, tuning, recommend setting \code{n.omp.threads} up to the number of hyperthreaded cores. Note, \code{n.omp.threads} > 1 might not work on some systems.} - - \item{verbose}{if \code{TRUE}, messages about data preparation, - model specification, and progress of the sampler are printed to the screen. + + \item{verbose}{if \code{TRUE}, messages about data preparation, + model specification, and progress of the sampler are printed to the screen. Otherwise, no messages are printed.} - + \item{n.report}{the interval to report Metropolis sampler acceptance and MCMC progress.} - \item{n.burn}{the number of samples out of the total \code{n.batch * batch.length} - samples in each chain to discard as burn-in. By default, the first + \item{n.burn}{the number of samples out of the total \code{n.batch * batch.length} + samples in each chain to discard as burn-in. By default, the first 10\% of samples is discarded.} - + \item{n.thin}{the thinning interval for collection of MCMC samples. The - thinning occurs after the \code{n.burn} samples are discarded. Default + thinning occurs after the \code{n.burn} samples are discarded. Default value is set to 1.} \item{n.chains}{the number of MCMC chains to run in sequence.} @@ -171,8 +172,8 @@ spAbund(formula, data, inits, priors, tuning, \code{y.rep.samples}, \code{mu.samples}, and \code{like.samples} will not be included in the model object, and subsequent functions for calculating WAIC, fitted values, and posterior predictive checks will not work, although they all can be calculated manually if - desired. Setting \code{save.fitted = FALSE} can be useful when working with very large - data sets to minimize the amount of RAM needed when fitting and storing the model object in + desired. Setting \code{save.fitted = FALSE} can be useful when working with very large + data sets to minimize the amount of RAM needed when fitting and storing the model object in memory.} \item{...}{currently no additional arguments} @@ -188,13 +189,13 @@ spAbund(formula, data, inits, priors, tuning, Hierarchical Nearest-Neighbor Gaussian process models for large geostatistical datasets. \emph{Journal of the American Statistical Association}, \doi{10.1080/01621459.2015.1044091}. - + Finley, A.O., A. Datta, B.D. Cook, D.C. Morton, H.E. Andersen, and S. Banerjee. (2019) Efficient algorithms for Bayesian Nearest Neighbor Gaussian Processes. \emph{Journal of Computational and Graphical Statistics}, \doi{10.1080/10618600.2018.1537924}. - Roberts, G.O. and Rosenthal J.S. (2009) Examples of adaptive MCMC. + Roberts, G.O. and Rosenthal J.S. (2009) Examples of adaptive MCMC. \emph{Journal of Computational and Graphical Statistics}, 18(2):349-367. } @@ -204,7 +205,7 @@ spAbund(formula, data, inits, priors, tuning, } \value{ - An object of class \code{spAbund} that is a list comprised of: + An object of class \code{spAbund} that is a list comprised of: \item{beta.samples}{a \code{coda} object of posterior samples for the abundance regression coefficients.} @@ -217,12 +218,12 @@ spAbund(formula, data, inits, priors, tuning, for the Gaussian residual variance parameter. Only included when \code{family = 'Gaussian'} or \code{family = 'zi-Gaussian'}.} - \item{y.rep.samples}{a two or three-dimensional object of posterior samples - for the abundance replicate (fitted) values with dimensions + \item{y.rep.samples}{a two or three-dimensional object of posterior samples + for the abundance replicate (fitted) values with dimensions corresponding to MCMC samples, site, and replicate.} \item{mu.samples}{a two or -three-dimensional array of posterior samples - for the expected abundance samples with dimensions corresponding + for the expected abundance samples with dimensions corresponding to MCMC samples, site, and replicate.} \item{theta.samples}{a \code{coda} object of posterior samples @@ -232,12 +233,12 @@ spAbund(formula, data, inits, priors, tuning, for latent spatial random effects.} \item{sigma.sq.mu.samples}{a \code{coda} object of posterior samples - for variances of random effects included in the model. - Only included if random effects are specified in + for variances of random effects included in the model. + Only included if random effects are specified in \code{formula}.} \item{beta.star.samples}{a \code{coda} object of posterior samples - for the abundance random effects. Only included if random effects + for the abundance random effects. Only included if random effects are specified in \code{formula}.} \item{like.samples}{a \code{coda} object of posterior samples @@ -251,8 +252,8 @@ spAbund(formula, data, inits, priors, tuning, \item{run.time}{execution time reported using \code{proc.time()}.} - The return object will include additional objects used for - subsequent prediction and/or model fit evaluation. + The return object will include additional objects used for + subsequent prediction and/or model fit evaluation. } \examples{ @@ -264,16 +265,16 @@ n.rep <- sample(3, J, replace = TRUE) beta <- c(0, -1.5, 0.3, -0.8) p.abund <- length(beta) mu.RE <- list(levels = c(50, 45), - sigma.sq.mu = c(1.3, 0.5), + sigma.sq.mu = c(1.3, 0.5), beta.indx = c(1, 2)) phi <- 3/.6 sigma.sq <- 2 kappa <- 0.2 -sp <- TRUE +sp <- TRUE cov.model <- 'exponential' family <- 'NB' -dat <- simAbund(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, - kappa = kappa, mu.RE = mu.RE, sp = sp, phi = phi, +dat <- simAbund(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, + kappa = kappa, mu.RE = mu.RE, sp = sp, phi = phi, sigma.sq = sigma.sq, cov.model = cov.model, family = 'NB') y <- dat$y @@ -281,11 +282,11 @@ X <- dat$X X.re <- dat$X.re coords <- dat$coords -covs <- list(int = X[, , 1], - abund.cov.1 = X[, , 2], - abund.cov.2 = X[, , 3], +covs <- list(int = X[, , 1], + abund.cov.1 = X[, , 2], + abund.cov.2 = X[, , 3], abund.cov.3 = X[, , 4], - abund.factor.1 = X.re[, , 1], + abund.factor.1 = X.re[, , 1], abund.factor.2 = X.re[, , 2]) data.list <- list(y = y, covs = covs, coords = coords) @@ -294,35 +295,35 @@ data.list <- list(y = y, covs = covs, coords = coords) prior.list <- list(beta.normal = list(mean = 0, var = 100), phi.unif = c(3 / 1, 3 / .1), sigma.sq.ig = c(2, 1), - kappa.unif = c(0.001, 10)) + kappa.unif = c(0.001, 10)) # Starting values inits.list <- list(beta = beta, kappa = kappa, sigma.sq = sigma.sq, phi = phi) -tuning <- list(phi = 0.3, kappa = 0.05, beta = 0.1, beta.star = 0.1, w = 0.1) +tuning <- list(phi = 0.3, kappa = 0.05, beta = 0.1, beta.star = 0.1, w = 0.1) n.batch <- 4 batch.length <- 25 -n.burn <- 20 +n.burn <- 20 n.thin <- 1 n.chains <- 1 out <- spAbund(formula = ~ abund.cov.1 + abund.cov.2 + abund.cov.3 + (1 | abund.factor.1) + (abund.cov.1 | abund.factor.2), - data = data.list, - n.batch = n.batch, - batch.length = batch.length, - inits = inits.list, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + inits = inits.list, tuning = tuning, - priors = prior.list, - NNGP = TRUE, + priors = prior.list, + NNGP = TRUE, cov.model = 'exponential', search.type = 'cb', n.neighbors = 5, - accept.rate = 0.43, - n.omp.threads = 1, - verbose = TRUE, + accept.rate = 0.43, + n.omp.threads = 1, + verbose = TRUE, n.report = 1, n.burn = n.burn, n.thin = n.thin, - n.chains = n.chains) + n.chains = n.chains) summary(out) } diff --git a/man/spDS.Rd b/man/spDS.Rd index 9f34bb9..4a12177 100644 --- a/man/spDS.Rd +++ b/man/spDS.Rd @@ -9,7 +9,7 @@ spDS(abund.formula, det.formula, data, inits, priors, tuning, n.batch, batch.length, accept.rate = 0.43, family = 'Poisson', transect = 'line', det.func = 'halfnormal', n.omp.threads = 1, verbose = TRUE, - n.report = 100, n.burn = round(.10 * n.batch * batch.length), n.thin = 1, + n.report = 100, n.burn = round(.10 * n.batch * batch.length), n.thin = 1, n.chains = 1, ...) } @@ -30,64 +30,64 @@ spDS(abund.formula, det.formula, data, inits, priors, tuning, \item{data}{a list containing data necessary for model fitting. Valid tags are \code{y}, \code{covs}, \code{coords}, \code{dist.breaks}, and \code{offset}. \code{y} - is a matrix or data frame of the observed count values, - with first dimension equal to the number of - sites (\eqn{J}{J}) and second dimension equal to the number of + is a matrix or data frame of the observed count values, + with first dimension equal to the number of + sites (\eqn{J}{J}) and second dimension equal to the number of distance bins. \code{covs} is a matrix or data frame containing the variables used in the abundance and/or the detection portion of the model, with - \eqn{J}{J} rows for each column (variable). \code{dist.breaks} is a vector of + \eqn{J}{J} rows for each column (variable). \code{dist.breaks} is a vector of distances that denote the breakpoints of the distance bands. \code{dist.breaks} should - have length equal to the number of columns in \code{y} plus one. \code{offset} is an - offset that can be used to scale estimates from abundance per transect to density per + have length equal to the number of columns in \code{y} plus one. \code{offset} is an + offset that can be used to scale estimates from abundance per transect to density per some desired unit of measure. This can be either a single value or a vector with an offset - value for each site (e.g., if transects differ in length). - \code{coords} is a \eqn{J \times 2}{J x 2} matrix of the observation coordinates. - Note that \code{spAbundance} assumes coordinates are specified + value for each site (e.g., if transects differ in length). + \code{coords} is a \eqn{J \times 2}{J x 2} matrix of the observation coordinates. + Note that \code{spAbundance} assumes coordinates are specified in a projected coordinate system. } \item{inits}{a list with each tag corresponding to a parameter name. - Valid tags are \code{N}, \code{beta}, \code{alpha}, \code{kappa}, + Valid tags are \code{N}, \code{beta}, \code{alpha}, \code{kappa}, \code{sigma.sq}, \code{phi}, \code{w}, \code{nu}, - \code{sigma.sq.mu}, and \code{sigma.sq.p}. The value portion of each tag is the - parameter's initial value. \code{sigma.sq.mu} and \code{sigma.sq.p} are - only relevant when including random effects in the abundance and - detection portion of the abundance model, respectively. \code{kappa} is - only relevant when \code{family = 'NB'}. \code{nu} is only - specified if \code{cov.model = "matern"}. See \code{priors} + \code{sigma.sq.mu}, and \code{sigma.sq.p}. The value portion of each tag is the + parameter's initial value. \code{sigma.sq.mu} and \code{sigma.sq.p} are + only relevant when including random effects in the abundance and + detection portion of the abundance model, respectively. \code{kappa} is + only relevant when \code{family = 'NB'}. \code{nu} is only + specified if \code{cov.model = "matern"}. See \code{priors} description for definition of each parameter name. - Additionally, the tag \code{fix} can be set to \code{TRUE} + Additionally, the tag \code{fix} can be set to \code{TRUE} to fix the starting values across all chains. If \code{fix} is not specified (the default), starting values are varied randomly across chains.} -\item{priors}{a list with each tag corresponding to a parameter name. - Valid tags are \code{beta.normal}, \code{alpha.normal}, \code{kappa.unif}, - \code{phi.unif}, \code{sigma.sq.ig}, \code{nu.unif}, - \code{sigma.sq.mu.ig}, and \code{sigma.sq.p.ig}. - Abundance (\code{beta}) and detection (\code{alpha}) - regression coefficients are assumed to follow a normal distribution. - The hyperparameters of the normal distribution are passed as a list of - length two with the first and second elements corresponding to the mean - and variance of the normal distribution, which are each specified as vectors of +\item{priors}{a list with each tag corresponding to a parameter name. + Valid tags are \code{beta.normal}, \code{alpha.normal}, \code{kappa.unif}, + \code{phi.unif}, \code{sigma.sq.ig}, \code{nu.unif}, + \code{sigma.sq.mu.ig}, and \code{sigma.sq.p.ig}. + Abundance (\code{beta}) and detection (\code{alpha}) + regression coefficients are assumed to follow a normal distribution. + The hyperparameters of the normal distribution are passed as a list of + length two with the first and second elements corresponding to the mean + and variance of the normal distribution, which are each specified as vectors of length equal to the number of coefficients to be estimated or of length one - if priors are the same for all coefficients. If not specified, prior means - are set to 0 and prior variances set to 100. The spatial variance parameter, - \code{sigma.sq}, is assumed to follow an - inverse-Gamma distribution. The spatial decay \code{phi}, spatial + if priors are the same for all coefficients. If not specified, prior means + are set to 0 and prior variances set to 100. The spatial variance parameter, + \code{sigma.sq}, is assumed to follow an + inverse-Gamma distribution. The spatial decay \code{phi}, spatial smoothness \code{nu}, and negative binomial dispersion \code{kappa} - parameters are assumed to follow Uniform - distributions. The hyperparameters of the inverse-Gamma for \code{sigma.sq} - are passed as a vector of length two, with the first and second - elements corresponding to the \emph{shape} and \emph{scale}, respectively. - The hyperparameters of the Uniform are also passed as a vector of - length two with the first and second elements corresponding to - the lower and upper support, respectively. \code{sigma.sq.mu} and - \code{sigma.sq.p} are the random effect variances for any abundance or + parameters are assumed to follow Uniform + distributions. The hyperparameters of the inverse-Gamma for \code{sigma.sq} + are passed as a vector of length two, with the first and second + elements corresponding to the \emph{shape} and \emph{scale}, respectively. + The hyperparameters of the Uniform are also passed as a vector of + length two with the first and second elements corresponding to + the lower and upper support, respectively. \code{sigma.sq.mu} and + \code{sigma.sq.p} are the random effect variances for any abundance or detection random effects, respectively, and are assumed to follow an inverse Gamma distribution. The hyperparameters of the inverse-Gamma distribution are passed as a list of length two with first and second elements corresponding to the shape and scale parameters, respectively, which are each specified as - vectors of length equal to the number of random intercepts/slopes or of length one + vectors of length equal to the number of random intercepts/slopes or of length one if priors are the same for all random effect variances.} \item{cov.model}{a quoted keyword that specifies the covariance @@ -96,45 +96,46 @@ spDS(abund.formula, det.formula, data, inits, priors, tuning, \code{"exponential"}, \code{"matern"}, \code{"spherical"}, and \code{"gaussian"}.} - \item{tuning}{a single numeric value representing the initial variance of the - adaptive sampler for \code{beta}, \code{alpha}, \code{beta.star} (the abundance + \item{tuning}{a list with each tag corresponding to a parameter name, whose value + defines the initial variance of the adpative sampler. Valid tags include + \code{beta}, \code{alpha}, \code{beta.star} (the abundance random effect values), \code{alpha.star} (the detection random effect values), \code{kappa}, \code{phi}, \code{nu}, and \code{w}. See Roberts and Rosenthal (2009) for details.} - \item{NNGP}{if \code{TRUE}, model is fit with an NNGP. See Datta et al. (2016) and + \item{NNGP}{if \code{TRUE}, model is fit with an NNGP. See Datta et al. (2016) and Finley et al. (2019) for more information. Currently only NNGP is supported, functionality for a Gaussian Process may be addded in future package development.} - - \item{n.neighbors}{number of neighbors used in the NNGP. Only used if - \code{NNGP = TRUE}. Datta et al. (2016) showed that 15 neighbors is usually + + \item{n.neighbors}{number of neighbors used in the NNGP. Only used if + \code{NNGP = TRUE}. Datta et al. (2016) showed that 15 neighbors is usually sufficient, but that as few as 5 neighbors can be adequate for certain data sets, which can lead to even greater decreases in run time. We recommend starting with 15 neighbors (the default) and if additional gains in computation time are desired, subsequently compare the results with a smaller number of neighbors using WAIC.} - + \item{search.type}{a quoted keyword that specifies the type of nearest neighbor search algorithm. Supported method key words are: \code{"cb"} and \code{"brute"}. The \code{"cb"} should generally be much faster. If locations do not have identical coordinate values on - the axis used for the nearest neighbor ordering then \code{"cb"} - and \code{"brute"} should produce identical neighbor sets. - However, if there are identical coordinate values on the axis used - for nearest neighbor ordering, then \code{"cb"} and \code{"brute"} - might produce different, but equally valid, neighbor sets, + the axis used for the nearest neighbor ordering then \code{"cb"} + and \code{"brute"} should produce identical neighbor sets. + However, if there are identical coordinate values on the axis used + for nearest neighbor ordering, then \code{"cb"} and \code{"brute"} + might produce different, but equally valid, neighbor sets, e.g., if data are on a grid.} -\item{n.batch}{the number of MCMC batches in each chain to run for the Adaptive MCMC +\item{n.batch}{the number of MCMC batches in each chain to run for the Adaptive MCMC sampler. See Roberts and Rosenthal (2009) for details.} -\item{batch.length}{the length of each MCMC batch in each chain to run for the Adaptive +\item{batch.length}{the length of each MCMC batch in each chain to run for the Adaptive MCMC sampler. See Roberts and Rosenthal (2009) for details.} -\item{accept.rate}{target acceptance rate for Adaptive MCMC. Default is +\item{accept.rate}{target acceptance rate for Adaptive MCMC. Default is 0.43. See Roberts and Rosenthal (2009) for details.} -\item{family}{the distribution to use for the latent abundance process. Currently - supports \code{'NB'} (negative binomial) and \code{'Poisson'}.} +\item{family}{the distribution to use for the latent abundance process. Currently + supports \code{'NB'} (negative binomial) and \code{'Poisson'}.} \item{transect}{the type of transect. Currently supports line transects (\code{'line'}) or circular transects (i.e., point counts; \code{'point'}).} @@ -145,23 +146,23 @@ spDS(abund.formula, det.formula, data, inits, priors, tuning, (\code{'negexp'}).} \item{n.omp.threads}{a positive integer indicating the number of threads - to use for SMP parallel processing. The package must be compiled for - OpenMP support. For most Intel-based machines, we recommend setting - \code{n.omp.threads} up to the number of hypterthreaded cores. Note, - \code{n.omp.threads} > 1 might not work on some systems. Currently only + to use for SMP parallel processing. The package must be compiled for + OpenMP support. For most Intel-based machines, we recommend setting + \code{n.omp.threads} up to the number of hypterthreaded cores. Note, + \code{n.omp.threads} > 1 might not work on some systems. Currently only relevant for spatial models.} -\item{verbose}{if \code{TRUE}, messages about data preparation, - model specification, and progress of the sampler are printed to the screen. +\item{verbose}{if \code{TRUE}, messages about data preparation, + model specification, and progress of the sampler are printed to the screen. Otherwise, no messages are printed.} \item{n.report}{the interval to report MCMC progress.} -\item{n.burn}{the number of samples out of the total \code{n.samples} to +\item{n.burn}{the number of samples out of the total \code{n.samples} to discard as burn-in for each chain. By default, the first 10\% of samples is discarded.} \item{n.thin}{the thinning interval for collection of MCMC samples. The - thinning occurs after the \code{n.burn} samples are discarded. Default + thinning occurs after the \code{n.burn} samples are discarded. Default value is set to 1.} \item{n.chains}{the number of chains to run in sequence.} @@ -179,13 +180,13 @@ spDS(abund.formula, det.formula, data, inits, priors, tuning, Hierarchical Nearest-Neighbor Gaussian process models for large geostatistical datasets. \emph{Journal of the American Statistical Association}, \doi{10.1080/01621459.2015.1044091}. - + Finley, A.O., A. Datta, B.D. Cook, D.C. Morton, H.E. Andersen, and S. Banerjee. (2019) Efficient algorithms for Bayesian Nearest Neighbor Gaussian Processes. \emph{Journal of Computational and Graphical Statistics}, \doi{10.1080/10618600.2018.1537924}. - Royle, J. A., Dawson, D. K., & Bates, S. (2004). Modeling + Royle, J. A., Dawson, D. K., & Bates, S. (2004). Modeling abundance effects in distance sampling. Ecology, 85(6), 1591-1597. } @@ -195,26 +196,26 @@ spDS(abund.formula, det.formula, data, inits, priors, tuning, } \value{ - An object of class \code{spDS} that is a list comprised of: + An object of class \code{spDS} that is a list comprised of: \item{beta.samples}{a \code{coda} object of posterior samples for the abundance regression coefficients.} \item{alpha.samples}{a \code{coda} object of posterior samples for the detection regression coefficients.} - + \item{kappa.samples}{a \code{coda} object of posterior samples for the abundance dispersion parameter. Only included when \code{family = 'NB'}.} - \item{N.samples}{a \code{coda} object of posterior samples + \item{N.samples}{a \code{coda} object of posterior samples for the latent abundance values. Note that these values always - represent transect-level abundance, even when an offset is + represent transect-level abundance, even when an offset is supplied.} \item{mu.samples}{a \code{coda} object of posterior samples - for the latent expected abundance values. When an offset is - supplied in the \code{data} object, these correspond to expected + for the latent expected abundance values. When an offset is + supplied in the \code{data} object, these correspond to expected abundance per unit area (i.e., density).} \item{theta.samples}{a \code{coda} object of posterior samples @@ -225,23 +226,23 @@ spDS(abund.formula, det.formula, data, inits, priors, tuning, \item{sigma.sq.mu.samples}{a \code{coda} object of posterior samples for variances of random effects included in the abundance portion - of the model. Only included if random effects are specified in + of the model. Only included if random effects are specified in \code{abund.formula}.} \item{sigma.sq.p.samples}{a \code{coda} object of posterior samples - for variances of random effects included in the detection portion - of the model. Only included if random effects are specified in + for variances of random effects included in the detection portion + of the model. Only included if random effects are specified in \code{det.formula}.} \item{beta.star.samples}{a \code{coda} object of posterior samples - for the abundance random effects. Only included if random effects + for the abundance random effects. Only included if random effects are specified in \code{abund.formula}.} \item{alpha.star.samples}{a \code{coda} object of posterior samples - for the detection random effects. Only included if random effects + for the detection random effects. Only included if random effects are specified in \code{det.formula}.} - \item{y.rep.samples}{a three-dimensional array of fitted values. + \item{y.rep.samples}{a three-dimensional array of fitted values. Array dimensions correspond to MCMC samples, sites, and distance band.} \item{pi.samples}{a three-dimensional array of cell-specific detection @@ -254,16 +255,16 @@ spDS(abund.formula, det.formula, data, inits, priors, tuning, \item{run.time}{execution time reported using \code{proc.time()}.} - The return object will include additional objects used for - subsequent prediction and/or model fit evaluation. + The return object will include additional objects used for + subsequent prediction and/or model fit evaluation. } \examples{ set.seed(123) J.x <- 10 -J.y <- 10 +J.y <- 10 J <- J.x * J.y -# Number of distance bins from which to simulate data. +# Number of distance bins from which to simulate data. n.bins <- 5 # Length of each bin. This should be of length n.bins bin.width <- c(.10, .10, .20, .3, .1) @@ -287,7 +288,7 @@ offset <- 1.8 transect <- 'point' dat <- simDS(J.x = J.x, J.y = J.y, n.bins = n.bins, bin.width = bin.width, - beta = beta, alpha = alpha, det.func = det.func, kappa = kappa, + beta = beta, alpha = alpha, det.func = det.func, kappa = kappa, mu.RE = mu.RE, p.RE = p.RE, sp = sp, offset = offset, transect = transect, phi = phi, sigma.sq = sigma.sq, cov.model = cov.model) @@ -301,52 +302,52 @@ dist.breaks <- dat$dist.breaks coords <- dat$coords covs <- cbind(X, X.p) -colnames(covs) <- c('int.abund', 'abund.cov.1', 'abund.cov.2', 'abund.cov.3', +colnames(covs) <- c('int.abund', 'abund.cov.1', 'abund.cov.2', 'abund.cov.3', 'int.det', 'det.cov.1') -data.list <- list(y = y, +data.list <- list(y = y, covs = covs, - dist.breaks = dist.breaks, + dist.breaks = dist.breaks, coords = coords, offset = offset) # Priors prior.list <- list(beta.normal = list(mean = 0, var = 10), alpha.normal = list(mean = 0, - var = 10), - kappa.unif = c(0, 100), + var = 10), + kappa.unif = c(0, 100), phi.unif = c(3 / 1, 3 / .1), - sigma.sq.ig = c(2, 1)) + sigma.sq.ig = c(2, 1)) # Starting values inits.list <- list(alpha = 0, beta = 0, - kappa = 1, - phi = 3 / .5, + kappa = 1, + phi = 3 / .5, sigma.sq = 1) # Tuning values -tuning <- list(beta = 0.1, alpha = 0.1, beta.star = 0.3, alpha.star = 0.1, - kappa = 0.2, phi = 1, w = 1) +tuning <- list(beta = 0.1, alpha = 0.1, beta.star = 0.3, alpha.star = 0.1, + kappa = 0.2, phi = 1, w = 1) out <- spDS(abund.formula = ~ abund.cov.1 + abund.cov.2 + abund.cov.3, det.formula = ~ det.cov.1, - data = data.list, - n.batch = 10, - batch.length = 25, - inits = inits.list, + data = data.list, + n.batch = 10, + batch.length = 25, + inits = inits.list, family = 'NB', - det.func = 'halfnormal', - transect = 'point', - cov.model = 'exponential', + det.func = 'halfnormal', + transect = 'point', + cov.model = 'exponential', NNGP = TRUE, n.neighbors = 5, tuning = tuning, - priors = prior.list, - accept.rate = 0.43, - n.omp.threads = 1, - verbose = TRUE, + priors = prior.list, + accept.rate = 0.43, + n.omp.threads = 1, + verbose = TRUE, n.report = 100, n.burn = 100, n.thin = 1, - n.chains = 1) + n.chains = 1) summary(out) } diff --git a/man/spNMix.Rd b/man/spNMix.Rd index be12991..e61cf48 100644 --- a/man/spNMix.Rd +++ b/man/spNMix.Rd @@ -3,16 +3,16 @@ \title{Function for Fitting Single-Species Spatial N-Mixture Models} \description{ - The function \code{spNMix} fits single-species spatial N-mixture models. Spatial models are fit using Nearest Neighbor Gaussian Processes. + The function \code{spNMix} fits single-species spatial N-mixture models. Spatial models are fit using Nearest Neighbor Gaussian Processes. } \usage{ spNMix(abund.formula, det.formula, data, inits, priors, tuning, - cov.model = 'exponential', NNGP = TRUE, + cov.model = 'exponential', NNGP = TRUE, n.neighbors = 15, search.type = 'cb', n.batch, batch.length, accept.rate = 0.43, family = 'Poisson', - n.omp.threads = 1, verbose = TRUE, n.report = 100, - n.burn = round(.10 * n.batch * batch.length), n.thin = 1, + n.omp.threads = 1, verbose = TRUE, n.report = 100, + n.burn = round(.10 * n.batch * batch.length), n.thin = 1, n.chains = 1, ...) } @@ -22,143 +22,144 @@ spNMix(abund.formula, det.formula, data, inits, priors, tuning, for the abundance portion of the model using R's model syntax. Only right-hand side of formula is specified. See example below. Random intercepts and random slopes are allowed using lme4 syntax (Bates et al. 2015).} - + \item{det.formula}{a symbolic description of the model to be fit for the detection portion of the model using R's model syntax. Only right-hand side of formula is specified. See example below. Random intercepts and random slopes are allowed using lme4 syntax (Bates et al. 2015).} \item{data}{a list containing data necessary for model fitting. - Valid tags are \code{y}, \code{abund.covs}, \code{det.covs}, \code{offset}, and \code{coords}. - \code{y} is the count data matrix or data frame with - first dimension equal to the number of sites (\eqn{J}{J}) and second - dimension equal to the maximum number of replicates at a given site. - \code{abund.covs} is a matrix or data frame containing the variables used - in the abundance portion of the model, with \eqn{J}{J} rows for each column - (variable). \code{det.covs} is a list of variables included in the - detection portion of the model. Each list element is a different detection - covariate, which can be site-level or observational-level. Site-level - covariates are specified as a vector of length \eqn{J}{J} while - observation-level covariates are specified - as a matrix or data frame with the number of rows equal to \eqn{J}{J} and - number of columns equal to the maximum number of replicates at a given site. - \code{coords} is a \eqn{J \times 2}{J x 2} matrix of the observation coordinates. - Note that \code{spAbundance} assumes coordinates are specified - in a projected coordinate system. \code{offset} is an offset to use in - the abundance model (e.g., an area offset). This can be either a single value or a + Valid tags are \code{y}, \code{abund.covs}, \code{det.covs}, \code{offset}, and \code{coords}. + \code{y} is the count data matrix or data frame with + first dimension equal to the number of sites (\eqn{J}{J}) and second + dimension equal to the maximum number of replicates at a given site. + \code{abund.covs} is a matrix or data frame containing the variables used + in the abundance portion of the model, with \eqn{J}{J} rows for each column + (variable). \code{det.covs} is a list of variables included in the + detection portion of the model. Each list element is a different detection + covariate, which can be site-level or observational-level. Site-level + covariates are specified as a vector of length \eqn{J}{J} while + observation-level covariates are specified + as a matrix or data frame with the number of rows equal to \eqn{J}{J} and + number of columns equal to the maximum number of replicates at a given site. + \code{coords} is a \eqn{J \times 2}{J x 2} matrix of the observation coordinates. + Note that \code{spAbundance} assumes coordinates are specified + in a projected coordinate system. \code{offset} is an offset to use in + the abundance model (e.g., an area offset). This can be either a single value or a vector with an offset for each site (e.g., if survey area differed in size).} - + \item{inits}{a list with each tag corresponding to a parameter name. - Valid tags are \code{N}, \code{beta}, \code{alpha}, \code{sigma.sq}, - \code{phi}, \code{w}, \code{nu}, \code{kappa}, \code{sigma.sq.mu}, \code{sigma.sq.p}. + Valid tags are \code{N}, \code{beta}, \code{alpha}, \code{sigma.sq}, + \code{phi}, \code{w}, \code{nu}, \code{kappa}, \code{sigma.sq.mu}, \code{sigma.sq.p}. \code{nu} is only specified if \code{cov.model = "matern"}, \code{sigma.sq.p} is only specified if there are random effects in \code{det.formula}, \code{sigma.sq.mu} is only specified if there are random effects in \code{abund.formula}, and - \code{kappa} is only specified when \code{family = 'NB'}. + \code{kappa} is only specified when \code{family = 'NB'}. The value portion of each tag is the parameter's initial value. See \code{priors} description for definition of each parameter name. - Additionally, the tag \code{fix} can be set to \code{TRUE} + Additionally, the tag \code{fix} can be set to \code{TRUE} to fix the starting values across all chains. If \code{fix} is not specified (the default), starting values are varied randomly across chains.} - - \item{priors}{a list with each tag corresponding to a parameter name. - Valid tags are \code{beta.normal}, \code{alpha.normal}, \code{phi.unif}, + + \item{priors}{a list with each tag corresponding to a parameter name. + Valid tags are \code{beta.normal}, \code{alpha.normal}, \code{phi.unif}, \code{sigma.sq.ig}, \code{nu.unif}, \code{kappa.unif}, - \code{sigma.sq.mu.ig}, and \code{sigma.sq.p.ig}. Abundance - (\code{beta}) and detection (\code{alpha}) regression coefficients - are assumed to follow a normal distribution. The hyperparameters of the + \code{sigma.sq.mu.ig}, and \code{sigma.sq.p.ig}. Abundance + (\code{beta}) and detection (\code{alpha}) regression coefficients + are assumed to follow a normal distribution. The hyperparameters of the normal distribution are passed as a list of length two with the first and second elements corresponding to the mean and variance of the normal - distribution, which are each specified as vectors of + distribution, which are each specified as vectors of length equal to the number of coefficients to be estimated or of length one if priors are the same for all coefficients. If not specified, prior means are set to 0 and prior variances for abundance coefficients - are set to 100 and for detection coefficients set to 2.72. The - spatial variance parameter, \code{sigma.sq}, is assumed to follow an - inverse-Gamma distribution. The spatial decay \code{phi}, spatial + are set to 100 and for detection coefficients set to 2.72. The + spatial variance parameter, \code{sigma.sq}, is assumed to follow an + inverse-Gamma distribution. The spatial decay \code{phi}, spatial smoothness \code{nu}, and negative binomial dispersion \code{kappa} - parameters are assumed to follow Uniform - distributions. The hyperparameters of the inverse-Gamma for \code{sigma.sq} - are passed as a vector of length two, with the first and second - elements corresponding to the \emph{shape} and \emph{scale}, respectively. - The hyperparameters of the Uniform are also passed as a vector of - length two with the first and second elements corresponding to - the lower and upper support, respectively. \code{sigma.sq.mu} and - \code{sigma.sq.p} are the random effect variances for any abundance or - detection random effects, respectively, and are assumed to follow an + parameters are assumed to follow Uniform + distributions. The hyperparameters of the inverse-Gamma for \code{sigma.sq} + are passed as a vector of length two, with the first and second + elements corresponding to the \emph{shape} and \emph{scale}, respectively. + The hyperparameters of the Uniform are also passed as a vector of + length two with the first and second elements corresponding to + the lower and upper support, respectively. \code{sigma.sq.mu} and + \code{sigma.sq.p} are the random effect variances for any abundance or + detection random effects, respectively, and are assumed to follow an inverse-Gamma distribution. The hyperparameters of - the inverse-Gamma distribution are passed as a list of length two with the - first and second elements corresponding to the shape and scale parameters, - respectively, which are each specified as vectors of length equal to the + the inverse-Gamma distribution are passed as a list of length two with the + first and second elements corresponding to the shape and scale parameters, + respectively, which are each specified as vectors of length equal to the number of random intercepts/slopes or of length one if priors are the same for all random effect variances.} - + \item{cov.model}{a quoted keyword that specifies the covariance function used to model the spatial dependence structure among the observations. Supported covariance model key words are: \code{"exponential"}, \code{"matern"}, \code{"spherical"}, and \code{"gaussian"}.} - \item{tuning}{a single numeric value representing the initial variance of the - adaptive sampler for \code{beta}, \code{alpha}, \code{beta.star} (the abundance + \item{tuning}{a list with each tag corresponding to a parameter name, whose value + corresponds to the initial tuning variance of the adaptive sampler for + \code{beta}, \code{alpha}, \code{beta.star} (the abundance random effect values), \code{alpha.star} (the detection random effect values), \code{kappa}, \code{phi}, \code{nu}, and \code{w}. See Roberts and Rosenthal (2009) for details.} - \item{NNGP}{if \code{TRUE}, model is fit with an NNGP. See Datta et al. (2016) and + \item{NNGP}{if \code{TRUE}, model is fit with an NNGP. See Datta et al. (2016) and Finley et al. (2019) for more information. Currently only NNGP is supported, functionality for a Gaussian Process may be addded in future package development.} - - \item{n.neighbors}{number of neighbors used in the NNGP. Only used if - \code{NNGP = TRUE}. Datta et al. (2016) showed that 15 neighbors is usually + + \item{n.neighbors}{number of neighbors used in the NNGP. Only used if + \code{NNGP = TRUE}. Datta et al. (2016) showed that 15 neighbors is usually sufficient, but that as few as 5 neighbors can be adequate for certain data sets, which can lead to even greater decreases in run time. We recommend starting with 15 neighbors (the default) and if additional gains in computation time are desired, subsequently compare the results with a smaller number of neighbors using WAIC.} - + \item{search.type}{a quoted keyword that specifies the type of nearest neighbor search algorithm. Supported method key words are: \code{"cb"} and \code{"brute"}. The \code{"cb"} should generally be much faster. If locations do not have identical coordinate values on - the axis used for the nearest neighbor ordering then \code{"cb"} - and \code{"brute"} should produce identical neighbor sets. - However, if there are identical coordinate values on the axis used - for nearest neighbor ordering, then \code{"cb"} and \code{"brute"} - might produce different, but equally valid, neighbor sets, + the axis used for the nearest neighbor ordering then \code{"cb"} + and \code{"brute"} should produce identical neighbor sets. + However, if there are identical coordinate values on the axis used + for nearest neighbor ordering, then \code{"cb"} and \code{"brute"} + might produce different, but equally valid, neighbor sets, e.g., if data are on a grid.} - - \item{n.batch}{the number of MCMC batches in each chain to run for the Adaptive MCMC + + \item{n.batch}{the number of MCMC batches in each chain to run for the Adaptive MCMC sampler. See Roberts and Rosenthal (2009) for details.} - - \item{batch.length}{the length of each MCMC batch in each chain to run for the Adaptive + + \item{batch.length}{the length of each MCMC batch in each chain to run for the Adaptive MCMC sampler. See Roberts and Rosenthal (2009) for details.} - - \item{accept.rate}{target acceptance rate for Adaptive MCMC. Default is + + \item{accept.rate}{target acceptance rate for Adaptive MCMC. Default is 0.43. See Roberts and Rosenthal (2009) for details.} - \item{family}{the distribution to use for the latent abundance process. Currently + \item{family}{the distribution to use for the latent abundance process. Currently supports \code{'NB'} (negative binomial) and \code{'Poisson'}.} - + \item{n.omp.threads}{a positive integer indicating the number of threads to use for SMP parallel processing. The package must be compiled for OpenMP support. For most Intel-based machines, we recommend setting \code{n.omp.threads} up to the number of hyperthreaded cores. Note, \code{n.omp.threads} > 1 might not work on some systems.} - - \item{verbose}{if \code{TRUE}, messages about data preparation, - model specification, and progress of the sampler are printed to the screen. + + \item{verbose}{if \code{TRUE}, messages about data preparation, + model specification, and progress of the sampler are printed to the screen. Otherwise, no messages are printed.} - + \item{n.report}{the interval to report Metropolis sampler acceptance and MCMC progress.} - \item{n.burn}{the number of samples out of the total \code{n.batch * batch.length} - samples in each chain to discard as burn-in. By default, the first + \item{n.burn}{the number of samples out of the total \code{n.batch * batch.length} + samples in each chain to discard as burn-in. By default, the first 10\% of samples is discarded.} - + \item{n.thin}{the thinning interval for collection of MCMC samples. The - thinning occurs after the \code{n.burn} samples are discarded. Default + thinning occurs after the \code{n.burn} samples are discarded. Default value is set to 1.} \item{n.chains}{the number of MCMC chains to run in sequence.} @@ -176,16 +177,16 @@ spNMix(abund.formula, det.formula, data, inits, priors, tuning, Hierarchical Nearest-Neighbor Gaussian process models for large geostatistical datasets. \emph{Journal of the American Statistical Association}, \doi{10.1080/01621459.2015.1044091}. - + Finley, A.O., A. Datta, B.D. Cook, D.C. Morton, H.E. Andersen, and S. Banerjee. (2019) Efficient algorithms for Bayesian Nearest Neighbor Gaussian Processes. \emph{Journal of Computational and Graphical Statistics}, \doi{10.1080/10618600.2018.1537924}. - Roberts, G.O. and Rosenthal J.S. (2009) Examples of adaptive MCMC. + Roberts, G.O. and Rosenthal J.S. (2009) Examples of adaptive MCMC. \emph{Journal of Computational and Graphical Statistics}, 18(2):349-367. - Royle, J. A. (2004). N‐mixture models for estimating population size + Royle, J. A. (2004). N‐mixture models for estimating population size from spatially replicated counts. Biometrics, 60(1), 108-115. } @@ -195,7 +196,7 @@ spNMix(abund.formula, det.formula, data, inits, priors, tuning, } \value{ - An object of class \code{spNMix} that is a list comprised of: + An object of class \code{spNMix} that is a list comprised of: \item{beta.samples}{a \code{coda} object of posterior samples for the abundance regression coefficients.} @@ -207,7 +208,7 @@ spNMix(abund.formula, det.formula, data, inits, priors, tuning, for the abundance dispersion parameter. Only included when \code{family = 'NB'}.} - \item{N.samples}{a \code{coda} object of posterior samples + \item{N.samples}{a \code{coda} object of posterior samples for the latent abundance values} \item{mu.samples}{a \code{coda} object of posterior samples @@ -221,20 +222,20 @@ spNMix(abund.formula, det.formula, data, inits, priors, tuning, \item{sigma.sq.mu.samples}{a \code{coda} object of posterior samples for variances of random intercepts/slopes included in the abundance portion - of the model. Only included if random effects are specified in + of the model. Only included if random effects are specified in \code{abund.formula}.} \item{sigma.sq.p.samples}{a \code{coda} object of posterior samples - for variances of random effects included in the detection portion - of the model. Only included if random effects are specified in + for variances of random effects included in the detection portion + of the model. Only included if random effects are specified in \code{det.formula}.} \item{beta.star.samples}{a \code{coda} object of posterior samples - for the abundance random effects. Only included if random effects + for the abundance random effects. Only included if random effects are specified in \code{abund.formula}.} \item{alpha.star.samples}{a \code{coda} object of posterior samples - for the detection random effects. Only included if random effects + for the detection random effects. Only included if random effects are specified in \code{det.formula}.} \item{rhat}{a list of Gelman-Rubin diagnostic values for some of the model @@ -244,9 +245,9 @@ spNMix(abund.formula, det.formula, data, inits, priors, tuning, \item{run.time}{execution time reported using \code{proc.time()}.} - The return object will include additional objects used for + The return object will include additional objects used for subsequent prediction and/or model fit evaluation. Note that detection - probability values are not included in the model object, but can be + probability values are not included in the model object, but can be extracted using \code{fitted()}. } @@ -254,7 +255,7 @@ spNMix(abund.formula, det.formula, data, inits, priors, tuning, set.seed(350) # Simulate Data ----------------------------------------------------------- J.x <- 15 -J.y <- 15 +J.y <- 15 J <- J.x * J.y n.rep <- sample(3, J, replace = TRUE) beta <- c(0.5, 1.5) @@ -264,13 +265,13 @@ p.det <- length(alpha) mu.RE <- list() p.RE <- list() phi <- runif(1, 3 / 1, 3 / .1) -sigma.sq <- runif(1, 0.2, 1.5) +sigma.sq <- runif(1, 0.2, 1.5) kappa <- 0.5 -sp <- TRUE +sp <- TRUE cov.model <- 'exponential' dat <- simNMix(J.x = J.x, J.y = J.y, n.rep = n.rep, beta = beta, alpha = alpha, - kappa = kappa, mu.RE = mu.RE, p.RE = p.RE, sp = sp, - phi = phi, sigma.sq = sigma.sq, cov.model = cov.model, + kappa = kappa, mu.RE = mu.RE, p.RE = p.RE, sp = sp, + phi = phi, sigma.sq = sigma.sq, cov.model = cov.model, family = 'NB') y <- dat$y @@ -283,29 +284,29 @@ coords <- dat$coords abund.covs <- X colnames(abund.covs) <- c('int', 'abund.cov.1') -det.covs <- list(det.cov.1 = X.p[, , 2], - det.cov.2 = X.p[, , 3]) +det.covs <- list(det.cov.1 = X.p[, , 2], + det.cov.2 = X.p[, , 3]) -data.list <- list(y = y, +data.list <- list(y = y, abund.covs = abund.covs, - det.covs = det.covs, + det.covs = det.covs, coords = coords) # Priors -prior.list <- list(beta.normal = list(mean = rep(0, p.abund), +prior.list <- list(beta.normal = list(mean = rep(0, p.abund), var = rep(100, p.abund)), alpha.normal = list(mean = rep(0, p.det), - var = rep(2.72, p.det)), - kappa.unif = c(0, 10)) + var = rep(2.72, p.det)), + kappa.unif = c(0, 10)) # Starting values inits.list <- list(alpha = alpha, beta = beta, - kappa = kappa, + kappa = kappa, w = rep(0, J), phi = 3 / 0.5, sigma.sq = 1, N = apply(y, 1, max, na.rm = TRUE)) -# Tuning values +# Tuning values tuning.list <- list(phi = 0.5, kappa = 0.5, beta = 0.1, alpha = 0.1, w = 0.1) @@ -316,18 +317,18 @@ n.thin <- 1 n.chains <- 1 out <- spNMix(abund.formula = ~ abund.cov.1, - det.formula = ~ det.cov.1 + det.cov.2, - data = data.list, - n.batch = n.batch, - batch.length = batch.length, - inits = inits.list, - priors = prior.list, + det.formula = ~ det.cov.1 + det.cov.2, + data = data.list, + n.batch = n.batch, + batch.length = batch.length, + inits = inits.list, + priors = prior.list, NNGP = TRUE, cov.model = 'spherical', n.neighbors = 10, - accept.rate = 0.43, - n.omp.threads = 1, - verbose = TRUE, + accept.rate = 0.43, + n.omp.threads = 1, + verbose = TRUE, n.report = 1, n.burn = n.burn, n.thin = n.thin, diff --git a/man/svcAbund.Rd b/man/svcAbund.Rd index 85509fb..1b568e8 100644 --- a/man/svcAbund.Rd +++ b/man/svcAbund.Rd @@ -3,17 +3,17 @@ \title{Function for Fitting Univariate Spatialy-Varying Coefficient GLMMs} \description{ - The function \code{svcAbund} fits univariate spatially-varying coefficient GLMMs. + The function \code{svcAbund} fits univariate spatially-varying coefficient GLMMs. } \usage{ svcAbund(formula, data, inits, priors, tuning, - svc.cols = 1, cov.model = 'exponential', NNGP = TRUE, + svc.cols = 1, cov.model = 'exponential', NNGP = TRUE, n.neighbors = 15, search.type = 'cb', n.batch, - batch.length, accept.rate = 0.43, family = 'Gaussian', - n.omp.threads = 1, verbose = TRUE, n.report = 100, - n.burn = round(.10 * n.batch * batch.length), n.thin = 1, - n.chains = 1, ...) + batch.length, accept.rate = 0.43, family = 'Poisson', + n.omp.threads = 1, verbose = TRUE, n.report = 100, + n.burn = round(.10 * n.batch * batch.length), n.thin = 1, + n.chains = 1, save.fitted = TRUE, ...) } \arguments{ @@ -22,64 +22,73 @@ svcAbund(formula, data, inits, priors, tuning, for the model using R's model syntax. Only right-hand side of formula is specified. See example below. Random intercepts and slopes are allowed using lme4 syntax (Bates et al. 2015).} - + \item{data}{a list containing data necessary for model fitting. - Valid tags are \code{y}, \code{covs}, \code{coords}, and \code{z} (for - \code{family = 'zi-Gaussian'} only. \code{y} - is a vector of the observed count values, where the values - represent the observed values at each site. \code{covs} is a list, matrix, or data - frame of covariates used in the model, where each column (or list element) represents a - different covariate. \code{coords} is a \eqn{J \times 2}{J x 2} matrix of the observation coordinates. - Note that \code{svcAbundance} assumes coordinates are specified - in a projected coordinate system. \code{z} is used for fitting a zero-inflated - Gaussian model. It is a vector where each value indicates the binary - component of the model. In the context of abundance models, this can be - thought of as the component of the model that indicates whether the species is - present at each location, and then the supplied values in \code{y} are the - observed abundance values at those locations where \code{z = 1}.} - + Valid tags are \code{y}, \code{covs}, \code{z}, \code{coords}, and \code{offset}. \code{y} + is a vector, matrix, or data frame of the observed count values. If a vector, + the values represent the observed counts at each site. If multiple replicate + observations are obtained at the sites (e.g., sub-samples, repeated sampling over + multiple seasons), \code{y} can be specified as a matrix or data frame + with first dimension equal to the number of + sites (\eqn{J}{J}) and second dimension equal to the maximum number of + replicates at a given site. \code{covs} is either a data frame or list + containing the variables used in the model. When only fitting a model with site-level + data, \code{covs} can be specified as a data frame, with each row corresponding to + site and each column corresponding to a variable. When multiple abundance values + are available at a site, \code{covs} is specified as a list, where each list element is a different + covariate, which can be site-level or observation-level. Site-level covariates + are specified as a vector of length \eqn{J}{J}, while observation-level covariates + are specified as a matrix or data frame with the number of rows equal to \eqn{J}{J} + and number of columns equal to the maximum number of replicate observations at a + given site. \code{coords} is a \eqn{J \times 2}{J x 2} matrix of the observation coordinates. + Note that \code{spAbundance} assumes coordinates are specified + in a projected coordinate system. For zero-inflated Gaussian models, the tag \code{z} is + used to specify the binary component of the zero-inflated model and should have the same + length as \code{y}. \code{offset} is an offset to use in the abundance model (e.g., an area offset). + This can be either a single value, a vector with an offset for each site (e.g., if survey area differed in size), or a site x replicate matrix if more than one count is available at a given site.} + \item{inits}{a list with each tag corresponding to a parameter name. - Valid tags are \code{beta}, \code{sigma.sq}, - \code{phi}, \code{w}, \code{nu}, \code{tau.sq}, \code{sigma.sq.mu}. + Valid tags are \code{beta}, \code{sigma.sq}, + \code{phi}, \code{w}, \code{nu}, \code{tau.sq}, \code{sigma.sq.mu}. \code{nu} is only specified if \code{cov.model = "matern"}, \code{sigma.sq.mu} is only specified if there are random effects in \code{formula}, and The value portion of each tag is the parameter's initial value. See \code{priors} description for definition of each parameter name. - Additionally, the tag \code{fix} can be set to \code{TRUE} + Additionally, the tag \code{fix} can be set to \code{TRUE} to fix the starting values across all chains. If \code{fix} is not specified (the default), starting values are varied randomly across chains.} - - \item{priors}{a list with each tag corresponding to a parameter name. - Valid tags are \code{beta.normal}, \code{phi.unif}, + + \item{priors}{a list with each tag corresponding to a parameter name. + Valid tags are \code{beta.normal}, \code{phi.unif}, \code{sigma.sq.ig}, \code{nu.unif}, \code{tau.sq.ig}, - \code{sigma.sq.mu.ig}. Abundance (\code{beta}) regression coefficients - are assumed to follow a normal distribution. The hyperparameters of the + \code{sigma.sq.mu.ig}. Abundance (\code{beta}) regression coefficients + are assumed to follow a normal distribution. The hyperparameters of the normal distribution are passed as a list of length two with the first and second elements corresponding to the mean and variance of the normal - distribution, which are each specified as vectors of + distribution, which are each specified as vectors of length equal to the number of coefficients to be estimated or of length one if priors are the same for all coefficients. If not - specified, prior means are set to 0 and prior variances are set to 100. The - spatial variance parameter, \code{sigma.sq}, and the Gaussian - residual variance parameter, \code{tau.sq}, are assumed to follow an - inverse-Gamma distribution. The spatial decay \code{phi} and spatial - smoothness \code{nu}, parameters are assumed to follow Uniform - distributions. The hyperparameters of the inverse-Gamma for \code{sigma.sq} + specified, prior means are set to 0 and prior variances are set to 100. The + spatial variance parameter, \code{sigma.sq}, and the Gaussian + residual variance parameter, \code{tau.sq}, are assumed to follow an + inverse-Gamma distribution. The spatial decay \code{phi} and spatial + smoothness \code{nu}, parameters are assumed to follow Uniform + distributions. The hyperparameters of the inverse-Gamma for \code{sigma.sq} is passed as a list of length two with the first and second elements corresponding to the shape and scale parameters of the inverse-Gamma distribution either for - each spatially-varying coefficient, or a single value if assumign the same values - for all spatially-varying coefficients. The hyperparameters of the inverse-Gamma for - \code{tau.sq} is passed as a vector of length two, with the first and second - elements corresponding to the \emph{shape} and \emph{scale}, respectively. - The hyperparameters of the Uniform are also passed as a list of - length two with the first and second elements corresponding to + each spatially-varying coefficient, or a single value if assuming the same values + for all spatially-varying coefficients. The hyperparameters of the inverse-Gamma for + \code{tau.sq} is passed as a vector of length two, with the first and second + elements corresponding to the \emph{shape} and \emph{scale}, respectively. + The hyperparameters of the Uniform are also passed as a list of + length two with the first and second elements corresponding to the lower and upper support, respectively, for each SVC or a single value if giving the same prior for each SVC. \code{sigma.sq.mu} - are the random effect variances for any random effects, and are assumed to follow an + are the random effect variances for any random effects, and are assumed to follow an inverse-Gamma distribution. The hyperparameters of - the inverse-Gamma distribution are passed as a list of length two with the - first and second elements corresponding to the shape and scale parameters, - respectively, which are each specified as vectors of length equal to the + the inverse-Gamma distribution are passed as a list of length two with the + first and second elements corresponding to the shape and scale parameters, + respectively, which are each specified as vectors of length equal to the number of random effects or of length one if priors are the same for all random effect variances.} @@ -98,69 +107,79 @@ svcAbund(formula, data, inits, priors, tuning, \code{"exponential"}, \code{"matern"}, \code{"spherical"}, and \code{"gaussian"}.} - \item{tuning}{a single numeric value representing the initial variance of the - adaptive sampler for \code{phi} and \code{nu}. See Roberts and Rosenthal (2009) for details.} + \item{tuning}{a list with each tag corresponding to a parameter name, + whose value defines the initial variance of the adaptive sampler. + Valid tags are \code{phi} and \code{nu}. See Roberts and Rosenthal (2009) for details.} - \item{NNGP}{if \code{TRUE}, model is fit with an NNGP. See Datta et al. (2016) and + \item{NNGP}{if \code{TRUE}, model is fit with an NNGP. See Datta et al. (2016) and Finley et al. (2019) for more information. Currently only NNGP is supported, functionality for a full GP may be addded in future package development.} - - \item{n.neighbors}{number of neighbors used in the NNGP. Only used if - \code{NNGP = TRUE}. Datta et al. (2016) showed that 15 neighbors is usually + + \item{n.neighbors}{number of neighbors used in the NNGP. Only used if + \code{NNGP = TRUE}. Datta et al. (2016) showed that 15 neighbors is usually sufficient, but that as few as 5 neighbors can be adequate for certain data sets, which can lead to even greater decreases in run time. We recommend starting with 15 neighbors (the default) and if additional gains in computation time are desired, subsequently compare the results with a smaller number of neighbors using WAIC.} - + \item{search.type}{a quoted keyword that specifies the type of nearest neighbor search algorithm. Supported method key words are: \code{"cb"} and \code{"brute"}. The \code{"cb"} should generally be much faster. If locations do not have identical coordinate values on - the axis used for the nearest neighbor ordering then \code{"cb"} - and \code{"brute"} should produce identical neighbor sets. - However, if there are identical coordinate values on the axis used - for nearest neighbor ordering, then \code{"cb"} and \code{"brute"} - might produce different, but equally valid, neighbor sets, + the axis used for the nearest neighbor ordering then \code{"cb"} + and \code{"brute"} should produce identical neighbor sets. + However, if there are identical coordinate values on the axis used + for nearest neighbor ordering, then \code{"cb"} and \code{"brute"} + might produce different, but equally valid, neighbor sets, e.g., if data are on a grid. } - - \item{n.batch}{the number of MCMC batches in each chain to run for the adaptive MCMC + + \item{n.batch}{the number of MCMC batches in each chain to run for the adaptive MCMC sampler. See Roberts and Rosenthal (2009) for details.} - - \item{batch.length}{the length of each MCMC batch in each chain to run for the adaptive + + \item{batch.length}{the length of each MCMC batch in each chain to run for the adaptive MCMC sampler. See Roberts and Rosenthal (2009) for details.} - - \item{accept.rate}{target acceptance rate for adaptive MCMC. Default is + + \item{accept.rate}{target acceptance rate for adaptive MCMC. Default is 0.43. See Roberts and Rosenthal (2009) for details.} - \item{family}{the distribution to use for abundance. Currently, spatially-varying - coefficient models are available for \code{family = 'Gaussian'} and - \code{family = 'zi-Gaussian'}.} - + \item{family}{the distribution to use for the latent abundance process. Currently + supports \code{'NB'} (negative binomial), \code{'Poisson'}, \code{'Gaussian'}, + and \code{'zi-Gaussian'}. Default is Poisson.} + \item{n.omp.threads}{a positive integer indicating the number of threads to use for SMP parallel processing. The package must be compiled for OpenMP support. For most Intel-based machines, we recommend setting \code{n.omp.threads} up to the number of hyperthreaded cores. Note, \code{n.omp.threads} > 1 might not work on some systems.} - - \item{verbose}{if \code{TRUE}, messages about data preparation, - model specification, and progress of the sampler are printed to the screen. + + \item{verbose}{if \code{TRUE}, messages about data preparation, + model specification, and progress of the sampler are printed to the screen. Otherwise, no messages are printed.} - + \item{n.report}{the interval to report Metropolis sampler acceptance and MCMC progress.} - \item{n.burn}{the number of samples out of the total \code{n.batch * batch.length} - samples in each chain to discard as burn-in. By default, the first + \item{n.burn}{the number of samples out of the total \code{n.batch * batch.length} + samples in each chain to discard as burn-in. By default, the first 10\% of samples is discarded.} - + \item{n.thin}{the thinning interval for collection of MCMC samples. The - thinning occurs after the \code{n.burn} samples are discarded. Default + thinning occurs after the \code{n.burn} samples are discarded. Default value is set to 1.} \item{n.chains}{the number of MCMC chains to run in sequence.} + \item{save.fitted}{logical value indicating whether or not fitted values and likelihood values + should be saved in the resulting model object. If \code{save.fitted = FALSE}, the components + \code{y.rep.samples}, \code{mu.samples}, and \code{like.samples} will not be included + in the model object, and subsequent functions for calculating WAIC, fitted values, and + posterior predictive checks will not work, although they all can be calculated manually if + desired. Setting \code{save.fitted = FALSE} can be useful when working with very large + data sets to minimize the amount of RAM needed when fitting and storing the model object in + memory.} + \item{...}{currently no additional arguments} } @@ -174,13 +193,13 @@ svcAbund(formula, data, inits, priors, tuning, Hierarchical Nearest-Neighbor Gaussian process models for large geostatistical datasets. \emph{Journal of the American Statistical Association}, \doi{10.1080/01621459.2015.1044091}. - + Finley, A.O., A. Datta, B.D. Cook, D.C. Morton, H.E. Andersen, and S. Banerjee. (2019) Efficient algorithms for Bayesian Nearest Neighbor Gaussian Processes. \emph{Journal of Computational and Graphical Statistics}, \doi{10.1080/10618600.2018.1537924}. - Roberts, G.O. and Rosenthal J.S. (2009) Examples of adaptive MCMC. + Roberts, G.O. and Rosenthal J.S. (2009) Examples of adaptive MCMC. \emph{Journal of Computational and Graphical Statistics}, 18(2):349-367. } @@ -190,7 +209,7 @@ svcAbund(formula, data, inits, priors, tuning, } \value{ - An object of class \code{svcAbund} that is a list comprised of: + An object of class \code{svcAbund} that is a list comprised of: \item{beta.samples}{a \code{coda} object of posterior samples for the abundance regression coefficients.} @@ -198,13 +217,13 @@ svcAbund(formula, data, inits, priors, tuning, \item{tau.sq.samples}{a \code{coda} object of posterior samples for the residual variance parameter.} - \item{y.rep.samples}{a \code{coda} object of posterior samples - for the abundance replicate (fitted) values with dimensions - corresponding to MCMC samples and site.} + \item{y.rep.samples}{a two or three-dimensional object of posterior samples + for the abundance replicate (fitted) values with dimensions + corresponding to MCMC samples, site, and replicate.} - \item{mu.samples}{a \code{coda} object of posterior samples - for the expected abundance samples with dimensions corresponding - to MCMC samples and site.} + \item{mu.samples}{a two or -three-dimensional array of posterior samples + for the expected abundance samples with dimensions corresponding + to MCMC samples, site, and replicate.} \item{theta.samples}{a \code{coda} object of posterior samples for spatial covariance parameters.} @@ -214,12 +233,12 @@ svcAbund(formula, data, inits, priors, tuning, to MCMC sample, SVC, and site.} \item{sigma.sq.mu.samples}{a \code{coda} object of posterior samples - for variances of random effects included in the model. - Only included if random effects are specified in + for variances of random effects included in the model. + Only included if random effects are specified in \code{formula}.} \item{beta.star.samples}{a \code{coda} object of posterior samples - for the abundance random effects. Only included if random effects + for the abundance random effects. Only included if random effects are specified in \code{formula}.} \item{like.samples}{a \code{coda} object of posterior samples @@ -233,8 +252,8 @@ svcAbund(formula, data, inits, priors, tuning, \item{run.time}{execution time reported using \code{proc.time()}.} - The return object will include additional objects used for - subsequent prediction and/or model fit evaluation. + The return object will include additional objects used for + subsequent prediction and/or model fit evaluation. } \examples{ @@ -262,8 +281,8 @@ z <- rbinom(J, 1, 0.5) # Get all the data dat <- simAbund(J.x = J.x, J.y = J.y, beta = beta, tau.sq = tau.sq, - mu.RE = mu.RE, sp = sp, svc.cols = svc.cols, - family = 'zi-Gaussian', cov.model = cov.model, + mu.RE = mu.RE, sp = sp, svc.cols = svc.cols, + family = 'zi-Gaussian', cov.model = cov.model, sigma.sq = sigma.sq, phi = phi, z = z) # Get data in format for spAbundance -------------------------------------- y <- dat$y @@ -285,7 +304,7 @@ prior.list <- list(beta.normal = list(mean = 0, var = 1000), # Starting values inits.list <- list(beta = 0, alpha = 0, - sigma.sq = 1, phi = 3 / 0.5, + sigma.sq = 1, phi = 3 / 0.5, tau.sq = 2, sigma.sq.mu = 0.5) # Tuning tuning.list <- list(phi = 1) @@ -295,7 +314,7 @@ batch.length <- 25 n.burn <- 100 n.thin <- 1 -out <- svcAbund(formula = ~ cov.1 + cov.2 + cov.3 + +out <- svcAbund(formula = ~ cov.1 + cov.2 + cov.3 + (1 | factor.1) + (1 | factor.2), svc.cols = c(1, 2), data = data.list, diff --git a/man/svcMsAbund.Rd b/man/svcMsAbund.Rd index 8e92ae8..9802b8f 100644 --- a/man/svcMsAbund.Rd +++ b/man/svcMsAbund.Rd @@ -3,15 +3,15 @@ \title{Function for Fitting Spatially-Varying Coefficient Multivariate Abundance GLMMs} \description{ - The function \code{svcMsAbund} fits multivariate spatially-varying coefficient GLMs with species correlations (i.e., a spatially-explicit abundace-based joint species distribution model). We use a spatial factor modeling approach. Models are implemented using a Nearest Neighbor Gaussian Process. + The function \code{svcMsAbund} fits multivariate spatially-varying coefficient GLMs with species correlations (i.e., a spatially-explicit abundace-based joint species distribution model). We use a spatial factor modeling approach. Models are implemented using a Nearest Neighbor Gaussian Process. } \usage{ svcMsAbund(formula, data, inits, priors, tuning, - svc.cols = 1, cov.model = 'exponential', NNGP = TRUE, + svc.cols = 1, cov.model = 'exponential', NNGP = TRUE, n.neighbors = 15, search.type = 'cb', n.factors, n.batch, batch.length, accept.rate = 0.43, family = 'Gaussian', - n.omp.threads = 1, verbose = TRUE, n.report = 100, + n.omp.threads = 1, verbose = TRUE, n.report = 100, n.burn = round(.10 * n.batch * batch.length), n.thin = 1, n.chains = 1, ...) } @@ -24,144 +24,144 @@ svcMsAbund(formula, data, inits, priors, tuning, and slopes are allowed using lme4 syntax (Bates et al. 2015).} \item{data}{a list containing data necessary for model fitting. - Valid tags are \code{y}, \code{covs}, \code{coords}, and \code{z}. + Valid tags are \code{y}, \code{covs}, \code{coords}, and \code{z}. \code{y} is a matrix with sites corresponding to species and columns corresponding to sites. \code{covs} is a list, matrix, or data - frame of covariates used in the model, where each column (or list element) - represents a different covariate. \code{coords} is a - \eqn{J \times 2}{J x 2} matrix of the observation coordinates. Note that - \code{spAbundance} assumes coordinates are specified in a projected coordinate system. - For zero-inflated Gaussian models, the tag \code{z} is used to specify the + frame of covariates used in the model, where each column (or list element) + represents a different covariate. \code{coords} is a + \eqn{J \times 2}{J x 2} matrix of the observation coordinates. Note that + \code{spAbundance} assumes coordinates are specified in a projected coordinate system. + For zero-inflated Gaussian models, the tag \code{z} is used to specify the binary component of the model and should have the same dimensions as \code{y}.} \item{inits}{a list with each tag corresponding to a parameter name. - Valid tags are \code{beta.comm}, \code{beta}, - \code{tau.sq.beta}, \code{sigma.sq.mu}, - \code{phi}, \code{lambda}, \code{nu}, and \code{tau.sq}. \code{nu} is only specified if - \code{cov.model = "matern"}, \code{tau.sq} is only + Valid tags are \code{beta.comm}, \code{beta}, + \code{tau.sq.beta}, \code{sigma.sq.mu}, + \code{phi}, \code{lambda}, \code{nu}, and \code{tau.sq}. \code{nu} is only specified if + \code{cov.model = "matern"}, \code{tau.sq} is only specified for Gaussian and zero-inflated Gaussian models, - and \code{sigma.sq.mu} is only specified if random effects are included in \code{formula}. - The value portion of each tag is + and \code{sigma.sq.mu} is only specified if random effects are included in \code{formula}. + The value portion of each tag is the parameter's initial value. See \code{priors} description for definition - of each parameter name. Additionally, the tag \code{fix} can be set to \code{TRUE} + of each parameter name. Additionally, the tag \code{fix} can be set to \code{TRUE} to fix the starting values across all chains. If \code{fix} is not specified (the default), starting values are varied randomly across chains.} - \item{priors}{a list with each tag corresponding to a parameter name. - Valid tags are \code{beta.comm.normal}, \code{tau.sq.beta.ig}, \code{sigma.sq.mu}, - \code{phi.unif}, \code{nu.unif}, and \code{tau.sq.ig}. - Community-level (\code{beta.comm}) regression coefficients are assumed to follow a + \item{priors}{a list with each tag corresponding to a parameter name. + Valid tags are \code{beta.comm.normal}, \code{tau.sq.beta.ig}, \code{sigma.sq.mu}, + \code{phi.unif}, \code{nu.unif}, and \code{tau.sq.ig}. + Community-level (\code{beta.comm}) regression coefficients are assumed to follow a normal distribution. The hyperparameters of the normal distribution - are passed as a list of length two with the first and second elements - corresponding to the mean and variance of the normal distribution, - which are each specified as vectors of length equal to the number of - coefficients to be estimated or of length one if priors are the same for - all coefficients. If not specified, prior means are set - to 0 and prior variances to 100. Community-level variance parameters - (\code{tau.sq.beta}) are - assumed to follow an inverse Gamma distribution. The hyperparameters of - the inverse gamma distribution are passed as a list of length two with + are passed as a list of length two with the first and second elements + corresponding to the mean and variance of the normal distribution, + which are each specified as vectors of length equal to the number of + coefficients to be estimated or of length one if priors are the same for + all coefficients. If not specified, prior means are set + to 0 and prior variances to 100. Community-level variance parameters + (\code{tau.sq.beta}) are + assumed to follow an inverse Gamma distribution. The hyperparameters of + the inverse gamma distribution are passed as a list of length two with the first and second elements corresponding to the shape and scale parameters, - which are each specified as vectors of length equal to the number of - coefficients to be estimated or a single value if priors are the same for all - parameters. If not specified, prior shape and scale + which are each specified as vectors of length equal to the number of + coefficients to be estimated or a single value if priors are the same for all + parameters. If not specified, prior shape and scale parameters are set to 0.1. If desired, the species-specific regression coefficients - (\code{beta}) can also be estimated indepdendently by specifying the + (\code{beta}) can also be estimated indepdendently by specifying the tag \code{independent.betas = TRUE}. If specified, this will not estimate species-specific coefficients as random effects from a common-community-level distribution, and rather - the values of \code{beta.comm} and \code{tau.sq.beta} will be fixed at the + the values of \code{beta.comm} and \code{tau.sq.beta} will be fixed at the specified initial values. This is equivalent to specifying a Gaussian, independent - prior for each of the species-specific effects. + prior for each of the species-specific effects. The spatial factor model fits \code{n.factors} independent - spatial processes. The spatial decay \code{phi} and smoothness \code{nu} parameters - for each latent factor and spatially-varying coefficient - are assumed to follow Uniform distributions. - The hyperparameters of the Uniform are passed as a list with two elements, + spatial processes. The spatial decay \code{phi} and smoothness \code{nu} parameters + for each latent factor and spatially-varying coefficient + are assumed to follow Uniform distributions. + The hyperparameters of the Uniform are passed as a list with two elements, with both elements being vectors of length equal to the number of spatial factors - times the number of spatially-varying coefficients corresponding to the lower and + times the number of spatially-varying coefficients corresponding to the lower and upper support, respectively, or as a single value if the same value is assigned - for all factors and spatially-varying coefficients. + for all factors and spatially-varying coefficients. The priors for the factor loadings matrix \code{lambda} are fixed - following the standard spatial factor model to ensure parameter + following the standard spatial factor model to ensure parameter identifiability (Christensen and Amemlya 2002). The - upper triangular elements of the \code{n.sp x n.factors} matrix - for each spatially-varying coefficient are fixed at 0 and the - diagonal elements are fixed at 1. The lower triangular elements are assigned a + upper triangular elements of the \code{n.sp x n.factors} matrix + for each spatially-varying coefficient are fixed at 0 and the + diagonal elements are fixed at 1. The lower triangular elements are assigned a standard normal prior (i.e., mean 0 and variance 1). - \code{sigma.sq.mu} are the random + \code{sigma.sq.mu} are the random effect variances random effects, respectively, and are assumed to follow an inverse Gamma distribution. The hyperparameters of the inverse-Gamma distribution are passed as a list of length two with first and second elements corresponding to the shape and scale parameters, respectively, which are each specified as - vectors of length equal to the number of random intercepts or of length one - if priors are the same for all random effect variances. \code{tau.sq} is the - species-specific residual variance for Gaussian (or zero-inflated Gaussian) models, and it is assigned - an inverse-Gamma prior. The hyperparameters of the inverse-Gamma are passed as a list - of length two, with the first and second element corresponding to the shape and + vectors of length equal to the number of random intercepts or of length one + if priors are the same for all random effect variances. \code{tau.sq} is the + species-specific residual variance for Gaussian (or zero-inflated Gaussian) models, and it is assigned + an inverse-Gamma prior. The hyperparameters of the inverse-Gamma are passed as a list + of length two, with the first and second element corresponding to the shape and scale parameters, respectively, which are each specified as vectors of length equal to the number of species or a single value if priors are the same for all species.} -\item{tuning}{a single numeric value representing the initial variance of the - adaptive sampler for \code{phi} and \code{nu}. +\item{tuning}{a list with each tag corresponding to a parameter name, whose value defines + the initial tuning variance of the adaptive sampler for \code{phi} and \code{nu}. See Roberts and Rosenthal (2009) for details.} -\item{svc.cols}{a vector indicating the variables whose effects will be - estimated as spatially-varying coefficients. \code{svc.cols} can be an - integer vector with values indicating the order of covariates specified - in the model formula (with 1 being the intercept if specified), or it can - be specified as a character vector with names corresponding to variable +\item{svc.cols}{a vector indicating the variables whose effects will be + estimated as spatially-varying coefficients. \code{svc.cols} can be an + integer vector with values indicating the order of covariates specified + in the model formula (with 1 being the intercept if specified), or it can + be specified as a character vector with names corresponding to variable names in \code{occ.covs} (for the intercept, use \code{'(Intercept)'}). \code{svc.cols} - default argument of 1 results in a spatial factor model analogous to - \code{sfMsAbund} (assuming an intercept is included in the model).} + default argument of 1 results in a spatial factor model analogous to + \code{sfMsAbund} (assuming an intercept is included in the model).} \item{cov.model}{a quoted keyword that specifies the covariance function used to model the spatial dependence structure among the observations. Supported covariance model key words are: \code{"exponential"}, \code{"matern"}, \code{"spherical"}, and \code{"gaussian"}.} - - \item{NNGP}{if \code{TRUE}, model is fit with an NNGP. If \code{FALSE}, - a full Gaussian process is used. See Datta et al. (2016) and - Finley et al. (2019) for more information. For spatial factor models, only + + \item{NNGP}{if \code{TRUE}, model is fit with an NNGP. If \code{FALSE}, + a full Gaussian process is used. See Datta et al. (2016) and + Finley et al. (2019) for more information. For spatial factor models, only \code{NNGP = TRUE} is currently supported.} - - \item{n.neighbors}{number of neighbors used in the NNGP. Only used if - \code{NNGP = TRUE}. Datta et al. (2016) showed that 15 neighbors is usually + + \item{n.neighbors}{number of neighbors used in the NNGP. Only used if + \code{NNGP = TRUE}. Datta et al. (2016) showed that 15 neighbors is usually sufficient, but that as few as 5 neighbors can be adequate for certain data sets, which can lead to even greater decreases in run time. We recommend starting with 15 neighbors (the default) and if additional gains in computation time are desired, subsequently compare the results with a smaller number of neighbors using WAIC.} - + \item{search.type}{a quoted keyword that specifies the type of nearest neighbor search algorithm. Supported method key words are: \code{"cb"} and \code{"brute"}. The \code{"cb"} should generally be much faster. If locations do not have identical coordinate values on - the axis used for the nearest neighbor ordering then \code{"cb"} - and \code{"brute"} should produce identical neighbor sets. - However, if there are identical coordinate values on the axis used - for nearest neighbor ordering, then \code{"cb"} and \code{"brute"} - might produce different, but equally valid, neighbor sets, + the axis used for the nearest neighbor ordering then \code{"cb"} + and \code{"brute"} should produce identical neighbor sets. + However, if there are identical coordinate values on the axis used + for nearest neighbor ordering, then \code{"cb"} and \code{"brute"} + might produce different, but equally valid, neighbor sets, e.g., if data are on a grid. } \item{n.factors}{the number of factors to use in the spatial factor - model approach for each spatially-varying coefficient. - Typically, the number of factors is set to be small (e.g., 4-5) relative to the - total number of species in the community, which will lead to substantial - decreases in computation time. However, the value can be anywhere + model approach for each spatially-varying coefficient. + Typically, the number of factors is set to be small (e.g., 4-5) relative to the + total number of species in the community, which will lead to substantial + decreases in computation time. However, the value can be anywhere between 1 and the number of species in the modeled community.} - \item{n.batch}{the number of MCMC batches in each chain to run for the adaptive MCMC + \item{n.batch}{the number of MCMC batches in each chain to run for the adaptive MCMC sampler. See Roberts and Rosenthal (2009) for details.} - - \item{batch.length}{the length of each MCMC batch to run for the adaptive + + \item{batch.length}{the length of each MCMC batch to run for the adaptive MCMC sampler. See Roberts and Rosenthal (2009) for details.} - - \item{accept.rate}{target acceptance rate for adaptive MCMC. Default is + + \item{accept.rate}{target acceptance rate for adaptive MCMC. Default is 0.43. See Roberts and Rosenthal (2009) for details.} - \item{family}{the distribution to use for abundance. Currently, spatially-varying - coefficient models are available for \code{family = 'Gaussian'} and + \item{family}{the distribution to use for abundance. Currently, spatially-varying + coefficient models are available for \code{family = 'Gaussian'} and \code{family = 'zi-Gaussian'}.} \item{n.omp.threads}{a positive integer indicating @@ -170,20 +170,20 @@ svcMsAbund(formula, data, inits, priors, tuning, recommend setting \code{n.omp.threads} up to the number of hyperthreaded cores. Note, \code{n.omp.threads} > 1 might not work on some systems.} - - \item{verbose}{if \code{TRUE}, messages about data preparation, - model specification, and progress of the sampler are printed to the screen. + + \item{verbose}{if \code{TRUE}, messages about data preparation, + model specification, and progress of the sampler are printed to the screen. Otherwise, no messages are printed.} - + \item{n.report}{the interval to report Metropolis sampler acceptance and MCMC progress. Note this is specified in terms of batches and not overall samples for spatial models.} - \item{n.burn}{the number of samples out of the total \code{n.samples} to + \item{n.burn}{the number of samples out of the total \code{n.samples} to discard as burn-in for each chain. By default, the first 10\% of samples is discarded.} - + \item{n.thin}{the thinning interval for collection of MCMC samples. The - thinning occurs after the \code{n.burn} samples are discarded. Default + thinning occurs after the \code{n.burn} samples are discarded. Default value is set to 1.} \item{n.chains}{the number of chains to run in sequence.} @@ -209,8 +209,8 @@ svcMsAbund(formula, data, inits, priors, tuning, Fitting Linear Mixed-Effects Models Using lme4. Journal of Statistical Software, 67(1), 1-48. \doi{10.18637/jss.v067.i01}. - Christensen, W. F., and Amemiya, Y. (2002). Latent variable analysis - of multivariate spatial data. \emph{Journal of the American Statistical Association}, + Christensen, W. F., and Amemiya, Y. (2002). Latent variable analysis + of multivariate spatial data. \emph{Journal of the American Statistical Association}, 97(457), 302-317. } @@ -221,11 +221,11 @@ svcMsAbund(formula, data, inits, priors, tuning, } \value{ - An object of class \code{svcMsAbund} that is a list comprised of: + An object of class \code{svcMsAbund} that is a list comprised of: \item{beta.comm.samples}{a \code{coda} object of posterior samples for the community level regression coefficients.} - + \item{tau.sq.beta.samples}{a \code{coda} object of posterior samples for the abundance community variance parameters.} @@ -250,22 +250,22 @@ svcMsAbund(formula, data, inits, priors, tuning, the expected abundance values for each species with dimensions corresponding to MCMC samples, species, site, and replicate.} - \item{w.samples}{a four-dimensional array of posterior samples for - the latent spatial random effects for each spatial factor within each - spatially-varying coefficient. Dimensions correspond to MCMC sample, + \item{w.samples}{a four-dimensional array of posterior samples for + the latent spatial random effects for each spatial factor within each + spatially-varying coefficient. Dimensions correspond to MCMC sample, factor, site, and spatially-varying coefficient.} \item{sigma.sq.mu.samples}{a \code{coda} object of posterior samples for variances of random effects included in the abundance portion - of the model. Only included if random effects are specified in + of the model. Only included if random effects are specified in \code{abund.formula}.} \item{beta.star.samples}{a \code{coda} object of posterior samples - for the abundance random effects. Only included if random effects + for the abundance random effects. Only included if random effects are specified in \code{abund.formula}.} \item{like.samples}{a three-dimensional array of posterior samples - for the likelihood value associated with each site and species. + for the likelihood value associated with each site and species. Used for calculating WAIC.} \item{rhat}{a list of Gelman-Rubin diagnostic values for some of the model @@ -275,8 +275,8 @@ svcMsAbund(formula, data, inits, priors, tuning, \item{run.time}{MCMC sampler execution time reported using \code{proc.time()}.} - The return object will include additional objects used for - subsequent prediction and/or model fit evaluation. + The return object will include additional objects used for + subsequent prediction and/or model fit evaluation. } \examples{ @@ -297,7 +297,7 @@ beta <- matrix(NA, nrow = n.sp, ncol = p.abund) for (i in 1:p.abund) { beta[, i] <- rnorm(n.sp, beta.mean[i], sqrt(tau.sq.beta[i])) } -sp <- TRUE +sp <- TRUE svc.cols <- c(1, 2) n.factors <- 2 q.p.svc <- length(svc.cols) * n.factors @@ -307,10 +307,10 @@ tau.sq <- runif(n.sp, 0.1, 5) cov.model <- 'exponential' family <- 'Gaussian' -dat <- simMsAbund(J.x = J.x, J.y = J.y, n.rep = n.rep, n.sp = n.sp, beta = beta, - mu.RE = mu.RE, sp = sp, tau.sq = tau.sq, family = family, - factor.model = factor.model, phi = phi, - cov.model = cov.model, n.factors = n.factors, +dat <- simMsAbund(J.x = J.x, J.y = J.y, n.rep = n.rep, n.sp = n.sp, beta = beta, + mu.RE = mu.RE, sp = sp, tau.sq = tau.sq, family = family, + factor.model = factor.model, phi = phi, + cov.model = cov.model, n.factors = n.factors, svc.cols = svc.cols) y <- dat$y @@ -321,11 +321,11 @@ covs <- data.frame(abund.cov.1 = X[, 2], abund.cov.2 = X[, 3]) data.list <- list(y = y, covs = covs, coords = coords) prior.list <- list(beta.comm.normal = list(mean = 0, var = 100), - tau.sq.ig = list(a = 2, b = 2), - phi.unif = list(a = 3 / 1, b = 3 / .1), - tau.sq.beta.ig = list(a = .1, b = .1)) -inits.list <- list(beta.comm = 0, - beta = 0, + tau.sq.ig = list(a = 2, b = 2), + phi.unif = list(a = 3 / 1, b = 3 / .1), + tau.sq.beta.ig = list(a = .1, b = .1)) +inits.list <- list(beta.comm = 0, + beta = 0, tau.sq = 1, tau.sq.beta = 1, phi = 3 / 0.5) @@ -338,23 +338,23 @@ n.thin <- 1 n.chains <- 1 out <- svcMsAbund(formula = ~ abund.cov.1 + abund.cov.2, - data = data.list, - n.batch = n.batch, - inits = inits.list, - priors = prior.list, + data = data.list, + n.batch = n.batch, + inits = inits.list, + priors = prior.list, tuning = tuning.list, - NNGP = TRUE, + NNGP = TRUE, svc.cols = c(1, 2), family = 'Gaussian', - cov.model = 'exponential', - n.neighbors = 5, - n.factors = n.factors, - batch.length = batch.length, + cov.model = 'exponential', + n.neighbors = 5, + n.factors = n.factors, + batch.length = batch.length, n.omp.threads = 1, - verbose = TRUE, - n.report = 20, - n.burn = n.burn, - n.thin = n.thin, + verbose = TRUE, + n.report = 20, + n.burn = n.burn, + n.thin = n.thin, n.chains = n.chains) summary(out) } diff --git a/spAbundance.Rproj b/spAbundance.Rproj index 398aa14..5caa49b 100644 --- a/spAbundance.Rproj +++ b/spAbundance.Rproj @@ -1,20 +1,20 @@ -Version: 1.0 - -RestoreWorkspace: Default -SaveWorkspace: Default -AlwaysSaveHistory: Default - -EnableCodeIndexing: Yes -UseSpacesForTab: Yes -NumSpacesForTab: 2 -Encoding: UTF-8 - -RnwWeave: knitr -LaTeX: pdfLaTeX - -AutoAppendNewline: Yes -StripTrailingWhitespace: Yes - -BuildType: Package -PackageUseDevtools: Yes -PackageInstallArgs: --no-multiarch --with-keep.source +Version: 1.0 + +RestoreWorkspace: Default +SaveWorkspace: Default +AlwaysSaveHistory: Default + +EnableCodeIndexing: Yes +UseSpacesForTab: Yes +NumSpacesForTab: 2 +Encoding: UTF-8 + +RnwWeave: knitr +LaTeX: pdfLaTeX + +AutoAppendNewline: Yes +StripTrailingWhitespace: Yes + +BuildType: Package +PackageUseDevtools: Yes +PackageInstallArgs: --no-multiarch --with-keep.source diff --git a/src/init.cpp b/src/init.cpp index a63cce5..695f241 100644 --- a/src/init.cpp +++ b/src/init.cpp @@ -9,7 +9,7 @@ static const R_CallMethodDef CallEntries[] = { {"abundGaussian", (DL_FUNC) &abundGaussian, 26}, {"spAbundNNGP", (DL_FUNC) &spAbundNNGP, 48}, {"spAbundGaussianNNGP", (DL_FUNC) &spAbundGaussianNNGP, 46}, - {"spAbundNNGPPredict", (DL_FUNC) &spAbundNNGPPredict, 24}, + {"svcAbundNNGPPredict", (DL_FUNC) &svcAbundNNGPPredict, 26}, {"msAbund", (DL_FUNC) &msAbund, 34}, {"msAbundGaussian", (DL_FUNC) &msAbundGaussian, 33}, {"lfMsAbund", (DL_FUNC) &lfMsAbund, 36}, @@ -32,8 +32,9 @@ static const R_CallMethodDef CallEntries[] = { {"waicAbund", (DL_FUNC) &waicAbund, 13}, {"checkAlphaDS", (DL_FUNC) &checkAlphaDS, 20}, {"checkMSAlphaDS", (DL_FUNC) &checkMSAlphaDS, 20}, - {"svcAbundNNGP", (DL_FUNC) &svcAbundNNGP, 46}, - {"svcAbundNNGPPredict", (DL_FUNC) &svcAbundNNGPPredict, 25}, + {"svcAbundNNGP", (DL_FUNC) &svcAbundNNGP, 48}, + {"svcAbundGaussianNNGP", (DL_FUNC) &svcAbundNNGP, 46}, + {"svcAbundGaussianNNGPPredict", (DL_FUNC) &svcAbundGaussianNNGPPredict, 25}, {"svcMsAbundGaussianNNGP", (DL_FUNC) &svcMsAbundGaussianNNGP, 50}, {"svcMsAbundGaussianNNGPPredict", (DL_FUNC) &svcMsAbundGaussianNNGPPredict, 27}, {NULL, NULL, 0} diff --git a/src/spAbundNNGPPredict.cpp b/src/spAbundNNGPPredict.cpp deleted file mode 100644 index 0522ad3..0000000 --- a/src/spAbundNNGPPredict.cpp +++ /dev/null @@ -1,267 +0,0 @@ -#define USE_FC_LEN_T -#include -#include "util.h" - -#ifdef _OPENMP -#include -#endif - -#define R_NO_REMAP -#include -#include -#include -#include -#include -#include -#ifndef FCONE -# define FCONE -#endif - -extern "C" { - - SEXP spAbundNNGPPredict(SEXP coords_r, SEXP J_r, SEXP nObs_r, - SEXP pAbund_r, SEXP m_r, SEXP X0_r, SEXP coords0_r, - SEXP J0_r, SEXP nObs0_r, - SEXP sitesLink_r, SEXP sites0Sampled_r, SEXP sites0_r, - SEXP nnIndx0_r, SEXP betaSamples_r, - SEXP thetaSamples_r, SEXP wSamples_r, - SEXP betaStarSiteSamples_r, SEXP kappaSamples_r, SEXP nSamples_r, - SEXP covModel_r, SEXP nThreads_r, SEXP verbose_r, - SEXP nReport_r, SEXP family_r){ - - int i, k, l, s, info, nProtect=0; - const int inc = 1; - const double one = 1.0; - const double zero = 0.0; - char const *lower = "L"; - - double *coords = REAL(coords_r); - int J = INTEGER(J_r)[0]; - int pAbund = INTEGER(pAbund_r)[0]; - - double *X0 = REAL(X0_r); - double *coords0 = REAL(coords0_r); - int J0 = INTEGER(J0_r)[0]; - int nObs0 = INTEGER(nObs0_r)[0]; - int m = INTEGER(m_r)[0]; - int mm = m * m; - int *sitesLink = INTEGER(sitesLink_r); - int *sites0Sampled = INTEGER(sites0Sampled_r); - int *sites0 = INTEGER(sites0_r); - - int *nnIndx0 = INTEGER(nnIndx0_r); - double *beta = REAL(betaSamples_r); - double *theta = REAL(thetaSamples_r); - double *w = REAL(wSamples_r); - double *betaStarSite = REAL(betaStarSiteSamples_r); - double *kappa = REAL(kappaSamples_r); - int family = INTEGER(family_r)[0]; - - int nSamples = INTEGER(nSamples_r)[0]; - int covModel = INTEGER(covModel_r)[0]; - std::string corName = getCorName(covModel); - int nThreads = INTEGER(nThreads_r)[0]; - int verbose = INTEGER(verbose_r)[0]; - int nReport = INTEGER(nReport_r)[0]; - -#ifdef _OPENMP - omp_set_num_threads(nThreads); -#else - if(nThreads > 1){ - Rf_warning("n.omp.threads > %i, but source not compiled with OpenMP support.", nThreads); - nThreads = 1; - } -#endif - - if(verbose){ - Rprintf("----------------------------------------\n"); - Rprintf("\tPrediction description\n"); - Rprintf("----------------------------------------\n"); - Rprintf("NNGP spatial GLMM fit with %i observations.\n\n", J); - Rprintf("Number of covariates %i (including intercept if specified).\n\n", pAbund); - Rprintf("Using the %s spatial correlation model.\n\n", corName.c_str()); - Rprintf("Using %i nearest neighbors.\n\n", m); - Rprintf("Number of MCMC samples %i.\n\n", nSamples); - Rprintf("Predicting at %i locations.\n", J0); -#ifdef _OPENMP - Rprintf("\nSource compiled with OpenMP support and model fit using %i threads.\n", nThreads); -#else - Rprintf("\n\nSource not compiled with OpenMP support.\n"); -#endif - } - - // parameters - int nTheta, sigmaSqIndx, phiIndx, nuIndx; - - if (corName != "matern") { - nTheta = 2; //sigma^2, phi - sigmaSqIndx = 0; phiIndx = 1; - } else{ - nTheta = 3; //sigma^2, phi, nu - sigmaSqIndx = 0; phiIndx = 1; nuIndx = 2; - } - - // get max nu - double nuMax = 0; - int nb = 0; - - if(corName == "matern"){ - for(i = 0; i < nSamples; i++){ - if(theta[i*nTheta+nuIndx] > nuMax){ - nuMax = theta[i*nTheta+nuIndx]; - } - } - - nb = 1+static_cast(floor(nuMax)); - } - - double *bk = (double *) R_alloc(nThreads*nb, sizeof(double)); - - double *C = (double *) R_alloc(nThreads*mm, sizeof(double)); zeros(C, nThreads*mm); - double *c = (double *) R_alloc(nThreads*m, sizeof(double)); zeros(c, nThreads*m); - double *tmp_m = (double *) R_alloc(nThreads*m, sizeof(double)); - double phi = 0, nu = 0, sigmaSq = 0, d; - int threadID = 0, status = 0; - - SEXP y0_r, w0_r, mu0_r; - PROTECT(y0_r = Rf_allocMatrix(REALSXP, nObs0, nSamples)); nProtect++; - PROTECT(mu0_r = Rf_allocMatrix(REALSXP, nObs0, nSamples)); nProtect++; - PROTECT(w0_r = Rf_allocMatrix(REALSXP, J0, nSamples)); nProtect++; - double *y0 = REAL(y0_r); - double *mu0 = REAL(mu0_r); - double *w0 = REAL(w0_r); - - if (verbose) { - Rprintf("-------------------------------------------------\n"); - Rprintf("\t\tPredicting\n"); - Rprintf("-------------------------------------------------\n"); - #ifdef Win32 - R_FlushConsole(); - #endif - } - - int vIndx = -1; - double *wV = (double *) R_alloc(J0*nSamples, sizeof(double)); - - GetRNGstate(); - - for(i = 0; i < J0*nSamples; i++){ - wV[i] = rnorm(0.0,1.0); - } - - for(i = 0; i < J0; i++){ -#ifdef _OPENMP -#pragma omp parallel for private(threadID, phi, nu, sigmaSq, k, l, d, info) -#endif - for(s = 0; s < nSamples; s++){ -#ifdef _OPENMP - threadID = omp_get_thread_num(); -#endif - if (sites0Sampled[i] == 1) { - w0[s * J0 + i] = w[s * J + sitesLink[i]]; - } else { - phi = theta[s*nTheta+phiIndx]; - if(corName == "matern"){ - nu = theta[s*nTheta+nuIndx]; - } - sigmaSq = theta[s*nTheta+sigmaSqIndx]; - - for(k = 0; k < m; k++){ - d = dist2(coords[nnIndx0[i+J0*k]], coords[J+nnIndx0[i+J0*k]], coords0[i], coords0[J0+i]); - c[threadID*m+k] = sigmaSq*spCor(d, phi, nu, covModel, &bk[threadID*nb]); - for(l = 0; l < m; l++){ - d = dist2(coords[nnIndx0[i+J0*k]], coords[J+nnIndx0[i+J0*k]], coords[nnIndx0[i+J0*l]], coords[J+nnIndx0[i+J0*l]]); - C[threadID*mm+l*m+k] = sigmaSq*spCor(d, phi, nu, covModel, &bk[threadID*nb]); - } - } - - F77_NAME(dpotrf)(lower, &m, &C[threadID*mm], &m, &info FCONE); - if(info != 0){Rf_error("c++ error: dpotrf failed\n");} - F77_NAME(dpotri)(lower, &m, &C[threadID*mm], &m, &info FCONE); - if(info != 0){Rf_error("c++ error: dpotri failed\n");} - - F77_NAME(dsymv)(lower, &m, &one, &C[threadID*mm], &m, &c[threadID*m], &inc, &zero, &tmp_m[threadID*m], &inc FCONE); - - d = 0; - for(k = 0; k < m; k++){ - d += tmp_m[threadID*m+k]*w[s*J+nnIndx0[i+J0*k]]; - } - - #ifdef _OPENMP - #pragma omp atomic - #endif - vIndx++; - - w0[s*J0+i] = sqrt(sigmaSq - F77_NAME(ddot)(&m, &tmp_m[threadID*m], &inc, &c[threadID*m], &inc))*wV[vIndx] + d; - - } - } - - if(verbose){ - if(status == nReport){ - Rprintf("Location: %i of %i, %3.2f%%\n", i, J0, 100.0*i/J0); - #ifdef Win32 - R_FlushConsole(); - #endif - status = 0; - } - } - status++; - R_CheckUserInterrupt(); - } - - if(verbose){ - Rprintf("Location: %i of %i, %3.2f%%\n", i, J0, 100.0*i/J0); - #ifdef Win32 - R_FlushConsole(); - #endif - } - - // Generate abundance after the fact. - // Temporary fix. Will embed this in the above loop at some point. - if (verbose) { - Rprintf("Generating abundance predictions\n"); - } - for(i = 0; i < nObs0; i++){ - for(s = 0; s < nSamples; s++){ - mu0[s*nObs0+i] = exp(F77_NAME(ddot)(&pAbund, &X0[i], &nObs0, &beta[s*pAbund], &inc) + - w0[s*J0+sites0[i]] + - betaStarSite[s * nObs0 + i]); - if (family == 1) { - y0[s * nObs0 + i] = rnbinom_mu(kappa[s], mu0[s * nObs0 + i]); - } else { - y0[s * nObs0 + i] = rpois(mu0[s * nObs0 + i]); - } - } // s - } // i - - PutRNGstate(); - - - //make return object - SEXP result_r, resultName_r; - int nResultListObjs = 3; - - PROTECT(result_r = Rf_allocVector(VECSXP, nResultListObjs)); nProtect++; - PROTECT(resultName_r = Rf_allocVector(VECSXP, nResultListObjs)); nProtect++; - - SET_VECTOR_ELT(result_r, 0, y0_r); - SET_VECTOR_ELT(resultName_r, 0, Rf_mkChar("y.0.samples")); - - SET_VECTOR_ELT(result_r, 1, w0_r); - SET_VECTOR_ELT(resultName_r, 1, Rf_mkChar("w.0.samples")); - - SET_VECTOR_ELT(result_r, 2, mu0_r); - SET_VECTOR_ELT(resultName_r, 2, Rf_mkChar("mu.0.samples")); - - Rf_namesgets(result_r, resultName_r); - - //unprotect - UNPROTECT(nProtect); - - return(result_r); - - } -} - - diff --git a/src/spAbundance.h b/src/spAbundance.h index e1832c1..73aec97 100644 --- a/src/spAbundance.h +++ b/src/spAbundance.h @@ -4,44 +4,44 @@ extern "C" { SEXP abund(SEXP y_r, SEXP X_r, SEXP XRE_r, SEXP XRandom_r, - SEXP consts_r,SEXP nAbundRELong_r, - SEXP betaStarting_r, SEXP kappaStarting_r, - SEXP sigmaSqMuStarting_r, SEXP betaStarStarting_r, - SEXP siteIndx_r, SEXP betaStarIndx_r, SEXP betaLevelIndx_r, - SEXP muBeta_r, SEXP SigmaBeta_r, - SEXP kappaA_r, SEXP kappaB_r, SEXP sigmaSqMuA_r, + SEXP consts_r,SEXP nAbundRELong_r, + SEXP betaStarting_r, SEXP kappaStarting_r, + SEXP sigmaSqMuStarting_r, SEXP betaStarStarting_r, + SEXP siteIndx_r, SEXP betaStarIndx_r, SEXP betaLevelIndx_r, + SEXP muBeta_r, SEXP SigmaBeta_r, + SEXP kappaA_r, SEXP kappaB_r, SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, SEXP tuning_r, - SEXP nBatch_r, SEXP batchLength_r, SEXP acceptRate_r, SEXP nThreads_r, + SEXP nBatch_r, SEXP batchLength_r, SEXP acceptRate_r, SEXP nThreads_r, SEXP verbose_r, SEXP nReport_r, SEXP samplesInfo_r, SEXP chainInfo_r, SEXP family_r, SEXP offset_r); SEXP abundGaussian(SEXP y_r, SEXP X_r, SEXP XRE_r, SEXP XRandom_r, - SEXP consts_r, SEXP nRELong_r, + SEXP consts_r, SEXP nRELong_r, SEXP betaStarting_r, SEXP tauSqStarting_r, SEXP sigmaSqMuStarting_r, - SEXP betaStarStarting_r, - SEXP betaStarIndx_r, SEXP betaLevelIndx_r, - SEXP muBeta_r, SEXP SigmaBeta_r, - SEXP tauSqA_r, SEXP tauSqB_r, - SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, SEXP nBatch_r, - SEXP batchLength_r, SEXP acceptRate_r, SEXP nThreads_r, SEXP verbose_r, + SEXP betaStarStarting_r, + SEXP betaStarIndx_r, SEXP betaLevelIndx_r, + SEXP muBeta_r, SEXP SigmaBeta_r, + SEXP tauSqA_r, SEXP tauSqB_r, + SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, SEXP nBatch_r, + SEXP batchLength_r, SEXP acceptRate_r, SEXP nThreads_r, SEXP verbose_r, SEXP nReport_r, SEXP samplesInfo_r, SEXP chainInfo_r); - SEXP spAbundNNGP(SEXP y_r, SEXP X_r, SEXP coords_r, SEXP XRE_r, - SEXP XRandom_r, SEXP consts_r, SEXP nAbundRELong_r, - SEXP m_r, SEXP nnIndx_r, + SEXP spAbundNNGP(SEXP y_r, SEXP X_r, SEXP coords_r, SEXP XRE_r, + SEXP XRandom_r, SEXP consts_r, SEXP nAbundRELong_r, + SEXP m_r, SEXP nnIndx_r, SEXP nnIndxLU_r, SEXP uIndx_r, SEXP uIndxLU_r, SEXP betaStarting_r, SEXP kappaStarting_r, - SEXP sigmaSqMuStarting_r, SEXP betaStarStarting_r, - SEXP wStarting_r, SEXP phiStarting_r, SEXP sigmaSqStarting_r, + SEXP sigmaSqMuStarting_r, SEXP betaStarStarting_r, + SEXP wStarting_r, SEXP phiStarting_r, SEXP sigmaSqStarting_r, SEXP nuStarting_r, - SEXP siteIndx_r, SEXP betaStarIndx_r, SEXP betaLevelIndx_r, - SEXP muBeta_r, SEXP SigmaBeta_r, + SEXP siteIndx_r, SEXP betaStarIndx_r, SEXP betaLevelIndx_r, + SEXP muBeta_r, SEXP SigmaBeta_r, SEXP kappaA_r, SEXP kappaB_r, - SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, - SEXP phiA_r, SEXP phiB_r, + SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, + SEXP phiA_r, SEXP phiB_r, SEXP sigmaSqA_r, SEXP sigmaSqB_r, SEXP nuA_r, SEXP nuB_r, SEXP tuning_r, SEXP covModel_r, - SEXP nBatch_r, SEXP batchLength_r, SEXP acceptRate_r, SEXP nThreads_r, + SEXP nBatch_r, SEXP batchLength_r, SEXP acceptRate_r, SEXP nThreads_r, SEXP verbose_r, SEXP nReport_r, SEXP samplesInfo_r, SEXP chainInfo_r, SEXP sigmaSqIG_r, SEXP family_r, SEXP offset_r); @@ -63,303 +63,303 @@ extern "C" { SEXP nReport_r, SEXP samplesInfo_r, SEXP chainInfo_r, SEXP sigmaSqIG_r); - SEXP spAbundNNGPPredict(SEXP coords_r, SEXP J_r, SEXP nObs_r, - SEXP pAbund_r, SEXP m_r, SEXP X0_r, SEXP coords0_r, - SEXP J0_r, SEXP nObs0_r, - SEXP sitesLink_r, SEXP sites0Sampled_r, SEXP sites0_r, - SEXP nnIndx0_r, SEXP betaSamples_r, - SEXP thetaSamples_r, SEXP wSamples_r, - SEXP betaStarSiteSamples_r, SEXP kappaSamples_r, SEXP nSamples_r, - SEXP covModel_r, SEXP nThreads_r, SEXP verbose_r, - SEXP nReport_r, SEXP family_r); - - SEXP msAbund(SEXP y_r, SEXP X_r, SEXP XRE_r, SEXP XRandom_r, - SEXP consts_r, SEXP nAbundRELong_r, - SEXP betaStarting_r, SEXP kappaStarting_r, - SEXP betaCommStarting_r, SEXP tauSqBetaStarting_r, - SEXP sigmaSqMuStarting_r, SEXP betaStarStarting_r, - SEXP siteIndx_r, SEXP betaStarIndx_r, SEXP betaLevelIndx_r, - SEXP muBetaComm_r, SEXP SigmaBetaComm_r, SEXP kappaA_r, - SEXP kappaB_r, SEXP tauSqBetaA_r, SEXP tauSqBetaB_r, - SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, SEXP tuning_r, + SEXP svcAbundNNGPPredict(SEXP coords_r, SEXP J_r, SEXP nObs_r, + SEXP pAbund_r, SEXP pTilde_r, SEXP m_r, SEXP X0_r, SEXP Xw0_r, + SEXP coords0_r, SEXP J0_r, SEXP nObs0_r, + SEXP sitesLink_r, SEXP sites0Sampled_r, SEXP sites0_r, + SEXP nnIndx0_r, SEXP betaSamples_r, + SEXP thetaSamples_r, SEXP wSamples_r, + SEXP betaStarSiteSamples_r, SEXP kappaSamples_r, SEXP nSamples_r, + SEXP covModel_r, SEXP nThreads_r, SEXP verbose_r, + SEXP nReport_r, SEXP family_r); + + SEXP msAbund(SEXP y_r, SEXP X_r, SEXP XRE_r, SEXP XRandom_r, + SEXP consts_r, SEXP nAbundRELong_r, + SEXP betaStarting_r, SEXP kappaStarting_r, + SEXP betaCommStarting_r, SEXP tauSqBetaStarting_r, + SEXP sigmaSqMuStarting_r, SEXP betaStarStarting_r, + SEXP siteIndx_r, SEXP betaStarIndx_r, SEXP betaLevelIndx_r, + SEXP muBetaComm_r, SEXP SigmaBetaComm_r, SEXP kappaA_r, + SEXP kappaB_r, SEXP tauSqBetaA_r, SEXP tauSqBetaB_r, + SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, SEXP tuning_r, SEXP nBatch_r, SEXP batchLength_r, SEXP acceptRate_r, - SEXP nThreads_r, SEXP verbose_r, SEXP nReport_r, + SEXP nThreads_r, SEXP verbose_r, SEXP nReport_r, SEXP samplesInfo_r, SEXP chainInfo_r, SEXP family_r, SEXP offset_r); SEXP msAbundGaussian(SEXP y_r, SEXP X_r, SEXP XRE_r, - SEXP XRandom_r, SEXP consts_r, SEXP nRELong_r, - SEXP betaStarting_r, SEXP betaCommStarting_r, + SEXP XRandom_r, SEXP consts_r, SEXP nRELong_r, + SEXP betaStarting_r, SEXP betaCommStarting_r, SEXP tauSqBetaStarting_r, SEXP tauSqStarting_r, - SEXP sigmaSqMuStarting_r, SEXP betaStarStarting_r, - SEXP betaStarIndx_r, SEXP betaLevelIndx_r, - SEXP muBetaComm_r, SEXP SigmaBetaComm_r, SEXP tauSqBetaA_r, + SEXP sigmaSqMuStarting_r, SEXP betaStarStarting_r, + SEXP betaStarIndx_r, SEXP betaLevelIndx_r, + SEXP muBetaComm_r, SEXP SigmaBetaComm_r, SEXP tauSqBetaA_r, SEXP tauSqBetaB_r, SEXP tauSqA_r, SEXP tauSqB_r, - SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, - SEXP tuning_r, SEXP nBatch_r, SEXP batchLength_r, - SEXP acceptRate_r, SEXP nThreads_r, - SEXP verbose_r, SEXP nReport_r, + SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, + SEXP tuning_r, SEXP nBatch_r, SEXP batchLength_r, + SEXP acceptRate_r, SEXP nThreads_r, + SEXP verbose_r, SEXP nReport_r, SEXP samplesInfo_r, SEXP chainInfo_r, SEXP z_r, SEXP family_r); SEXP lfMsAbund(SEXP y_r, SEXP X_r, SEXP XRE_r, SEXP XRandom_r, - SEXP consts_r, SEXP nAbundRELong_r, - SEXP betaStarting_r, SEXP kappaStarting_r, SEXP betaCommStarting_r, + SEXP consts_r, SEXP nAbundRELong_r, + SEXP betaStarting_r, SEXP kappaStarting_r, SEXP betaCommStarting_r, SEXP tauSqBetaStarting_r, SEXP lambdaStarting_r, SEXP wStarting_r, - SEXP sigmaSqMuStarting_r, SEXP betaStarStarting_r, - SEXP siteIndx_r, SEXP betaStarIndx_r, SEXP betaLevelIndx_r, - SEXP muBetaComm_r, SEXP SigmaBetaComm_r, SEXP kappaA_r, - SEXP kappaB_r, SEXP tauSqBetaA_r, SEXP tauSqBetaB_r, - SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, SEXP tuning_r, + SEXP sigmaSqMuStarting_r, SEXP betaStarStarting_r, + SEXP siteIndx_r, SEXP betaStarIndx_r, SEXP betaLevelIndx_r, + SEXP muBetaComm_r, SEXP SigmaBetaComm_r, SEXP kappaA_r, + SEXP kappaB_r, SEXP tauSqBetaA_r, SEXP tauSqBetaB_r, + SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, SEXP tuning_r, SEXP nBatch_r, SEXP batchLength_r, SEXP acceptRate_r, - SEXP nThreads_r, SEXP verbose_r, SEXP nReport_r, + SEXP nThreads_r, SEXP verbose_r, SEXP nReport_r, SEXP samplesInfo_r, SEXP chainInfo_r, SEXP family_r, SEXP offset_r); SEXP lfMsAbundGaussian(SEXP y_r, SEXP X_r, SEXP XRE_r, - SEXP XRandom_r, SEXP consts_r, SEXP nRELong_r, - SEXP betaStarting_r, SEXP betaCommStarting_r, + SEXP XRandom_r, SEXP consts_r, SEXP nRELong_r, + SEXP betaStarting_r, SEXP betaCommStarting_r, SEXP tauSqBetaStarting_r, SEXP tauSqStarting_r, SEXP lambdaStarting_r, SEXP wStarting_r, - SEXP sigmaSqMuStarting_r, SEXP betaStarStarting_r, - SEXP betaStarIndx_r, SEXP betaLevelIndx_r, - SEXP muBetaComm_r, SEXP SigmaBetaComm_r, SEXP tauSqBetaA_r, + SEXP sigmaSqMuStarting_r, SEXP betaStarStarting_r, + SEXP betaStarIndx_r, SEXP betaLevelIndx_r, + SEXP muBetaComm_r, SEXP SigmaBetaComm_r, SEXP tauSqBetaA_r, SEXP tauSqBetaB_r, SEXP tauSqA_r, SEXP tauSqB_r, - SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, - SEXP tuning_r, SEXP nBatch_r, SEXP batchLength_r, - SEXP acceptRate_r, SEXP nThreads_r, - SEXP verbose_r, SEXP nReport_r, + SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, + SEXP tuning_r, SEXP nBatch_r, SEXP batchLength_r, + SEXP acceptRate_r, SEXP nThreads_r, + SEXP verbose_r, SEXP nReport_r, SEXP samplesInfo_r, SEXP chainInfo_r, SEXP z_r, SEXP family_r); SEXP sfMsAbundNNGP(SEXP y_r, SEXP X_r, SEXP coords_r, SEXP XRE_r, SEXP XRandom_r, - SEXP consts_r, SEXP nAbundRELong_r, SEXP m_r, SEXP nnIndx_r, + SEXP consts_r, SEXP nAbundRELong_r, SEXP m_r, SEXP nnIndx_r, SEXP nnIndxLU_r, SEXP uIndx_r, SEXP uIndxLU_r, SEXP uiIndx_r, - SEXP betaStarting_r, SEXP kappaStarting_r, SEXP betaCommStarting_r, - SEXP tauSqBetaStarting_r, SEXP phiStarting_r, + SEXP betaStarting_r, SEXP kappaStarting_r, SEXP betaCommStarting_r, + SEXP tauSqBetaStarting_r, SEXP phiStarting_r, SEXP lambdaStarting_r, SEXP nuStarting_r, SEXP wStarting_r, - SEXP sigmaSqMuStarting_r, SEXP betaStarStarting_r, - SEXP siteIndx_r, SEXP betaStarIndx_r, SEXP betaLevelIndx_r, - SEXP muBetaComm_r, SEXP SigmaBetaComm_r, SEXP kappaA_r, - SEXP kappaB_r, SEXP tauSqBetaA_r, SEXP tauSqBetaB_r, + SEXP sigmaSqMuStarting_r, SEXP betaStarStarting_r, + SEXP siteIndx_r, SEXP betaStarIndx_r, SEXP betaLevelIndx_r, + SEXP muBetaComm_r, SEXP SigmaBetaComm_r, SEXP kappaA_r, + SEXP kappaB_r, SEXP tauSqBetaA_r, SEXP tauSqBetaB_r, SEXP phiA_r, SEXP phiB_r, SEXP nuA_r, SEXP nuB_r, - SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, - SEXP tuning_r, SEXP covModel_r, + SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, + SEXP tuning_r, SEXP covModel_r, SEXP nBatch_r, SEXP batchLength_r, SEXP acceptRate_r, - SEXP nThreads_r, SEXP verbose_r, SEXP nReport_r, + SEXP nThreads_r, SEXP verbose_r, SEXP nReport_r, SEXP samplesInfo_r, SEXP chainInfo_r, SEXP family_r, SEXP offset_r); SEXP sfMsAbundGaussianNNGP(SEXP y_r, SEXP X_r, SEXP coords_r, SEXP XRE_r, - SEXP XRandom_r, SEXP consts_r, SEXP nRELong_r, - SEXP m_r, SEXP nnIndx_r, - SEXP nnIndxLU_r, SEXP uIndx_r, SEXP uIndxLU_r, SEXP uiIndx_r, - SEXP betaStarting_r, SEXP betaCommStarting_r, + SEXP XRandom_r, SEXP consts_r, SEXP nRELong_r, + SEXP m_r, SEXP nnIndx_r, + SEXP nnIndxLU_r, SEXP uIndx_r, SEXP uIndxLU_r, SEXP uiIndx_r, + SEXP betaStarting_r, SEXP betaCommStarting_r, SEXP tauSqBetaStarting_r, SEXP tauSqStarting_r, - SEXP phiStarting_r, SEXP lambdaStarting_r, SEXP nuStarting_r, - SEXP wStarting_r, SEXP sigmaSqMuStarting_r, - SEXP betaStarStarting_r, SEXP betaStarIndx_r, - SEXP betaLevelIndx_r, - SEXP muBetaComm_r, SEXP SigmaBetaComm_r, SEXP tauSqBetaA_r, - SEXP tauSqBetaB_r, SEXP tauSqA_r, SEXP tauSqB_r, SEXP phiA_r, - SEXP phiB_r, SEXP nuA_r, SEXP nuB_r, - SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, + SEXP phiStarting_r, SEXP lambdaStarting_r, SEXP nuStarting_r, + SEXP wStarting_r, SEXP sigmaSqMuStarting_r, + SEXP betaStarStarting_r, SEXP betaStarIndx_r, + SEXP betaLevelIndx_r, + SEXP muBetaComm_r, SEXP SigmaBetaComm_r, SEXP tauSqBetaA_r, + SEXP tauSqBetaB_r, SEXP tauSqA_r, SEXP tauSqB_r, SEXP phiA_r, + SEXP phiB_r, SEXP nuA_r, SEXP nuB_r, + SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, SEXP tuning_r, SEXP covModel_r, - SEXP nBatch_r, SEXP batchLength_r, - SEXP acceptRate_r, SEXP nThreads_r, - SEXP verbose_r, SEXP nReport_r, + SEXP nBatch_r, SEXP batchLength_r, + SEXP acceptRate_r, SEXP nThreads_r, + SEXP verbose_r, SEXP nReport_r, SEXP samplesInfo_r, SEXP chainInfo_r, SEXP z_r, SEXP family_r); - SEXP sfMsAbundNNGPPredict(SEXP coords_r, SEXP J_r, SEXP nObs_r, SEXP family_r, SEXP nSp_r, - SEXP q_r, SEXP pAbund_r, SEXP m_r, SEXP X0_r, SEXP coords0_r, - SEXP J0_r, SEXP nObs0_r, SEXP sitesLink_r, SEXP sites0Sampled_r, - SEXP sites0_r, SEXP nnIndx0_r, SEXP betaSamples_r, - SEXP thetaSamples_r, SEXP kappaSamples_r, SEXP lambdaSamples_r, - SEXP wSamples_r, SEXP betaStarSiteSamples_r, - SEXP nSamples_r, SEXP covModel_r, SEXP nThreads_r, SEXP verbose_r, + SEXP sfMsAbundNNGPPredict(SEXP coords_r, SEXP J_r, SEXP nObs_r, SEXP family_r, SEXP nSp_r, + SEXP q_r, SEXP pAbund_r, SEXP m_r, SEXP X0_r, SEXP coords0_r, + SEXP J0_r, SEXP nObs0_r, SEXP sitesLink_r, SEXP sites0Sampled_r, + SEXP sites0_r, SEXP nnIndx0_r, SEXP betaSamples_r, + SEXP thetaSamples_r, SEXP kappaSamples_r, SEXP lambdaSamples_r, + SEXP wSamples_r, SEXP betaStarSiteSamples_r, + SEXP nSamples_r, SEXP covModel_r, SEXP nThreads_r, SEXP verbose_r, SEXP nReport_r); - SEXP NMix(SEXP y_r, SEXP X_r, SEXP Xp_r, SEXP XRE_r, SEXP XpRE_r, + SEXP NMix(SEXP y_r, SEXP X_r, SEXP Xp_r, SEXP XRE_r, SEXP XpRE_r, SEXP XRandom_r, SEXP XpRandom_r, SEXP yMax_r, SEXP consts_r, SEXP K_r, SEXP nAbundRELong_r, SEXP nDetRELong_r, SEXP betaStarting_r, SEXP alphaStarting_r, SEXP kappaStarting_r, SEXP sigmaSqMuStarting_r, SEXP sigmaSqPStarting_r, SEXP betaStarStarting_r, SEXP alphaStarStarting_r, SEXP NStarting_r, - SEXP NLongIndx_r, SEXP betaStarIndx_r, SEXP betaLevelIndx_r, + SEXP NLongIndx_r, SEXP betaStarIndx_r, SEXP betaLevelIndx_r, SEXP alphaStarIndx_r, SEXP alphaLevelIndx_r, - SEXP muBeta_r, SEXP SigmaBeta_r, - SEXP muAlpha_r, SEXP SigmaAlpha_r, - SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, - SEXP sigmaSqPA_r, SEXP sigmaSqPB_r, + SEXP muBeta_r, SEXP SigmaBeta_r, + SEXP muAlpha_r, SEXP SigmaAlpha_r, + SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, + SEXP sigmaSqPA_r, SEXP sigmaSqPB_r, SEXP kappaA_r, SEXP kappaB_r, SEXP tuning_r, - SEXP nBatch_r, SEXP batchLength_r, SEXP acceptRate_r, SEXP nThreads_r, + SEXP nBatch_r, SEXP batchLength_r, SEXP acceptRate_r, SEXP nThreads_r, SEXP verbose_r, SEXP nReport_r, SEXP samplesInfo_r, SEXP chainInfo_r, SEXP family_r, SEXP offset_r); - SEXP spNMixNNGP(SEXP y_r, SEXP X_r, SEXP Xp_r, SEXP coords_r, SEXP XRE_r, SEXP XpRE_r, + SEXP spNMixNNGP(SEXP y_r, SEXP X_r, SEXP Xp_r, SEXP coords_r, SEXP XRE_r, SEXP XpRE_r, SEXP XRandom_r, SEXP XpRandom_r, SEXP yMax_r, SEXP consts_r, SEXP nAbundRELong_r, SEXP nDetRELong_r, - SEXP m_r, SEXP nnIndx_r, + SEXP m_r, SEXP nnIndx_r, SEXP nnIndxLU_r, SEXP uIndx_r, SEXP uIndxLU_r, SEXP uiIndx_r, SEXP betaStarting_r, SEXP alphaStarting_r, SEXP kappaStarting_r, SEXP sigmaSqMuStarting_r, SEXP sigmaSqPStarting_r, SEXP betaStarStarting_r, SEXP alphaStarStarting_r, SEXP NStarting_r, SEXP wStarting_r, SEXP phiStarting_r, SEXP sigmaSqStarting_r, SEXP nuStarting_r, - SEXP NLongIndx_r, SEXP betaStarIndx_r, SEXP betaLevelIndx_r, + SEXP NLongIndx_r, SEXP betaStarIndx_r, SEXP betaLevelIndx_r, SEXP alphaStarIndx_r, SEXP alphaLevelIndx_r, - SEXP muBeta_r, SEXP SigmaBeta_r, - SEXP muAlpha_r, SEXP SigmaAlpha_r, + SEXP muBeta_r, SEXP SigmaBeta_r, + SEXP muAlpha_r, SEXP SigmaAlpha_r, SEXP phiA_r, SEXP phiB_r, SEXP sigmaSqA_r, SEXP sigmaSqB_r, - SEXP nuA_r, SEXP nuB_r, SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, - SEXP sigmaSqPA_r, SEXP sigmaSqPB_r, + SEXP nuA_r, SEXP nuB_r, SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, + SEXP sigmaSqPA_r, SEXP sigmaSqPB_r, SEXP kappaA_r, SEXP kappaB_r, SEXP tuning_r, SEXP covModel_r, - SEXP nBatch_r, SEXP batchLength_r, SEXP acceptRate_r, SEXP nThreads_r, + SEXP nBatch_r, SEXP batchLength_r, SEXP acceptRate_r, SEXP nThreads_r, SEXP verbose_r, SEXP nReport_r, SEXP samplesInfo_r, SEXP chainInfo_r, SEXP sigmaSqIG_r, SEXP family_r, SEXP offset_r); SEXP spNMixNNGPPredict(SEXP coords_r, SEXP J_r, SEXP family_r, - SEXP pAbund_r, SEXP m_r, SEXP X0_r, SEXP coords0_r, - SEXP J0_r, SEXP nnIndx0_r, SEXP betaSamples_r, - SEXP thetaSamples_r, SEXP kappaSamples_r, SEXP wSamples_r, - SEXP betaStarSiteSamples_r, + SEXP pAbund_r, SEXP m_r, SEXP X0_r, SEXP coords0_r, + SEXP J0_r, SEXP nnIndx0_r, SEXP betaSamples_r, + SEXP thetaSamples_r, SEXP kappaSamples_r, SEXP wSamples_r, + SEXP betaStarSiteSamples_r, SEXP sitesLink_r, SEXP sites0Sampled_r, SEXP sites0_r, - SEXP nSamples_r, SEXP covModel_r, SEXP nThreads_r, SEXP verbose_r, + SEXP nSamples_r, SEXP covModel_r, SEXP nThreads_r, SEXP verbose_r, SEXP nReport_r); - SEXP msNMix(SEXP y_r, SEXP X_r, SEXP Xp_r, SEXP XRE_r, SEXP XpRE_r, - SEXP XRandom_r, SEXP XpRandom_r, SEXP yMax_r, - SEXP consts_r, SEXP nAbundRELong_r, SEXP nDetRELong_r, - SEXP betaStarting_r, SEXP alphaStarting_r, SEXP kappaStarting_r, SEXP NStarting_r, - SEXP betaCommStarting_r, SEXP alphaCommStarting_r, - SEXP tauSqBetaStarting_r, SEXP tauSqAlphaStarting_r, - SEXP sigmaSqMuStarting_r, SEXP sigmaSqPStarting_r, - SEXP betaStarStarting_r, SEXP alphaStarStarting_r, - SEXP NLongIndx_r, SEXP betaStarIndx_r, SEXP betaLevelIndx_r, - SEXP alphaStarIndx_r, SEXP alphaLevelIndx_r, - SEXP muBetaComm_r, SEXP muAlphaComm_r, - SEXP SigmaBetaComm_r, SEXP SigmaAlphaComm_r, SEXP kappaA_r, - SEXP kappaB_r, SEXP tauSqBetaA_r, - SEXP tauSqBetaB_r, SEXP tauSqAlphaA_r, SEXP tauSqAlphaB_r, - SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, - SEXP sigmaSqPA_r, SEXP sigmaSqPB_r, + SEXP msNMix(SEXP y_r, SEXP X_r, SEXP Xp_r, SEXP XRE_r, SEXP XpRE_r, + SEXP XRandom_r, SEXP XpRandom_r, SEXP yMax_r, + SEXP consts_r, SEXP nAbundRELong_r, SEXP nDetRELong_r, + SEXP betaStarting_r, SEXP alphaStarting_r, SEXP kappaStarting_r, SEXP NStarting_r, + SEXP betaCommStarting_r, SEXP alphaCommStarting_r, + SEXP tauSqBetaStarting_r, SEXP tauSqAlphaStarting_r, + SEXP sigmaSqMuStarting_r, SEXP sigmaSqPStarting_r, + SEXP betaStarStarting_r, SEXP alphaStarStarting_r, + SEXP NLongIndx_r, SEXP betaStarIndx_r, SEXP betaLevelIndx_r, + SEXP alphaStarIndx_r, SEXP alphaLevelIndx_r, + SEXP muBetaComm_r, SEXP muAlphaComm_r, + SEXP SigmaBetaComm_r, SEXP SigmaAlphaComm_r, SEXP kappaA_r, + SEXP kappaB_r, SEXP tauSqBetaA_r, + SEXP tauSqBetaB_r, SEXP tauSqAlphaA_r, SEXP tauSqAlphaB_r, + SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, + SEXP sigmaSqPA_r, SEXP sigmaSqPB_r, SEXP tuning_r, SEXP nBatch_r, SEXP batchLength_r, SEXP acceptRate_r, - SEXP nThreads_r, SEXP verbose_r, SEXP nReport_r, + SEXP nThreads_r, SEXP verbose_r, SEXP nReport_r, SEXP samplesInfo_r, SEXP chainInfo_r, SEXP family_r, SEXP offset_r); - SEXP lfMsNMix(SEXP y_r, SEXP X_r, SEXP Xp_r, SEXP XRE_r, SEXP XpRE_r, - SEXP XRandom_r, SEXP XpRandom_r, SEXP yMax_r, - SEXP consts_r, SEXP nAbundRELong_r, SEXP nDetRELong_r, - SEXP betaStarting_r, SEXP alphaStarting_r, - SEXP kappaStarting_r, SEXP NStarting_r, - SEXP betaCommStarting_r, SEXP alphaCommStarting_r, + SEXP lfMsNMix(SEXP y_r, SEXP X_r, SEXP Xp_r, SEXP XRE_r, SEXP XpRE_r, + SEXP XRandom_r, SEXP XpRandom_r, SEXP yMax_r, + SEXP consts_r, SEXP nAbundRELong_r, SEXP nDetRELong_r, + SEXP betaStarting_r, SEXP alphaStarting_r, + SEXP kappaStarting_r, SEXP NStarting_r, + SEXP betaCommStarting_r, SEXP alphaCommStarting_r, SEXP lambdaStarting_r, SEXP wStarting_r, - SEXP tauSqBetaStarting_r, SEXP tauSqAlphaStarting_r, - SEXP sigmaSqMuStarting_r, SEXP sigmaSqPStarting_r, - SEXP betaStarStarting_r, SEXP alphaStarStarting_r, - SEXP NLongIndx_r, SEXP betaStarIndx_r, SEXP betaLevelIndx_r, - SEXP alphaStarIndx_r, SEXP alphaLevelIndx_r, - SEXP muBetaComm_r, SEXP muAlphaComm_r, - SEXP SigmaBetaComm_r, SEXP SigmaAlphaComm_r, SEXP kappaA_r, - SEXP kappaB_r, SEXP tauSqBetaA_r, - SEXP tauSqBetaB_r, SEXP tauSqAlphaA_r, SEXP tauSqAlphaB_r, - SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, - SEXP sigmaSqPA_r, SEXP sigmaSqPB_r, SEXP tuning_r, + SEXP tauSqBetaStarting_r, SEXP tauSqAlphaStarting_r, + SEXP sigmaSqMuStarting_r, SEXP sigmaSqPStarting_r, + SEXP betaStarStarting_r, SEXP alphaStarStarting_r, + SEXP NLongIndx_r, SEXP betaStarIndx_r, SEXP betaLevelIndx_r, + SEXP alphaStarIndx_r, SEXP alphaLevelIndx_r, + SEXP muBetaComm_r, SEXP muAlphaComm_r, + SEXP SigmaBetaComm_r, SEXP SigmaAlphaComm_r, SEXP kappaA_r, + SEXP kappaB_r, SEXP tauSqBetaA_r, + SEXP tauSqBetaB_r, SEXP tauSqAlphaA_r, SEXP tauSqAlphaB_r, + SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, + SEXP sigmaSqPA_r, SEXP sigmaSqPB_r, SEXP tuning_r, SEXP nBatch_r, SEXP batchLength_r, SEXP acceptRate_r, - SEXP nThreads_r, SEXP verbose_r, SEXP nReport_r, + SEXP nThreads_r, SEXP verbose_r, SEXP nReport_r, SEXP samplesInfo_r, SEXP chainInfo_r, SEXP family_r, SEXP offset_r); - SEXP sfMsNMixNNGP(SEXP y_r, SEXP X_r, SEXP Xp_r, SEXP coords_r, SEXP XRE_r, SEXP XpRE_r, - SEXP XRandom_r, SEXP XpRandom_r, SEXP yMax_r, - SEXP consts_r, SEXP nAbundRELong_r, SEXP nDetRELong_r, - SEXP m_r, SEXP nnIndx_r, - SEXP nnIndxLU_r, SEXP uIndx_r, SEXP uIndxLU_r, SEXP uiIndx_r, - SEXP betaStarting_r, SEXP alphaStarting_r, SEXP kappaStarting_r, SEXP NStarting_r, - SEXP betaCommStarting_r, SEXP alphaCommStarting_r, + SEXP sfMsNMixNNGP(SEXP y_r, SEXP X_r, SEXP Xp_r, SEXP coords_r, SEXP XRE_r, SEXP XpRE_r, + SEXP XRandom_r, SEXP XpRandom_r, SEXP yMax_r, + SEXP consts_r, SEXP nAbundRELong_r, SEXP nDetRELong_r, + SEXP m_r, SEXP nnIndx_r, + SEXP nnIndxLU_r, SEXP uIndx_r, SEXP uIndxLU_r, SEXP uiIndx_r, + SEXP betaStarting_r, SEXP alphaStarting_r, SEXP kappaStarting_r, SEXP NStarting_r, + SEXP betaCommStarting_r, SEXP alphaCommStarting_r, SEXP phiStarting_r, SEXP lambdaStarting_r, SEXP nuStarting_r, SEXP wStarting_r, - SEXP tauSqBetaStarting_r, SEXP tauSqAlphaStarting_r, - SEXP sigmaSqMuStarting_r, SEXP sigmaSqPStarting_r, - SEXP betaStarStarting_r, SEXP alphaStarStarting_r, - SEXP NLongIndx_r, SEXP betaStarIndx_r, SEXP betaLevelIndx_r, - SEXP alphaStarIndx_r, SEXP alphaLevelIndx_r, - SEXP muBetaComm_r, SEXP muAlphaComm_r, - SEXP SigmaBetaComm_r, SEXP SigmaAlphaComm_r, SEXP kappaA_r, - SEXP kappaB_r, SEXP tauSqBetaA_r, - SEXP tauSqBetaB_r, SEXP tauSqAlphaA_r, SEXP tauSqAlphaB_r, - SEXP spatialPriors_r, SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, - SEXP sigmaSqPA_r, SEXP sigmaSqPB_r, - SEXP tuning_r, SEXP covModel_r, - SEXP batchInfo_r, SEXP acceptRate_r, - SEXP nThreads_r, SEXP verbose_r, SEXP nReport_r, + SEXP tauSqBetaStarting_r, SEXP tauSqAlphaStarting_r, + SEXP sigmaSqMuStarting_r, SEXP sigmaSqPStarting_r, + SEXP betaStarStarting_r, SEXP alphaStarStarting_r, + SEXP NLongIndx_r, SEXP betaStarIndx_r, SEXP betaLevelIndx_r, + SEXP alphaStarIndx_r, SEXP alphaLevelIndx_r, + SEXP muBetaComm_r, SEXP muAlphaComm_r, + SEXP SigmaBetaComm_r, SEXP SigmaAlphaComm_r, SEXP kappaA_r, + SEXP kappaB_r, SEXP tauSqBetaA_r, + SEXP tauSqBetaB_r, SEXP tauSqAlphaA_r, SEXP tauSqAlphaB_r, + SEXP spatialPriors_r, SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, + SEXP sigmaSqPA_r, SEXP sigmaSqPB_r, + SEXP tuning_r, SEXP covModel_r, + SEXP batchInfo_r, SEXP acceptRate_r, + SEXP nThreads_r, SEXP verbose_r, SEXP nReport_r, SEXP samplesInfo_r, SEXP chainInfo_r, SEXP family_r, SEXP offset_r); SEXP sfMsNMixNNGPPredict(SEXP coords_r, SEXP J_r, SEXP family_r, SEXP nSp_r, SEXP q_r, - SEXP pAbund_r, SEXP m_r, SEXP X0_r, SEXP coords0_r, - SEXP JStr_r, SEXP nnIndx0_r, SEXP betaSamples_r, - SEXP thetaSamples_r, SEXP kappaSamples_r, SEXP lambdaSamples_r, - SEXP wSamples_r, SEXP betaStarSiteSamples_r, - SEXP nSamples_r, SEXP covModel_r, SEXP nThreads_r, SEXP verbose_r, + SEXP pAbund_r, SEXP m_r, SEXP X0_r, SEXP coords0_r, + SEXP JStr_r, SEXP nnIndx0_r, SEXP betaSamples_r, + SEXP thetaSamples_r, SEXP kappaSamples_r, SEXP lambdaSamples_r, + SEXP wSamples_r, SEXP betaStarSiteSamples_r, + SEXP nSamples_r, SEXP covModel_r, SEXP nThreads_r, SEXP verbose_r, SEXP nReport_r, SEXP sitesLink_r, SEXP sites0Sampled_r); - SEXP DS(SEXP y_r, SEXP X_r, SEXP Xp_r, SEXP XRE_r, SEXP XpRE_r, + SEXP DS(SEXP y_r, SEXP X_r, SEXP Xp_r, SEXP XRE_r, SEXP XpRE_r, SEXP XRandom_r, SEXP XpRandom_r, SEXP yMax_r, SEXP offset_r, SEXP consts_r, SEXP K_r, SEXP nAbundRELong_r, SEXP nDetRELong_r, SEXP betaStarting_r, SEXP alphaStarting_r, SEXP kappaStarting_r, SEXP sigmaSqMuStarting_r, SEXP sigmaSqPStarting_r, SEXP betaStarStarting_r, SEXP alphaStarStarting_r, SEXP NStarting_r, - SEXP NLongIndx_r, SEXP betaStarIndx_r, SEXP betaLevelIndx_r, + SEXP NLongIndx_r, SEXP betaStarIndx_r, SEXP betaLevelIndx_r, SEXP alphaStarIndx_r, SEXP alphaLevelIndx_r, - SEXP muBeta_r, SEXP SigmaBeta_r, - SEXP muAlpha_r, SEXP SigmaAlpha_r, - SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, - SEXP sigmaSqPA_r, SEXP sigmaSqPB_r, - SEXP kappaA_r, SEXP kappaB_r, SEXP detModel_r, + SEXP muBeta_r, SEXP SigmaBeta_r, + SEXP muAlpha_r, SEXP SigmaAlpha_r, + SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, + SEXP sigmaSqPA_r, SEXP sigmaSqPB_r, + SEXP kappaA_r, SEXP kappaB_r, SEXP detModel_r, SEXP transect_r, SEXP distBreaks_r, SEXP tuning_r, - SEXP nBatch_r, SEXP batchLength_r, SEXP acceptRate_r, SEXP nThreads_r, + SEXP nBatch_r, SEXP batchLength_r, SEXP acceptRate_r, SEXP nThreads_r, SEXP verbose_r, SEXP nReport_r, SEXP samplesInfo_r, SEXP chainInfo_r, SEXP family_r); - SEXP spDSNNGP(SEXP y_r, SEXP X_r, SEXP Xp_r, SEXP coords_r, SEXP XRE_r, SEXP XpRE_r, + SEXP spDSNNGP(SEXP y_r, SEXP X_r, SEXP Xp_r, SEXP coords_r, SEXP XRE_r, SEXP XpRE_r, SEXP XRandom_r, SEXP XpRandom_r, SEXP yMax_r, SEXP offset_r, SEXP consts_r, SEXP K_r, SEXP nAbundRELong_r, SEXP nDetRELong_r, - SEXP m_r, SEXP nnIndx_r, + SEXP m_r, SEXP nnIndx_r, SEXP nnIndxLU_r, SEXP uIndx_r, SEXP uIndxLU_r, SEXP uiIndx_r, SEXP betaStarting_r, SEXP alphaStarting_r, SEXP kappaStarting_r, SEXP sigmaSqMuStarting_r, SEXP sigmaSqPStarting_r, SEXP betaStarStarting_r, SEXP alphaStarStarting_r, SEXP NStarting_r, SEXP wStarting_r, SEXP phiStarting_r, SEXP sigmaSqStarting_r, SEXP nuStarting_r, - SEXP NLongIndx_r, SEXP betaStarIndx_r, SEXP betaLevelIndx_r, + SEXP NLongIndx_r, SEXP betaStarIndx_r, SEXP betaLevelIndx_r, SEXP alphaStarIndx_r, SEXP alphaLevelIndx_r, - SEXP muBeta_r, SEXP SigmaBeta_r, + SEXP muBeta_r, SEXP SigmaBeta_r, SEXP muAlpha_r, SEXP SigmaAlpha_r, SEXP spatialPriors_r, - SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, - SEXP sigmaSqPA_r, SEXP sigmaSqPB_r, - SEXP kappaA_r, SEXP kappaB_r, SEXP detModel_r, + SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, + SEXP sigmaSqPA_r, SEXP sigmaSqPB_r, + SEXP kappaA_r, SEXP kappaB_r, SEXP detModel_r, SEXP transect_r, SEXP distBreaks_r, SEXP tuning_r, SEXP covModel_r, - SEXP nBatch_r, SEXP batchLength_r, SEXP acceptRate_r, SEXP nThreads_r, + SEXP nBatch_r, SEXP batchLength_r, SEXP acceptRate_r, SEXP nThreads_r, SEXP verbose_r, SEXP nReport_r, SEXP samplesInfo_r, SEXP chainInfo_r, SEXP sigmaSqIG_r, SEXP family_r); - SEXP msDS(SEXP y_r, SEXP X_r, SEXP Xp_r, SEXP XRE_r, SEXP XpRE_r, + SEXP msDS(SEXP y_r, SEXP X_r, SEXP Xp_r, SEXP XRE_r, SEXP XpRE_r, SEXP XRandom_r, SEXP XpRandom_r, SEXP yMax_r, SEXP offset_r, SEXP consts_r, SEXP K_r, SEXP nAbundRELong_r, SEXP nDetRELong_r, SEXP betaStarting_r, SEXP alphaStarting_r, SEXP kappaStarting_r, SEXP NStarting_r, SEXP betaCommStarting_r, SEXP alphaCommStarting_r, SEXP tauSqBetaStarting_r, SEXP tauSqAlphaStarting_r, SEXP sigmaSqMuStarting_r, SEXP sigmaSqPStarting_r, - SEXP betaStarStarting_r, SEXP alphaStarStarting_r, - SEXP NLongIndx_r, SEXP betaStarIndx_r, SEXP betaLevelIndx_r, + SEXP betaStarStarting_r, SEXP alphaStarStarting_r, + SEXP NLongIndx_r, SEXP betaStarIndx_r, SEXP betaLevelIndx_r, SEXP alphaStarIndx_r, SEXP alphaLevelIndx_r, - SEXP muBetaComm_r, SEXP SigmaBetaComm_r, - SEXP muAlphaComm_r, SEXP SigmaAlphaComm_r, - SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, - SEXP sigmaSqPA_r, SEXP sigmaSqPB_r, - SEXP kappaA_r, SEXP kappaB_r, - SEXP tauSqBetaA_r, SEXP tauSqBetaB_r, - SEXP tauSqAlphaA_r, SEXP tauSqAlphaB_r, SEXP detModel_r, + SEXP muBetaComm_r, SEXP SigmaBetaComm_r, + SEXP muAlphaComm_r, SEXP SigmaAlphaComm_r, + SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, + SEXP sigmaSqPA_r, SEXP sigmaSqPB_r, + SEXP kappaA_r, SEXP kappaB_r, + SEXP tauSqBetaA_r, SEXP tauSqBetaB_r, + SEXP tauSqAlphaA_r, SEXP tauSqAlphaB_r, SEXP detModel_r, SEXP transect_r, SEXP distBreaks_r, SEXP tuning_r, - SEXP nBatch_r, SEXP batchLength_r, SEXP acceptRate_r, SEXP nThreads_r, + SEXP nBatch_r, SEXP batchLength_r, SEXP acceptRate_r, SEXP nThreads_r, SEXP verbose_r, SEXP nReport_r, SEXP samplesInfo_r, SEXP chainInfo_r, SEXP family_r); - SEXP lfMsDS(SEXP y_r, SEXP X_r, SEXP Xp_r, SEXP XRE_r, SEXP XpRE_r, + SEXP lfMsDS(SEXP y_r, SEXP X_r, SEXP Xp_r, SEXP XRE_r, SEXP XpRE_r, SEXP XRandom_r, SEXP XpRandom_r, SEXP yMax_r, SEXP offset_r, SEXP consts_r, SEXP K_r, SEXP nAbundRELong_r, SEXP nDetRELong_r, SEXP betaStarting_r, SEXP alphaStarting_r, SEXP kappaStarting_r, @@ -367,133 +367,152 @@ extern "C" { SEXP lambdaStarting_r, SEXP wStarting_r, SEXP tauSqBetaStarting_r, SEXP tauSqAlphaStarting_r, SEXP sigmaSqMuStarting_r, SEXP sigmaSqPStarting_r, - SEXP betaStarStarting_r, SEXP alphaStarStarting_r, - SEXP NLongIndx_r, SEXP betaStarIndx_r, SEXP betaLevelIndx_r, + SEXP betaStarStarting_r, SEXP alphaStarStarting_r, + SEXP NLongIndx_r, SEXP betaStarIndx_r, SEXP betaLevelIndx_r, SEXP alphaStarIndx_r, SEXP alphaLevelIndx_r, - SEXP muBetaComm_r, SEXP SigmaBetaComm_r, - SEXP muAlphaComm_r, SEXP SigmaAlphaComm_r, - SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, - SEXP sigmaSqPA_r, SEXP sigmaSqPB_r, - SEXP kappaA_r, SEXP kappaB_r, - SEXP tauSqBetaA_r, SEXP tauSqBetaB_r, - SEXP tauSqAlphaA_r, SEXP tauSqAlphaB_r, SEXP detModel_r, + SEXP muBetaComm_r, SEXP SigmaBetaComm_r, + SEXP muAlphaComm_r, SEXP SigmaAlphaComm_r, + SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, + SEXP sigmaSqPA_r, SEXP sigmaSqPB_r, + SEXP kappaA_r, SEXP kappaB_r, + SEXP tauSqBetaA_r, SEXP tauSqBetaB_r, + SEXP tauSqAlphaA_r, SEXP tauSqAlphaB_r, SEXP detModel_r, SEXP transect_r, SEXP distBreaks_r, SEXP tuning_r, - SEXP nBatch_r, SEXP batchLength_r, SEXP acceptRate_r, SEXP nThreads_r, + SEXP nBatch_r, SEXP batchLength_r, SEXP acceptRate_r, SEXP nThreads_r, SEXP verbose_r, SEXP nReport_r, SEXP samplesInfo_r, SEXP chainInfo_r, SEXP family_r); - SEXP sfMsDSNNGP(SEXP y_r, SEXP X_r, SEXP Xp_r, SEXP coords_r, SEXP XRE_r, SEXP XpRE_r, + SEXP sfMsDSNNGP(SEXP y_r, SEXP X_r, SEXP Xp_r, SEXP coords_r, SEXP XRE_r, SEXP XpRE_r, SEXP XRandom_r, SEXP XpRandom_r, SEXP yMax_r, SEXP offset_r, SEXP consts_r, SEXP nAbundRELong_r, SEXP nDetRELong_r, - SEXP nnIndx_r, SEXP nnIndxLU_r, SEXP uIndx_r, SEXP uIndxLU_r, SEXP uiIndx_r, + SEXP nnIndx_r, SEXP nnIndxLU_r, SEXP uIndx_r, SEXP uIndxLU_r, SEXP uiIndx_r, SEXP betaStarting_r, SEXP alphaStarting_r, SEXP kappaStarting_r, SEXP NStarting_r, SEXP betaCommStarting_r, SEXP alphaCommStarting_r, SEXP phiStarting_r, SEXP lambdaStarting_r, SEXP nuStarting_r, SEXP wStarting_r, SEXP tauSqBetaStarting_r, SEXP tauSqAlphaStarting_r, SEXP sigmaSqMuStarting_r, SEXP sigmaSqPStarting_r, - SEXP betaStarStarting_r, SEXP alphaStarStarting_r, - SEXP NLongIndx_r, SEXP betaStarIndx_r, SEXP betaLevelIndx_r, + SEXP betaStarStarting_r, SEXP alphaStarStarting_r, + SEXP NLongIndx_r, SEXP betaStarIndx_r, SEXP betaLevelIndx_r, SEXP alphaStarIndx_r, SEXP alphaLevelIndx_r, - SEXP muBetaComm_r, SEXP SigmaBetaComm_r, - SEXP muAlphaComm_r, SEXP SigmaAlphaComm_r, - SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, - SEXP sigmaSqPA_r, SEXP sigmaSqPB_r, - SEXP kappaA_r, SEXP kappaB_r, - SEXP tauSqBetaA_r, SEXP tauSqBetaB_r, - SEXP tauSqAlphaA_r, SEXP tauSqAlphaB_r, SEXP spatialPriors_r, - SEXP transect_r, SEXP distBreaks_r, SEXP tuning_r, - SEXP nBatch_r, SEXP batchLength_r, SEXP acceptRate_r, SEXP nThreads_r, + SEXP muBetaComm_r, SEXP SigmaBetaComm_r, + SEXP muAlphaComm_r, SEXP SigmaAlphaComm_r, + SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, + SEXP sigmaSqPA_r, SEXP sigmaSqPB_r, + SEXP kappaA_r, SEXP kappaB_r, + SEXP tauSqBetaA_r, SEXP tauSqBetaB_r, + SEXP tauSqAlphaA_r, SEXP tauSqAlphaB_r, SEXP spatialPriors_r, + SEXP transect_r, SEXP distBreaks_r, SEXP tuning_r, + SEXP nBatch_r, SEXP batchLength_r, SEXP acceptRate_r, SEXP nThreads_r, SEXP verbose_r, SEXP nReport_r, SEXP samplesInfo_r, SEXP chainInfo_r); SEXP waicAbund(SEXP J_r, SEXP yNA_r, SEXP dist_r, SEXP modelType_r, SEXP y_r, - SEXP nSamples_r, SEXP NSamples_r, SEXP kappaSamples_r, - SEXP muSamples_r, SEXP pSamples_r, SEXP NMax_r, SEXP KMax_r, + SEXP nSamples_r, SEXP NSamples_r, SEXP kappaSamples_r, + SEXP muSamples_r, SEXP pSamples_r, SEXP NMax_r, SEXP KMax_r, SEXP yMax_r); - SEXP checkAlphaDS(SEXP y_r, SEXP Xp_r, SEXP XpRE_r, - SEXP XpRandom_r, SEXP yMax_r, + SEXP checkAlphaDS(SEXP y_r, SEXP Xp_r, SEXP XpRE_r, + SEXP XpRandom_r, SEXP yMax_r, SEXP consts_r, SEXP K_r, SEXP nDetRELong_r, - SEXP alphaStarting_r, + SEXP alphaStarting_r, SEXP sigmaSqPStarting_r, SEXP alphaStarStarting_r, SEXP NStarting_r, - SEXP NLongIndx_r, + SEXP NLongIndx_r, SEXP alphaStarIndx_r, SEXP alphaLevelIndx_r, - SEXP muAlpha_r, SEXP SigmaAlpha_r, - SEXP detModel_r, + SEXP muAlpha_r, SEXP SigmaAlpha_r, + SEXP detModel_r, SEXP transect_r, SEXP distBreaks_r); - SEXP checkMSAlphaDS(SEXP y_r, SEXP Xp_r, SEXP XpRE_r, - SEXP XpRandom_r, SEXP yMax_r, - SEXP consts_r, SEXP K_r, - SEXP alphaStarting_r, + SEXP checkMSAlphaDS(SEXP y_r, SEXP Xp_r, SEXP XpRE_r, + SEXP XpRandom_r, SEXP yMax_r, + SEXP consts_r, SEXP K_r, + SEXP alphaStarting_r, SEXP alphaCommStarting_r, SEXP tauSqAlphaStarting_r, SEXP sigmaSqPStarting_r, SEXP alphaStarStarting_r, SEXP NStarting_r, SEXP alphaStarIndx_r, SEXP alphaLevelIndx_r, - SEXP muAlphaComm_r, SEXP SigmaAlphaComm_r, - SEXP detModel_r, + SEXP muAlphaComm_r, SEXP SigmaAlphaComm_r, + SEXP detModel_r, SEXP transect_r, SEXP distBreaks_r); - SEXP svcAbundNNGP(SEXP y_r, SEXP X_r, SEXP Xw_r, SEXP coords_r, SEXP XRE_r, SEXP XRandom_r, - SEXP consts_r, SEXP nRELong_r, SEXP m_r, SEXP nnIndx_r, - SEXP nnIndxLU_r, SEXP uIndx_r, SEXP uIndxLU_r, SEXP uiIndx_r, - SEXP betaStarting_r, SEXP tauSqStarting_r, SEXP sigmaSqMuStarting_r, - SEXP betaStarStarting_r, - SEXP wStarting_r, SEXP phiStarting_r, - SEXP sigmaSqStarting_r, SEXP nuStarting_r, - SEXP betaStarIndx_r, SEXP betaLevelIndx_r, - SEXP muBeta_r, SEXP SigmaBeta_r, - SEXP tauSqA_r, SEXP tauSqB_r, SEXP phiA_r, SEXP phiB_r, - SEXP sigmaSqA_r, SEXP sigmaSqB_r, SEXP nuA_r, SEXP nuB_r, - SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, - SEXP tuning_r, SEXP covModel_r, SEXP nBatch_r, - SEXP batchLength_r, SEXP acceptRate_r, SEXP nThreads_r, SEXP verbose_r, - SEXP nReport_r, SEXP samplesInfo_r, SEXP chainInfo_r); - - SEXP svcAbundNNGPPredict(SEXP coords_r, SEXP J_r, SEXP family_r, - SEXP pAbund_r, SEXP pTilde_r, - SEXP m_r, SEXP X0_r, SEXP Xw0_r, SEXP coords0_r, - SEXP J0_r, SEXP nnIndx0_r, SEXP betaSamples_r, - SEXP thetaSamples_r, SEXP tauSqSamples_r, SEXP wSamples_r, - SEXP betaStarSiteSamples_r, SEXP sitesLink_r, - SEXP sites0Sampled_r, SEXP sites0_r, SEXP nSamples_r, - SEXP covModel_r, SEXP nThreads_r, SEXP verbose_r, - SEXP nReport_r, SEXP z0Samples_r); + SEXP svcAbundNNGP(SEXP y_r, SEXP X_r, SEXP Xw_r, SEXP coords_r, SEXP XRE_r, + SEXP XRandom_r, SEXP consts_r, SEXP nAbundRELong_r, + SEXP m_r, SEXP nnIndx_r, + SEXP nnIndxLU_r, SEXP uIndx_r, SEXP uIndxLU_r, + SEXP betaStarting_r, SEXP kappaStarting_r, + SEXP sigmaSqMuStarting_r, SEXP betaStarStarting_r, + SEXP wStarting_r, SEXP phiStarting_r, SEXP sigmaSqStarting_r, + SEXP nuStarting_r, + SEXP siteIndx_r, SEXP betaStarIndx_r, SEXP betaLevelIndx_r, + SEXP muBeta_r, SEXP SigmaBeta_r, + SEXP kappaA_r, SEXP kappaB_r, + SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, + SEXP phiA_r, SEXP phiB_r, + SEXP sigmaSqA_r, SEXP sigmaSqB_r, SEXP nuA_r, SEXP nuB_r, SEXP tuning_r, + SEXP covModel_r, + SEXP nBatch_r, SEXP batchLength_r, SEXP acceptRate_r, SEXP nThreads_r, + SEXP verbose_r, SEXP nReport_r, SEXP samplesInfo_r, + SEXP chainInfo_r, SEXP family_r, SEXP offset_r); + + SEXP svcAbundGaussianNNGP(SEXP y_r, SEXP X_r, SEXP Xw_r, SEXP coords_r, SEXP XRE_r, SEXP XRandom_r, + SEXP consts_r, SEXP nRELong_r, SEXP m_r, SEXP nnIndx_r, + SEXP nnIndxLU_r, SEXP uIndx_r, SEXP uIndxLU_r, SEXP uiIndx_r, + SEXP betaStarting_r, SEXP tauSqStarting_r, SEXP sigmaSqMuStarting_r, + SEXP betaStarStarting_r, + SEXP wStarting_r, SEXP phiStarting_r, + SEXP sigmaSqStarting_r, SEXP nuStarting_r, + SEXP betaStarIndx_r, SEXP betaLevelIndx_r, + SEXP muBeta_r, SEXP SigmaBeta_r, + SEXP tauSqA_r, SEXP tauSqB_r, SEXP phiA_r, SEXP phiB_r, + SEXP sigmaSqA_r, SEXP sigmaSqB_r, SEXP nuA_r, SEXP nuB_r, + SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, + SEXP tuning_r, SEXP covModel_r, SEXP nBatch_r, + SEXP batchLength_r, SEXP acceptRate_r, SEXP nThreads_r, SEXP verbose_r, + SEXP nReport_r, SEXP samplesInfo_r, SEXP chainInfo_r); + + SEXP svcAbundGaussianNNGPPredict(SEXP coords_r, SEXP J_r, SEXP family_r, + SEXP pAbund_r, SEXP pTilde_r, + SEXP m_r, SEXP X0_r, SEXP Xw0_r, SEXP coords0_r, + SEXP J0_r, SEXP nnIndx0_r, SEXP betaSamples_r, + SEXP thetaSamples_r, SEXP tauSqSamples_r, SEXP wSamples_r, + SEXP betaStarSiteSamples_r, SEXP sitesLink_r, + SEXP sites0Sampled_r, SEXP sites0_r, SEXP nSamples_r, + SEXP covModel_r, SEXP nThreads_r, SEXP verbose_r, + SEXP nReport_r, SEXP z0Samples_r); SEXP svcMsAbundGaussianNNGP(SEXP y_r, SEXP X_r, SEXP Xw_r, SEXP coords_r, SEXP XRE_r, - SEXP XRandom_r, SEXP consts_r, SEXP nRELong_r, - SEXP m_r, SEXP nnIndx_r, - SEXP nnIndxLU_r, SEXP uIndx_r, SEXP uIndxLU_r, SEXP uiIndx_r, - SEXP betaStarting_r, SEXP betaCommStarting_r, + SEXP XRandom_r, SEXP consts_r, SEXP nRELong_r, + SEXP m_r, SEXP nnIndx_r, + SEXP nnIndxLU_r, SEXP uIndx_r, SEXP uIndxLU_r, SEXP uiIndx_r, + SEXP betaStarting_r, SEXP betaCommStarting_r, SEXP tauSqBetaStarting_r, SEXP tauSqStarting_r, - SEXP phiStarting_r, SEXP lambdaStarting_r, SEXP nuStarting_r, - SEXP wStarting_r, SEXP sigmaSqMuStarting_r, - SEXP betaStarStarting_r, SEXP betaStarIndx_r, - SEXP betaLevelIndx_r, - SEXP muBetaComm_r, SEXP SigmaBetaComm_r, SEXP tauSqBetaA_r, - SEXP tauSqBetaB_r, SEXP tauSqA_r, SEXP tauSqB_r, SEXP phiA_r, - SEXP phiB_r, SEXP nuA_r, SEXP nuB_r, - SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, + SEXP phiStarting_r, SEXP lambdaStarting_r, SEXP nuStarting_r, + SEXP wStarting_r, SEXP sigmaSqMuStarting_r, + SEXP betaStarStarting_r, SEXP betaStarIndx_r, + SEXP betaLevelIndx_r, + SEXP muBetaComm_r, SEXP SigmaBetaComm_r, SEXP tauSqBetaA_r, + SEXP tauSqBetaB_r, SEXP tauSqA_r, SEXP tauSqB_r, SEXP phiA_r, + SEXP phiB_r, SEXP nuA_r, SEXP nuB_r, + SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, SEXP tuning_r, SEXP covModel_r, - SEXP nBatch_r, SEXP batchLength_r, - SEXP acceptRate_r, SEXP nThreads_r, - SEXP verbose_r, SEXP nReport_r, + SEXP nBatch_r, SEXP batchLength_r, + SEXP acceptRate_r, SEXP nThreads_r, + SEXP verbose_r, SEXP nReport_r, SEXP samplesInfo_r, SEXP chainInfo_r, - SEXP z_r, SEXP family_r); - - SEXP svcMsAbundGaussianNNGPPredict(SEXP coords_r, SEXP J_r, SEXP family_r, - SEXP N_r, SEXP q_r, SEXP p_r, - SEXP pTilde_r, SEXP m_r, - SEXP X0_r, SEXP Xw0_r, SEXP coords0_r, - SEXP J0_r, SEXP sitesLink_r, - SEXP sites0Sampled_r, - SEXP nnIndx0_r, SEXP betaSamples_r, - SEXP thetaSamples_r, SEXP tauSqSamples_r, - SEXP lambdaSamples_r, - SEXP wSamples_r, SEXP betaStarSiteSamples_r, - SEXP nSamples_r, SEXP covModel_r, - SEXP nThreads_r, SEXP verbose_r, SEXP nReport_r, - SEXP z0Samples_r); + SEXP z_r, SEXP family_r); + + SEXP svcMsAbundGaussianNNGPPredict(SEXP coords_r, SEXP J_r, SEXP family_r, + SEXP N_r, SEXP q_r, SEXP p_r, + SEXP pTilde_r, SEXP m_r, + SEXP X0_r, SEXP Xw0_r, SEXP coords0_r, + SEXP J0_r, SEXP sitesLink_r, + SEXP sites0Sampled_r, + SEXP nnIndx0_r, SEXP betaSamples_r, + SEXP thetaSamples_r, SEXP tauSqSamples_r, + SEXP lambdaSamples_r, + SEXP wSamples_r, SEXP betaStarSiteSamples_r, + SEXP nSamples_r, SEXP covModel_r, + SEXP nThreads_r, SEXP verbose_r, SEXP nReport_r, + SEXP z0Samples_r); } diff --git a/src/svcAbundNNGP.cpp b/src/svcAbundNNGP.cpp old mode 100644 new mode 100755 index 01940bc..36b6e4d --- a/src/svcAbundNNGP.cpp +++ b/src/svcAbundNNGP.cpp @@ -18,7 +18,7 @@ # define FCONE #endif -void updateBFSVCNNGP(double *B, double *F, double *c, double *C, double *coords, int *nnIndx, int *nnIndxLU, int n, int m, double sigmaSq, double phi, double nu, int covModel, double *bk, double nuUnifb){ +void updateBFsvcAbund(double *B, double *F, double *c, double *C, double *coords, int *nnIndx, int *nnIndxLU, int n, int m, double sigmaSq, double phi, double nu, int covModel, double *bk, double nuUnifb){ int i, k, l; int info = 0; @@ -62,81 +62,66 @@ void updateBFSVCNNGP(double *B, double *F, double *c, double *C, double *coords, } extern "C" { - SEXP svcAbundNNGP(SEXP y_r, SEXP X_r, SEXP Xw_r, SEXP coords_r, SEXP XRE_r, SEXP XRandom_r, - SEXP consts_r, SEXP nRELong_r, SEXP m_r, SEXP nnIndx_r, - SEXP nnIndxLU_r, SEXP uIndx_r, SEXP uIndxLU_r, SEXP uiIndx_r, - SEXP betaStarting_r, SEXP tauSqStarting_r, SEXP sigmaSqMuStarting_r, - SEXP betaStarStarting_r, - SEXP wStarting_r, SEXP phiStarting_r, - SEXP sigmaSqStarting_r, SEXP nuStarting_r, - SEXP betaStarIndx_r, SEXP betaLevelIndx_r, + SEXP svcAbundNNGP(SEXP y_r, SEXP X_r, SEXP Xw_r, SEXP coords_r, SEXP XRE_r, + SEXP XRandom_r, SEXP consts_r, SEXP nAbundRELong_r, + SEXP m_r, SEXP nnIndx_r, + SEXP nnIndxLU_r, SEXP uIndx_r, SEXP uIndxLU_r, + SEXP betaStarting_r, SEXP kappaStarting_r, + SEXP sigmaSqMuStarting_r, SEXP betaStarStarting_r, + SEXP wStarting_r, SEXP phiStarting_r, SEXP sigmaSqStarting_r, + SEXP nuStarting_r, + SEXP siteIndx_r, SEXP betaStarIndx_r, SEXP betaLevelIndx_r, SEXP muBeta_r, SEXP SigmaBeta_r, - SEXP tauSqA_r, SEXP tauSqB_r, SEXP phiA_r, SEXP phiB_r, - SEXP sigmaSqA_r, SEXP sigmaSqB_r, SEXP nuA_r, SEXP nuB_r, + SEXP kappaA_r, SEXP kappaB_r, SEXP sigmaSqMuA_r, SEXP sigmaSqMuB_r, - SEXP tuning_r, SEXP covModel_r, SEXP nBatch_r, - SEXP batchLength_r, SEXP acceptRate_r, SEXP nThreads_r, SEXP verbose_r, - SEXP nReport_r, SEXP samplesInfo_r, SEXP chainInfo_r){ + SEXP phiA_r, SEXP phiB_r, + SEXP sigmaSqA_r, SEXP sigmaSqB_r, SEXP nuA_r, SEXP nuB_r, SEXP tuning_r, + SEXP covModel_r, + SEXP nBatch_r, SEXP batchLength_r, SEXP acceptRate_r, SEXP nThreads_r, + SEXP verbose_r, SEXP nReport_r, SEXP samplesInfo_r, + SEXP chainInfo_r, SEXP family_r, SEXP offset_r){ /********************************************************************** * Initial constants * *******************************************************************/ - int i, j, l, ll, ii, k, s, r, q, info, nProtect=0; - int status = 0; // For AMCMC. + int i, g, t, j, k, jj, s, r, l, ll, rr, nProtect=0; const int inc = 1; - const double one = 1.0; - const double zero = 0.0; - char const *lower = "L"; - char const *ntran = "N"; - char const *ytran = "T"; - /********************************************************************** * Get Inputs * *******************************************************************/ double *y = REAL(y_r); double *X = REAL(X_r); - // Order: covariate, site double *Xw = REAL(Xw_r); + double *offset = REAL(offset_r); int *XRE = INTEGER(XRE_r); double *XRandom = REAL(XRandom_r); - int m = INTEGER(m_r)[0]; // Load constants int J = INTEGER(consts_r)[0]; - int p = INTEGER(consts_r)[1]; - int pRE = INTEGER(consts_r)[2]; - int nRE = INTEGER(consts_r)[3]; - int pTilde = INTEGER(consts_r)[4]; - int JZero = INTEGER(consts_r)[5]; - int pp = p * p; - int ppTilde = pTilde * pTilde; + int nObs = INTEGER(consts_r)[1]; + int pAbund = INTEGER(consts_r)[2]; + int pAbundRE = INTEGER(consts_r)[3]; + int nAbundRE = INTEGER(consts_r)[4]; + int saveFitted = INTEGER(consts_r)[5]; + int pTilde = INTEGER(consts_r)[6]; int JpTilde = J * pTilde; - int JpRE = J * pRE; - // Priors - double *muBeta = (double *) R_alloc(p, sizeof(double)); - F77_NAME(dcopy)(&p, REAL(muBeta_r), &inc, muBeta, &inc); - double *SigmaBetaInv = (double *) R_alloc(pp, sizeof(double)); - F77_NAME(dcopy)(&pp, REAL(SigmaBeta_r), &inc, SigmaBetaInv, &inc); + int ppAbund = pAbund * pAbund; + double *muBeta = (double *) R_alloc(pAbund, sizeof(double)); + F77_NAME(dcopy)(&pAbund, REAL(muBeta_r), &inc, muBeta, &inc); + double *SigmaBeta = (double *) R_alloc(ppAbund, sizeof(double)); + F77_NAME(dcopy)(&ppAbund, REAL(SigmaBeta_r), &inc, SigmaBeta, &inc); + double kappaA = REAL(kappaA_r)[0]; + double kappaB = REAL(kappaB_r)[0]; + double *sigmaSqMuA = REAL(sigmaSqMuA_r); + double *sigmaSqMuB = REAL(sigmaSqMuB_r); double *phiA = REAL(phiA_r); double *phiB = REAL(phiB_r); double *nuA = REAL(nuA_r); double *nuB = REAL(nuB_r); - double tauSqA = REAL(tauSqA_r)[0]; - double tauSqB = REAL(tauSqB_r)[0]; double *sigmaSqA = REAL(sigmaSqA_r); double *sigmaSqB = REAL(sigmaSqB_r); - double *sigmaSqMuA = REAL(sigmaSqMuA_r); - double *sigmaSqMuB = REAL(sigmaSqMuB_r); - double *tuning = REAL(tuning_r); - double *coords = REAL(coords_r); - int *nRELong = INTEGER(nRELong_r); - int *nnIndx = INTEGER(nnIndx_r); - int *nnIndxLU = INTEGER(nnIndxLU_r); - int *uIndx = INTEGER(uIndx_r); - int *uIndxLU = INTEGER(uIndxLU_r); - int *uiIndx = INTEGER(uiIndx_r); - int covModel = INTEGER(covModel_r)[0]; - std::string corName = getCorName(covModel); + int *nAbundRELong = INTEGER(nAbundRELong_r); + int *siteIndx = INTEGER(siteIndx_r); int *betaStarIndx = INTEGER(betaStarIndx_r); int *betaLevelIndx = INTEGER(betaLevelIndx_r); int nBatch = INTEGER(nBatch_r)[0]; @@ -145,20 +130,32 @@ extern "C" { int nBurn = INTEGER(samplesInfo_r)[0]; int nThin = INTEGER(samplesInfo_r)[1]; int nPost = INTEGER(samplesInfo_r)[2]; + int m = INTEGER(m_r)[0]; + int *nnIndx = INTEGER(nnIndx_r); + int *nnIndxLU = INTEGER(nnIndxLU_r); + int *uIndx = INTEGER(uIndx_r); + int *uIndxLU = INTEGER(uIndxLU_r); + int covModel = INTEGER(covModel_r)[0]; + std::string corName = getCorName(covModel); int currChain = INTEGER(chainInfo_r)[0]; - int nChain = INTEGER(chainInfo_r)[1]; double acceptRate = REAL(acceptRate_r)[0]; + double *tuning = REAL(tuning_r); + double *coords = REAL(coords_r); + int nChain = INTEGER(chainInfo_r)[1]; int nThreads = INTEGER(nThreads_r)[0]; int verbose = INTEGER(verbose_r)[0]; int nReport = INTEGER(nReport_r)[0]; + int status = 0; int thinIndx = 0; int sPost = 0; + // NB = 1, Poisson = 0; + int family = INTEGER(family_r)[0]; #ifdef _OPENMP omp_set_num_threads(nThreads); #else if(nThreads > 1){ - Rf_warning("n.omp.threads > %i, but source not compiled with OpenMP support.", nThreads); + Rf_warning("n.omp.threads > 1, but source not compiled with OpenMP support."); nThreads = 1; } #endif @@ -171,13 +168,17 @@ extern "C" { Rprintf("----------------------------------------\n"); Rprintf("\tModel description\n"); Rprintf("----------------------------------------\n"); - Rprintf("Spatial NNGP model with %i sites.\n\n", J); - Rprintf("Samples per chain: %i (%i batches of length %i)\n", nSamples, nBatch, batchLength); + if (family == 1) { + Rprintf("Spatial NNGP Negative Binomial Abundance model fit with %i sites.\n\n", J); + } else { + Rprintf("Spatial NNGP Poisson Abundance model fit with %i sites.\n\n", J); + } + Rprintf("Samples per Chain: %i (%i batches of length %i)\n", nSamples, nBatch, batchLength); Rprintf("Burn-in: %i \n", nBurn); Rprintf("Thinning Rate: %i \n", nThin); Rprintf("Number of Chains: %i \n", nChain); Rprintf("Total Posterior Samples: %i \n\n", nPost * nChain); - Rprintf("Number of spatially-varying coefficients: %i \n", pTilde); + Rprintf("Number of spatially-varying coefficients: %i \n", pTilde); Rprintf("Using the %s spatial correlation model.\n\n", corName.c_str()); Rprintf("Using %i nearest neighbors.\n\n", m); #ifdef _OPENMP @@ -199,122 +200,73 @@ extern "C" { /********************************************************************** * Parameters * *******************************************************************/ - double *beta = (double *) R_alloc(p, sizeof(double)); - F77_NAME(dcopy)(&p, REAL(betaStarting_r), &inc, beta, &inc); - // Occupancy random effect variances - double *sigmaSqMu = (double *) R_alloc(pRE, sizeof(double)); - F77_NAME(dcopy)(&pRE, REAL(sigmaSqMuStarting_r), &inc, sigmaSqMu, &inc); - // Latent occupancy random effects - double *betaStar = (double *) R_alloc(nRE, sizeof(double)); - F77_NAME(dcopy)(&nRE, REAL(betaStarStarting_r), &inc, betaStar, &inc); - // Spatial processes + // Abundance Covariates + double *beta = (double *) R_alloc(pAbund, sizeof(double)); + F77_NAME(dcopy)(&pAbund, REAL(betaStarting_r), &inc, beta, &inc); + // Abundance random effect variances + double *sigmaSqMu = (double *) R_alloc(pAbundRE, sizeof(double)); + F77_NAME(dcopy)(&pAbundRE, REAL(sigmaSqMuStarting_r), &inc, sigmaSqMu, &inc); + // Overdispersion parameter for NB; + double kappa = REAL(kappaStarting_r)[0]; + // Latent random effects + double *betaStar = (double *) R_alloc(nAbundRE, sizeof(double)); + F77_NAME(dcopy)(&nAbundRE, REAL(betaStarStarting_r), &inc, betaStar, &inc); + // Spatial parameters double *w = (double *) R_alloc(JpTilde, sizeof(double)); F77_NAME(dcopy)(&JpTilde, REAL(wStarting_r), &inc, w, &inc); - // Spatial variance - double *sigmaSq = (double *) R_alloc(pTilde, sizeof(double)); - F77_NAME(dcopy)(&pTilde, REAL(sigmaSqStarting_r), &inc, sigmaSq, &inc); - // Nugget - double tauSq = REAL(tauSqStarting_r)[0]; - // Spatial range parameter - double *phi = (double *) R_alloc(pTilde, sizeof(double)); - F77_NAME(dcopy)(&pTilde, REAL(phiStarting_r), &inc, phi, &inc); - // Spatial smoothing parameter for Matern - double *nu = (double *) R_alloc(pTilde, sizeof(double)); - F77_NAME(dcopy)(&pTilde, REAL(nuStarting_r), &inc, nu, &inc); + // Latent Abundance + double *yRep = (double *) R_alloc(nObs, sizeof(double)); zeros(yRep, nObs); /********************************************************************** * Return Stuff * *******************************************************************/ SEXP betaSamples_r; - PROTECT(betaSamples_r = Rf_allocMatrix(REALSXP, p, nPost)); nProtect++; - zeros(REAL(betaSamples_r), p * nPost); + PROTECT(betaSamples_r = Rf_allocMatrix(REALSXP, pAbund, nPost)); nProtect++; + zeros(REAL(betaSamples_r), pAbund * nPost); SEXP yRepSamples_r; - PROTECT(yRepSamples_r = Rf_allocMatrix(REALSXP, J, nPost)); nProtect++; - zeros(REAL(yRepSamples_r), J * nPost); - SEXP yRepZeroSamples_r; - PROTECT(yRepZeroSamples_r = Rf_allocMatrix(REALSXP, JZero, nPost)); nProtect++; - zeros(REAL(yRepZeroSamples_r), JZero * nPost); + SEXP muSamples_r; + SEXP likeSamples_r; + if (saveFitted == 1) { + PROTECT(yRepSamples_r = Rf_allocMatrix(REALSXP, nObs, nPost)); nProtect++; + zeros(REAL(yRepSamples_r), nObs * nPost); + PROTECT(muSamples_r = Rf_allocMatrix(REALSXP, nObs, nPost)); nProtect++; + zeros(REAL(muSamples_r), nObs * nPost); + PROTECT(likeSamples_r = Rf_allocMatrix(REALSXP, nObs, nPost)); nProtect++; + zeros(REAL(likeSamples_r), nObs * nPost); + } SEXP wSamples_r; PROTECT(wSamples_r = Rf_allocMatrix(REALSXP, JpTilde, nPost)); nProtect++; zeros(REAL(wSamples_r), JpTilde * nPost); - SEXP muSamples_r; - PROTECT(muSamples_r = Rf_allocMatrix(REALSXP, J, nPost)); nProtect++; - zeros(REAL(muSamples_r), J * nPost); - // Occurrence random effects + SEXP kappaSamples_r; + if (family == 1) { + PROTECT(kappaSamples_r = Rf_allocMatrix(REALSXP, inc, nPost)); nProtect++; + zeros(REAL(kappaSamples_r), nPost); + } + // Abundance random effects SEXP sigmaSqMuSamples_r; SEXP betaStarSamples_r; - if (pRE > 0) { - PROTECT(sigmaSqMuSamples_r = Rf_allocMatrix(REALSXP, pRE, nPost)); nProtect++; - zeros(REAL(sigmaSqMuSamples_r), pRE * nPost); - PROTECT(betaStarSamples_r = Rf_allocMatrix(REALSXP, nRE, nPost)); nProtect++; - zeros(REAL(betaStarSamples_r), nRE * nPost); + if (pAbundRE > 0) { + PROTECT(sigmaSqMuSamples_r = Rf_allocMatrix(REALSXP, pAbundRE, nPost)); nProtect++; + zeros(REAL(sigmaSqMuSamples_r), pAbundRE * nPost); + PROTECT(betaStarSamples_r = Rf_allocMatrix(REALSXP, nAbundRE, nPost)); nProtect++; + zeros(REAL(betaStarSamples_r), nAbundRE * nPost); } - SEXP tauSqSamples_r; - PROTECT(tauSqSamples_r = Rf_allocMatrix(REALSXP, inc, nPost)); nProtect++; - zeros(REAL(tauSqSamples_r), nPost); - // Likelihood samples for WAIC. - SEXP likeSamples_r; - PROTECT(likeSamples_r = Rf_allocMatrix(REALSXP, J, nPost)); nProtect++; - zeros(REAL(likeSamples_r), J * nPost); - /********************************************************************** - * Other initial starting stuff - * *******************************************************************/ - int Jp = J * p; - int jj, kk; - double tmp_0, tmp_02; - double *tmp_pp = (double *) R_alloc(pp, sizeof(double)); - double *tmp_p = (double *) R_alloc(p, sizeof(double)); - double *tmp_p2 = (double *) R_alloc(p, sizeof(double)); - double *tmp_one = (double *) R_alloc(1, sizeof(double)); - int *tmp_J = (int *) R_alloc(J, sizeof(int)); - for (j = 0; j < J; j++) { - tmp_J[j] = zero; - } - double *tmp_Jp = (double *) R_alloc(Jp, sizeof(double)); - double *tmp_J1 = (double *) R_alloc(J, sizeof(double)); - double *tmp_pTilde = (double *) R_alloc(pTilde, sizeof(double)); - double * tmp_ppTilde = (double *) R_alloc(ppTilde, sizeof(double)); - - // For latent occupancy - double *mu = (double *) R_alloc(J, sizeof(double)); - zeros(mu, J); - double *like = (double *) R_alloc(J, sizeof(double)); zeros(like, J); - double *yRep = (double *) R_alloc(J, sizeof(double)); zeros(yRep, J); - double *yRepZero = (double *) R_alloc(JZero, sizeof(double)); zeros(yRepZero, JZero); - - // For normal priors - // Occupancy regression coefficient priors. - F77_NAME(dpotrf)(lower, &p, SigmaBetaInv, &p, &info FCONE); - if(info != 0){Rf_error("c++ error: dpotrf SigmaBetaInv failed\n");} - F77_NAME(dpotri)(lower, &p, SigmaBetaInv, &p, &info FCONE); - if(info != 0){Rf_error("c++ error: dpotri SigmaBetaInv failed\n");} - double *SigmaBetaInvMuBeta = (double *) R_alloc(p, sizeof(double)); - F77_NAME(dsymv)(lower, &p, &one, SigmaBetaInv, &p, muBeta, &inc, &zero, - SigmaBetaInvMuBeta, &inc FCONE); + /******************************************************************** + Some constants and temporary variables to be used later + ********************************************************************/ + double tmp_0; + double *tmp_nObs = (double *) R_alloc(nObs, sizeof(double)); - /********************************************************************** - * Prep for random effects - * *******************************************************************/ - // Site-level sums of the occurrence random effects - double *betaStarSites = (double *) R_alloc(J, sizeof(double)); - int *betaStarLongIndx = (int *) R_alloc(JpRE, sizeof(int)); - zeros(betaStarSites, J); - // Initial sums - for (j = 0; j < J; j++) { - for (l = 0; l < pRE; l++) { - betaStarLongIndx[l * J + j] = which(XRE[l * J + j], betaLevelIndx, nRE); - betaStarSites[j] += betaStar[betaStarLongIndx[l * J + j]] * XRandom[l * J + j]; - } - } - // Starting index for occurrence random effects - int *betaStarStart = (int *) R_alloc(pRE, sizeof(int)); - for (l = 0; l < pRE; l++) { - betaStarStart[l] = which(l, betaStarIndx, nRE); - } + // For latent abundance and WAIC + double *like = (double *) R_alloc(nObs, sizeof(double)); zeros(like, nObs); + double *psi = (double *) R_alloc(nObs, sizeof(double)); + zeros(psi, nObs); + double *mu = (double *) R_alloc(nObs, sizeof(double)); + zeros(mu, nObs); /********************************************************************** - * Set up spatial stuff and MH stuff + * Set up spatial stuff * *******************************************************************/ int nTheta, sigmaSqIndx, phiIndx, nuIndx; if (corName != "matern") { @@ -325,33 +277,20 @@ extern "C" { sigmaSqIndx = 0; phiIndx = 1; nuIndx = 2; } int nThetapTilde = nTheta * pTilde; - double *accept = (double *) R_alloc(nThetapTilde, sizeof(double)); zeros(accept, nThetapTilde); + // theta is ordered by parameter, then SVC within parameter double *theta = (double *) R_alloc(nThetapTilde, sizeof(double)); - double logPostCurr = 0.0, logPostCand = 0.0; - double logDet; - double phiCand = 0.0, nuCand = 0.0; - SEXP acceptSamples_r; - PROTECT(acceptSamples_r = Rf_allocMatrix(REALSXP, nThetapTilde, nBatch)); nProtect++; - zeros(REAL(acceptSamples_r), nThetapTilde * nBatch); - SEXP tuningSamples_r; - PROTECT(tuningSamples_r = Rf_allocMatrix(REALSXP, nThetapTilde, nBatch)); nProtect++; - zeros(REAL(tuningSamples_r), nThetapTilde * nBatch); + double *nu = (double *) R_alloc(pTilde, sizeof(double)); SEXP thetaSamples_r; PROTECT(thetaSamples_r = Rf_allocMatrix(REALSXP, nThetapTilde, nPost)); nProtect++; zeros(REAL(thetaSamples_r), nThetapTilde * nPost); - double b, e, aij, aa; - double *a = (double *) R_alloc(pTilde, sizeof(double)); - double *v = (double *) R_alloc(pTilde, sizeof(double)); - double *muNNGP = (double *) R_alloc(pTilde, sizeof(double)); - double *var = (double *) R_alloc(ppTilde, sizeof(double)); zeros(var, ppTilde); - double *ff = (double *) R_alloc(pTilde, sizeof(double)); - double *gg = (double *) R_alloc(pTilde, sizeof(double)); + double a, b, e; // Initiate spatial values for (i = 0; i < pTilde; i++) { - theta[sigmaSqIndx * pTilde + i] = sigmaSq[i]; - theta[phiIndx * pTilde + i] = phi[i]; + theta[sigmaSqIndx * pTilde + i] = REAL(sigmaSqStarting_r)[i]; + theta[phiIndx * pTilde + i] = REAL(phiStarting_r)[i]; if (corName == "matern") { - theta[nuIndx * pTilde + i] = nu[i]; + theta[nuIndx * pTilde + i] = REAL(nuStarting_r)[i]; + nu[i] = theta[nuIndx * pTilde + i]; } } // i // Allocate for the U index vector that keep track of which locations have @@ -367,459 +306,616 @@ extern "C" { double *c =(double *) R_alloc(m*nThreads * pTilde, sizeof(double)); double *C = (double *) R_alloc(mm*nThreads * pTilde, sizeof(double)); int sizeBK = nThreads*(1.0+static_cast(floor(nuB[0]))); - double *bk = (double *) R_alloc(pTilde*sizeBK, sizeof(double)); + double *bk = (double *) R_alloc(nThreads* pTilde * sizeBK, sizeof(double)); - // Initiate B and F for each SVC for (i = 0; i < pTilde; i++) { - updateBFSVCNNGP(&B[i * nIndx], &F[i*J], &c[i * m*nThreads], &C[i * mm * nThreads], coords, nnIndx, nnIndxLU, J, m, theta[sigmaSqIndx * pTilde + i], theta[phiIndx * pTilde + i], nu[i], covModel, &bk[i * sizeBK], nuB[i]); + updateBFsvcAbund(&B[i * nIndx], &F[i * J], &c[i * m * nThreads], + &C[i * mm * nThreads], coords, nnIndx, nnIndxLU, J, m, + theta[sigmaSqIndx * pTilde + i], theta[phiIndx * pTilde + i], nu[i], + covModel, &bk[i * sizeBK], nuB[i]); } + // Spatial process sums for each site - double *wSites = (double *) R_alloc(J, sizeof(double)); + double *wSites = (double *) R_alloc(nObs, sizeof(double)); + double *wSitesCand = (double *) R_alloc(nObs, sizeof(double)); // For each location, multiply w x Xw - for (j = 0; j < J; j++) { - wSites[j] = 0.0; + for (i = 0; i < nObs; i++) { + wSites[i] = 0.0; for (ll = 0; ll < pTilde; ll++) { - wSites[j] += w[j * pTilde + ll] * Xw[ll * J + j]; + wSites[i] += w[siteIndx[i] * pTilde + ll] * Xw[ll * nObs + i]; } + wSitesCand[i] = wSites[i]; } - GetRNGstate(); + /******************************************************************** + Set up MH stuff + ********************************************************************/ + double logPostBetaCurr = 0.0, logPostBetaCand = 0.0; + double logPostKappaCurr = 0.0, logPostKappaCand = 0.0; + double logPostThetaCurr = 0.0, logPostThetaCand = 0.0; + double *logPostWCand = (double *) R_alloc(JpTilde, sizeof(double)); + double *logPostWCurr = (double *) R_alloc(JpTilde, sizeof(double)); + for (j = 0; j < JpTilde; j++) { + logPostWCurr[j] = R_NegInf; + logPostWCand[j] = logPostWCurr[j]; + } + double *logPostBetaStarCand = (double *) R_alloc(nAbundRE, sizeof(double)); + double *logPostBetaStarCurr = (double *) R_alloc(nAbundRE, sizeof(double)); + for (j = 0; j < nAbundRE; j++) { + logPostBetaStarCurr[j] = R_NegInf; + logPostBetaStarCand[j] = logPostBetaStarCurr[j]; + } + double logDet; + double *phiCand = (double *) R_alloc(pTilde, sizeof(double)); + double *sigmaSqCand = (double *) R_alloc(pTilde, sizeof(double)); + double *nuCand = (double *) R_alloc(pTilde, sizeof(double)); + for (i = 0; i < pTilde; i++) { + phiCand[i] = theta[phiIndx * pTilde + i]; + sigmaSqCand[i] = theta[sigmaSqIndx * pTilde + i]; + if (corName == "matern") { + nuCand[i] = theta[nuIndx * pTilde + i]; + } + } + double *betaCand = (double *) R_alloc(pAbund, sizeof(double)); + for (j = 0; j < pAbund; j++) { + betaCand[j] = beta[j]; + } + // w is ordered by site, then SVC within site. + double *wCand = (double *) R_alloc(JpTilde, sizeof(double)); + for (i = 0; i < pTilde; i++) { + for (j = 0; j < J; j++) { + wCand[j * pTilde + i] = w[j * pTilde + i]; + } + } + double *betaStarCand = (double *) R_alloc(nAbundRE, sizeof(double)); + for (j = 0; j < nAbundRE; j++) { + betaStarCand[j] = betaStar[j]; + } + double kappaCand = 0.0; + kappaCand = kappa; + // theta, beta, and w + int nAMCMC = 0; + if (pAbundRE > 0) { + nAMCMC = nThetapTilde + pAbund + JpTilde + nAbundRE; + } else { + nAMCMC = nThetapTilde + pAbund + JpTilde; + } + if (family == 1) { + nAMCMC++; + } + int betaAMCMCIndx = 0; + int sigmaSqAMCMCIndx = betaAMCMCIndx + pAbund; + int phiAMCMCIndx = sigmaSqAMCMCIndx + pTilde; + int nuAMCMCIndx; + if (corName == "matern") { + nuAMCMCIndx = phiAMCMCIndx + pTilde; + } else { + nuAMCMCIndx = phiAMCMCIndx; + } + int wAMCMCIndx = nuAMCMCIndx + pTilde; + int betaStarAMCMCIndx = wAMCMCIndx + JpTilde; + int kappaAMCMCIndx = betaStarAMCMCIndx + nAbundRE; + double *accept = (double *) R_alloc(nAMCMC, sizeof(double)); zeros(accept, nAMCMC); + SEXP acceptSamples_r; + PROTECT(acceptSamples_r = Rf_allocMatrix(REALSXP, nAMCMC, nBatch)); nProtect++; + zeros(REAL(acceptSamples_r), nAMCMC * nBatch); + SEXP tuningSamples_r; + PROTECT(tuningSamples_r = Rf_allocMatrix(REALSXP, nAMCMC, nBatch)); nProtect++; + zeros(REAL(tuningSamples_r), nAMCMC * nBatch); /********************************************************************** - * Begin Sampler + * Prep for random effects * *******************************************************************/ - for (s = 0, q = 0; s < nBatch; s++) { - for (r = 0; r < batchLength; r++, q++) { + // Site-level sums of the abundance random effects + double *betaStarSites = (double *) R_alloc(nObs, sizeof(double)); + double *betaStarSitesCand = (double *) R_alloc(nObs, sizeof(double)); + zeros(betaStarSites, nObs); + // Initial sums + for (j = 0; j < nObs; j++) { + for (l = 0; l < pAbundRE; l++) { + betaStarSites[j] += betaStar[which(XRE[l * nObs + j], betaLevelIndx, nAbundRE)] * + XRandom[l * nObs + j]; + } + betaStarSitesCand[j] = betaStarSites[j]; + } + // Starting index for abundance random effects + int *betaStarStart = (int *) R_alloc(pAbundRE, sizeof(int)); + for (l = 0; l < pAbundRE; l++) { + betaStarStart[l] = which(l, betaStarIndx, nAbundRE); + } + logPostBetaCurr = R_NegInf; + logPostThetaCurr = R_NegInf; + GetRNGstate(); + + for (s = 0, g = 0; s < nBatch; s++) { + for (t = 0; t < batchLength; t++, g++) { /******************************************************************** - *Update Regression Coefficients + *Update Abundance Regression Coefficients *******************************************************************/ - for (j = 0; j < J; j++) { - tmp_J1[j] = (y[j] - wSites[j] - betaStarSites[j]) / tauSq; - } // j - /******************************** - * Compute b.beta - *******************************/ - F77_NAME(dgemv)(ytran, &J, &p, &one, X, &J, tmp_J1, &inc, &zero, tmp_p, &inc FCONE); - for (j = 0; j < p; j++) { - tmp_p[j] += SigmaBetaInvMuBeta[j]; - } // j - - /******************************** - * Compute A.beta - * *****************************/ - for(j = 0; j < J; j++){ - for(i = 0; i < p; i++){ - tmp_Jp[i*J+j] = X[i*J+j] / tauSq; + for (k = 0; k < pAbund; k++) { + logPostBetaCand = 0.0; + logPostBetaCurr = 0.0; + betaCand[k] = rnorm(beta[k], exp(tuning[betaAMCMCIndx + k])); + logPostBetaCand += dnorm(betaCand[k], muBeta[k], sqrt(SigmaBeta[k * pAbund + k]), 1); + logPostBetaCurr += dnorm(beta[k], muBeta[k], sqrt(SigmaBeta[k * pAbund + k]), 1); + for (j = 0; j < nObs; j++) { + tmp_nObs[j] = exp(F77_NAME(ddot)(&pAbund, &X[j], &nObs, betaCand, &inc) + betaStarSites[j] + + wSites[j]); + if (family == 1) { + logPostBetaCand += dnbinom_mu(y[j], kappa, tmp_nObs[j] * offset[j], 1); + } else { + logPostBetaCand += dpois(y[j], tmp_nObs[j] * offset[j], 1); + } + tmp_nObs[j] = exp(F77_NAME(ddot)(&pAbund, &X[j], &nObs, beta, &inc) + betaStarSites[j] + + wSites[j]); + if (family == 1) { + logPostBetaCurr += dnbinom_mu(y[j], kappa, tmp_nObs[j] * offset[j], 1); + } else { + logPostBetaCurr += dpois(y[j], tmp_nObs[j] * offset[j], 1); + } + } + if (runif(0.0, 1.0) <= exp(logPostBetaCand - logPostBetaCurr)) { + beta[k] = betaCand[k]; + accept[betaAMCMCIndx + k]++; + } else { + betaCand[k] = beta[k]; } } - F77_NAME(dgemm)(ytran, ntran, &p, &p, &J, &one, X, &J, tmp_Jp, &J, &zero, tmp_pp, &p FCONE FCONE); - for (j = 0; j < pp; j++) { - tmp_pp[j] += SigmaBetaInv[j]; - } // j - - F77_NAME(dpotrf)(lower, &p, tmp_pp, &p, &info FCONE); - if(info != 0){Rf_error("c++ error: dpotrf here failed\n");} - F77_NAME(dpotri)(lower, &p, tmp_pp, &p, &info FCONE); - if(info != 0){Rf_error("c++ error: dpotri here failed\n");} - F77_NAME(dsymv)(lower, &p, &one, tmp_pp, &p, tmp_p, &inc, &zero, tmp_p2, &inc FCONE); - F77_NAME(dpotrf)(lower, &p, tmp_pp, &p, &info FCONE); - if(info != 0){Rf_error("c++ error: dpotrf here failed\n");} - mvrnorm(beta, tmp_p2, tmp_pp, p); - /******************************************************************** - *Update random effects variance + *Update abundance random effects variance *******************************************************************/ - for (l = 0; l < pRE; l++) { - tmp_0 = F77_NAME(ddot)(&nRELong[l], &betaStar[betaStarStart[l]], &inc, &betaStar[betaStarStart[l]], &inc); + for (l = 0; l < pAbundRE; l++) { + tmp_0 = F77_NAME(ddot)(&nAbundRELong[l], &betaStar[betaStarStart[l]], + &inc, &betaStar[betaStarStart[l]], &inc); tmp_0 *= 0.5; - sigmaSqMu[l] = rigamma(sigmaSqMuA[l] + nRELong[l] / 2.0, sigmaSqMuB[l] + tmp_0); + sigmaSqMu[l] = rigamma(sigmaSqMuA[l] + nAbundRELong[l] / 2.0, sigmaSqMuB[l] + tmp_0); } /******************************************************************** - *Update random effects + *Update abundance random effects *******************************************************************/ - // TODO: The random slopes component of this does not work. - if (pRE > 0) { - // Update each individual random effect one by one. - for (l = 0; l < nRE; l++) { - /******************************** - * Compute b.beta.star - *******************************/ - zeros(tmp_one, inc); - tmp_0 = 0.0; - // Only allow information to come from when XRE == betaLevelIndx[l]. - // aka information only comes from the sites with any given level - // of a random effect. - for (j = 0; j < J; j++) { - if (XRE[betaStarIndx[l] * J + j] == betaLevelIndx[l]) { - tmp_02 = 0.0; - for (ll = 0; ll < pRE; ll++) { - tmp_02 += betaStar[betaStarLongIndx[ll * J + j]] * XRandom[ll * J + j]; - } - tmp_one[0] += XRandom[betaStarIndx[l] * J + j] * (y[j] - F77_NAME(ddot)(&p, &X[j], &J, beta, &inc) - - tmp_02 + (betaStar[l] * XRandom[betaStarIndx[l] * J + j]) - - wSites[j]) / tauSq; - // TODO: check this out. This matches postHocLM. - tmp_0 += XRandom[betaStarIndx[l] * J + j] * XRandom[betaStarIndx[l] * J + j] / tauSq; + if (pAbundRE > 0) { + for (l = 0; l < nAbundRE; l++) { + betaStarCand[l] = rnorm(betaStar[l], exp(tuning[betaStarAMCMCIndx + l])); + logPostBetaStarCand[l] = dnorm(betaStarCand[l], 0.0, + sqrt(sigmaSqMu[betaStarIndx[l]]), 1); + logPostBetaStarCurr[l] = dnorm(betaStar[l], 0.0, + sqrt(sigmaSqMu[betaStarIndx[l]]), 1); + for (j = 0; j < nObs; j++) { + if (XRE[betaStarIndx[l] * nObs + j] == betaLevelIndx[l]) { + // Candidate + betaStarSitesCand[j] = 0.0; + for (ll = 0; ll < pAbundRE; ll++) { + betaStarSitesCand[j] += betaStarCand[which(XRE[ll * nObs + j], + betaLevelIndx, nAbundRE)] * + XRandom[ll * nObs + j]; + } + tmp_nObs[j] = exp(F77_NAME(ddot)(&pAbund, &X[j], &nObs, beta, &inc) + + betaStarSitesCand[j] + wSites[j]); + if (family == 1) { + logPostBetaStarCand[l] += dnbinom_mu(y[j], kappa, tmp_nObs[j] * offset[j], 1); + } else { + logPostBetaStarCand[l] += dpois(y[j], tmp_nObs[j] * offset[j], 1); + } + // Current + betaStarSites[j] = 0.0; + for (ll = 0; ll < pAbundRE; ll++) { + betaStarSites[j] += betaStar[which(XRE[ll * nObs + j], + betaLevelIndx, nAbundRE)] * + XRandom[ll * nObs + j]; + } + tmp_nObs[j] = exp(F77_NAME(ddot)(&pAbund, &X[j], &nObs, beta, &inc) + + betaStarSites[j] + wSites[j]); + if (family == 1) { + logPostBetaStarCurr[l] += dnbinom_mu(y[j], kappa, tmp_nObs[j] * offset[j], 1); + } else { + logPostBetaStarCurr[l] += dpois(y[j], tmp_nObs[j] * offset[j], 1); + } } } - /******************************** - * Compute A.beta.star - *******************************/ - tmp_0 += 1.0 / sigmaSqMu[betaStarIndx[l]]; - tmp_0 = 1.0 / tmp_0; - betaStar[l] = rnorm(tmp_0 * tmp_one[0], sqrt(tmp_0)); - } - - // Update the RE sums for the current species - zeros(betaStarSites, J); - for (j = 0; j < J; j++) { - for (l = 0; l < pRE; l++) { - betaStarSites[j] += betaStar[betaStarLongIndx[l * J + j]] * XRandom[l * J + j]; + if (runif (0.0, 1.0) <= exp(logPostBetaStarCand[l] - logPostBetaStarCurr[l])) { + betaStar[l] = betaStarCand[l]; + F77_NAME(dcopy)(&nObs, betaStarSitesCand, &inc, betaStarSites, &inc); + accept[betaStarAMCMCIndx + l]++; + } else { + betaStarCand[l] = betaStar[l]; + F77_NAME(dcopy)(&nObs, betaStarSites, &inc, betaStarSitesCand, &inc); } } } /******************************************************************** - *Update tau.sq + * Update all spatial parameters one SVC at a time *******************************************************************/ - for(j = 0; j < J; j++){ - tmp_J1[j] = y[j] - wSites[j] - - F77_NAME(ddot)(&p, &X[j], &J, beta, &inc) - betaStarSites[j]; - } - tauSq = rigamma(tauSqA + J / 2.0, tauSqB + 0.5 * - F77_NAME(ddot)(&J, tmp_J1, &inc, tmp_J1, &inc)); - - /******************************************************************** - *Update w (spatial random effects) - *******************************************************************/ - for (ii = 0; ii < J; ii++) { - - for (ll = 0; ll < pTilde; ll++) { // row - // tmp_pTilde = X_tilde' %*% omega_beta - tmp_pTilde[ll] = Xw[ll * J + ii] / tauSq; - // Compute tmp_pTilde %*% t(Xw) - for (k = 0; k < pTilde; k++) { // column - tmp_ppTilde[ll * pTilde + k] = tmp_pTilde[ll] * - Xw[k * J + ii]; - } // k - - a[ll] = 0; - v[ll] = 0; - - if (uIndxLU[J + ii] > 0){ // is ii a neighbor for anybody - for (j = 0; j < uIndxLU[J+ii]; j++){ // how many locations have ii as a neighbor - b = 0; - // now the neighbors for the jth location who has ii as a neighbor - jj = uIndx[uIndxLU[ii]+j]; // jj is the index of the jth location who has ii as a neighbor - for(k = 0; k < nnIndxLU[J+jj]; k++){ // these are the neighbors of the jjth location - kk = nnIndx[nnIndxLU[jj]+k]; // kk is the index for the jth locations neighbors - if(kk != ii){ //if the neighbor of jj is not ii - b += B[ll*nIndx + nnIndxLU[jj]+k]*w[kk * pTilde + ll]; //covariance between jj and kk and the random effect of kk + for (ll = 0; ll < pTilde; ll++) { + /******************************************************************** + *Update w (spatial random effects) + *******************************************************************/ + for (j = 0; j < J; j++) { + // Proposal + a = 0.0; + // Propose new value + logPostWCand[j * pTilde + ll] = 0.0; + wCand[j * pTilde + ll] = rnorm(w[j * pTilde + ll], + exp(tuning[wAMCMCIndx + j * pTilde + ll])); + // MVN for any neighbors of j + if (uIndxLU[J + j] > 0) { // if current location j is a neighbor for anybody + for (r = 0; r < uIndxLU[J + j]; r++) { // how many locations have j as a neighbor + jj = uIndx[uIndxLU[j] + r]; // jj is the index of the rth location who has j as a neighbor + e = 0; + for (i = 0; i < nnIndxLU[J+jj]; i++){ // neighbors of the jjth location + e += B[ll * nIndx + nnIndxLU[jj]+i]*wCand[(nnIndx[nnIndxLU[jj]+i]) * pTilde + ll]; + } + b = wCand[jj * pTilde + ll] - e; + a += b*b/F[ll * J + j]; + } } - } // k - aij = w[jj * pTilde + ll] - b; - a[ll] += B[ll*nIndx + nnIndxLU[jj]+uiIndx[uIndxLU[ii]+j]]*aij/F[ll*J + jj]; - v[ll] += pow(B[ll * nIndx + nnIndxLU[jj]+uiIndx[uIndxLU[ii]+j]],2)/F[ll * J + jj]; - } // j - } - - e = 0; - for(j = 0; j < nnIndxLU[J+ii]; j++){ - e += B[ll * nIndx + nnIndxLU[ii]+j]*w[nnIndx[nnIndxLU[ii]+j] * pTilde + ll]; - } - - ff[ll] = 1.0 / F[ll * J + ii]; - gg[ll] = e / F[ll * J + ii]; - } // ll - - // var - F77_NAME(dcopy)(&ppTilde, tmp_ppTilde, &inc, var, &inc); - for (k = 0; k < pTilde; k++) { - var[k * pTilde + k] += ff[k] + v[k]; - } // k - F77_NAME(dpotrf)(lower, &pTilde, var, &pTilde, &info FCONE); - if(info != 0){Rf_error("c++ error: dpotrf var failed\n");} - F77_NAME(dpotri)(lower, &pTilde, var, &pTilde, &info FCONE); - if(info != 0){Rf_error("c++ error: dpotri var failed\n");} - - // muNNGP - for (k = 0; k < pTilde; k++) { - muNNGP[k] = (y[ii] - F77_NAME(ddot)(&p, &X[ii], &J, beta, &inc) - betaStarSites[ii]) / tauSq * Xw[k * J + ii] + gg[k] + a[k]; - } // k - - F77_NAME(dsymv)(lower, &pTilde, &one, var, &pTilde, muNNGP, &inc, &zero, tmp_pTilde, &inc FCONE); - - F77_NAME(dpotrf)(lower, &pTilde, var, &pTilde, &info FCONE); - if(info != 0){Rf_error("c++ error: dpotrf var 2 failed\n");} - - mvrnorm(&w[ii * pTilde], tmp_pTilde, var, pTilde); - - } // ii - - - // Compute Xw %*% w = wSites. - // This calculation is correct (confirmed April 27) - for (j = 0; j < J; j++) { - wSites[j] = 0.0; - for (ll = 0; ll < pTilde; ll++) { - wSites[j] += w[j * pTilde + ll] * Xw[ll * J + j]; - // Rprintf("w[%i]: %f\n", j * pTilde + ll, w[j * pTilde + ll]); - } - // Rprintf("wSites[%i]: %f\n", j, wSites[j]); - } + // MVN for j + if (nnIndxLU[J + j] > 0) { // if j has any neighbors + e = 0; + for(i = 0; i < nnIndxLU[J+j]; i++){ + e += B[ll * nIndx + nnIndxLU[j]+i]*wCand[(nnIndx[nnIndxLU[j]+i]) * pTilde + ll]; + } + b = wCand[j * pTilde + ll] - e; + } else{ + b = wCand[j * pTilde + ll]; + } + a += b*b/F[ll * J + j]; + logPostWCand[j * pTilde + ll] = -0.5*a; + for (i = 0; i < nObs; i++) { + if (siteIndx[i] == j) { + wSitesCand[i] = 0.0; + for (rr = 0; rr < pTilde; rr++) { + wSitesCand[i] += wCand[j * pTilde + rr] * Xw[rr * nObs + i]; + } + tmp_nObs[i] = exp(F77_NAME(ddot)(&pAbund, &X[i], &nObs, beta, &inc) + + betaStarSites[i] + wSitesCand[i]); + if (family == 1) { + logPostWCand[j * pTilde + ll] += dnbinom_mu(y[i], kappa, tmp_nObs[i] * offset[i], 1); + } else { + logPostWCand[j * pTilde + ll] += dpois(y[i], tmp_nObs[i] * offset[i], 1); + } + } + } + a = 0.0; + // MVN for any neighbors of j + if (uIndxLU[J + j] > 0) { // if current location j is a neighbor for anybody + for (r = 0; r < uIndxLU[J + j]; r++) { // how many locations have j as a neighbor + jj = uIndx[uIndxLU[j] + r]; // jj is the index of the rth location who has j as a neighbor + e = 0; + for (i = 0; i < nnIndxLU[J+jj]; i++){ // neighbors of the jjth location + e += B[ll * nIndx + nnIndxLU[jj]+i]*w[(nnIndx[nnIndxLU[jj]+i]) * pTilde + ll]; + } + b = w[jj * pTilde + ll] - e; + a += b*b/F[ll * J + jj]; + } + } + // MVN for j + if(nnIndxLU[J+j] > 0){ // if j has any neighbors + e = 0; + for(i = 0; i < nnIndxLU[J+j]; i++){ + e += B[ll * nIndx + nnIndxLU[j]+i]*w[(nnIndx[nnIndxLU[j]+i]) * pTilde + ll]; + } + b = w[j * pTilde + ll] - e; + } else{ + b = w[j * pTilde + ll]; + } + a += b*b/F[ll * J + j]; + logPostWCurr[j * pTilde + ll] = -0.5*a; + for (i = 0; i < nObs; i++) { + if (siteIndx[i] == j) { + tmp_nObs[i] = exp(F77_NAME(ddot)(&pAbund, &X[i], &nObs, beta, &inc) + + betaStarSites[i] + wSites[i]); + if (family == 1) { + logPostWCurr[j * pTilde + ll] += dnbinom_mu(y[i], kappa, tmp_nObs[i] * offset[i], 1); + } else { + logPostWCurr[j * pTilde + ll] += dpois(y[i], tmp_nObs[i] * offset[i], 1); + } + } + } + if (runif(0.0, 1.0) <= exp(logPostWCand[j * pTilde + ll] - logPostWCurr[j * pTilde + ll])) { + w[j * pTilde + ll] = wCand[j * pTilde + ll]; + for (i = 0; i < nObs; i++) { + wSites[i] = wSitesCand[i]; + } + accept[wAMCMCIndx + j * pTilde + ll]++; + } else { + wCand[j * pTilde + ll] = w[j * pTilde + ll]; + for (i = 0; i < nObs; i++) { + wSitesCand[i] = wSites[i]; + } + } + } // j - /******************************************************************** - *Update spatial covariance parameters - *******************************************************************/ - for (ll = 0; ll < pTilde; ll++) { - /****************************************************************** + /******************************************************************** *Update sigmaSq - *****************************************************************/ - aa = 0; + *******************************************************************/ + a = 0; #ifdef _OPENMP -#pragma omp parallel for private (e, i, b) reduction(+:aa, logDet) +#pragma omp parallel for private (e, i, b) reduction(+:a) #endif for (j = 0; j < J; j++){ - if(nnIndxLU[J+j] > 0){ + if (nnIndxLU[J+j] > 0){ e = 0; for(i = 0; i < nnIndxLU[J+j]; i++){ e += B[ll * nIndx + nnIndxLU[j]+i]*w[nnIndx[nnIndxLU[j]+i] * pTilde + ll]; } b = w[j * pTilde + ll] - e; - }else{ + } else{ b = w[j * pTilde + ll]; } - aa += b*b/F[ll * J + j]; + a += b*b/F[ll * J + j]; } - theta[sigmaSqIndx * pTilde + ll] = rigamma(sigmaSqA[ll] + J / 2.0, sigmaSqB[ll] + 0.5 * aa * theta[sigmaSqIndx * pTilde + ll]); + theta[sigmaSqIndx * pTilde + ll] = rigamma(sigmaSqA[ll] + J / 2.0, + sigmaSqB[ll] + 0.5 * a * theta[sigmaSqIndx * pTilde + ll]); - /****************************************************************** + /******************************************************************** *Update phi (and nu if matern) - *****************************************************************/ - // Current + *******************************************************************/ if (corName == "matern"){ - nu[ll] = theta[nuIndx * pTilde + ll]; - } - updateBFSVCNNGP(&B[ll * nIndx], &F[ll*J], &c[ll * m*nThreads], &C[ll * mm * nThreads], coords, nnIndx, nnIndxLU, J, m, theta[sigmaSqIndx * pTilde + ll], theta[phiIndx * pTilde + ll], nu[ll], covModel, &bk[ll * sizeBK], nuB[ll]); - aa = 0; + nu[ll] = theta[nuIndx * pTilde + ll]; + } + updateBFsvcAbund(&B[ll * nIndx], &F[ll * J], &c[ll * m * nThreads], + &C[ll * mm * nThreads], coords, nnIndx, nnIndxLU, J, m, + theta[sigmaSqIndx * pTilde + ll], theta[phiIndx * pTilde + ll], nu[ll], + covModel, &bk[ll * sizeBK], nuB[ll]); + a = 0; logDet = 0; #ifdef _OPENMP -#pragma omp parallel for private (e, ii, b) reduction(+:aa, logDet) +#pragma omp parallel for private (e, i, b) reduction(+:a, logDet) #endif for (j = 0; j < J; j++){ if (nnIndxLU[J+j] > 0){ e = 0; - for (ii = 0; ii < nnIndxLU[J+j]; ii++){ - e += B[ll * nIndx + nnIndxLU[j]+ii]*w[nnIndx[nnIndxLU[j]+ii] * pTilde + ll]; + for (i = 0; i < nnIndxLU[J+j]; i++){ + e += B[ll * nIndx + nnIndxLU[j]+i]*w[(nnIndx[nnIndxLU[j]+i]) * pTilde + ll]; } b = w[j * pTilde + ll] - e; } else{ b = w[j * pTilde + ll]; } - aa += b*b/F[ll * J + j]; + a += b*b/F[ll * J + j]; logDet += log(F[ll * J + j]); } - logPostCurr = -0.5 * logDet - 0.5 * aa; - logPostCurr += log(theta[phiIndx * pTilde + ll] - phiA[ll]) + log(phiB[ll] - theta[phiIndx * pTilde + ll]); - if(corName == "matern"){ - logPostCurr += log(theta[nuIndx * pTilde + ll] - nuA[ll]) + log(nuB[ll] - theta[nuIndx * pTilde + ll]); + logPostThetaCurr = -0.5*logDet - 0.5*a; + logPostThetaCurr += log(theta[phiIndx * pTilde + ll] - phiA[ll]) + + log(phiB[ll] - theta[phiIndx * pTilde + ll]); + if (corName == "matern"){ + logPostThetaCurr += log(theta[nuIndx * pTilde + ll] - nuA[ll]) + + log(nuB[ll] - theta[nuIndx * pTilde + ll]); } // Candidate - phiCand = logitInv(rnorm(logit(theta[phiIndx * pTilde + ll], phiA[ll], phiB[ll]), exp(tuning[phiIndx * pTilde + ll])), phiA[ll], phiB[ll]); + phiCand[ll] = logitInv(rnorm(logit(theta[phiIndx * pTilde + ll], phiA[ll], phiB[ll]), + exp(tuning[phiAMCMCIndx + ll])), phiA[ll], phiB[ll]); if (corName == "matern"){ - nuCand = logitInv(rnorm(logit(theta[nuIndx * pTilde + ll], nuA[ll], nuB[ll]), exp(tuning[nuIndx * pTilde + ll])), nuA[ll], nuB[ll]); + nuCand[ll] = logitInv(rnorm(logit(theta[nuIndx * pTilde + ll], nuA[ll], nuB[ll]), + exp(tuning[nuAMCMCIndx + ll])), nuA[ll], nuB[ll]); } - updateBFSVCNNGP(BCand, FCand, &c[ll * m*nThreads], &C[ll * mm * nThreads], coords, nnIndx, nnIndxLU, J, m, theta[sigmaSqIndx * pTilde + ll], phiCand, nuCand, covModel, &bk[ll * sizeBK], nuB[ll]); + updateBFsvcAbund(BCand, FCand, &c[ll * m * nThreads], &C[ll * mm * nThreads], + coords, nnIndx, nnIndxLU, J, m, + theta[sigmaSqIndx * pTilde + ll], phiCand[ll], nuCand[ll], covModel, + &bk[ll * sizeBK], nuB[ll]); - aa = 0; + a = 0; logDet = 0; #ifdef _OPENMP -#pragma omp parallel for private (e, ii, b) reduction(+:aa, logDet) +#pragma omp parallel for private (e, i, b) reduction(+:a, logDet) #endif for (j = 0; j < J; j++){ if (nnIndxLU[J+j] > 0){ e = 0; - for (ii = 0; ii < nnIndxLU[J+j]; ii++){ - e += BCand[nnIndxLU[j]+ii]*w[nnIndx[nnIndxLU[j]+ii] * pTilde + ll]; + for (i = 0; i < nnIndxLU[J+j]; i++){ + e += BCand[nnIndxLU[j]+i]*w[(nnIndx[nnIndxLU[j]+i]) * pTilde + ll]; } b = w[j * pTilde + ll] - e; } else{ b = w[j * pTilde + ll]; - } - aa += b*b/FCand[j]; - logDet += log(FCand[j]); + } + a += b*b/FCand[j]; + logDet += log(FCand[j]); } - logPostCand = -0.5*logDet - 0.5*aa; - logPostCand += log(phiCand - phiA[ll]) + log(phiB[ll] - phiCand); + logPostThetaCand = -0.5*logDet - 0.5*a; + logPostThetaCand += log(phiCand[ll] - phiA[ll]) + log(phiB[ll] - phiCand[ll]); if (corName == "matern"){ - logPostCand += log(nuCand - nuA[ll]) + log(nuB[ll] - nuCand); + logPostThetaCand += log(nuCand[ll] - nuA[ll]) + log(nuB[ll] - nuCand[ll]); } - - if (runif(0.0,1.0) <= exp(logPostCand - logPostCurr)) { + + if (runif(0.0,1.0) <= exp(logPostThetaCand - logPostThetaCurr)) { F77_NAME(dcopy)(&nIndx, BCand, &inc, &B[ll * nIndx], &inc); F77_NAME(dcopy)(&J, FCand, &inc, &F[ll * J], &inc); - theta[phiIndx * pTilde + ll] = phiCand; - accept[phiIndx * pTilde + ll]++; - if (corName == "matern") { - nu[ll] = nuCand; - theta[nuIndx * pTilde + ll] = nu[ll]; - accept[nuIndx * pTilde + ll]++; + theta[phiIndx * pTilde + ll] = phiCand[ll]; + accept[phiAMCMCIndx + ll]++; + if(corName == "matern"){ + theta[nuIndx * pTilde + ll] = nuCand[ll]; + accept[nuAMCMCIndx + ll]++; } } - } // ll + } // svc /******************************************************************** - *Get fitted values and likelihood for WAIC + *Update kappa (the NB size parameter) *******************************************************************/ - for (j = 0; j < J; j++) { - mu[j] = F77_NAME(ddot)(&p, &X[j], &J, beta, &inc) + wSites[j] + betaStarSites[j]; - yRep[j] = rnorm(mu[j], sqrt(tauSq)); - like[j] = dnorm(y[j], mu[j], sqrt(tauSq), 0); - } // j + if (family == 1) { + kappaCand = logitInv(rnorm(logit(kappa, kappaA, kappaB), exp(tuning[kappaAMCMCIndx])), + kappaA, kappaB); + logPostKappaCurr = 0.0; + logPostKappaCand = 0.0; + for (j = 0; j < nObs; j++) { + mu[j] = exp(F77_NAME(ddot)(&pAbund, &X[j], &nObs, beta, &inc) + + betaStarSites[j] + wSites[j]); + logPostKappaCurr += dnbinom_mu(y[j], kappa, mu[j] * offset[j], 1); + logPostKappaCand += dnbinom_mu(y[j], kappaCand, mu[j] * offset[j], 1); + } + // Jacobian adjustment + logPostKappaCurr += log(kappa - kappaA) + log(kappaB - kappa); + logPostKappaCand += log(kappaCand - kappaA) + log(kappaB - kappaCand); + if (runif(0.0, 1.0) <= exp(logPostKappaCand - logPostKappaCurr)) { + kappa = kappaCand; + accept[kappaAMCMCIndx]++; + } + } + /******************************************************************** - *Get fitted values and likelihood for WAIC for the zero values + *Get fitted values *******************************************************************/ - for (j = 0; j < JZero; j++) { - yRepZero[j] = rnorm(0.0, sqrt(0.0001)); - } // j + if (saveFitted == 1) { + for (j = 0; j < nObs; j++) { + // Only calculate if Poisson since it's already calculated in kappa update + if (family == 0) { + mu[j] = exp(F77_NAME(ddot)(&pAbund, &X[j], &nObs, beta, &inc) + + betaStarSites[j] + wSites[j]); + yRep[j] = rpois(mu[j] * offset[j]); + like[j] = dpois(y[j], mu[j] * offset[j], 0); + } else { + yRep[j] = rnbinom_mu(kappa, mu[j] * offset[j]); + like[j] = dnbinom_mu(y[j], kappa, mu[j] * offset[j], 0); + } + } + } /******************************************************************** *Save samples *******************************************************************/ - if (q >= nBurn) { + if (g >= nBurn) { thinIndx++; - if (thinIndx == nThin) { - F77_NAME(dcopy)(&p, beta, &inc, &REAL(betaSamples_r)[sPost*p], &inc); - F77_NAME(dcopy)(&J, mu, &inc, &REAL(muSamples_r)[sPost*J], &inc); + if (thinIndx == nThin) { + F77_NAME(dcopy)(&pAbund, beta, &inc, &REAL(betaSamples_r)[sPost*pAbund], &inc); + if (saveFitted == 1) { + F77_NAME(dcopy)(&nObs, mu, &inc, &REAL(muSamples_r)[sPost*nObs], &inc); + F77_NAME(dcopy)(&nObs, yRep, &inc, &REAL(yRepSamples_r)[sPost*nObs], &inc); + F77_NAME(dcopy)(&nObs, like, &inc, + &REAL(likeSamples_r)[sPost*nObs], &inc); + } + F77_NAME(dcopy)(&nThetapTilde, theta, &inc, &REAL(thetaSamples_r)[sPost*nThetapTilde], &inc); F77_NAME(dcopy)(&JpTilde, w, &inc, &REAL(wSamples_r)[sPost*JpTilde], &inc); - REAL(tauSqSamples_r)[sPost] = tauSq; - F77_NAME(dcopy)(&nThetapTilde, theta, &inc, - &REAL(thetaSamples_r)[sPost*nThetapTilde], &inc); - F77_NAME(dcopy)(&J, yRep, &inc, &REAL(yRepSamples_r)[sPost*J], &inc); - F77_NAME(dcopy)(&JZero, yRepZero, &inc, &REAL(yRepZeroSamples_r)[sPost*JZero], &inc); - if (pRE > 0) { - F77_NAME(dcopy)(&pRE, sigmaSqMu, &inc, - &REAL(sigmaSqMuSamples_r)[sPost*pRE], &inc); - F77_NAME(dcopy)(&nRE, betaStar, &inc, - &REAL(betaStarSamples_r)[sPost*nRE], &inc); + if (family == 1) { + REAL(kappaSamples_r)[sPost] = kappa; } - F77_NAME(dcopy)(&J, like, &inc, - &REAL(likeSamples_r)[sPost*J], &inc); - sPost++; - thinIndx = 0; - } - } - + if (pAbundRE > 0) { + F77_NAME(dcopy)(&pAbundRE, sigmaSqMu, &inc, + &REAL(sigmaSqMuSamples_r)[sPost*pAbundRE], &inc); + F77_NAME(dcopy)(&nAbundRE, betaStar, &inc, + &REAL(betaStarSamples_r)[sPost*nAbundRE], &inc); + } + sPost++; + thinIndx = 0; + } + } R_CheckUserInterrupt(); - } // r (end batch) - + } // t (end batch) /******************************************************************** *Adjust tuning *******************************************************************/ - for (ll = 0; ll < pTilde; ll++) { - for (j = 0; j < nTheta; j++) { - REAL(acceptSamples_r)[s * nThetapTilde + j * pTilde + ll] = accept[j * pTilde + ll]/batchLength; - REAL(tuningSamples_r)[s * nThetapTilde + j * pTilde + ll] = tuning[j * pTilde + ll]; - if (accept[j * pTilde + ll] / batchLength > acceptRate) { - tuning[j * pTilde + ll] += std::min(0.01, 1.0/sqrt(static_cast(s))); - } else{ - tuning[j * pTilde + ll] -= std::min(0.01, 1.0/sqrt(static_cast(s))); + for (j = 0; j < nAMCMC; j++) { + REAL(acceptSamples_r)[s * nAMCMC + j] = accept[j]/batchLength; + REAL(tuningSamples_r)[s * nAMCMC + j] = tuning[j]; + if (accept[j] / batchLength > acceptRate) { + tuning[j] += std::min(0.01, 1.0/sqrt(static_cast(s))); + } else{ + tuning[j] -= std::min(0.01, 1.0/sqrt(static_cast(s))); } - accept[j * pTilde + ll] = 0; - } // j - } // ll + accept[j] = 0; + } + /******************************************************************** *Report *******************************************************************/ if (verbose) { - if (status == nReport) { - Rprintf("Batch: %i of %i, %3.2f%%\n", s, nBatch, 100.0*s/nBatch); - Rprintf("\tCoefficient\tParameter\tAcceptance\tTuning\n"); + if (status == nReport) { + Rprintf("Batch: %i of %i, %3.2f%%\n", s, nBatch, 100.0*s/nBatch); + Rprintf("\tParameter\tAcceptance\tTuning\n"); + for (j = 0; j < pAbund; j++) { + Rprintf("\tbeta[%i]\t\t%3.1f\t\t%1.5f\n", j + 1, 100.0*REAL(acceptSamples_r)[s * nAMCMC + betaAMCMCIndx + j], exp(tuning[betaAMCMCIndx + j])); + } for (ll = 0; ll < pTilde; ll++) { - Rprintf("\t%i\t\tphi\t\t%3.1f\t\t%1.5f\n", ll + 1, 100.0*REAL(acceptSamples_r)[s * nThetapTilde + phiIndx * pTilde + ll], exp(tuning[phiIndx * pTilde + ll])); - if (corName == "matern") { - Rprintf("\t%i\t\tnu\t\t%3.1f\t\t%1.5f\n", ll + 1, 100.0*REAL(acceptSamples_r)[s * nThetapTilde + nuIndx * pTilde + ll], exp(tuning[nuIndx * pTilde + ll])); - } - } // ll - Rprintf("-------------------------------------------------\n"); + Rprintf("\tphi[%i]\t\t%3.1f\t\t%1.5f\n", ll + 1, 100.0*REAL(acceptSamples_r)[s * nAMCMC + phiAMCMCIndx + ll], exp(tuning[phiAMCMCIndx + ll])); + if (corName == "matern") { + Rprintf("\tnu[%i]\t\t%3.1f\t\t%1.5f\n", ll + 1, 100.0*REAL(acceptSamples_r)[s * nAMCMC + nuAMCMCIndx + ll], exp(tuning[nuAMCMCIndx + ll])); + } + } + if (family == 1) { + Rprintf("\tkappa\t\t%3.1f\t\t%1.5f\n", 100.0*REAL(acceptSamples_r)[s * nAMCMC + kappaAMCMCIndx], exp(tuning[kappaAMCMCIndx])); + } + Rprintf("-------------------------------------------------\n"); #ifdef Win32 - R_FlushConsole(); + R_FlushConsole(); #endif - status = 0; - } + status = 0; + } } status++; - } // s (sample loop) + + } // all batches if (verbose) { Rprintf("Batch: %i of %i, %3.2f%%\n", s, nBatch, 100.0*s/nBatch); } - - - // This is necessary when generating random numbers in C. PutRNGstate(); - //make return object (which is a list) SEXP result_r, resultName_r; - int nResultListObjs = 10; - if (pRE > 0) { + int nResultListObjs = 6; + if (pAbundRE > 0) { nResultListObjs += 2; } + if (family == 1) { + nResultListObjs += 1; + } PROTECT(result_r = Rf_allocVector(VECSXP, nResultListObjs)); nProtect++; PROTECT(resultName_r = Rf_allocVector(VECSXP, nResultListObjs)); nProtect++; // Setting the components of the output list. SET_VECTOR_ELT(result_r, 0, betaSamples_r); - SET_VECTOR_ELT(result_r, 1, tauSqSamples_r); - SET_VECTOR_ELT(result_r, 2, yRepSamples_r); - SET_VECTOR_ELT(result_r, 3, muSamples_r); - SET_VECTOR_ELT(result_r, 4, thetaSamples_r); - SET_VECTOR_ELT(result_r, 5, wSamples_r); - SET_VECTOR_ELT(result_r, 6, tuningSamples_r); - SET_VECTOR_ELT(result_r, 7, acceptSamples_r); - SET_VECTOR_ELT(result_r, 8, likeSamples_r); - SET_VECTOR_ELT(result_r, 9, yRepZeroSamples_r); - if (pRE > 0) { - SET_VECTOR_ELT(result_r, 10, sigmaSqMuSamples_r); - SET_VECTOR_ELT(result_r, 11, betaStarSamples_r); + if (saveFitted == 1) { + SET_VECTOR_ELT(result_r, 1, yRepSamples_r); + SET_VECTOR_ELT(result_r, 2, muSamples_r); + SET_VECTOR_ELT(result_r, 3, likeSamples_r); + } + SET_VECTOR_ELT(result_r, 4, wSamples_r); + SET_VECTOR_ELT(result_r, 5, thetaSamples_r); + if (pAbundRE > 0) { + SET_VECTOR_ELT(result_r, 6, sigmaSqMuSamples_r); + SET_VECTOR_ELT(result_r, 7, betaStarSamples_r); + } + if (family == 1) { + if (pAbundRE > 0) { + tmp_0 = 8; + } else { + tmp_0 = 6; + } + SET_VECTOR_ELT(result_r, tmp_0, kappaSamples_r); } - // Rf_mkChar turns a C string into a CHARSXP SET_VECTOR_ELT(resultName_r, 0, Rf_mkChar("beta.samples")); - SET_VECTOR_ELT(resultName_r, 1, Rf_mkChar("tau.sq.samples")); - SET_VECTOR_ELT(resultName_r, 2, Rf_mkChar("y.rep.samples")); - SET_VECTOR_ELT(resultName_r, 3, Rf_mkChar("mu.samples")); - SET_VECTOR_ELT(resultName_r, 4, Rf_mkChar("theta.samples")); - SET_VECTOR_ELT(resultName_r, 5, Rf_mkChar("w.samples")); - SET_VECTOR_ELT(resultName_r, 6, Rf_mkChar("tune")); - SET_VECTOR_ELT(resultName_r, 7, Rf_mkChar("accept")); - SET_VECTOR_ELT(resultName_r, 8, Rf_mkChar("like.samples")); - SET_VECTOR_ELT(resultName_r, 9, Rf_mkChar("y.rep.zero.samples")); - if (pRE > 0) { - SET_VECTOR_ELT(resultName_r, 10, Rf_mkChar("sigma.sq.mu.samples")); - SET_VECTOR_ELT(resultName_r, 11, Rf_mkChar("beta.star.samples")); + if (saveFitted == 1) { + SET_VECTOR_ELT(resultName_r, 1, Rf_mkChar("y.rep.samples")); + SET_VECTOR_ELT(resultName_r, 2, Rf_mkChar("mu.samples")); + SET_VECTOR_ELT(resultName_r, 3, Rf_mkChar("like.samples")); + } + SET_VECTOR_ELT(resultName_r, 4, Rf_mkChar("w.samples")); + SET_VECTOR_ELT(resultName_r, 5, Rf_mkChar("theta.samples")); + if (pAbundRE > 0) { + SET_VECTOR_ELT(resultName_r, 6, Rf_mkChar("sigma.sq.mu.samples")); + SET_VECTOR_ELT(resultName_r, 7, Rf_mkChar("beta.star.samples")); + } + if (family == 1) { + SET_VECTOR_ELT(resultName_r, tmp_0, Rf_mkChar("kappa.samples")); } - // Set the names of the output list. Rf_namesgets(result_r, resultName_r); - //unprotect UNPROTECT(nProtect); return(result_r); } } - - diff --git a/src/svcAbundNNGPPredict.cpp b/src/svcAbundNNGPPredict.cpp index 1233537..1cc0ec1 100644 --- a/src/svcAbundNNGPPredict.cpp +++ b/src/svcAbundNNGPPredict.cpp @@ -1,3 +1,4 @@ +// TODO: there is a memory problem here at 255 and 260 for spAbund type models (at least). #define USE_FC_LEN_T #include #include "util.h" @@ -19,17 +20,17 @@ extern "C" { - SEXP svcAbundNNGPPredict(SEXP coords_r, SEXP J_r, SEXP family_r, - SEXP pAbund_r, SEXP pTilde_r, - SEXP m_r, SEXP X0_r, SEXP Xw0_r, SEXP coords0_r, - SEXP J0_r, SEXP nnIndx0_r, SEXP betaSamples_r, - SEXP thetaSamples_r, SEXP tauSqSamples_r, SEXP wSamples_r, - SEXP betaStarSiteSamples_r, SEXP sitesLink_r, - SEXP sites0Sampled_r, SEXP sites0_r, SEXP nSamples_r, + SEXP svcAbundNNGPPredict(SEXP coords_r, SEXP J_r, SEXP nObs_r, + SEXP pAbund_r, SEXP pTilde_r, SEXP m_r, SEXP X0_r, SEXP Xw0_r, + SEXP coords0_r, SEXP J0_r, SEXP nObs0_r, + SEXP sitesLink_r, SEXP sites0Sampled_r, SEXP sites0_r, + SEXP nnIndx0_r, SEXP betaSamples_r, + SEXP thetaSamples_r, SEXP wSamples_r, + SEXP betaStarSiteSamples_r, SEXP kappaSamples_r, SEXP nSamples_r, SEXP covModel_r, SEXP nThreads_r, SEXP verbose_r, - SEXP nReport_r, SEXP z0Samples_r){ + SEXP nReport_r, SEXP family_r){ - int i, j, ll, k, l, s, info, nProtect=0; + int i, j, k, l, s, ll, info, nProtect=0; const int inc = 1; const double one = 1.0; const double zero = 0.0; @@ -39,26 +40,27 @@ extern "C" { int J = INTEGER(J_r)[0]; int pAbund = INTEGER(pAbund_r)[0]; int pTilde = INTEGER(pTilde_r)[0]; - int family = INTEGER(family_r)[0]; double *X0 = REAL(X0_r); double *Xw0 = REAL(Xw0_r); double *coords0 = REAL(coords0_r); int J0 = INTEGER(J0_r)[0]; + int nObs0 = INTEGER(nObs0_r)[0]; int m = INTEGER(m_r)[0]; int mm = m * m; + int *sitesLink = INTEGER(sitesLink_r); int JpTilde = J * pTilde; int J0pTilde = J0 * pTilde; - int *sitesLink = INTEGER(sitesLink_r); int *sites0Sampled = INTEGER(sites0Sampled_r); + int *sites0 = INTEGER(sites0_r); int *nnIndx0 = INTEGER(nnIndx0_r); double *beta = REAL(betaSamples_r); double *theta = REAL(thetaSamples_r); double *w = REAL(wSamples_r); double *betaStarSite = REAL(betaStarSiteSamples_r); - double *tauSq = REAL(tauSqSamples_r); - double *z0 = REAL(z0Samples_r); + double *kappa = REAL(kappaSamples_r); + int family = INTEGER(family_r)[0]; int nSamples = INTEGER(nSamples_r)[0]; int covModel = INTEGER(covModel_r)[0]; @@ -80,13 +82,13 @@ extern "C" { Rprintf("----------------------------------------\n"); Rprintf("\tPrediction description\n"); Rprintf("----------------------------------------\n"); - Rprintf("NNGP Model fit with %i observations.\n\n", J); - Rprintf("Number of covariates: %i (including intercept if specified).\n\n", pAbund); + Rprintf("NNGP spatial GLMM fit with %i observations.\n\n", J); + Rprintf("Number of covariates %i (including intercept if specified).\n\n", pAbund); Rprintf("Number of spatially-varying coefficients: %i (including intercept if specified).\n\n", pTilde); Rprintf("Using the %s spatial correlation model.\n\n", corName.c_str()); Rprintf("Using %i nearest neighbors.\n\n", m); - Rprintf("Number of MCMC samples: %i.\n\n", nSamples); - Rprintf("Predicting at %i non-sampled locations.\n\n", J0); + Rprintf("Number of MCMC samples %i.\n\n", nSamples); + Rprintf("Predicting at %i locations.\n", J0); #ifdef _OPENMP Rprintf("\nSource compiled with OpenMP support and model fit using %i threads.\n", nThreads); #else @@ -95,15 +97,16 @@ extern "C" { } // parameters + int nTheta, sigmaSqIndx, phiIndx, nuIndx; if (corName != "matern") { nTheta = 2; //sigma^2, phi sigmaSqIndx = 0; phiIndx = 1; - } else{ - nTheta = 3; //sigma^2, phi, nu - sigmaSqIndx = 0; phiIndx = 1; nuIndx = 2; - } + } else{ + nTheta = 3; //sigma^2, phi, nu + sigmaSqIndx = 0; phiIndx = 1; nuIndx = 2; + } int nThetapTilde = nTheta * pTilde; // get max nu @@ -141,9 +144,10 @@ extern "C" { double phi = 0, nu = 0, sigmaSq = 0, d; int threadID = 0, status = 0; + SEXP y0_r, w0_r, mu0_r; - PROTECT(y0_r = Rf_allocMatrix(REALSXP, J0, nSamples)); nProtect++; - PROTECT(mu0_r = Rf_allocMatrix(REALSXP, J0, nSamples)); nProtect++; + PROTECT(y0_r = Rf_allocMatrix(REALSXP, nObs0, nSamples)); nProtect++; + PROTECT(mu0_r = Rf_allocMatrix(REALSXP, nObs0, nSamples)); nProtect++; PROTECT(w0_r = Rf_allocMatrix(REALSXP, J0pTilde, nSamples)); nProtect++; double *y0 = REAL(y0_r); double *mu0 = REAL(mu0_r); @@ -168,64 +172,64 @@ extern "C" { wV[i] = rnorm(0.0,1.0); } - for(j = 0; j < J0; j++){ + for (j = 0; j < J0; j++){ for (ll = 0; ll < pTilde; ll++) { #ifdef _OPENMP #pragma omp parallel for private(threadID, phi, nu, sigmaSq, k, l, d, info) #endif for(s = 0; s < nSamples; s++){ #ifdef _OPENMP - threadID = omp_get_thread_num(); + threadID = omp_get_thread_num(); #endif - if (sites0Sampled[j] == 1) { + if (sites0Sampled[j] == 1) { w0[s * J0pTilde + j * pTilde + ll] = w[s * JpTilde + sitesLink[j] * pTilde + ll]; - } else { - phi = theta[s * nThetapTilde + phiIndx * pTilde + ll]; - if(corName == "matern"){ - nu = theta[s * nThetapTilde + nuIndx * pTilde + ll]; - } - sigmaSq = theta[s * nThetapTilde + sigmaSqIndx * pTilde + ll]; - - for(k = 0; k < m; k++){ - d = dist2(coords[nnIndx0[j+J0*k]], coords[J+nnIndx0[j+J0*k]], coords0[j], coords0[J0+j]); - c[threadID*m+k] = sigmaSq*spCor(d, phi, nu, covModel, &bk[threadID*nb[ll]]); - for(l = 0; l < m; l++){ - d = dist2(coords[nnIndx0[j+J0*k]], coords[J+nnIndx0[j+J0*k]], coords[nnIndx0[j+J0*l]], coords[J+nnIndx0[j+J0*l]]); - C[threadID*mm+l*m+k] = sigmaSq*spCor(d, phi, nu, covModel, &bk[threadID*nb[ll]]); - } - } - - F77_NAME(dpotrf)(lower, &m, &C[threadID*mm], &m, &info FCONE); - if(info != 0){Rf_error("c++ error: dpotrf failed\n");} - F77_NAME(dpotri)(lower, &m, &C[threadID*mm], &m, &info FCONE); - if(info != 0){Rf_error("c++ error: dpotri failed\n");} - - F77_NAME(dsymv)(lower, &m, &one, &C[threadID*mm], &m, &c[threadID*m], &inc, &zero, &tmp_m[threadID*m], &inc FCONE); - - d = 0; - for(k = 0; k < m; k++){ - d += tmp_m[threadID*m+k]*w[s*JpTilde+nnIndx0[j+J0*k] * pTilde + ll]; - } - - #ifdef _OPENMP - #pragma omp atomic - #endif - vIndx++; - - w0[s * J0pTilde + j * pTilde + ll] = sqrt(sigmaSq - F77_NAME(ddot)(&m, &tmp_m[threadID*m], &inc, &c[threadID*m], &inc))*wV[vIndx] + d; - } + } else { + phi = theta[s * nThetapTilde + phiIndx * pTilde + ll]; + if(corName == "matern"){ + nu = theta[s * nThetapTilde + nuIndx * pTilde + ll]; + } + sigmaSq = theta[s * nThetapTilde + sigmaSqIndx * pTilde + ll]; + + for(k = 0; k < m; k++){ + d = dist2(coords[nnIndx0[j+J0*k]], coords[J+nnIndx0[j+J0*k]], coords0[j], coords0[J0+j]); + c[threadID*m+k] = sigmaSq*spCor(d, phi, nu, covModel, &bk[threadID*nb[ll]]); + for(l = 0; l < m; l++){ + d = dist2(coords[nnIndx0[j+J0*k]], coords[J+nnIndx0[j+J0*k]], coords[nnIndx0[j+J0*l]], coords[J+nnIndx0[j+J0*l]]); + C[threadID*mm+l*m+k] = sigmaSq*spCor(d, phi, nu, covModel, &bk[threadID*nb[ll]]); + } + } + + F77_NAME(dpotrf)(lower, &m, &C[threadID*mm], &m, &info FCONE); + if(info != 0){Rf_error("c++ error: dpotrf failed\n");} + F77_NAME(dpotri)(lower, &m, &C[threadID*mm], &m, &info FCONE); + if(info != 0){Rf_error("c++ error: dpotri failed\n");} + + F77_NAME(dsymv)(lower, &m, &one, &C[threadID*mm], &m, &c[threadID*m], &inc, &zero, &tmp_m[threadID*m], &inc FCONE); + + d = 0; + for(k = 0; k < m; k++){ + d += tmp_m[threadID*m+k]*w[s*JpTilde+nnIndx0[j+J0*k] * pTilde + ll]; + } + +#ifdef _OPENMP +#pragma omp atomic +#endif + vIndx++; + + w0[s * J0pTilde + j * pTilde + ll] = sqrt(sigmaSq - F77_NAME(ddot)(&m, &tmp_m[threadID*m], &inc, &c[threadID*m], &inc))*wV[vIndx] + d; + } } // sample } // covariate if(verbose){ - if(status == nReport){ - Rprintf("Location: %i of %i, %3.2f%%\n", j, J0, 100.0*j/J0); - #ifdef Win32 - R_FlushConsole(); - #endif - status = 0; - } + if(status == nReport){ + Rprintf("Location: %i of %i, %3.2f%%\n", j, J0, 100.0*j/J0); +#ifdef Win32 + R_FlushConsole(); +#endif + status = 0; + } } status++; R_CheckUserInterrupt(); @@ -233,42 +237,35 @@ extern "C" { if(verbose){ Rprintf("Location: %i of %i, %3.2f%%\n", j, J0, 100.0*j/J0); - #ifdef Win32 +#ifdef Win32 R_FlushConsole(); - #endif +#endif } - // Generate latent occurrence state after the fact. + // Generate abundance after the fact. + // Temporary fix. Will embed this in the above loop at some point. if (verbose) { - Rprintf("Generating abundance estimates\n"); + Rprintf("Generating abundance predictions\n"); } - for(j = 0; j < J0; j++){ + for(i = 0; i < nObs0; i++){ for(s = 0; s < nSamples; s++){ - if (family == 3) { - if (z0[s * J0 + j] == 1.0) { - wSites = F77_NAME(ddot)(&pTilde, &Xw0[j], &J0, - &w0[s * J0pTilde + j * pTilde], &inc); - mu0[s * J0 + j] = F77_NAME(ddot)(&pAbund, &X0[j], &J0, - &beta[s*pAbund], &inc) + - wSites + betaStarSite[s * J0 + j]; - y0[s * J0 + j] = rnorm(mu0[s * J0 + j], sqrt(tauSq[s])); - } else { - mu0[s * J0 + j] = 0.0; - y0[s * J0 + j] = rnorm(mu0[s * J0 + j], sqrt(0.0001)); - } - } else { - wSites = F77_NAME(ddot)(&pTilde, &Xw0[j], &J0, - &w0[s * J0pTilde + j * pTilde], &inc); - mu0[s * J0 + j] = F77_NAME(ddot)(&pAbund, &X0[j], &J0, - &beta[s*pAbund], &inc) + - wSites + betaStarSite[s * J0 + j]; - y0[s * J0 + j] = rnorm(mu0[s * J0 + j], sqrt(tauSq[s])); - } + wSites = 0.0; + for (ll = 0; ll < pTilde; ll++) { + wSites += w0[s * J0pTilde + sites0[i] * pTilde + ll] * Xw0[ll * nObs0 + i]; + } + mu0[s*nObs0+i] = exp(F77_NAME(ddot)(&pAbund, &X0[i], &nObs0, &beta[s*pAbund], &inc) + + wSites + betaStarSite[s * nObs0 + i]); + if (family == 1) { + y0[s * nObs0 + i] = rnbinom_mu(kappa[s], mu0[s * nObs0 + i]); + } else { + y0[s * nObs0 + i] = rpois(mu0[s * nObs0 + i]); + } } // s } // i PutRNGstate(); + //make return object SEXP result_r, resultName_r; int nResultListObjs = 3; @@ -296,4 +293,3 @@ extern "C" { } - diff --git a/src/svcMsAbundGaussianNNGP.cpp b/src/svcMsAbundGaussianNNGP.cpp index dade8c4..3e2ddca 100644 --- a/src/svcMsAbundGaussianNNGP.cpp +++ b/src/svcMsAbundGaussianNNGP.cpp @@ -447,7 +447,7 @@ extern "C" { int sizeBK = nThreads*(1.0+static_cast(floor(nuB[0]))); double *bk = (double *) R_alloc(q*sizeBK, sizeof(double)); - // wStar is JN x pTilde + // wSites is JN x pTilde // Spatial process sums for each site and species double *wSites = (double *) R_alloc(JN, sizeof(double)); // For each species and each location, multiply w x Xw