From ac45869e7eba9c0ffbc46b87c90e89ffa3231df6 Mon Sep 17 00:00:00 2001 From: doserjef Date: Thu, 12 Oct 2023 11:36:38 -0400 Subject: [PATCH] lots of testing --- R/NMix.R | 35 +- R/abund.R | 4 +- R/abundGaussian.R | 37 +- R/generics.R | 1784 +++++++++++++------------ R/lfMsAbund.R | 65 +- R/lfMsAbundGaussian.R | 28 +- R/lfMsNMix.R | 38 +- R/msAbund.R | 7 +- R/msAbundGaussian.R | 29 +- R/msNMix.R | 40 +- R/sfMsAbund.R | 61 +- R/sfMsAbundGaussian.R | 34 +- R/sfMsNMix.R | 38 +- R/spAbund.R | 4 +- R/spAbundGaussian.R | 49 +- R/spNMix.R | 35 +- man/lfMsAbund.Rd | 11 +- man/predict.lfMsAbund.Rd | 4 +- man/predict.lfMsDS.Rd | 4 +- man/predict.lfMsNMix.Rd | 4 +- man/predict.sfMsAbund.Rd | 4 +- man/predict.sfMsNMix.Rd | 2 +- man/predict.spAbund.Rd | 4 +- man/sfMsAbund.Rd | 11 +- src/DS.cpp | 13 + src/NMix.cpp | 11 + src/abund.cpp | 2 + src/abundGaussian.cpp | 64 +- src/lfMsAbund.cpp | 75 +- src/lfMsAbundGaussian.cpp | 78 +- src/lfMsDS.cpp | 19 + src/lfMsNMix.cpp | 17 + src/msAbund.cpp | 9 +- src/msAbundGaussian.cpp | 72 +- src/msDS.cpp | 29 +- src/msNMix.cpp | 15 + src/sfMsAbundGaussianNNGP.cpp | 77 +- src/sfMsAbundNNGP.cpp | 76 +- src/sfMsAbundNNGPPredict.cpp | 2 - src/sfMsDSNNGP.cpp | 20 + src/sfMsNMixNNGP.cpp | 18 + src/sfMsNMixNNGPPredict.cpp | 1 - src/spAbund.cpp | 793 ----------- src/spAbundGaussianNNGP.cpp | 81 +- src/spAbundNNGP.cpp | 8 + src/spDSNNGP.cpp | 15 + src/spNMixNNGP.cpp | 13 + src/svcAbundNNGP.cpp | 12 + src/svcAbundNNGPPredict.cpp | 1 - src/svcMsAbundGaussianNNGP.cpp | 11 +- src/svcMsAbundGaussianNNGPPredict.cpp | 1 - tests/testthat/test-sfMsNMix.R | 21 +- 52 files changed, 1777 insertions(+), 2109 deletions(-) delete mode 100755 src/spAbund.cpp diff --git a/R/NMix.R b/R/NMix.R index 455c15b..c5b124d 100644 --- a/R/NMix.R +++ b/R/NMix.R @@ -119,6 +119,8 @@ NMix <- function(abund.formula, det.formula, data, inits, priors, tuning, # Make both covariates a data frame. Unlist is necessary for when factors # are supplied. data$det.covs <- data.frame(lapply(data$det.covs, function(a) unlist(c(a)))) + # Indicator of whether all det.covs are site level or not + site.level.ind <- ifelse(nrow(data$det.covs) == nrow(y), TRUE, FALSE) data$abund.covs <- as.data.frame(data$abund.covs) # Check whether random effects are sent in as numeric, and @@ -159,21 +161,28 @@ NMix <- function(abund.formula, det.formula, data, inits, priors, tuning, stop("error: missing values in abund.covs. Please remove these sites from all objects in data or somehow replace the NA values with non-missing values (e.g., mean imputation).") } # det.covs ------------------------ - for (i in 1:ncol(data$det.covs)) { - if (sum(is.na(data$det.covs[, i])) > sum(is.na(y))) { - stop("error: some elements in det.covs have missing values where there is an observed data value in y. Please either replace the NA values in det.covs with non-missing values (e.g., mean imputation) or set the corresponding values in y to NA where the covariate is missing.") + if (!site.level.ind) { + for (i in 1:ncol(data$det.covs)) { + if (sum(is.na(data$det.covs[, i])) > sum(is.na(y))) { + stop("error: some elements in det.covs have missing values where there is an observed data value in y. Please either replace the NA values in det.covs with non-missing values (e.g., mean imputation) or set the corresponding values in y to NA where the covariate is missing.") + } + } + # Misalignment between y and det.covs + y.missing <- which(is.na(data$y)) + det.covs.missing <- lapply(data$det.covs, function(a) which(is.na(a))) + for (i in 1:length(det.covs.missing)) { + tmp.indx <- !(y.missing %in% det.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$det.covs.\nRemoving these site/replicate combinations for fitting the model.\n") + } + data$det.covs[y.missing, i] <- NA + } } } - # Misalignment between y and det.covs - y.missing <- which(is.na(data$y)) - det.covs.missing <- lapply(data$det.covs, function(a) which(is.na(a))) - for (i in 1:length(det.covs.missing)) { - tmp.indx <- !(y.missing %in% det.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$det.covs.\nRemoving these site/replicate combinations for fitting the model.\n") - } - data$det.covs[y.missing, i] <- NA + if (site.level.ind) { + if (sum(is.na(data$det.covs)) != 0) { + stop("missing values in site-level det.covs. Please remove these sites from all objects in data or somehow replace the NA values with non-missing values (e.g., mean imputation).") } } diff --git a/R/abund.R b/R/abund.R index ed6712b..00d0c72 100644 --- a/R/abund.R +++ b/R/abund.R @@ -12,7 +12,7 @@ abund <- function(formula, data, inits, priors, tuning, if (family %in% c('Gaussian', 'zi-Gaussian')) { abundGaussian(formula, data, inits, priors, tuning, n.batch, batch.length, accept.rate, family, - n.omp.threads, verbose, n.report, n.burn, n.thin, n.chains) + n.omp.threads, verbose, n.report, n.burn, n.thin, n.chains, save.fitted) } else { # Make it look nice @@ -114,7 +114,7 @@ abund <- function(formula, data, inits, priors, tuning, 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(mapply(rep, data$covs, dim(y)[2])) + data$covs <- as.data.frame(lapply(data$covs, rep, dim(y)[2])) } # Check whether random effects are sent in as numeric, and diff --git a/R/abundGaussian.R b/R/abundGaussian.R index 9e261ab..9634dc5 100644 --- a/R/abundGaussian.R +++ b/R/abundGaussian.R @@ -2,7 +2,7 @@ abundGaussian <- function(formula, data, inits, priors, tuning, 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, ...){ + n.thin = 1, n.chains = 1, save.fitted = TRUE, ...){ ptm <- proc.time() @@ -136,6 +136,11 @@ abundGaussian <- function(formula, data, inits, priors, tuning, n.batch, } } + # Check save.fitted --------------------------------------------------- + if (!(save.fitted %in% c(TRUE, FALSE))) { + stop("save.fitted must be either TRUE or FALSE") + } + # Formula ------------------------------------------------------------- # Occupancy ----------------------- if (is(formula, 'formula')) { @@ -393,7 +398,7 @@ abundGaussian <- function(formula, data, inits, priors, tuning, n.batch, # Set storage for all variables --------------------------------------- storage.mode(y) <- "double" storage.mode(X) <- "double" - consts <- c(J.est, p, p.re, n.re, J.zero) + consts <- c(J.est, p, p.re, n.re, J.zero, save.fitted) storage.mode(consts) <- "integer" storage.mode(beta.inits) <- "double" storage.mode(tau.sq.inits) <- "double" @@ -485,22 +490,24 @@ abundGaussian <- function(formula, data, inits, priors, tuning, n.batch, out$tau.sq.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$tau.sq.samples)))) colnames(out$tau.sq.samples) <- 'tau.sq' # Get everything back in the original order - if (!two.stage) { - out$y.rep.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$y.rep.samples)))) - out$like.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$like.samples)))) - } else { - y.rep.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$y.rep.samples)))) - 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)))) + if (save.fitted) { + if (!two.stage) { + out$y.rep.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$y.rep.samples)))) + out$like.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$like.samples)))) + } else { + y.rep.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$y.rep.samples)))) + 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$mu.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$mu.samples)))) + out$mu.samples <- mcmc(out$mu.samples) } out$X <- X out$X.re <- X.re - out$mu.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$mu.samples)))) - out$mu.samples <- mcmc(out$mu.samples) out$y <- y.orig if (p.re > 0) { out$sigma.sq.mu.samples <- mcmc( diff --git a/R/generics.R b/R/generics.R index e096d27..778742b 100644 --- a/R/generics.R +++ b/R/generics.R @@ -176,8 +176,8 @@ predict.abund <- function(object, X.0, ignore.RE = FALSE, z.0.samples, ...) { if (missing(object)) { stop("error: predict expects object\n") } - if (!is(object, "abund")) { - stop("error: requires an output object of class abund\n") + if (!(class(object) %in% c('abund', 'spAbund'))) { + stop("error: requires an output object of class abund or spAbund\n") } # Check X.0 ------------------------------------------------------------- @@ -349,6 +349,7 @@ predict.abund <- function(object, X.0, ignore.RE = FALSE, z.0.samples, ...) { out$mu.0.samples <- array(tmp, dim = c(n.post, J.0, K.max.0)) K <- apply(out$mu.0.samples[1, , , drop = FALSE], 2, function(a) sum(!is.na(a))) out$y.0.samples <- array(NA, dim(out$mu.0.samples)) + # TODO: not right. J <- nrow(object$y) rep.indx <- vector(mode = 'list', length = J) for (j in 1:J) { @@ -492,7 +493,7 @@ summary.spAbund <- function(object, predict.spAbund <- function(object, X.0, coords.0, n.omp.threads = 1, verbose = TRUE, n.report = 100, - ignore.RE = FALSE, z.0.samples, ...) { + ignore.RE = FALSE, z.0.samples, include.sp = TRUE, ...) { if (object$dist %in% c('Gaussian', 'zi-Gaussian')) { predict.svcAbund(object, X.0, coords.0, n.omp.threads, @@ -509,240 +510,246 @@ predict.spAbund <- function(object, X.0, coords.0, # 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))} - - # Some initial checks --------------------------------------------------- - 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") - } + # Call predict.abund if don't care about spatial effects + if (!include.sp) { + out <- predict.abund(object, X.0, ignore.RE, z.0.samples) + } else { - if (missing(X.0)) { - stop("error: X.0 must be specified\n") - } - if (!(length(dim(X.0)) %in% c(2, 3))) { - stop("error: X.0 must be a matrix with two columns corresponding to site and covariate or a three-dimensional array with dimensions corresponding to site, replicate, and covariate") - } - if (length(dim(X.0)) == 2) { - tmp <- colnames(X.0) - X.0 <- array(X.0, dim = c(nrow(X.0), 1, ncol(X.0))) - dimnames(X.0)[[3]] <- tmp - } - 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) - sites.0.indx <- rep(0:(nrow(X.0) - 1), times = ncol(X.0)) - K.max.0 <- ncol(X.0) + # 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))} - # Get X.0 in long format. - tmp.names <- dimnames(X.0)[[3]] - X.0 <- matrix(X.0, nrow = nrow(X.0) * ncol(X.0), ncol = dim(X.0)[3]) - colnames(X.0) <- tmp.names - missing.indx <- which(apply(X.0, 1, function(a) sum(is.na(a)) > 0)) - non.missing.indx <- which(apply(X.0, 1, function(a) sum(is.na(a)) == 0)) - X.0 <- X.0[non.missing.indx, , drop = FALSE] + # Some initial checks --------------------------------------------------- + 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") + } - n.post <- object$n.post * object$n.chains - X <- object$X - 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 - n.neighbors <- object$n.neighbors - cov.model.indx <- object$cov.model.indx - re.cols <- object$re.cols - sp.type <- object$type - if (object$muRE & !ignore.RE) { - p.abund.re <- length(object$re.level.names) - } else { - p.abund.re <- 0 - } - # 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)) + if (missing(X.0)) { + stop("error: X.0 must be specified\n") + } + if (!(length(dim(X.0)) %in% c(2, 3))) { + stop("error: X.0 must be a matrix with two columns corresponding to site and covariate or a three-dimensional array with dimensions corresponding to site, replicate, and covariate") + } + if (length(dim(X.0)) == 2) { + tmp <- colnames(X.0) + X.0 <- array(X.0, dim = c(nrow(X.0), 1, ncol(X.0))) + dimnames(X.0)[[3]] <- tmp + } + 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) + sites.0.indx <- rep(0:(nrow(X.0) - 1), times = ncol(X.0)) + K.max.0 <- ncol(X.0) - # 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.") - # } + # Get X.0 in long format. + tmp.names <- dimnames(X.0)[[3]] + X.0 <- matrix(X.0, nrow = nrow(X.0) * ncol(X.0), ncol = dim(X.0)[3]) + colnames(X.0) <- tmp.names + missing.indx <- which(apply(X.0, 1, function(a) sum(is.na(a)) > 0)) + non.missing.indx <- which(apply(X.0, 1, function(a) sum(is.na(a)) == 0)) + X.0 <- X.0[non.missing.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 <- dimnames(object$X.re)[[3]] - x.0.names <- colnames(X.0) - # Get the number of times each factor is used. - re.long.indx <- sapply(re.cols, length) - # Need sapply to keep the replicate columns if a factor is used - # in both a random intercept and random slope. - tmp <- sapply(x.re.names, function(a) which(colnames(X.0) %in% a)) - # tmp <- which(colnames(X.0) %in% x.re.names) - 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$occ.covs") + n.post <- object$n.post * object$n.chains + X <- object$X + 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 + n.neighbors <- object$n.neighbors + cov.model.indx <- object$cov.model.indx + re.cols <- object$re.cols + sp.type <- object$type + if (object$muRE & !ignore.RE) { + p.abund.re <- length(object$re.level.names) + } else { + p.abund.re <- 0 } - n.re <- length(indx) - n.unique.re <- length(unique(indx)) - # Check RE columns - for (i in 1:n.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 occurrence 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)) + + # 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 + # Get columns in design matrix with random effects + x.re.names <- dimnames(object$X.re)[[3]] + x.0.names <- colnames(X.0) + # Get the number of times each factor is used. + re.long.indx <- sapply(re.cols, length) + # Need sapply to keep the replicate columns if a factor is used + # in both a random intercept and random slope. + tmp <- sapply(x.re.names, function(a) which(colnames(X.0) %in% a)) + # tmp <- which(colnames(X.0) %in% x.re.names) + 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$occ.covs") + } + n.re <- length(indx) + n.unique.re <- length(unique(indx)) + # Check RE columns + for (i in 1:n.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 occurrence 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) + 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 + 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.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.re <- 0 - } - # Sub-sample previous - beta.samples <- t(beta.samples) - 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) - } else { - kappa.samples <- matrix(0, 1, n.post) - } - family.c <- ifelse(object$dist == 'NB', 1, 0) - theta.samples <- t(theta.samples) + # Sub-sample previous + beta.samples <- t(beta.samples) + 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) + } else { + kappa.samples <- matrix(0, 1, n.post) + } + family.c <- ifelse(object$dist == 'NB', 1, 0) + theta.samples <- t(theta.samples) - n.obs.0 <- nrow(X.fix) - J.0 <- length(unique(sites.0.indx)) + n.obs.0 <- nrow(X.fix) + J.0 <- length(unique(sites.0.indx)) - # Indicates whether a site has been sampled. 1 = sampled - 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 + # Indicates whether a site has been sampled. 1 = sampled + 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 - if (sp.type == 'GP') { - stop("NNGP = FALSE is not currently supported for spAbund") - } 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(n.obs) <- "integer" - storage.mode(p.abund) <- "integer" - storage.mode(n.neighbors) <- "integer" - storage.mode(X.fix) <- "double" - storage.mode(coords.0) <- "double" - storage.mode(J.0) <- "integer" - storage.mode(n.obs.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(kappa.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" - - 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, - theta.samples, w.samples, beta.star.sites.0.samples, kappa.samples, - n.post, cov.model.indx, n.omp.threads, verbose, n.report, family.c) - } + if (sp.type == 'GP') { + stop("NNGP = FALSE is not currently supported for spAbund") + } else { + # Get nearest neighbors + # nn2 is a function from RANN. + nn.indx.0 <- nn2(coords, coords.0, k=n.neighbors)$nn.idx-1 - tmp <- matrix(NA, n.post, length(c(missing.indx, non.missing.indx))) - tmp[, non.missing.indx] <- t(out$y.0.samples) - out$y.0.samples <- array(tmp, dim = c(n.post, J.0, K.max.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)) - # This gives the same result, just switched the order - # tmp <- matrix(NA, length(c(missing.indx, non.missing.indx)), n.post) - # tmp[non.missing.indx, ] <- out$y.0.samples - # out$y.0.samples <- array(tmp, dim = c(J.0, K.max.0, n.post)) - # tmp <- matrix(NA, length(c(missing.indx, non.missing.indx)), n.post) - # tmp[non.missing.indx, ] <- out$mu.0.samples - # out$mu.0.samples <- array(tmp, dim = c(J.0, K.max.0, n.post)) - out$w.0.samples <- mcmc(t(out$w.0.samples)) - out$run.time <- proc.time() - ptm + storage.mode(coords) <- "double" + storage.mode(J) <- "integer" + storage.mode(n.obs) <- "integer" + storage.mode(p.abund) <- "integer" + storage.mode(n.neighbors) <- "integer" + storage.mode(X.fix) <- "double" + storage.mode(coords.0) <- "double" + storage.mode(J.0) <- "integer" + storage.mode(n.obs.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(kappa.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" + + 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, + theta.samples, w.samples, beta.star.sites.0.samples, kappa.samples, + 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))) + tmp[, non.missing.indx] <- t(out$y.0.samples) + out$y.0.samples <- array(tmp, dim = c(n.post, J.0, K.max.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)) + # This gives the same result, just switched the order + # tmp <- matrix(NA, length(c(missing.indx, non.missing.indx)), n.post) + # tmp[non.missing.indx, ] <- out$y.0.samples + # out$y.0.samples <- array(tmp, dim = c(J.0, K.max.0, n.post)) + # tmp <- matrix(NA, length(c(missing.indx, non.missing.indx)), n.post) + # tmp[non.missing.indx, ] <- out$mu.0.samples + # out$mu.0.samples <- array(tmp, dim = c(J.0, K.max.0, n.post)) + out$w.0.samples <- mcmc(t(out$w.0.samples)) + out$run.time <- proc.time() - ptm + } out$call <- cl out$object.class <- class(object) class(out) <- "predict.spAbund" @@ -913,8 +920,8 @@ predict.msAbund <- function(object, X.0, ignore.RE = FALSE, z.0.samples, ...) { if (missing(object)) { stop("error: predict expects object\n") } - if (!is(object, "msAbund")) { - stop("error: requires an output object of class msAbund\n") + if (!(class(object) %in% c('msAbund', 'sfMsAbund', 'lfMsAbund'))) { + stop("error: requires an output object of class msAbund, lfMsAbund, sfMsAbund\n") } # Check X.0 ------------------------------------------------------------- @@ -1079,12 +1086,6 @@ predict.msAbund <- function(object, X.0, ignore.RE = FALSE, z.0.samples, ...) { sp.indx <- rep(1:n.sp, p.abund) out$mu.0.samples <- array(NA, dim = c(n.post, n.sp, J.0, K.max.0)) mu.long <- array(NA, dim = c(n.post, n.sp, nrow(X.fix))) - J <- ncol(object$y) - rep.indx <- vector(mode = 'list', length = J) - # Note this assumes the same missingness across species. - for (j in 1:J) { - rep.indx[[j]] <- which(!is.na(object$y[1, j, ])) - } for (i in 1:n.sp) { if (object$dist %in% c('Poisson', 'NB')) { mu.long[, i, ] <- exp(t(X.fix %*% t(beta.samples[, sp.indx == i]) + @@ -1101,25 +1102,27 @@ predict.msAbund <- function(object, X.0, ignore.RE = FALSE, z.0.samples, ...) { out$y.0.samples <- array(NA, dim(out$mu.0.samples)) for (i in 1:n.sp) { for (j in 1:J.0) { - for (k in rep.indx[[j]]) { - if (object$dist == 'NB') { - out$y.0.samples[, i, j, k] <- rnbinom(n.post, kappa.samples[, i], - mu = out$mu.0.samples[, i, j, k]) - } - if (object$dist == 'Poisson') { - out$y.0.samples[, i, j, k] <- rpois(n.post, out$mu.0.samples[, i, j, k]) - } - if (object$dist == 'Gaussian') { - out$y.0.samples[, i, j, k] <- rnorm(n.post, out$mu.0.samples[, i, j, k], - sqrt(object$tau.sq.samples[, i])) - } - if (object$dist == 'zi-Gaussian') { - out$y.0.samples[, i, j, k] <- ifelse(z.0.samples[, i, j] == 1, - rnorm(n.post, out$mu.0.samples[, i, j, k], - sqrt(object$tau.sq.samples[, i])), - rnorm(n.post, 0, sqrt(0.0001))) - out$mu.0.samples[, i, j, k] <- ifelse(z.0.samples[, i, j] == 1, - out$mu.0.samples[, i, j, k], 0) + for (k in 1:K.max.0) { + if (sum(is.na(out$mu.0.samples[, i, j, k])) == 0) { + if (object$dist == 'NB') { + out$y.0.samples[, i, j, k] <- rnbinom(n.post, kappa.samples[, i], + mu = out$mu.0.samples[, i, j, k]) + } + if (object$dist == 'Poisson') { + out$y.0.samples[, i, j, k] <- rpois(n.post, out$mu.0.samples[, i, j, k]) + } + if (object$dist == 'Gaussian') { + out$y.0.samples[, i, j, k] <- rnorm(n.post, out$mu.0.samples[, i, j, k], + sqrt(object$tau.sq.samples[, i])) + } + if (object$dist == 'zi-Gaussian') { + out$y.0.samples[, i, j, k] <- ifelse(z.0.samples[, i, j] == 1, + rnorm(n.post, out$mu.0.samples[, i, j, k], + sqrt(object$tau.sq.samples[, i])), + rnorm(n.post, 0, sqrt(0.0001))) + out$mu.0.samples[, i, j, k] <- ifelse(z.0.samples[, i, j] == 1, + out$mu.0.samples[, i, j, k], 0) + } } } } @@ -1294,7 +1297,7 @@ fitted.sfMsAbund <- function(object, ...) { predict.sfMsAbund <- function(object, X.0, coords.0, n.omp.threads = 1, verbose = TRUE, n.report = 100, - ignore.RE = FALSE, z.0.samples, ...) { + ignore.RE = FALSE, z.0.samples, include.sp = TRUE, ...) { if (object$dist %in% c('Gaussian', 'zi-Gaussian')) { predict.svcMsAbund(object, X.0, coords.0, n.omp.threads, @@ -1312,261 +1315,267 @@ predict.sfMsAbund <- function(object, X.0, coords.0, n.omp.threads = 1, # 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))} - - # Some initial checks --------------------------------------------------- - if (missing(object)) { - stop("error: predict expects object\n") - } - if (!(class(object) %in% c('sfMsAbund'))) { - stop("error: requires an output object of class sfMsAbund\n") - } - - # Check X.0 ------------------------------------------------------------- - if (missing(X.0)) { - stop("error: X.0 must be specified\n") - } - if (!(length(dim(X.0)) %in% c(2, 3))) { - stop("error: X.0 must be a matrix with two columns corresponding to site and covariate or a three-dimensional array with dimensions corresponding to site, replicate, and covariate") - } - if (length(dim(X.0)) == 2) { - tmp <- colnames(X.0) - X.0 <- array(X.0, dim = c(nrow(X.0), 1, ncol(X.0))) - dimnames(X.0)[[3]] <- tmp - } - 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) - sites.0.indx <- rep(0:(nrow(X.0) - 1), times = ncol(X.0)) - K.max.0 <- ncol(X.0) - - # Get X.0 in long format. - tmp.names <- dimnames(X.0)[[3]] - X.0 <- matrix(X.0, nrow = nrow(X.0) * ncol(X.0), ncol = dim(X.0)[3]) - colnames(X.0) <- tmp.names - missing.indx <- which(apply(X.0, 1, function(a) sum(is.na(a)) > 0)) - non.missing.indx <- which(apply(X.0, 1, function(a) sum(is.na(a)) == 0)) - X.0 <- X.0[non.missing.indx, , drop = FALSE] - - # Abundance predictions ------------------------------------------------ - n.post <- object$n.post * object$n.chains - X <- object$X - y <- object$y - coords <- object$coords - J <- nrow(coords) - n.obs <- sum(!is.na(object$y[1, , ])) - n.sp <- dim(y)[1] - q <- object$q - p.abund <- dim(X)[3] - theta.samples <- object$theta.samples - beta.samples <- object$beta.samples - lambda.samples <- object$lambda.samples - w.samples <- object$w.samples - kappa.samples <- object$kappa.samples - n.neighbors <- object$n.neighbors - cov.model.indx <- object$cov.model.indx - family <- object$dist - family.c <- ifelse(family == 'NB', 1, 0) - sp.type <- object$type - if (object$muRE & !ignore.RE) { - p.abund.re <- length(object$re.level.names) + # Call predict.msAbund if don't care about spatial effects + if (!include.sp) { + out <- predict.msAbund(object, X.0, ignore.RE, z.0.samples) } else { - p.abund.re <- 0 - } - re.cols <- object$re.cols - # if (ncol(X.0) != p.abund + p.abund.re){ - # stop(paste("error: X.0 must have ", p.abund + p.abund.re," columns\n")) - # } - X.0 <- as.matrix(X.0) + # 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))} - 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") + } + if (!(class(object) %in% c('sfMsAbund'))) { + stop("error: requires an output object of class sfMsAbund\n") + } - re.cols <- object$re.cols + # Check X.0 ------------------------------------------------------------- + if (missing(X.0)) { + stop("error: X.0 must be specified\n") + } + if (!(length(dim(X.0)) %in% c(2, 3))) { + stop("error: X.0 must be a matrix with two columns corresponding to site and covariate or a three-dimensional array with dimensions corresponding to site, replicate, and covariate") + } + if (length(dim(X.0)) == 2) { + tmp <- colnames(X.0) + X.0 <- array(X.0, dim = c(nrow(X.0), 1, ncol(X.0))) + dimnames(X.0)[[3]] <- tmp + } + 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) + sites.0.indx <- rep(0:(nrow(X.0) - 1), times = ncol(X.0)) + K.max.0 <- ncol(X.0) + + # Get X.0 in long format. + tmp.names <- dimnames(X.0)[[3]] + X.0 <- matrix(X.0, nrow = nrow(X.0) * ncol(X.0), ncol = dim(X.0)[3]) + colnames(X.0) <- tmp.names + missing.indx <- which(apply(X.0, 1, function(a) sum(is.na(a)) > 0)) + non.missing.indx <- which(apply(X.0, 1, function(a) sum(is.na(a)) == 0)) + X.0 <- X.0[non.missing.indx, , drop = FALSE] + + # Abundance predictions ------------------------------------------------ + n.post <- object$n.post * object$n.chains + X <- object$X + y <- object$y + coords <- object$coords + J <- nrow(coords) + n.obs <- sum(!is.na(object$y[1, , ])) + n.sp <- dim(y)[1] + q <- object$q + p.abund <- dim(X)[3] + theta.samples <- object$theta.samples + beta.samples <- object$beta.samples + lambda.samples <- object$lambda.samples + w.samples <- object$w.samples + kappa.samples <- object$kappa.samples + n.neighbors <- object$n.neighbors + cov.model.indx <- object$cov.model.indx + family <- object$dist + family.c <- ifelse(family == 'NB', 1, 0) + sp.type <- object$type + if (object$muRE & !ignore.RE) { + p.abund.re <- length(object$re.level.names) + } else { + p.abund.re <- 0 + } + re.cols <- object$re.cols - 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 <- dimnames(object$X.re)[[3]] - x.0.names <- colnames(X.0) - # Get the number of times each factor is used. - 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]) + # if (ncol(X.0) != p.abund + p.abund.re){ + # stop(paste("error: X.0 must have ", p.abund + p.abund.re," columns\n")) + # } + X.0 <- as.matrix(X.0) + + if (missing(coords.0)) { + stop("error: coords.0 must be specified\n") } - indx <- unlist(indx) - if (length(indx) == 0) { - stop("error: column names in X.0 must match variable names in data$occ.covs") + if (!any(is.data.frame(coords.0), is.matrix(coords.0))) { + stop("error: coords.0 must be a data.frame or matrix\n") } - n.re <- length(indx) - n.unique.re <- length(unique(indx)) - # Check RE columns - for (i in 1:n.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 occurrence 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="")) + if (!ncol(coords.0) == 2){ + stop("error: coords.0 must have two columns\n") + } + coords.0 <- as.matrix(coords.0) + + re.cols <- object$re.cols + + 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 <- dimnames(object$X.re)[[3]] + x.0.names <- colnames(X.0) + # Get the number of times each factor is used. + 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$occ.covs") + } + n.re <- length(indx) + n.unique.re <- length(unique(indx)) + # Check RE columns + for (i in 1:n.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 occurrence 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) + 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 + 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 + beta.star.sites.0.samples <- array(0, dim = c(n.post, n.sp, nrow(X.re))) + for (i in 1:n.sp) { + 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[, i, j] <- + beta.star.samples[, (i - 1) * n.abund.re + X.re.ind[j, t]] * X.random[j, t] + + beta.star.sites.0.samples[, i, j] + } else { + beta.star.sites.0.samples[, i, j] <- + rnorm(n.post, 0, sqrt(object$sigma.sq.mu.samples[, t])) * X.random[j, t] + + beta.star.sites.0.samples[, i, j] + } + } # j + } # t + } # i + } else { + X.fix <- X.0 + beta.star.sites.0.samples <- array(0, dim = c(n.post, n.sp, nrow(X.0))) + p.abund.re <- 0 } - # Create the random effects corresponding to each - # new location - beta.star.sites.0.samples <- array(0, dim = c(n.post, n.sp, nrow(X.re))) - for (i in 1:n.sp) { - 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[, i, j] <- - beta.star.samples[, (i - 1) * n.abund.re + X.re.ind[j, t]] * X.random[j, t] + - beta.star.sites.0.samples[, i, j] - } else { - beta.star.sites.0.samples[, i, j] <- - rnorm(n.post, 0, sqrt(object$sigma.sq.mu.samples[, t])) * X.random[j, t] + - beta.star.sites.0.samples[, i, j] - } - } # j - } # t - } # i - } else { - X.fix <- X.0 - beta.star.sites.0.samples <- array(0, dim = c(n.post, n.sp, nrow(X.0))) - p.abund.re <- 0 - } - # Sub-sample previous - theta.samples <- t(theta.samples) - lambda.samples <- t(lambda.samples) - beta.samples <- t(beta.samples) - if (family == 'NB') { - kappa.samples <- t(kappa.samples) - } else { - kappa.samples <- matrix(0, n.sp, n.post) - } - w.samples <- aperm(w.samples, c(2, 3, 1)) - beta.star.sites.0.samples <- aperm(beta.star.sites.0.samples, c(2, 3, 1)) + # Sub-sample previous + theta.samples <- t(theta.samples) + lambda.samples <- t(lambda.samples) + beta.samples <- t(beta.samples) + if (family == 'NB') { + kappa.samples <- t(kappa.samples) + } else { + kappa.samples <- matrix(0, n.sp, n.post) + } + w.samples <- aperm(w.samples, c(2, 3, 1)) + beta.star.sites.0.samples <- aperm(beta.star.sites.0.samples, c(2, 3, 1)) - n.obs.0 <- nrow(X.fix) - J.0 <- length(unique(sites.0.indx)) + n.obs.0 <- nrow(X.fix) + J.0 <- length(unique(sites.0.indx)) - 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)) - # Indicates whether a site has been sampled. 1 = sampled - 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 + 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)) + # Indicates whether a site has been sampled. 1 = sampled + 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 - if (sp.type == 'GP') { - # Not currently implemented or accessed. - } 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(n.sp) <- "integer" - storage.mode(J) <- "integer" - storage.mode(n.obs) <- 'integer' - storage.mode(p.abund) <- "integer" - storage.mode(n.neighbors) <- "integer" - storage.mode(X.fix) <- "double" - storage.mode(coords.0) <- "double" - storage.mode(J.0) <- "integer" - storage.mode(n.obs.0) <- "integer" - storage.mode(q) <- "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(lambda.samples) <- "double" - storage.mode(kappa.samples) <- "double" - storage.mode(beta.star.sites.0.samples) <- "double" - storage.mode(w.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(family.c) <- "integer" - - out <- .Call("sfMsAbundNNGPPredict", coords, J, n.obs, family.c, - n.sp, q, 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, - theta.samples, kappa.samples, lambda.samples, w.samples, - beta.star.sites.0.samples, n.post, - cov.model.indx, n.omp.threads, verbose, n.report) - } - out$y.0.samples <- array(out$y.0.samples, dim = c(n.sp, n.obs.0, n.post)) - out$y.0.samples <- aperm(out$y.0.samples, c(3, 1, 2)) - out$w.0.samples <- array(out$w.0.samples, dim = c(q, J.0, n.post)) - out$w.0.samples <- aperm(out$w.0.samples, c(3, 1, 2)) - out$mu.0.samples <- array(out$mu.0.samples, dim = c(n.sp, n.obs.0, n.post)) - out$mu.0.samples <- aperm(out$mu.0.samples, c(3, 1, 2)) - - tmp <- array(NA, dim = c(n.post, n.sp, length(c(missing.indx, non.missing.indx)))) - tmp[, , non.missing.indx] <- out$y.0.samples - out$y.0.samples <- array(tmp, dim = c(n.post, n.sp, J.0, K.max.0)) - tmp <- array(NA, dim = c(n.post, n.sp, length(c(missing.indx, non.missing.indx)))) - tmp[, , non.missing.indx] <- out$mu.0.samples - out$mu.0.samples <- array(tmp, dim = c(n.post, n.sp, J.0, K.max.0)) - out$run.time <- proc.time() - ptm + if (sp.type == 'GP') { + # Not currently implemented or accessed. + } 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(n.sp) <- "integer" + storage.mode(J) <- "integer" + storage.mode(n.obs) <- 'integer' + storage.mode(p.abund) <- "integer" + storage.mode(n.neighbors) <- "integer" + storage.mode(X.fix) <- "double" + storage.mode(coords.0) <- "double" + storage.mode(J.0) <- "integer" + storage.mode(n.obs.0) <- "integer" + storage.mode(q) <- "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(lambda.samples) <- "double" + storage.mode(kappa.samples) <- "double" + storage.mode(beta.star.sites.0.samples) <- "double" + storage.mode(w.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(family.c) <- "integer" + + out <- .Call("sfMsAbundNNGPPredict", coords, J, n.obs, family.c, + n.sp, q, 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, + theta.samples, kappa.samples, lambda.samples, w.samples, + beta.star.sites.0.samples, n.post, + cov.model.indx, n.omp.threads, verbose, n.report) + } + out$y.0.samples <- array(out$y.0.samples, dim = c(n.sp, n.obs.0, n.post)) + out$y.0.samples <- aperm(out$y.0.samples, c(3, 1, 2)) + out$w.0.samples <- array(out$w.0.samples, dim = c(q, J.0, n.post)) + out$w.0.samples <- aperm(out$w.0.samples, c(3, 1, 2)) + out$mu.0.samples <- array(out$mu.0.samples, dim = c(n.sp, n.obs.0, n.post)) + out$mu.0.samples <- aperm(out$mu.0.samples, c(3, 1, 2)) + + tmp <- array(NA, dim = c(n.post, n.sp, length(c(missing.indx, non.missing.indx)))) + tmp[, , non.missing.indx] <- out$y.0.samples + out$y.0.samples <- array(tmp, dim = c(n.post, n.sp, J.0, K.max.0)) + tmp <- array(NA, dim = c(n.post, n.sp, length(c(missing.indx, non.missing.indx)))) + tmp[, , non.missing.indx] <- out$mu.0.samples + out$mu.0.samples <- array(tmp, dim = c(n.post, n.sp, J.0, K.max.0)) + out$run.time <- proc.time() - ptm + } out$call <- cl out$object.class <- class(object) class(out) <- "predict.sfMsAbund" @@ -3090,9 +3099,9 @@ predict.sfMsNMix <- function(object, X.0, coords.0, n.omp.threads = 1, # Call ---------------------------------------------------------------- cl <- match.call() - # Call predict.lfMsNMix if you don't care about spatial effects + # Call predict.msNMix if you don't care about spatial effects if (!include.sp) { - out <- predict.lfMsNMix(object, X.0, coords.0, ignore.RE, type) + out <- predict.msNMix(object, X.0, ignore.RE, type) } else { # Functions --------------------------------------------------------------- @@ -3357,7 +3366,7 @@ fitted.lfMsNMix <- function(object, type = 'marginal', ...) { fitted.msNMix(object, type) } predict.lfMsNMix <- function(object, X.0, coords.0, ignore.RE = FALSE, - type = 'abundance', ...) { + type = 'abundance', include.w = TRUE, ...) { # Check for unused arguments ------------------------------------------ formal.args <- names(formals(sys.function(sys.parent()))) elip.args <- names(list(...)) @@ -3368,190 +3377,195 @@ predict.lfMsNMix <- function(object, X.0, coords.0, ignore.RE = FALSE, # 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))} + if (!include.w) { + out <- predict.msNMix(object, X.0, ignore.RE, type) + } else { - # Some initial checks --------------------------------------------------- - if (missing(object)) { - stop("error: predict expects object\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))} - if (!(tolower(type) %in% c('abundance', 'detection'))) { - stop("error: prediction type must be either 'abundance' or 'detection'") - } + # Some initial checks --------------------------------------------------- + if (missing(object)) { + stop("error: predict expects object\n") + } - # 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") - } + if (!(tolower(type) %in% c('abundance', 'detection'))) { + stop("error: prediction type must be either 'abundance' or 'detection'") + } - # Abundance predictions ------------------------------------------------ - if (tolower(type) == 'abundance') { - p.abund <- ncol(object$X) - # Composition sampling -------------------------------------------------- - beta.samples <- as.matrix(object$beta.samples) - if (object$dist == 'NB') { - kappa.samples <- as.matrix(object$kappa.samples) + # Check X.0 ------------------------------------------------------------- + if (missing(X.0)) { + stop("error: X.0 must be specified\n") } - n.sp <- nrow(object$y) - J.0 <- nrow(X.0) - q <- object$q - sp.indx <- rep(1:n.sp, p.abund) - n.post <- object$n.post * object$n.chains - out <- list() - coords <- out$coords - out$mu.0.samples <- array(NA, dim = c(n.post, n.sp, nrow(X.0))) - out$N.0.samples <- array(NA, dim = c(n.post, n.sp, nrow(X.0))) - lambda.samples <- array(object$lambda.samples, dim = c(n.post, n.sp, q)) - w.samples <- object$w.samples - if (object$muRE) { - p.abund.re <- length(object$re.level.names) - } else { - p.abund.re <- 0 + if (!any(is.data.frame(X.0), is.matrix(X.0))) { + stop("error: X.0 must be a data.frame or matrix\n") } - re.cols <- object$re.cols - # Eliminate prediction sites that have already been sampled for now - if (!missing(coords.0)) { - 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 (length(coords.indx) == nrow(X.0)) { - stop("error: no new locations to predict at. See object$psi.samples for occurrence probabilities at sampled sites.") + # Abundance predictions ------------------------------------------------ + if (tolower(type) == 'abundance') { + p.abund <- ncol(object$X) + # Composition sampling -------------------------------------------------- + beta.samples <- as.matrix(object$beta.samples) + if (object$dist == 'NB') { + kappa.samples <- as.matrix(object$kappa.samples) } - } else { - X.0.new <- X.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.new) - re.long.indx <- sapply(re.cols, length) - tmp <- sapply(x.re.names, function(a) which(colnames(X.0.new) %in% a)) - indx <- list() - for (i in 1:length(tmp)) { - indx[[i]] <- rep(tmp[i], re.long.indx[i]) + n.sp <- nrow(object$y) + J.0 <- nrow(X.0) + q <- object$q + sp.indx <- rep(1:n.sp, p.abund) + n.post <- object$n.post * object$n.chains + out <- list() + coords <- out$coords + out$mu.0.samples <- array(NA, dim = c(n.post, n.sp, nrow(X.0))) + out$N.0.samples <- array(NA, dim = c(n.post, n.sp, nrow(X.0))) + lambda.samples <- array(object$lambda.samples, dim = c(n.post, n.sp, q)) + w.samples <- object$w.samples + if (object$muRE) { + p.abund.re <- length(object$re.level.names) + } else { + p.abund.re <- 0 } - indx <- unlist(indx) - if (length(indx) == 0) { - stop("error: column names in X.0 must match variable names in data$abund.covs") + re.cols <- object$re.cols + + # Eliminate prediction sites that have already been sampled for now + if (!missing(coords.0)) { + 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 (length(coords.indx) == nrow(X.0)) { + stop("error: no new locations to predict at. See object$psi.samples for occurrence probabilities at sampled sites.") + } + } else { + X.0.new <- X.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="")) + + + 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.new) + re.long.indx <- sapply(re.cols, length) + tmp <- sapply(x.re.names, function(a) which(colnames(X.0.new) %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="")) + } } - # 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.new[, indx, drop = FALSE]) + X.fix <- as.matrix(X.0.new[, -indx, drop = FALSE]) + X.random <- as.matrix(X.0.new[, 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.new[, indx, drop = FALSE]) - X.fix <- as.matrix(X.0.new[, -indx, drop = FALSE]) - X.random <- as.matrix(X.0.new[, 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]) } } + # 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, n.sp * nrow(X.re)) + for (i in 1:n.sp) { + 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 - 1) * n.sp + i] <- + beta.star.samples[, (i - 1) * n.abund.re + X.re.ind[j, t]] * X.random[j, t] + + beta.star.sites.0.samples[, (j - 1) * n.sp + i] + } else { + beta.star.sites.0.samples[, (j - 1) * n.sp + i] <- + rnorm(n.post, 0, sqrt(object$sigma.sq.mu.samples[, t])) * X.random[j, t] + + beta.star.sites.0.samples[, (j - 1) * n.sp + i] + } + } # j + } # t + } # i + } else { + X.fix <- X.0.new + beta.star.sites.0.samples <- matrix(0, n.post, n.sp * nrow(X.0.new)) + p.abund.re <- 0 } - 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]) - } + J.str <- nrow(X.0.new) + # Create new random normal latent factors at unobserved sites. + w.0.samples <- array(rnorm(n.post * q * J.str), dim = c(n.post, q, J.str)) + w.star.0.samples <- array(NA, dim = c(n.post, n.sp, J.str)) + + for (i in 1:n.post) { + w.star.0.samples[i, , ] <- matrix(lambda.samples[i, , ], n.sp, q) %*% + matrix(w.0.samples[i, , ], q, J.str) } - # 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, n.sp * nrow(X.re)) + # Make predictions for (i in 1:n.sp) { - 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 - 1) * n.sp + i] <- - beta.star.samples[, (i - 1) * n.abund.re + X.re.ind[j, t]] * X.random[j, t] + - beta.star.sites.0.samples[, (j - 1) * n.sp + i] - } else { - beta.star.sites.0.samples[, (j - 1) * n.sp + i] <- - rnorm(n.post, 0, sqrt(object$sigma.sq.mu.samples[, t])) * X.random[j, t] + - beta.star.sites.0.samples[, (j - 1) * n.sp + i] - } - } # j - } # t - } # i - } else { - X.fix <- X.0.new - beta.star.sites.0.samples <- matrix(0, n.post, n.sp * nrow(X.0.new)) - p.abund.re <- 0 - } - J.str <- nrow(X.0.new) - # Create new random normal latent factors at unobserved sites. - w.0.samples <- array(rnorm(n.post * q * J.str), dim = c(n.post, q, J.str)) - w.star.0.samples <- array(NA, dim = c(n.post, n.sp, J.str)) - - for (i in 1:n.post) { - w.star.0.samples[i, , ] <- matrix(lambda.samples[i, , ], n.sp, q) %*% - matrix(w.0.samples[i, , ], q, J.str) - } - # Make predictions - for (i in 1:n.sp) { - for (j in 1:J.str) { - out$mu.0.samples[, i, j] <- exp(t(as.matrix(X.fix[j, ])) %*% - t(beta.samples[, sp.indx == i]) + - w.star.0.samples[, i, j] + - beta.star.sites.0.samples[, (j - 1) * n.sp + i]) - if (object$dist == 'NB') { - out$N.0.samples[, i, j] <- rnbinom(n.post, kappa.samples[, i], - mu = out$mu.0.samples[, i, j]) - } else { - out$N.0.samples[, i, j] <- rpois(n.post, out$mu.0.samples[, i, j]) - } - } # j - } # i + for (j in 1:J.str) { + out$mu.0.samples[, i, j] <- exp(t(as.matrix(X.fix[j, ])) %*% + t(beta.samples[, sp.indx == i]) + + w.star.0.samples[, i, j] + + beta.star.sites.0.samples[, (j - 1) * n.sp + i]) + if (object$dist == 'NB') { + out$N.0.samples[, i, j] <- rnbinom(n.post, kappa.samples[, i], + mu = out$mu.0.samples[, i, j]) + } else { + out$N.0.samples[, i, j] <- rpois(n.post, out$mu.0.samples[, i, j]) + } + } # j + } # i - # If some of the sites are sampled - if (nrow(X.0) != J.str) { - tmp <- array(NA, dim = c(n.post, n.sp, nrow(X.0))) - tmp[, , coords.0.indx] <- out$N.0.samples - tmp[, , coords.place.indx] <- object$N.samples[, , coords.indx] - out$N.0.samples <- tmp - tmp <- array(NA, dim = c(n.post, n.sp, nrow(X.0))) - tmp[, , coords.0.indx] <- out$mu.0.samples - tmp[, , coords.place.indx] <- object$mu.samples[, , coords.indx] - out$mu.0.samples <- tmp + # If some of the sites are sampled + if (nrow(X.0) != J.str) { + tmp <- array(NA, dim = c(n.post, n.sp, nrow(X.0))) + tmp[, , coords.0.indx] <- out$N.0.samples + tmp[, , coords.place.indx] <- object$N.samples[, , coords.indx] + out$N.0.samples <- tmp + tmp <- array(NA, dim = c(n.post, n.sp, nrow(X.0))) + tmp[, , coords.0.indx] <- out$mu.0.samples + tmp[, , coords.place.indx] <- object$mu.samples[, , coords.indx] + out$mu.0.samples <- tmp + } + } # abundance predictions + # Detection predictions ------------------------------------------------- + if (tolower(type) == 'detection') { + out <- predict.msNMix(object, X.0, ignore.RE, type) } - } # abundance predictions - # Detection predictions ------------------------------------------------- - if (tolower(type) == 'detection') { - out <- predict.msNMix(object, X.0, ignore.RE, type) } out$call <- cl @@ -3577,7 +3591,7 @@ fitted.lfMsAbund <- function(object, ...) { } predict.lfMsAbund <- function(object, X.0, coords.0, ignore.RE = FALSE, - z.0.samples, ...) { + z.0.samples, include.w = TRUE, ...) { # Check for unused arguments ------------------------------------------ formal.args <- names(formals(sys.function(sys.parent()))) elip.args <- names(list(...)) @@ -3587,263 +3601,267 @@ predict.lfMsAbund <- function(object, X.0, coords.0, ignore.RE = FALSE, } # 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))} - - # Some initial checks --------------------------------------------------- - if (missing(object)) { - stop("error: predict expects object\n") - } - if (!is(object, "lfMsAbund")) { - stop("error: requires an output object of class lfMsAbund\n") - } - - # Check X.0 ------------------------------------------------------------- - if (missing(X.0)) { - stop("error: X.0 must be specified\n") - } - if (!(length(dim(X.0)) %in% c(2, 3))) { - stop("error: X.0 must be a matrix with two columns corresponding to site and covariate or a three-dimensional array with dimensions corresponding to site, replicate, and covariate") - } - if (length(dim(X.0)) == 2) { - tmp <- colnames(X.0) - X.0 <- array(X.0, dim = c(nrow(X.0), 1, ncol(X.0))) - dimnames(X.0)[[3]] <- tmp - } - # Predictions ----------------------------------------------------------- - if (object$dist %in% c('Gaussian', 'zi-Gaussian')) { - p.abund <- dim(object$X)[2] + + # Call predict.msAbund if don't care about latent effects + if (!include.w) { + out <- predict.msAbund(object, X.0, ignore.RE, z.0.samples) } else { - p.abund <- dim(object$X)[3] - } - J.0 <- nrow(X.0) - K.max.0 <- ncol(X.0) - n.sp <- dim(object$y)[1] - q <- object$q - n.post <- object$n.post * object$n.chains - 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) - sites.0.indx <- rep(1:(nrow(X.0)), times = ncol(X.0)) - # Composition sampling -------------------------------------------------- - re.cols <- object$re.cols - beta.samples <- as.matrix(object$beta.samples) - if (object$dist == 'NB') { - kappa.samples <- as.matrix(object$kappa.samples) - } - lambda.samples <- array(object$lambda.samples, dim = c(n.post, n.sp, q)) - w.samples <- object$w.samples - out <- list() - if (object$muRE) { - p.abund.re <- length(object$re.level.names) - } else { - p.abund.re <- 0 - } + # 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))} - # Get X.0 in long format. - tmp.names <- dimnames(X.0)[[3]] - X.0 <- matrix(X.0, nrow = nrow(X.0) * ncol(X.0), ncol = dim(X.0)[3]) - colnames(X.0) <- tmp.names - missing.indx <- which(apply(X.0, 1, function(a) sum(is.na(a)) > 0)) - non.missing.indx <- which(apply(X.0, 1, function(a) sum(is.na(a)) == 0)) - X.0 <- X.0[non.missing.indx, , drop = FALSE] - sites.0.indx <- sites.0.indx[non.missing.indx] + # Some initial checks --------------------------------------------------- + if (missing(object)) { + stop("error: predict expects object\n") + } + if (!is(object, "lfMsAbund")) { + stop("error: requires an output object of class lfMsAbund\n") + } - 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 - # Get columns in design matrix with random effects + # Check X.0 ------------------------------------------------------------- + if (missing(X.0)) { + stop("error: X.0 must be specified\n") + } + if (!(length(dim(X.0)) %in% c(2, 3))) { + stop("error: X.0 must be a matrix with two columns corresponding to site and covariate or a three-dimensional array with dimensions corresponding to site, replicate, and covariate") + } + if (length(dim(X.0)) == 2) { + tmp <- colnames(X.0) + X.0 <- array(X.0, dim = c(nrow(X.0), 1, ncol(X.0))) + dimnames(X.0)[[3]] <- tmp + } + # Predictions ----------------------------------------------------------- if (object$dist %in% c('Gaussian', 'zi-Gaussian')) { - x.re.names <- dimnames(object$X.re)[[2]] + p.abund <- dim(object$X)[2] } else { - x.re.names <- dimnames(object$X.re)[[3]] + p.abund <- dim(object$X)[3] + } + J.0 <- nrow(X.0) + K.max.0 <- ncol(X.0) + n.sp <- dim(object$y)[1] + q <- object$q + n.post <- object$n.post * object$n.chains + 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") } - x.0.names <- colnames(X.0) - # Get the number of times each factor is used. - 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]) + coords.0 <- as.matrix(coords.0) + sites.0.indx <- rep(1:(nrow(X.0)), times = ncol(X.0)) + + # Composition sampling -------------------------------------------------- + re.cols <- object$re.cols + beta.samples <- as.matrix(object$beta.samples) + if (object$dist == 'NB') { + kappa.samples <- as.matrix(object$kappa.samples) } - indx <- unlist(indx) - if (length(indx) == 0) { - stop("error: column names in X.0 must match variable names in data$occ.covs") + lambda.samples <- array(object$lambda.samples, dim = c(n.post, n.sp, q)) + w.samples <- object$w.samples + out <- list() + if (object$muRE) { + p.abund.re <- length(object$re.level.names) + } else { + p.abund.re <- 0 } - n.re <- length(indx) - n.unique.re <- length(unique(indx)) - # Check RE columns - for (i in 1:n.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 occurrence 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="")) + + # Get X.0 in long format. + tmp.names <- dimnames(X.0)[[3]] + X.0 <- matrix(X.0, nrow = nrow(X.0) * ncol(X.0), ncol = dim(X.0)[3]) + colnames(X.0) <- tmp.names + missing.indx <- which(apply(X.0, 1, function(a) sum(is.na(a)) > 0)) + non.missing.indx <- which(apply(X.0, 1, function(a) sum(is.na(a)) == 0)) + X.0 <- X.0[non.missing.indx, , drop = FALSE] + sites.0.indx <- sites.0.indx[non.missing.indx] + + 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 + # Get columns in design matrix with random effects + if (object$dist %in% c('Gaussian', 'zi-Gaussian')) { + x.re.names <- dimnames(object$X.re)[[2]] + } else { + x.re.names <- dimnames(object$X.re)[[3]] + } + x.0.names <- colnames(X.0) + # Get the number of times each factor is used. + 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$occ.covs") + } + n.re <- length(indx) + n.unique.re <- length(unique(indx)) + # Check RE columns + for (i in 1:n.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 occurrence 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) + 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 + 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 + beta.star.sites.0.samples <- array(0, dim = c(n.post, n.sp, nrow(X.re))) + for (i in 1:n.sp) { + 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[, i, j] <- + beta.star.samples[, (i - 1) * n.abund.re + X.re.ind[j, t]] * X.random[j, t] + + beta.star.sites.0.samples[, i, j] + } else { + beta.star.sites.0.samples[, i, j] <- + rnorm(n.post, 0, sqrt(object$sigma.sq.mu.samples[, t])) * X.random[j, t] + + beta.star.sites.0.samples[, i, j] + } + } # j + } # t + } + } else { + X.fix <- X.0 + beta.star.sites.0.samples <- array(0, dim = c(n.post, n.sp, nrow(X.0))) + p.abund.re <- 0 } - # Create the random effects corresponding to each - # new location - beta.star.sites.0.samples <- array(0, dim = c(n.post, n.sp, nrow(X.re))) - for (i in 1:n.sp) { - 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[, i, j] <- - beta.star.samples[, (i - 1) * n.abund.re + X.re.ind[j, t]] * X.random[j, t] + - beta.star.sites.0.samples[, i, j] - } else { - beta.star.sites.0.samples[, i, j] <- - rnorm(n.post, 0, sqrt(object$sigma.sq.mu.samples[, t])) * X.random[j, t] + - beta.star.sites.0.samples[, i, j] - } - } # j - } # t - } - } else { - X.fix <- X.0 - beta.star.sites.0.samples <- array(0, dim = c(n.post, n.sp, nrow(X.0))) - p.abund.re <- 0 - } - coords <- object$coords - 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)) - # Indicates whether a site has been sampled. 1 = sampled - 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 - family <- object$dist + coords <- object$coords + 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)) + # Indicates whether a site has been sampled. 1 = sampled + 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 + family <- object$dist - if (family == 'zi-Gaussian') { - if (missing(z.0.samples)) { - stop("z.0.samples must be supplied for a zi-Gaussian model") - } - if (length(dim(z.0.samples)) != 3) { - stop(paste("z.0.samples must be a three-dimensional array with dimensions of ", - n.post, ", ", n.sp, ", and ", J.0, sep = '')) - } - if (dim(z.0.samples)[1] != n.post | dim(z.0.samples)[2] != n.sp | - dim(z.0.samples)[3] != J.0) { - stop(paste("z.0.samples must be a three-dimensional array with dimensions of ", - n.post, ", ", n.sp, ", and ", J.0, sep = '')) - } - } else { - if (!missing(z.0.samples)) { - message("z.0.samples is ignored for the current model family\n") + if (family == 'zi-Gaussian') { + if (missing(z.0.samples)) { + stop("z.0.samples must be supplied for a zi-Gaussian model") + } + if (length(dim(z.0.samples)) != 3) { + stop(paste("z.0.samples must be a three-dimensional array with dimensions of ", + n.post, ", ", n.sp, ", and ", J.0, sep = '')) + } + if (dim(z.0.samples)[1] != n.post | dim(z.0.samples)[2] != n.sp | + dim(z.0.samples)[3] != J.0) { + stop(paste("z.0.samples must be a three-dimensional array with dimensions of ", + n.post, ", ", n.sp, ", and ", J.0, sep = '')) + } + } else { + if (!missing(z.0.samples)) { + message("z.0.samples is ignored for the current model family\n") + } + z.0.samples <- array(NA, dim = c(1, 1, 1)) } - z.0.samples <- array(NA, dim = c(1, 1, 1)) - } - # Create new random normal latent factors at all sites. - w.0.samples <- array(rnorm(n.post * q * J.0), dim = c(n.post, q, J.0)) - # Replace already sampled sites with values from model fit. - for (j in 1:J.0) { - if (sites.0.sampled[j] == 1) { - w.0.samples[, , j] <- w.samples[, , sites.link[j]] + # Create new random normal latent factors at all sites. + w.0.samples <- array(rnorm(n.post * q * J.0), dim = c(n.post, q, J.0)) + # Replace already sampled sites with values from model fit. + for (j in 1:J.0) { + if (sites.0.sampled[j] == 1) { + w.0.samples[, , j] <- w.samples[, , sites.link[j]] + } } - } - w.star.0.samples <- array(NA, dim = c(n.post, n.sp, J.0)) - - for (i in 1:n.post) { - w.star.0.samples[i, , ] <- matrix(lambda.samples[i, , ], n.sp, q) %*% - matrix(w.0.samples[i, , ], q, J.0) - } + w.star.0.samples <- array(NA, dim = c(n.post, n.sp, J.0)) - tmp <- matrix(NA, n.post, length(c(missing.indx, non.missing.indx))) - sp.indx <- rep(1:n.sp, p.abund) - out$mu.0.samples <- array(NA, dim = c(n.post, n.sp, J.0, K.max.0)) - mu.long <- array(NA, dim = c(n.post, n.sp, nrow(X.fix))) - for (i in 1:n.sp) { - if (object$dist %in% c('Poisson', 'NB')) { - mu.long[, i, ] <- exp(t(X.fix %*% t(beta.samples[, sp.indx == i]) + - t(beta.star.sites.0.samples[, i, ]) + - t(w.star.0.samples[, i, sites.0.indx]))) + for (i in 1:n.post) { + w.star.0.samples[i, , ] <- matrix(lambda.samples[i, , ], n.sp, q) %*% + matrix(w.0.samples[i, , ], q, J.0) } - if (object$dist %in% c('Gaussian', 'zi-Gaussian')) { - mu.long[, i, ] <- t(X.fix %*% t(beta.samples[, sp.indx == i]) + - t(beta.star.sites.0.samples[, i, ]) + - t(w.star.0.samples[, i, sites.0.indx])) + + tmp <- matrix(NA, n.post, length(c(missing.indx, non.missing.indx))) + sp.indx <- rep(1:n.sp, p.abund) + out$mu.0.samples <- array(NA, dim = c(n.post, n.sp, J.0, K.max.0)) + mu.long <- array(NA, dim = c(n.post, n.sp, nrow(X.fix))) + for (i in 1:n.sp) { + if (object$dist %in% c('Poisson', 'NB')) { + mu.long[, i, ] <- exp(t(X.fix %*% t(beta.samples[, sp.indx == i]) + + t(beta.star.sites.0.samples[, i, ]) + + t(w.star.0.samples[, i, sites.0.indx]))) + } + if (object$dist %in% c('Gaussian', 'zi-Gaussian')) { + mu.long[, i, ] <- t(X.fix %*% t(beta.samples[, sp.indx == i]) + + t(beta.star.sites.0.samples[, i, ]) + + t(w.star.0.samples[, i, sites.0.indx])) + } + tmp[, non.missing.indx] <- mu.long[, i, ] + out$mu.0.samples[, i, , ] <- array(tmp, dim = c(n.post, J.0, K.max.0)) } - tmp[, non.missing.indx] <- mu.long[, i, ] - out$mu.0.samples[, i, , ] <- array(tmp, dim = c(n.post, J.0, K.max.0)) - } - K <- apply(out$mu.0.samples[1, 1, , , drop = FALSE], 3, function(a) sum(!is.na(a))) - out$y.0.samples <- array(NA, dim(out$mu.0.samples)) - J <- ncol(object$y) - rep.indx <- vector(mode = 'list', length = J) - # Note this assumes the same missingness across species. - for (j in 1:J) { - rep.indx[[j]] <- which(!is.na(object$y[1, j, ])) - } - for (i in 1:n.sp) { - for (j in 1:J.0) { - for (k in rep.indx[[j]]) { - if (object$dist == 'NB') { - out$y.0.samples[, i, j, k] <- rnbinom(n.post, kappa.samples[, i], - mu = out$mu.0.samples[, i, j, k]) - } - if (object$dist == 'Poisson') { - out$y.0.samples[, i, j, k] <- rpois(n.post, out$mu.0.samples[, i, j, k]) + K <- apply(out$mu.0.samples[1, 1, , , drop = FALSE], 3, function(a) sum(!is.na(a))) + out$y.0.samples <- array(NA, dim(out$mu.0.samples)) + J <- ncol(object$y) + rep.indx <- vector(mode = 'list', length = J) + for (i in 1:n.sp) { + for (j in 1:J.0) { + for (k in 1:K.max.0) { + if (sum(is.na(out$mu.0.samples[, i, j, k])) == 0) { + if (object$dist == 'NB') { + out$y.0.samples[, i, j, k] <- rnbinom(n.post, kappa.samples[, i], + mu = out$mu.0.samples[, i, j, k]) + } + if (object$dist == 'Poisson') { + out$y.0.samples[, i, j, k] <- rpois(n.post, out$mu.0.samples[, i, j, k]) + } + if (object$dist == 'Gaussian') { + out$y.0.samples[, i, j, k] <- rnorm(n.post, out$mu.0.samples[, i, j, k], + sqrt(object$tau.sq.samples[, i])) + } + if (object$dist == 'zi-Gaussian') { + out$y.0.samples[, i, j, k] <- ifelse(z.0.samples[, i, j] == 1, + rnorm(n.post, out$mu.0.samples[, i, j, k], + sqrt(object$tau.sq.samples[, i])), + rnorm(n.post, 0, sqrt(0.0001))) + out$mu.0.samples[, i, j, k] <- ifelse(z.0.samples[, i, j] == 1, + out$mu.0.samples[, i, j, k], 0) + } + } } - if (object$dist == 'Gaussian') { - out$y.0.samples[, i, j, k] <- rnorm(n.post, out$mu.0.samples[, i, j, k], - sqrt(object$tau.sq.samples[, i])) - } - if (object$dist == 'zi-Gaussian') { - out$y.0.samples[, i, j, k] <- ifelse(z.0.samples[, i, j] == 1, - rnorm(n.post, out$mu.0.samples[, i, j, k], - sqrt(object$tau.sq.samples[, i])), - rnorm(n.post, 0, sqrt(0.0001))) - out$mu.0.samples[, i, j, k] <- ifelse(z.0.samples[, i, j] == 1, - out$mu.0.samples[, i, j, k], 0) - } } } + out$w.0.samples <- w.0.samples } - out$w.0.samples <- w.0.samples out$call <- cl # If Gaussian, collapse to a 3D array if (object$dist %in% c('Gaussian', 'zi-Gaussian')) { @@ -4343,11 +4361,11 @@ fitted.lfMsDS <- function(object, ...) { } predict.lfMsDS <- function(object, X.0, coords.0, ignore.RE = FALSE, - type = 'abundance', ...) { + type = 'abundance', include.w = TRUE, ...) { # Abundance predictions ------------------------------------------------- if (tolower(type) == 'abundance') { - out <- predict.lfMsNMix(object, X.0, coords.0, ignore.RE, type = 'abundance') + out <- predict.lfMsNMix(object, X.0, coords.0, ignore.RE, type = 'abundance', include.w) } # Detection predictions ------------------------------------------------- if (tolower(type) == 'detection') { diff --git a/R/lfMsAbund.R b/R/lfMsAbund.R index d7d2e74..e286200 100644 --- a/R/lfMsAbund.R +++ b/R/lfMsAbund.R @@ -3,7 +3,7 @@ lfMsAbund <- function(formula, data, inits, priors, 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, ...){ + n.thin = 1, n.chains = 1, save.fitted = TRUE, ...){ ptm <- proc.time() @@ -13,7 +13,7 @@ lfMsAbund <- function(formula, data, inits, priors, if (family %in% c('Gaussian', 'zi-Gaussian')) { lfMsAbundGaussian(formula, data, inits, priors, tuning, n.factors, n.batch, batch.length, accept.rate, family, n.omp.threads, - verbose, n.report, n.burn, n.thin, n.chains) + verbose, n.report, n.burn, n.thin, n.chains, save.fitted) } else { # Functions ----------------------------------------------------------- @@ -139,7 +139,7 @@ lfMsAbund <- function(formula, data, inits, priors, 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(mapply(rep, data$covs, dim(y)[2])) + data$covs <- as.data.frame(lapply(data$covs, rep, dim(y)[3])) } # Check whether random effects are sent in as numeric, and @@ -158,8 +158,6 @@ lfMsAbund <- function(formula, data, inits, priors, } # Checking missing values --------------------------------------------- - # TODO: I believe these checks will fail if only site-level covariates on - # abundance # y ------------------------------- y.na.test <- apply(y.mat, c(1, 2), function(a) sum(!is.na(a))) if (sum(y.na.test == 0) > 0) { @@ -190,6 +188,11 @@ lfMsAbund <- function(formula, data, inits, priors, tmp <- apply(data$covs, 1, function (a) sum(is.na(a))) data$covs <- as.data.frame(data$covs[tmp == 0, , drop = FALSE]) + # Check save.fitted --------------------------------------------------- + if (!(save.fitted %in% c(TRUE, FALSE))) { + stop("save.fitted must be either TRUE or FALSE") + } + # Formula ------------------------------------------------------------- # Abundance ----------------------- if (missing(formula)) { @@ -230,7 +233,7 @@ lfMsAbund <- function(formula, data, inits, priors, # Note this assumes equivalent detection histories for all species. # May want to change this at some point. n.rep <- apply(y.mat[1, , , drop = FALSE], 2, function(a) sum(!is.na(a))) - K.max <- max(n.rep) + K.max <- dim(y.mat)[3] # Because I like K better than n.rep K <- n.rep @@ -706,7 +709,7 @@ lfMsAbund <- function(formula, data, inits, priors, storage.mode(X) <- "double" storage.mode(coords) <- "double" storage.mode(offset) <- 'double' - consts <- c(n.sp, J, n.obs, p.abund, p.abund.re, n.abund.re, q) + consts <- c(n.sp, J, n.obs, p.abund, p.abund.re, n.abund.re, q, save.fitted) storage.mode(consts) <- "integer" storage.mode(beta.inits) <- "double" storage.mode(kappa.inits) <- "double" @@ -847,30 +850,32 @@ lfMsAbund <- function(formula, data, inits, priors, out$lambda.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$lambda.samples)))) colnames(out$lambda.samples) <- loadings.names y.non.miss.indx <- which(!is.na(y.mat), arr.ind = TRUE) - out$y.rep.samples <- do.call(abind, lapply(out.tmp, function(a) array(a$y.rep.samples, - dim = c(n.sp * n.obs, n.post.samples)))) - tmp <- array(NA, dim = c(n.post.samples * n.chains, n.sp, J, K.max)) - for (j in 1:(n.obs * n.sp)) { - curr.indx <- y.non.miss.indx[j, ] - tmp[, curr.indx[1], curr.indx[2], curr.indx[3]] <- out$y.rep.samples[j, ] - } - out$y.rep.samples <- tmp - out$mu.samples <- do.call(abind, lapply(out.tmp, function(a) array(a$mu.samples, - dim = c(n.sp * n.obs, n.post.samples)))) - tmp <- array(NA, dim = c(n.post.samples * n.chains, n.sp, J, K.max)) - for (j in 1:(n.obs * n.sp)) { - curr.indx <- y.non.miss.indx[j, ] - tmp[, curr.indx[1], curr.indx[2], curr.indx[3]] <- out$mu.samples[j, ] - } - out$mu.samples <- tmp - out$like.samples <- do.call(abind, lapply(out.tmp, function(a) array(a$like.samples, - dim = c(n.sp * n.obs, n.post.samples)))) - tmp <- array(NA, dim = c(n.post.samples * n.chains, n.sp, J, K.max)) - for (j in 1:(n.obs * n.sp)) { - curr.indx <- y.non.miss.indx[j, ] - tmp[, curr.indx[1], curr.indx[2], curr.indx[3]] <- out$like.samples[j, ] + if (save.fitted) { + out$y.rep.samples <- do.call(abind, lapply(out.tmp, function(a) array(a$y.rep.samples, + dim = c(n.sp * n.obs, n.post.samples)))) + tmp <- array(NA, dim = c(n.post.samples * n.chains, n.sp, J, K.max)) + for (j in 1:(n.obs * n.sp)) { + curr.indx <- y.non.miss.indx[j, ] + tmp[, curr.indx[1], curr.indx[2], curr.indx[3]] <- out$y.rep.samples[j, ] + } + out$y.rep.samples <- tmp + out$mu.samples <- do.call(abind, lapply(out.tmp, function(a) array(a$mu.samples, + dim = c(n.sp * n.obs, n.post.samples)))) + tmp <- array(NA, dim = c(n.post.samples * n.chains, n.sp, J, K.max)) + for (j in 1:(n.obs * n.sp)) { + curr.indx <- y.non.miss.indx[j, ] + tmp[, curr.indx[1], curr.indx[2], curr.indx[3]] <- out$mu.samples[j, ] + } + out$mu.samples <- tmp + out$like.samples <- do.call(abind, lapply(out.tmp, function(a) array(a$like.samples, + dim = c(n.sp * n.obs, n.post.samples)))) + tmp <- array(NA, dim = c(n.post.samples * n.chains, n.sp, J, K.max)) + for (j in 1:(n.obs * n.sp)) { + curr.indx <- y.non.miss.indx[j, ] + tmp[, curr.indx[1], curr.indx[2], curr.indx[3]] <- out$like.samples[j, ] + } + out$like.samples <- tmp } - out$like.samples <- tmp out$w.samples <- do.call(abind, lapply(out.tmp, function(a) array(a$w.samples, dim = c(q, J, n.post.samples)))) out$w.samples <- aperm(out$w.samples, c(3, 1, 2)) diff --git a/R/lfMsAbundGaussian.R b/R/lfMsAbundGaussian.R index c80849a..a30b9dd 100644 --- a/R/lfMsAbundGaussian.R +++ b/R/lfMsAbundGaussian.R @@ -2,7 +2,7 @@ lfMsAbundGaussian <- function(formula, data, inits, priors, tuning, 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, ...){ + n.thin = 1, n.chains = 1, save.fitted = TRUE, ...){ ptm <- proc.time() @@ -123,6 +123,10 @@ lfMsAbundGaussian <- function(formula, data, inits, priors, tuning, n.factors, } } } + # Check save.fitted --------------------------------------------------- + if (!(save.fitted %in% c(TRUE, FALSE))) { + stop("save.fitted must be either TRUE or FALSE") + } # Formula ------------------------------------------------------------- if (missing(formula)) { @@ -547,7 +551,7 @@ lfMsAbundGaussian <- function(formula, data, inits, priors, tuning, n.factors, storage.mode(y) <- "double" storage.mode(X) <- "double" storage.mode(z) <- 'double' - consts <- c(N, J, p, p.re, n.re, q) + consts <- c(N, J, p, p.re, n.re, q, save.fitted) storage.mode(consts) <- "integer" storage.mode(beta.inits) <- "double" storage.mode(beta.comm.inits) <- "double" @@ -694,15 +698,17 @@ lfMsAbundGaussian <- function(formula, data, inits, priors, tuning, n.factors, loadings.names <- paste(rep(sp.names, times = n.factors), rep(1:n.factors, each = N), sep = '-') out$lambda.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$lambda.samples)))) colnames(out$lambda.samples) <- loadings.names - 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 <- 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 <- 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 <- aperm(out$y.rep.samples, c(3, 1, 2)) + if (save.fitted) { + 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 <- 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 <- 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 <- aperm(out$y.rep.samples, c(3, 1, 2)) + } out$w.samples <- do.call(abind, lapply(out.tmp, function(a) array(a$w.samples, dim = c(q, J, n.post.samples)))) out$w.samples <- aperm(out$w.samples, c(3, 1, 2)) diff --git a/R/lfMsNMix.R b/R/lfMsNMix.R index c39965c..8e2573b 100644 --- a/R/lfMsNMix.R +++ b/R/lfMsNMix.R @@ -124,6 +124,8 @@ lfMsNMix <- function(abund.formula, det.formula, data, inits, priors, # Make both covariates a data frame. Unlist is necessary for when factors # are supplied. data$det.covs <- data.frame(lapply(data$det.covs, function(a) unlist(c(a)))) + # Indicator of whether all det.covs are site level or not + site.level.ind <- ifelse(nrow(data$det.covs) == ncol(y), TRUE, FALSE) data$abund.covs <- as.data.frame(data$abund.covs) # Check whether random effects are sent in as numeric, and @@ -164,22 +166,28 @@ lfMsNMix <- function(abund.formula, det.formula, data, inits, priors, stop("error: missing values in abund.covs. Please remove these sites from all objects in data or somehow replace the NA values with non-missing values (e.g., mean imputation).") } # det.covs ------------------------ - for (i in 1:ncol(data$det.covs)) { - # Note that this assumes the same detection history for each species. - if (sum(is.na(data$det.covs[, i])) > sum(is.na(y.mat[1, , ]))) { - stop("error: some elements in det.covs have missing values where there is an observed data value in y. Please either replace the NA values in det.covs with non-missing values (e.g., mean imputation) or set the corresponding values in y to NA where the covariate is missing.") - } - } - # Misalignment between y and det.covs - y.missing <- which(is.na(y[1, , ])) - det.covs.missing <- lapply(data$det.covs, function(a) which(is.na(a))) - for (i in 1:length(det.covs.missing)) { - tmp.indx <- !(y.missing %in% det.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$det.covs.\nRemoving these site/replicate combinations for fitting the model.") + if (!site.level.ind) { + for (i in 1:ncol(data$det.covs)) { + if (sum(is.na(data$det.covs[, i])) > sum(is.na(y.mat[1, , ]))) { + stop("error: some elements in det.covs have missing values where there is an observed data value in y. Please either replace the NA values in det.covs with non-missing values (e.g., mean imputation) or set the corresponding values in y to NA where the covariate is missing.") } - data$det.covs[y.missing, i] <- NA + } + # Misalignment between y and det.covs + y.missing <- which(is.na(y[1, , ])) + det.covs.missing <- lapply(data$det.covs, function(a) which(is.na(a))) + for (i in 1:length(det.covs.missing)) { + tmp.indx <- !(y.missing %in% det.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$det.covs.\nRemoving these site/replicate combinations for fitting the model.\n") + } + data$det.covs[y.missing, i] <- NA + } + } + } + if (site.level.ind) { + if (sum(is.na(data$det.covs)) != 0) { + stop("missing values in site-level det.covs. Please remove these sites from all objects in data or somehow replace the NA values with non-missing values (e.g., mean imputation).") } } diff --git a/R/msAbund.R b/R/msAbund.R index 196b25b..90d6378 100644 --- a/R/msAbund.R +++ b/R/msAbund.R @@ -12,7 +12,7 @@ msAbund <- function(formula, data, inits, priors, tuning, if (family %in% c('Gaussian', 'zi-Gaussian')) { msAbundGaussian(formula, data, inits, priors, tuning, n.batch, batch.length, accept.rate, family, n.omp.threads, - verbose, n.report, n.burn, n.thin, n.chains) + verbose, n.report, n.burn, n.thin, n.chains, save.fitted) } else { # Functions ----------------------------------------------------------- @@ -122,9 +122,8 @@ msAbund <- function(formula, data, inits, priors, tuning, # 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 - # TODO: this leads to a problem if factors are supplied if (nrow(data$covs) == dim(y)[2] & dim(y)[3] != 1) { - data$covs <- as.data.frame(mapply(rep, data$covs, dim(y)[3])) + data$covs <- as.data.frame(lapply(data$covs, rep, dim(y)[3])) } # Check whether random effects are sent in as numeric, and @@ -211,7 +210,7 @@ msAbund <- function(formula, data, inits, priors, tuning, # Note this assumes equivalent detection histories for all species. # May want to change this at some point. n.rep <- apply(y.mat[1, , , drop = FALSE], 2, function(a) sum(!is.na(a))) - K.max <- max(n.rep) + K.max <- dim(y.mat)[3] # Because I like K better than n.rep K <- n.rep diff --git a/R/msAbundGaussian.R b/R/msAbundGaussian.R index bb01bdc..e4f03a2 100644 --- a/R/msAbundGaussian.R +++ b/R/msAbundGaussian.R @@ -2,7 +2,7 @@ msAbundGaussian <- function(formula, data, inits, priors, tuning, 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, ...){ + n.thin = 1, n.chains = 1, save.fitted = TRUE, ...){ ptm <- proc.time() @@ -115,6 +115,11 @@ msAbundGaussian <- function(formula, data, inits, priors, tuning, } } + # Check save.fitted --------------------------------------------------- + if (!(save.fitted %in% c(TRUE, FALSE))) { + stop("save.fitted must be either TRUE or FALSE") + } + # Formula ------------------------------------------------------------- if (missing(formula)) { stop("error: formula must be specified") @@ -489,7 +494,7 @@ msAbundGaussian <- function(formula, data, inits, priors, tuning, storage.mode(y) <- "double" storage.mode(X) <- "double" storage.mode(z) <- 'double' - consts <- c(N, J, p, p.re, n.re) + consts <- c(N, J, p, p.re, n.re, save.fitted) storage.mode(consts) <- "integer" storage.mode(beta.inits) <- "double" storage.mode(beta.comm.inits) <- "double" @@ -622,15 +627,17 @@ msAbundGaussian <- function(formula, data, inits, priors, tuning, colnames(out$beta.star.samples) <- beta.star.names out$re.level.names <- re.level.names } - 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 <- 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 <- 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 <- aperm(out$y.rep.samples, c(3, 1, 2)) + if (save.fitted) { + 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 <- 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 <- 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 <- aperm(out$y.rep.samples, c(3, 1, 2)) + } out$X.re <- X.re # Calculate effective sample sizes diff --git a/R/msNMix.R b/R/msNMix.R index 99a47b4..68c5d49 100644 --- a/R/msNMix.R +++ b/R/msNMix.R @@ -103,6 +103,8 @@ msNMix <- function(abund.formula, det.formula, data, inits, priors, # Make both covariates a data frame. Unlist is necessary for when factors # are supplied. data$det.covs <- data.frame(lapply(data$det.covs, function(a) unlist(c(a)))) + # Indicator of whether all det.covs are site level or not + site.level.ind <- ifelse(nrow(data$det.covs) == ncol(y), TRUE, FALSE) data$abund.covs <- as.data.frame(data$abund.covs) # Check whether random effects are sent in as numeric, and @@ -133,8 +135,6 @@ msNMix <- function(abund.formula, det.formula, data, inits, priors, } # Checking missing values --------------------------------------------- - # TODO: I believe these checks will fail if only site-level covariates on - # abundance # y ------------------------------- y.na.test <- apply(y.mat, c(1, 2), function(a) sum(!is.na(a))) if (sum(y.na.test == 0) > 0) { @@ -145,22 +145,28 @@ msNMix <- function(abund.formula, det.formula, data, inits, priors, stop("error: missing values in abund.covs. Please remove these sites from all objects in data or somehow replace the NA values with non-missing values (e.g., mean imputation).") } # det.covs ------------------------ - for (i in 1:ncol(data$det.covs)) { - # Note that this assumes the same detection history for each species. - if (sum(is.na(data$det.covs[, i])) > sum(is.na(y.mat[1, , ]))) { - stop("error: some elements in det.covs have missing values where there is an observed data value in y. Please either replace the NA values in det.covs with non-missing values (e.g., mean imputation) or set the corresponding values in y to NA where the covariate is missing.") - } - } - # Misalignment between y and det.covs - y.missing <- which(is.na(y[1, , ])) - det.covs.missing <- lapply(data$det.covs, function(a) which(is.na(a))) - for (i in 1:length(det.covs.missing)) { - tmp.indx <- !(y.missing %in% det.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$det.covs.\nRemoving these site/replicate combinations for fitting the model.") + if (!site.level.ind) { + for (i in 1:ncol(data$det.covs)) { + if (sum(is.na(data$det.covs[, i])) > sum(is.na(y.mat[1, , ]))) { + stop("error: some elements in det.covs have missing values where there is an observed data value in y. Please either replace the NA values in det.covs with non-missing values (e.g., mean imputation) or set the corresponding values in y to NA where the covariate is missing.") } - data$det.covs[y.missing, i] <- NA + } + # Misalignment between y and det.covs + y.missing <- which(is.na(y[1, , ])) + det.covs.missing <- lapply(data$det.covs, function(a) which(is.na(a))) + for (i in 1:length(det.covs.missing)) { + tmp.indx <- !(y.missing %in% det.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$det.covs.\nRemoving these site/replicate combinations for fitting the model.\n") + } + data$det.covs[y.missing, i] <- NA + } + } + } + if (site.level.ind) { + if (sum(is.na(data$det.covs)) != 0) { + stop("missing values in site-level det.covs. Please remove these sites from all objects in data or somehow replace the NA values with non-missing values (e.g., mean imputation).") } } diff --git a/R/sfMsAbund.R b/R/sfMsAbund.R index eecb7f4..f0987ef 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, ...){ + n.thin = 1, n.chains = 1, save.fitted = TRUE, ...){ ptm <- proc.time() @@ -15,7 +15,7 @@ sfMsAbund <- function(formula, data, inits, priors, sfMsAbundGaussian(formula, data, inits, priors, tuning, 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) + verbose, n.report, n.burn, n.thin, n.chains, save.fitted) } else { @@ -213,6 +213,11 @@ sfMsAbund <- function(formula, data, inits, priors, tmp <- apply(data$covs, 1, function (a) sum(is.na(a))) data$covs <- as.data.frame(data$covs[tmp == 0, , drop = FALSE]) + # Check save.fitted --------------------------------------------------- + if (!(save.fitted %in% c(TRUE, FALSE))) { + stop("save.fitted must be either TRUE or FALSE") + } + # Formula ------------------------------------------------------------- # Abundance ----------------------- if (missing(formula)) { @@ -921,7 +926,7 @@ sfMsAbund <- function(formula, data, inits, priors, storage.mode(X) <- "double" storage.mode(coords) <- "double" storage.mode(offset) <- 'double' - consts <- c(n.sp, J, n.obs, p.abund, p.abund.re, n.abund.re, q, ind.betas) + consts <- c(n.sp, J, n.obs, p.abund, p.abund.re, n.abund.re, q, ind.betas, save.fitted) storage.mode(consts) <- "integer" storage.mode(beta.inits) <- "double" storage.mode(kappa.inits) <- "double" @@ -1099,30 +1104,32 @@ sfMsAbund <- function(formula, data, inits, priors, } colnames(out$theta.samples) <- theta.names y.non.miss.indx <- which(!is.na(y.mat), arr.ind = TRUE) - out$y.rep.samples <- do.call(abind, lapply(out.tmp, function(a) array(a$y.rep.samples, - dim = c(n.sp * n.obs, n.post.samples)))) - tmp <- array(NA, dim = c(n.post.samples * n.chains, n.sp, J, K.max)) - for (j in 1:(n.obs * n.sp)) { - curr.indx <- y.non.miss.indx[j, ] - tmp[, curr.indx[1], curr.indx[2], curr.indx[3]] <- out$y.rep.samples[j, ] - } - out$y.rep.samples <- tmp[, , order(ord), , drop = FALSE] - out$mu.samples <- do.call(abind, lapply(out.tmp, function(a) array(a$mu.samples, - dim = c(n.sp * n.obs, n.post.samples)))) - tmp <- array(NA, dim = c(n.post.samples * n.chains, n.sp, J, K.max)) - for (j in 1:(n.obs * n.sp)) { - curr.indx <- y.non.miss.indx[j, ] - tmp[, curr.indx[1], curr.indx[2], curr.indx[3]] <- out$mu.samples[j, ] - } - out$mu.samples <- tmp[, , order(ord), , drop = FALSE] - out$like.samples <- do.call(abind, lapply(out.tmp, function(a) array(a$like.samples, - dim = c(n.sp * n.obs, n.post.samples)))) - tmp <- array(NA, dim = c(n.post.samples * n.chains, n.sp, J, K.max)) - for (j in 1:(n.obs * n.sp)) { - curr.indx <- y.non.miss.indx[j, ] - tmp[, curr.indx[1], curr.indx[2], curr.indx[3]] <- out$like.samples[j, ] - } - out$like.samples <- tmp[, , order(ord), , drop = FALSE] + if (save.fitted) { + out$y.rep.samples <- do.call(abind, lapply(out.tmp, function(a) array(a$y.rep.samples, + dim = c(n.sp * n.obs, n.post.samples)))) + tmp <- array(NA, dim = c(n.post.samples * n.chains, n.sp, J, K.max)) + for (j in 1:(n.obs * n.sp)) { + curr.indx <- y.non.miss.indx[j, ] + tmp[, curr.indx[1], curr.indx[2], curr.indx[3]] <- out$y.rep.samples[j, ] + } + out$y.rep.samples <- tmp[, , order(ord), , drop = FALSE] + out$mu.samples <- do.call(abind, lapply(out.tmp, function(a) array(a$mu.samples, + dim = c(n.sp * n.obs, n.post.samples)))) + tmp <- array(NA, dim = c(n.post.samples * n.chains, n.sp, J, K.max)) + for (j in 1:(n.obs * n.sp)) { + curr.indx <- y.non.miss.indx[j, ] + tmp[, curr.indx[1], curr.indx[2], curr.indx[3]] <- out$mu.samples[j, ] + } + out$mu.samples <- tmp[, , order(ord), , drop = FALSE] + out$like.samples <- do.call(abind, lapply(out.tmp, function(a) array(a$like.samples, + dim = c(n.sp * n.obs, n.post.samples)))) + tmp <- array(NA, dim = c(n.post.samples * n.chains, n.sp, J, K.max)) + for (j in 1:(n.obs * n.sp)) { + curr.indx <- y.non.miss.indx[j, ] + tmp[, curr.indx[1], curr.indx[2], curr.indx[3]] <- out$like.samples[j, ] + } + out$like.samples <- tmp[, , order(ord), , drop = FALSE] + } out$w.samples <- do.call(abind, lapply(out.tmp, function(a) array(a$w.samples, dim = c(q, J, n.post.samples)))) out$w.samples <- out$w.samples[, order(ord), , drop = FALSE] diff --git a/R/sfMsAbundGaussian.R b/R/sfMsAbundGaussian.R index 2086944..3da82f9 100644 --- a/R/sfMsAbundGaussian.R +++ b/R/sfMsAbundGaussian.R @@ -4,7 +4,7 @@ sfMsAbundGaussian <- function(formula, data, inits, priors, 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, ...){ + n.thin = 1, n.chains = 1, save.fitted = TRUE, ...){ ptm <- proc.time() @@ -139,6 +139,10 @@ sfMsAbundGaussian <- function(formula, data, inits, priors, } } } + # Check save.fitted --------------------------------------------------- + if (!(save.fitted %in% c(TRUE, FALSE))) { + stop("save.fitted must be either TRUE or FALSE") + } # Formula ------------------------------------------------------------- if (missing(formula)) { @@ -762,7 +766,7 @@ sfMsAbundGaussian <- function(formula, data, inits, priors, storage.mode(X) <- "double" storage.mode(z) <- 'double' storage.mode(coords) <- "double" - consts <- c(N, J, p, p.re, n.re, q, ind.betas) + consts <- c(N, J, p, p.re, n.re, q, ind.betas, save.fitted) storage.mode(consts) <- "integer" storage.mode(beta.inits) <- "double" storage.mode(beta.comm.inits) <- "double" @@ -952,18 +956,20 @@ sfMsAbundGaussian <- function(formula, data, inits, priors, dim = c(q, J, n.post.samples)))) out$w.samples <- out$w.samples[, order(ord), , drop = FALSE] out$w.samples <- aperm(out$w.samples, c(3, 1, 2)) - 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)) + if (save.fitted) { + 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 diff --git a/R/sfMsNMix.R b/R/sfMsNMix.R index 1822e39..b84da20 100644 --- a/R/sfMsNMix.R +++ b/R/sfMsNMix.R @@ -148,6 +148,8 @@ sfMsNMix <- function(abund.formula, det.formula, data, inits, priors, # Make both covariates a data frame. Unlist is necessary for when factors # are supplied. data$det.covs <- data.frame(lapply(data$det.covs, function(a) unlist(c(a)))) + # Indicator of whether all det.covs are site level or not + site.level.ind <- ifelse(nrow(data$det.covs) == ncol(y), TRUE, FALSE) data$abund.covs <- as.data.frame(data$abund.covs) # Check whether random effects are sent in as numeric, and @@ -188,22 +190,28 @@ sfMsNMix <- function(abund.formula, det.formula, data, inits, priors, stop("error: missing values in abund.covs. Please remove these sites from all objects in data or somehow replace the NA values with non-missing values (e.g., mean imputation).") } # det.covs ------------------------ - for (i in 1:ncol(data$det.covs)) { - # Note that this assumes the same detection history for each species. - if (sum(is.na(data$det.covs[, i])) > sum(is.na(y.mat[1, , ]))) { - stop("error: some elements in det.covs have missing values where there is an observed data value in y. Please either replace the NA values in det.covs with non-missing values (e.g., mean imputation) or set the corresponding values in y to NA where the covariate is missing.") - } - } - # Misalignment between y and det.covs - y.missing <- which(is.na(y[1, , ])) - det.covs.missing <- lapply(data$det.covs, function(a) which(is.na(a))) - for (i in 1:length(det.covs.missing)) { - tmp.indx <- !(y.missing %in% det.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$det.covs.\nRemoving these site/replicate combinations for fitting the model.") + if (!site.level.ind) { + for (i in 1:ncol(data$det.covs)) { + if (sum(is.na(data$det.covs[, i])) > sum(is.na(y.mat[1, , ]))) { + stop("error: some elements in det.covs have missing values where there is an observed data value in y. Please either replace the NA values in det.covs with non-missing values (e.g., mean imputation) or set the corresponding values in y to NA where the covariate is missing.") } - data$det.covs[y.missing, i] <- NA + } + # Misalignment between y and det.covs + y.missing <- which(is.na(y[1, , ])) + det.covs.missing <- lapply(data$det.covs, function(a) which(is.na(a))) + for (i in 1:length(det.covs.missing)) { + tmp.indx <- !(y.missing %in% det.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$det.covs.\nRemoving these site/replicate combinations for fitting the model.\n") + } + data$det.covs[y.missing, i] <- NA + } + } + } + if (site.level.ind) { + if (sum(is.na(data$det.covs)) != 0) { + stop("missing values in site-level det.covs. Please remove these sites from all objects in data or somehow replace the NA values with non-missing values (e.g., mean imputation).") } } diff --git a/R/spAbund.R b/R/spAbund.R index df7fab1..9d666b9 100644 --- a/R/spAbund.R +++ b/R/spAbund.R @@ -15,7 +15,7 @@ spAbund <- function(formula, data, inits, priors, tuning, spAbundGaussian(formula, data, inits, priors, tuning, 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) + n.chains, save.fitted) } else { # Make it look nice @@ -238,7 +238,7 @@ spAbund <- function(formula, data, inits, priors, tuning, # Number of replicates at each site n.rep <- apply(y, 1, function(a) sum(!is.na(a))) # Max number of repeat visits - K.max <- max(n.rep) + K.max <- ncol(y) # Because I like K better than n.rep K <- n.rep diff --git a/R/spAbundGaussian.R b/R/spAbundGaussian.R index 61c8be0..0c5ac53 100644 --- a/R/spAbundGaussian.R +++ b/R/spAbundGaussian.R @@ -4,7 +4,7 @@ spAbundGaussian <- function(formula, data, inits, priors, tuning, 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, ...){ + n.thin = 1, n.chains = 1, save.fitted = TRUE, ...){ ptm <- proc.time() @@ -157,6 +157,11 @@ spAbundGaussian <- function(formula, data, inits, priors, tuning, } } + # Check save.fitted --------------------------------------------------- + if (!(save.fitted %in% c(TRUE, FALSE))) { + stop("save.fitted must be either TRUE or FALSE") + } + # Formula ------------------------------------------------------------- # Occupancy ----------------------- if (is(formula, 'formula')) { @@ -639,7 +644,7 @@ spAbundGaussian <- function(formula, data, inits, priors, tuning, # Set storage for all variables --------------------------------------- storage.mode(y) <- "double" storage.mode(X) <- "double" - consts <- c(J.est, p, p.re, n.re, J.zero) + consts <- c(J.est, p, p.re, n.re, J.zero, save.fitted) storage.mode(consts) <- "integer" storage.mode(coords) <- "double" storage.mode(beta.inits) <- "double" @@ -775,30 +780,32 @@ spAbundGaussian <- function(formula, data, inits, priors, tuning, colnames(out$tau.sq.samples) <- 'tau.sq' # 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]) + if (save.fitted) { + 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$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$X <- X[order(ord), , drop = FALSE] out$X.re <- X.re[order(ord), , drop = FALSE] out$w.samples <- mcmc(do.call(rbind, lapply(out.tmp, function(a) t(a$w.samples)))) out$w.samples <- mcmc(out$w.samples[, order(ord), drop = FALSE]) - 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( diff --git a/R/spNMix.R b/R/spNMix.R index 8249984..87c7808 100644 --- a/R/spNMix.R +++ b/R/spNMix.R @@ -153,6 +153,8 @@ spNMix <- function(abund.formula, det.formula, data, inits, priors, tuning, # Make both covariates a data frame. Unlist is necessary for when factors # are supplied. data$det.covs <- data.frame(lapply(data$det.covs, function(a) unlist(c(a)))) + # Indicator of whether all det.covs are site level or not + site.level.ind <- ifelse(nrow(data$det.covs) == nrow(y), TRUE, FALSE) data$abund.covs <- as.data.frame(data$abund.covs) # Check whether random effects are sent in as numeric, and @@ -193,21 +195,28 @@ spNMix <- function(abund.formula, det.formula, data, inits, priors, tuning, stop("error: missing values in abund.covs. Please remove these sites from all objects in data or somehow replace the NA values with non-missing values (e.g., mean imputation).") } # det.covs ------------------------ - for (i in 1:ncol(data$det.covs)) { - if (sum(is.na(data$det.covs[, i])) > sum(is.na(y))) { - stop("error: some elements in det.covs have missing values where there is an observed data value in y. Please either replace the NA values in det.covs with non-missing values (e.g., mean imputation) or set the corresponding values in y to NA where the covariate is missing.") + if (!site.level.ind) { + for (i in 1:ncol(data$det.covs)) { + if (sum(is.na(data$det.covs[, i])) > sum(is.na(y))) { + stop("error: some elements in det.covs have missing values where there is an observed data value in y. Please either replace the NA values in det.covs with non-missing values (e.g., mean imputation) or set the corresponding values in y to NA where the covariate is missing.") + } } - } - # Misalignment between y and det.covs - y.missing <- which(is.na(y)) - det.covs.missing <- lapply(data$det.covs, function(a) which(is.na(a))) - for (i in 1:length(det.covs.missing)) { - tmp.indx <- !(y.missing %in% det.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$det.covs.\nRemoving these site/replicate combinations for fitting the model.\n") + # Misalignment between y and det.covs + y.missing <- which(is.na(data$y)) + det.covs.missing <- lapply(data$det.covs, function(a) which(is.na(a))) + for (i in 1:length(det.covs.missing)) { + tmp.indx <- !(y.missing %in% det.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$det.covs.\nRemoving these site/replicate combinations for fitting the model.\n") + } + data$det.covs[y.missing, i] <- NA } - data$det.covs[y.missing, i] <- NA + } + } + if (site.level.ind) { + if (sum(is.na(data$det.covs)) != 0) { + stop("missing values in site-level det.covs. Please remove these sites from all objects in data or somehow replace the NA values with non-missing values (e.g., mean imputation).") } } diff --git a/man/lfMsAbund.Rd b/man/lfMsAbund.Rd index 2fd0efc..988800b 100644 --- a/man/lfMsAbund.Rd +++ b/man/lfMsAbund.Rd @@ -13,7 +13,7 @@ lfMsAbund(formula, data, inits, priors, tuning, n.factors, 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, ...) } \arguments{ @@ -145,6 +145,15 @@ lfMsAbund(formula, data, inits, priors, tuning, n.factors, \item{n.chains}{the number of 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} } diff --git a/man/predict.lfMsAbund.Rd b/man/predict.lfMsAbund.Rd index 89d0be2..0d8ce6e 100644 --- a/man/predict.lfMsAbund.Rd +++ b/man/predict.lfMsAbund.Rd @@ -7,7 +7,7 @@ } \usage{ -\method{predict}{lfMsAbund}(object, X.0, coords.0, ignore.RE = FALSE, z.0.samples, ...) +\method{predict}{lfMsAbund}(object, X.0, coords.0, ignore.RE = FALSE, z.0.samples, include.w = TRUE, ...) } \arguments{ @@ -24,6 +24,8 @@ \item{z.0.samples}{a three-dimensional array with dimensions corresponding to MCMC samples, species, and prediction locations. The array contains the full posterior samples of the predicted binary portion of a Gaussian hurdle model. In the context of abundance models, this typically corresponds to estimates of the presence or absence of each species at the location. When using \code{spOccupancy} to generate the first stage samples of the Gaussian-hurdle model, this is the object contained in the \code{z.0.samples} object of the predition function for the spOccupancy object. Ignored for all model types other than Gaussian-hurdle.} + \item{include.w}{a logical value used to indicate whether the latent 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} } diff --git a/man/predict.lfMsDS.Rd b/man/predict.lfMsDS.Rd index d5d1e57..65be58c 100644 --- a/man/predict.lfMsDS.Rd +++ b/man/predict.lfMsDS.Rd @@ -8,7 +8,7 @@ \usage{ \method{predict}{lfMsDS}(object, X.0, coords.0, ignore.RE = FALSE, - type = 'abundance', ...) + type = 'abundance', include.w = TRUE, ...) } \arguments{ @@ -23,6 +23,8 @@ \item{ignore.RE}{a logical value indicating whether to include unstructured random effects for prediction. If TRUE, random effects will be ignored and prediction will only use the fixed effects. If FALSE, random effects will be included in the prediction for both observed and unobserved levels of the random effect.} \item{type}{a quoted keyword indicating what type of prediction to produce. Valid keywords are 'abundance' to predict expected abundance and latent abundance values (this is the default), or 'detection' to predict detection probability given new values of detection covariates.} + + \item{include.w}{a logical value used to indicate whether the latent 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} diff --git a/man/predict.lfMsNMix.Rd b/man/predict.lfMsNMix.Rd index 8c65b88..b58e31f 100644 --- a/man/predict.lfMsNMix.Rd +++ b/man/predict.lfMsNMix.Rd @@ -8,7 +8,7 @@ \usage{ \method{predict}{lfMsNMix}(object, X.0, coords.0, ignore.RE = FALSE, - type = 'abundance', ...) + type = 'abundance', include.w = TRUE, ...) } \arguments{ @@ -23,6 +23,8 @@ \item{ignore.RE}{a logical value indicating whether to include unstructured random effects for prediction. If TRUE, random effects will be ignored and prediction will only use the fixed effects. If FALSE, random effects will be included in the prediction for both observed and unobserved levels of the random effect.} \item{type}{a quoted keyword indicating what type of prediction to produce. Valid keywords are 'abundance' to predict expected abundance and latent abundance values (this is the default), or 'detection' to predict detection probability given new values of detection covariates.} + + \item{include.w}{a logical value used to indicate whether the latent 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} } diff --git a/man/predict.sfMsAbund.Rd b/man/predict.sfMsAbund.Rd index bdaf086..cf4e080 100644 --- a/man/predict.sfMsAbund.Rd +++ b/man/predict.sfMsAbund.Rd @@ -9,7 +9,7 @@ \usage{ \method{predict}{sfMsAbund}(object, X.0, coords.0, n.omp.threads = 1, verbose = TRUE, n.report = 100, ignore.RE = FALSE, - z.0.samples, ...) + z.0.samples, include.sp = TRUE, ...) } \arguments{ @@ -38,6 +38,8 @@ \item{z.0.samples}{a three-dimensional array with dimensions corresponding to MCMC samples, species, and prediction locations. The array contains 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 each 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 the 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} } diff --git a/man/predict.sfMsNMix.Rd b/man/predict.sfMsNMix.Rd index 8566216..9be9295 100644 --- a/man/predict.sfMsNMix.Rd +++ b/man/predict.sfMsNMix.Rd @@ -38,7 +38,7 @@ \item{type}{a quoted keyword indicating what type of prediction to produce. Valid keywords are 'abundance' to predict expected abundance and latent abundance values (this is the default), or 'detection' to predict detection probability given new values of detection covariates.} - \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} argument is not required.} + \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} diff --git a/man/predict.spAbund.Rd b/man/predict.spAbund.Rd index b823a81..70ffa87 100644 --- a/man/predict.spAbund.Rd +++ b/man/predict.spAbund.Rd @@ -9,7 +9,7 @@ \usage{ \method{predict}{spAbund}(object, X.0, coords.0, n.omp.threads = 1, verbose = TRUE, n.report = 100, - ignore.RE = FALSE, z.0.samples, ...) + ignore.RE = FALSE, z.0.samples, include.sp = TRUE, ...) } \arguments{ @@ -37,6 +37,8 @@ \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 the 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} } diff --git a/man/sfMsAbund.Rd b/man/sfMsAbund.Rd index 9ae8038..d980ff6 100644 --- a/man/sfMsAbund.Rd +++ b/man/sfMsAbund.Rd @@ -13,7 +13,7 @@ sfMsAbund(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, ...) } \arguments{ @@ -187,6 +187,15 @@ sfMsAbund(formula, data, inits, priors, \item{n.chains}{the number of 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} } diff --git a/src/DS.cpp b/src/DS.cpp index d554a98..e201c88 100755 --- a/src/DS.cpp +++ b/src/DS.cpp @@ -184,37 +184,48 @@ extern "C" { * *******************************************************************/ SEXP betaSamples_r; PROTECT(betaSamples_r = allocMatrix(REALSXP, pAbund, nPost)); nProtect++; + zeros(REAL(betaSamples_r), pAbund * nPost); SEXP alphaSamples_r; PROTECT(alphaSamples_r = allocMatrix(REALSXP, pDet, nPost)); nProtect++; + zeros(REAL(alphaSamples_r), pDet * nPost); SEXP NSamples_r; PROTECT(NSamples_r = allocMatrix(REALSXP, J, nPost)); nProtect++; + zeros(REAL(NSamples_r), J * nPost); SEXP kappaSamples_r; if (family == 1) { PROTECT(kappaSamples_r = allocMatrix(REALSXP, inc, nPost)); nProtect++; + zeros(REAL(kappaSamples_r), nPost); } SEXP muSamples_r; PROTECT(muSamples_r = allocMatrix(REALSXP, J, nPost)); nProtect++; + zeros(REAL(muSamples_r), J * nPost); // Detection random effects SEXP sigmaSqPSamples_r; SEXP alphaStarSamples_r; if (pDetRE > 0) { PROTECT(sigmaSqPSamples_r = allocMatrix(REALSXP, pDetRE, nPost)); nProtect++; + zeros(REAL(sigmaSqPSamples_r), pDetRE * nPost); PROTECT(alphaStarSamples_r = allocMatrix(REALSXP, nDetRE, nPost)); nProtect++; + zeros(REAL(alphaStarSamples_r), nDetRE * nPost); } // Abundance random effects SEXP sigmaSqMuSamples_r; SEXP betaStarSamples_r; if (pAbundRE > 0) { PROTECT(sigmaSqMuSamples_r = allocMatrix(REALSXP, pAbundRE, nPost)); nProtect++; + zeros(REAL(sigmaSqMuSamples_r), pAbundRE * nPost); PROTECT(betaStarSamples_r = allocMatrix(REALSXP, nAbundRE, nPost)); nProtect++; + zeros(REAL(betaStarSamples_r), nAbundRE * nPost); } // Stuff for fitted values int KFull = K + 1; int nObsFull = KFull * J; SEXP yRepSamples_r; PROTECT(yRepSamples_r = allocMatrix(INTSXP, nObsFull, nPost)); nProtect++; + zeros(REAL(yRepSamples_r), nObsFull * nPost); SEXP piFullSamples_r; PROTECT(piFullSamples_r = allocMatrix(REALSXP, nObsFull, nPost)); nProtect++; + zeros(REAL(piFullSamples_r), nObsFull * nPost); /******************************************************************** Some constants and temporary variables to be used later @@ -295,8 +306,10 @@ extern "C" { } SEXP acceptSamples_r; PROTECT(acceptSamples_r = allocMatrix(REALSXP, nAMCMC, nBatch)); nProtect++; + zeros(REAL(acceptSamples_r), nAMCMC * nBatch); SEXP tuningSamples_r; PROTECT(tuningSamples_r = allocMatrix(REALSXP, nAMCMC, nBatch)); nProtect++; + zeros(REAL(tuningSamples_r), nAMCMC * nBatch); /********************************************************************** * Prep for random effects diff --git a/src/NMix.cpp b/src/NMix.cpp index d263b1e..ee7a3ff 100755 --- a/src/NMix.cpp +++ b/src/NMix.cpp @@ -181,29 +181,38 @@ extern "C" { * *******************************************************************/ SEXP betaSamples_r; PROTECT(betaSamples_r = allocMatrix(REALSXP, pAbund, nPost)); nProtect++; + zeros(REAL(betaSamples_r), pAbund * nPost); SEXP alphaSamples_r; PROTECT(alphaSamples_r = allocMatrix(REALSXP, pDet, nPost)); nProtect++; + zeros(REAL(alphaSamples_r), pDet * nPost); SEXP NSamples_r; PROTECT(NSamples_r = allocMatrix(REALSXP, J, nPost)); nProtect++; + zeros(REAL(NSamples_r), J * nPost); SEXP kappaSamples_r; if (family == 1) { PROTECT(kappaSamples_r = allocMatrix(REALSXP, inc, nPost)); nProtect++; + zeros(REAL(kappaSamples_r), nPost); } SEXP muSamples_r; PROTECT(muSamples_r = allocMatrix(REALSXP, J, nPost)); nProtect++; + zeros(REAL(muSamples_r), J * nPost); // Detection random effects SEXP sigmaSqPSamples_r; SEXP alphaStarSamples_r; if (pDetRE > 0) { PROTECT(sigmaSqPSamples_r = allocMatrix(REALSXP, pDetRE, nPost)); nProtect++; + zeros(REAL(sigmaSqPSamples_r), pDetRE * nPost); PROTECT(alphaStarSamples_r = allocMatrix(REALSXP, nDetRE, nPost)); nProtect++; + zeros(REAL(alphaStarSamples_r), nDetRE * nPost); } // Abundance random effects SEXP sigmaSqMuSamples_r; SEXP betaStarSamples_r; if (pAbundRE > 0) { PROTECT(sigmaSqMuSamples_r = allocMatrix(REALSXP, pAbundRE, nPost)); nProtect++; + zeros(REAL(sigmaSqMuSamples_r), pAbundRE * nPost); PROTECT(betaStarSamples_r = allocMatrix(REALSXP, nAbundRE, nPost)); nProtect++; + zeros(REAL(betaStarSamples_r), nAbundRE * nPost); } /******************************************************************** @@ -282,8 +291,10 @@ extern "C" { } SEXP acceptSamples_r; PROTECT(acceptSamples_r = allocMatrix(REALSXP, nAMCMC, nBatch)); nProtect++; + zeros(REAL(acceptSamples_r), nAMCMC * nBatch); SEXP tuningSamples_r; PROTECT(tuningSamples_r = allocMatrix(REALSXP, nAMCMC, nBatch)); nProtect++; + zeros(REAL(tuningSamples_r), nAMCMC * nBatch); /********************************************************************** * Prep for random effects diff --git a/src/abund.cpp b/src/abund.cpp index 478cfce..0ba3b77 100755 --- a/src/abund.cpp +++ b/src/abund.cpp @@ -223,8 +223,10 @@ extern "C" { kappaCand = kappa; SEXP acceptSamples_r; PROTECT(acceptSamples_r = allocMatrix(REALSXP, nAMCMC, nBatch)); nProtect++; + zeros(REAL(acceptSamples_r), nAMCMC * nBatch); SEXP tuningSamples_r; PROTECT(tuningSamples_r = allocMatrix(REALSXP, nAMCMC, nBatch)); nProtect++; + zeros(REAL(tuningSamples_r), nAMCMC * nBatch); /********************************************************************** * Prep for random effects diff --git a/src/abundGaussian.cpp b/src/abundGaussian.cpp index 629f775..45bbb9d 100644 --- a/src/abundGaussian.cpp +++ b/src/abundGaussian.cpp @@ -54,6 +54,7 @@ extern "C" { int pRE = INTEGER(consts_r)[2]; int nRE = INTEGER(consts_r)[3]; int JZero = INTEGER(consts_r)[4]; + int saveFitted = INTEGER(consts_r)[5]; int pp = p * p; int JpRE = J * pRE; // Priors @@ -143,24 +144,34 @@ extern "C" { * *******************************************************************/ SEXP betaSamples_r; PROTECT(betaSamples_r = allocMatrix(REALSXP, p, nPost)); nProtect++; + zeros(REAL(betaSamples_r), p * nPost); SEXP yRepSamples_r; - PROTECT(yRepSamples_r = allocMatrix(REALSXP, J, nPost)); nProtect++; SEXP yRepZeroSamples_r; - PROTECT(yRepZeroSamples_r = allocMatrix(REALSXP, JZero, nPost)); nProtect++; SEXP muSamples_r; - PROTECT(muSamples_r = allocMatrix(REALSXP, J, nPost)); nProtect++; + SEXP likeSamples_r; + if (saveFitted == 1) { + PROTECT(yRepSamples_r = allocMatrix(REALSXP, J, nPost)); nProtect++; + zeros(REAL(yRepSamples_r), J * nPost); + PROTECT(yRepZeroSamples_r = allocMatrix(REALSXP, JZero, nPost)); nProtect++; + zeros(REAL(yRepZeroSamples_r), JZero * nPost); + PROTECT(muSamples_r = allocMatrix(REALSXP, J, nPost)); nProtect++; + zeros(REAL(muSamples_r), J * nPost); + PROTECT(likeSamples_r = allocMatrix(REALSXP, J, nPost)); nProtect++; + zeros(REAL(likeSamples_r), J * nPost); + } // Occurrence random effects SEXP sigmaSqMuSamples_r; SEXP betaStarSamples_r; if (pRE > 0) { PROTECT(sigmaSqMuSamples_r = allocMatrix(REALSXP, pRE, nPost)); nProtect++; + zeros(REAL(sigmaSqMuSamples_r), pRE * nPost); PROTECT(betaStarSamples_r = allocMatrix(REALSXP, nRE, nPost)); nProtect++; + zeros(REAL(betaStarSamples_r), nRE * nPost); } SEXP tauSqSamples_r; PROTECT(tauSqSamples_r = allocMatrix(REALSXP, inc, nPost)); nProtect++; + zeros(REAL(tauSqSamples_r), nPost); // Likelihood samples for WAIC. - SEXP likeSamples_r; - PROTECT(likeSamples_r = allocMatrix(REALSXP, J, nPost)); nProtect++; /********************************************************************** * Other initial starting stuff @@ -324,18 +335,21 @@ extern "C" { /******************************************************************** *Get fitted values and likelihood for WAIC *******************************************************************/ + if (saveFitted == 1) { for (j = 0; j < J; j++) { mu[j] = F77_NAME(ddot)(&p, &X[j], &J, beta, &inc) + betaStarSites[j]; yRep[j] = rnorm(mu[j], sqrt(tauSq)); like[j] = dnorm(y[j], mu[j], sqrt(tauSq), 0); } // j + } /******************************************************************** *Get fitted values and likelihood for WAIC for the zero values *******************************************************************/ - for (j = 0; j < JZero; j++) { - yRepZero[j] = rnorm(0.0, sqrt(0.0001)); - } // j - + if (saveFitted == 1) { + for (j = 0; j < JZero; j++) { + yRepZero[j] = rnorm(0.0, sqrt(0.0001)); + } // j + } /******************************************************************** *Save samples *******************************************************************/ @@ -343,18 +357,20 @@ extern "C" { 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); REAL(tauSqSamples_r)[sPost] = tauSq; - 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 (saveFitted == 1) { + F77_NAME(dcopy)(&J, yRep, &inc, &REAL(yRepSamples_r)[sPost*J], &inc); + F77_NAME(dcopy)(&J, mu, &inc, &REAL(muSamples_r)[sPost*J], &inc); + F77_NAME(dcopy)(&JZero, yRepZero, &inc, &REAL(yRepZeroSamples_r)[sPost*JZero], &inc); + F77_NAME(dcopy)(&J, like, &inc, + &REAL(likeSamples_r)[sPost*J], &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); } - F77_NAME(dcopy)(&J, like, &inc, - &REAL(likeSamples_r)[sPost*J], &inc); sPost++; thinIndx = 0; } @@ -399,10 +415,12 @@ extern "C" { // 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, likeSamples_r); - SET_VECTOR_ELT(result_r, 5, yRepZeroSamples_r); + if (saveFitted == 1) { + SET_VECTOR_ELT(result_r, 2, yRepSamples_r); + SET_VECTOR_ELT(result_r, 3, muSamples_r); + SET_VECTOR_ELT(result_r, 4, likeSamples_r); + SET_VECTOR_ELT(result_r, 5, yRepZeroSamples_r); + } if (pRE > 0) { SET_VECTOR_ELT(result_r, 6, sigmaSqMuSamples_r); SET_VECTOR_ELT(result_r, 7, betaStarSamples_r); @@ -411,10 +429,12 @@ extern "C" { // mkChar turns a C string into a CHARSXP SET_VECTOR_ELT(resultName_r, 0, mkChar("beta.samples")); SET_VECTOR_ELT(resultName_r, 1, mkChar("tau.sq.samples")); - SET_VECTOR_ELT(resultName_r, 2, mkChar("y.rep.samples")); - SET_VECTOR_ELT(resultName_r, 3, mkChar("mu.samples")); - SET_VECTOR_ELT(resultName_r, 4, mkChar("like.samples")); - SET_VECTOR_ELT(resultName_r, 5, mkChar("y.rep.zero.samples")); + if (saveFitted == 1) { + SET_VECTOR_ELT(resultName_r, 2, mkChar("y.rep.samples")); + SET_VECTOR_ELT(resultName_r, 3, mkChar("mu.samples")); + SET_VECTOR_ELT(resultName_r, 4, mkChar("like.samples")); + SET_VECTOR_ELT(resultName_r, 5, mkChar("y.rep.zero.samples")); + } if (pRE > 0) { SET_VECTOR_ELT(resultName_r, 6, mkChar("sigma.sq.mu.samples")); SET_VECTOR_ELT(resultName_r, 7, mkChar("beta.star.samples")); diff --git a/src/lfMsAbund.cpp b/src/lfMsAbund.cpp index 07bcc94..ce5df00 100644 --- a/src/lfMsAbund.cpp +++ b/src/lfMsAbund.cpp @@ -58,6 +58,7 @@ extern "C" { int pAbundRE = INTEGER(consts_r)[4]; int nAbundRE = INTEGER(consts_r)[5]; int q = INTEGER(consts_r)[6]; + int saveFitted = INTEGER(consts_r)[7]; int ppAbund = pAbund * pAbund; double *muBetaComm = REAL(muBetaComm_r); double *SigmaBetaCommInv = (double *) R_alloc(ppAbund, sizeof(double)); @@ -188,35 +189,47 @@ extern "C" { // Community level SEXP betaCommSamples_r; PROTECT(betaCommSamples_r = allocMatrix(REALSXP, pAbund, nPost)); nProtect++; + zeros(REAL(betaCommSamples_r), pAbund * nPost); SEXP tauSqBetaSamples_r; PROTECT(tauSqBetaSamples_r = allocMatrix(REALSXP, pAbund, nPost)); nProtect++; + zeros(REAL(tauSqBetaSamples_r), pAbund * nPost); // Species level SEXP betaSamples_r; PROTECT(betaSamples_r = allocMatrix(REALSXP, pAbundnSp, nPost)); nProtect++; + zeros(REAL(betaSamples_r), pAbundnSp * nPost); SEXP yRepSamples_r; - PROTECT(yRepSamples_r = allocMatrix(REALSXP, nObsnSp, nPost)); nProtect++; SEXP muSamples_r; - PROTECT(muSamples_r = allocMatrix(REALSXP, nObsnSp, nPost)); nProtect++; + SEXP likeSamples_r; + if (saveFitted == 1) { + PROTECT(yRepSamples_r = allocMatrix(REALSXP, nObsnSp, nPost)); nProtect++; + zeros(REAL(yRepSamples_r), nObsnSp * nPost); + PROTECT(muSamples_r = allocMatrix(REALSXP, nObsnSp, nPost)); nProtect++; + zeros(REAL(muSamples_r), nObsnSp * nPost); + PROTECT(likeSamples_r = allocMatrix(REALSXP, nObsnSp, nPost)); nProtect++; + zeros(REAL(likeSamples_r), nObsnSp * nPost); + } // Spatial parameters SEXP lambdaSamples_r; PROTECT(lambdaSamples_r = allocMatrix(REALSXP, nSpq, nPost)); nProtect++; + zeros(REAL(lambdaSamples_r), nSpq * nPost); SEXP wSamples_r; PROTECT(wSamples_r = allocMatrix(REALSXP, Jq, nPost)); nProtect++; + zeros(REAL(wSamples_r), Jq * nPost); // Abundance random effects SEXP sigmaSqMuSamples_r; SEXP betaStarSamples_r; if (pAbundRE > 0) { PROTECT(sigmaSqMuSamples_r = allocMatrix(REALSXP, pAbundRE, nPost)); nProtect++; + zeros(REAL(sigmaSqMuSamples_r), pAbundRE * nPost); PROTECT(betaStarSamples_r = allocMatrix(REALSXP, nAbundREnSp, nPost)); nProtect++; + zeros(REAL(betaStarSamples_r), nAbundREnSp * nPost); } // Overdispersion SEXP kappaSamples_r; if (family == 1) { PROTECT(kappaSamples_r = allocMatrix(REALSXP, nSp, nPost)); nProtect++; + zeros(REAL(kappaSamples_r), nSp * nPost); } - // Likelihood samples for WAIC. - SEXP likeSamples_r; - PROTECT(likeSamples_r = allocMatrix(REALSXP, nObsnSp, nPost)); nProtect++; /********************************************************************** * Additional Sampler Prep @@ -319,8 +332,10 @@ extern "C" { double *accept = (double *) R_alloc(nAMCMC, sizeof(double)); zeros(accept, nAMCMC); SEXP acceptSamples_r; PROTECT(acceptSamples_r = allocMatrix(REALSXP, nAMCMC, nBatch)); nProtect++; + zeros(REAL(acceptSamples_r), nAMCMC * nBatch); SEXP tuningSamples_r; PROTECT(tuningSamples_r = allocMatrix(REALSXP, nAMCMC, nBatch)); nProtect++; + zeros(REAL(tuningSamples_r), nAMCMC * nBatch); // Set the initial candidate values for everything to the inital values. double *betaCand = (double *) R_alloc(pAbund * nSp, sizeof(double)); // beta is sorted by parameter, then species within parameter. @@ -666,18 +681,20 @@ extern "C" { /******************************************************************** *Get fitted values *******************************************************************/ - for (r = 0; r < nObs; r++) { - // Only calculate mu if Poisson since it's already calculated in kappa update - if (family == 0) { - mu[r * nSp + i] = exp(F77_NAME(ddot)(&pAbund, &X[r], &nObs, &beta[i], &nSp) + - betaStarSites[i * nObs + r] + wStar[siteIndx[r] * nSp + i]); - yRep[r * nSp + i] = rpois(mu[r * nSp + i] * offset[r]); - like[r * nSp + i] = dpois(y[r * nSp + i], mu[r * nSp + i] * offset[r], 0); - } else { - yRep[r * nSp + i] = rnbinom_mu(kappa[i], mu[r * nSp + i] * offset[r]); - like[r * nSp + i] = dnbinom_mu(y[r * nSp + i], kappa[i], mu[r * nSp + i] * offset[r], 0); - } - } + if (saveFitted == 1) { + for (r = 0; r < nObs; r++) { + // Only calculate mu if Poisson since it's already calculated in kappa update + if (family == 0) { + mu[r * nSp + i] = exp(F77_NAME(ddot)(&pAbund, &X[r], &nObs, &beta[i], &nSp) + + betaStarSites[i * nObs + r] + wStar[siteIndx[r] * nSp + i]); + yRep[r * nSp + i] = rpois(mu[r * nSp + i] * offset[r]); + like[r * nSp + i] = dpois(y[r * nSp + i], mu[r * nSp + i] * offset[r], 0); + } else { + yRep[r * nSp + i] = rnbinom_mu(kappa[i], mu[r * nSp + i] * offset[r]); + like[r * nSp + i] = dnbinom_mu(y[r * nSp + i], kappa[i], mu[r * nSp + i] * offset[r], 0); + } + } + } } // i (species) /******************************************************************** @@ -692,11 +709,13 @@ extern "C" { if (family == 1) { F77_NAME(dcopy)(&nSp, kappa, &inc, &REAL(kappaSamples_r)[sPost*nSp], &inc); } - F77_NAME(dcopy)(&nObsnSp, yRep, &inc, &REAL(yRepSamples_r)[sPost*nObsnSp], &inc); - F77_NAME(dcopy)(&nObsnSp, mu, &inc, &REAL(muSamples_r)[sPost*nObsnSp], &inc); + if (saveFitted == 1) { + F77_NAME(dcopy)(&nObsnSp, yRep, &inc, &REAL(yRepSamples_r)[sPost*nObsnSp], &inc); + F77_NAME(dcopy)(&nObsnSp, mu, &inc, &REAL(muSamples_r)[sPost*nObsnSp], &inc); + F77_NAME(dcopy)(&nObsnSp, like, &inc, &REAL(likeSamples_r)[sPost*nObsnSp], &inc); + } F77_NAME(dcopy)(&Jq, w, &inc, &REAL(wSamples_r)[sPost*Jq], &inc); F77_NAME(dcopy)(&nSpq, lambda, &inc, &REAL(lambdaSamples_r)[sPost*nSpq], &inc); - F77_NAME(dcopy)(&nObsnSp, like, &inc, &REAL(likeSamples_r)[sPost*nObsnSp], &inc); if (pAbundRE > 0) { F77_NAME(dcopy)(&pAbundRE, sigmaSqMu, &inc, &REAL(sigmaSqMuSamples_r)[sPost*pAbundRE], &inc); F77_NAME(dcopy)(&nAbundREnSp, betaStar, &inc, &REAL(betaStarSamples_r)[sPost*nAbundREnSp], &inc); @@ -765,13 +784,15 @@ extern "C" { SET_VECTOR_ELT(result_r, 0, betaCommSamples_r); SET_VECTOR_ELT(result_r, 1, tauSqBetaSamples_r); SET_VECTOR_ELT(result_r, 2, betaSamples_r); - SET_VECTOR_ELT(result_r, 3, yRepSamples_r); - SET_VECTOR_ELT(result_r, 4, muSamples_r); + if (saveFitted == 1) { + SET_VECTOR_ELT(result_r, 3, yRepSamples_r); + SET_VECTOR_ELT(result_r, 4, muSamples_r); + SET_VECTOR_ELT(result_r, 9, likeSamples_r); + } SET_VECTOR_ELT(result_r, 5, lambdaSamples_r); SET_VECTOR_ELT(result_r, 6, wSamples_r); SET_VECTOR_ELT(result_r, 7, tuningSamples_r); SET_VECTOR_ELT(result_r, 8, acceptSamples_r); - SET_VECTOR_ELT(result_r, 9, likeSamples_r); if (pAbundRE > 0) { SET_VECTOR_ELT(result_r, 10, sigmaSqMuSamples_r); SET_VECTOR_ELT(result_r, 11, betaStarSamples_r); @@ -788,13 +809,15 @@ extern "C" { SET_VECTOR_ELT(resultName_r, 0, mkChar("beta.comm.samples")); SET_VECTOR_ELT(resultName_r, 1, mkChar("tau.sq.beta.samples")); SET_VECTOR_ELT(resultName_r, 2, mkChar("beta.samples")); - SET_VECTOR_ELT(resultName_r, 3, mkChar("y.rep.samples")); - SET_VECTOR_ELT(resultName_r, 4, mkChar("mu.samples")); + if (saveFitted == 1) { + SET_VECTOR_ELT(resultName_r, 3, mkChar("y.rep.samples")); + SET_VECTOR_ELT(resultName_r, 4, mkChar("mu.samples")); + SET_VECTOR_ELT(resultName_r, 9, mkChar("like.samples")); + } SET_VECTOR_ELT(resultName_r, 5, mkChar("lambda.samples")); SET_VECTOR_ELT(resultName_r, 6, mkChar("w.samples")); SET_VECTOR_ELT(resultName_r, 7, mkChar("tune")); SET_VECTOR_ELT(resultName_r, 8, mkChar("accept")); - SET_VECTOR_ELT(resultName_r, 9, mkChar("like.samples")); if (pAbundRE > 0) { SET_VECTOR_ELT(resultName_r, 10, mkChar("sigma.sq.mu.samples")); SET_VECTOR_ELT(resultName_r, 11, mkChar("beta.star.samples")); diff --git a/src/lfMsAbundGaussian.cpp b/src/lfMsAbundGaussian.cpp index 3c41779..7ed1cdc 100644 --- a/src/lfMsAbundGaussian.cpp +++ b/src/lfMsAbundGaussian.cpp @@ -68,6 +68,7 @@ extern "C" { int pRE = INTEGER(consts_r)[3]; int nRE = INTEGER(consts_r)[4]; int q = INTEGER(consts_r)[5]; + int saveFitted = INTEGER(consts_r)[6]; int pp = p * p; double *muBetaComm = REAL(muBetaComm_r); double *SigmaBetaCommInv = (double *) R_alloc(pp, sizeof(double)); @@ -209,31 +210,43 @@ extern "C" { // Community level SEXP betaCommSamples_r; PROTECT(betaCommSamples_r = allocMatrix(REALSXP, p, nPost)); nProtect++; + zeros(REAL(betaCommSamples_r), p * nPost); SEXP tauSqBetaSamples_r; PROTECT(tauSqBetaSamples_r = allocMatrix(REALSXP, p, nPost)); nProtect++; + zeros(REAL(tauSqBetaSamples_r), p * nPost); // Species level SEXP betaSamples_r; PROTECT(betaSamples_r = allocMatrix(REALSXP, pN, nPost)); nProtect++; + zeros(REAL(betaSamples_r), pN * nPost); SEXP tauSqSamples_r; PROTECT(tauSqSamples_r = allocMatrix(REALSXP, N, nPost)); nProtect++; + zeros(REAL(tauSqSamples_r), N * nPost); SEXP yRepSamples_r; - PROTECT(yRepSamples_r = allocMatrix(REALSXP, JN, nPost)); nProtect++; SEXP muSamples_r; - PROTECT(muSamples_r = allocMatrix(REALSXP, JN, nPost)); nProtect++; + SEXP likeSamples_r; + if (saveFitted == 1) { + PROTECT(yRepSamples_r = allocMatrix(REALSXP, JN, nPost)); nProtect++; + zeros(REAL(yRepSamples_r), JN * nPost); + PROTECT(muSamples_r = allocMatrix(REALSXP, JN, nPost)); nProtect++; + zeros(REAL(muSamples_r), JN * nPost); + PROTECT(likeSamples_r = allocMatrix(REALSXP, JN, nPost)); nProtect++; + zeros(REAL(likeSamples_r), JN * nPost); + } SEXP lambdaSamples_r; PROTECT(lambdaSamples_r = allocMatrix(REALSXP, Nq, nPost)); nProtect++; + zeros(REAL(lambdaSamples_r), Nq * nPost); SEXP wSamples_r; PROTECT(wSamples_r = allocMatrix(REALSXP, Jq, nPost)); nProtect++; + zeros(REAL(wSamples_r), Jq * nPost); // Random effects SEXP sigmaSqMuSamples_r; SEXP betaStarSamples_r; if (pRE > 0) { PROTECT(sigmaSqMuSamples_r = allocMatrix(REALSXP, pRE, nPost)); nProtect++; + zeros(REAL(sigmaSqMuSamples_r), pRE * nPost); PROTECT(betaStarSamples_r = allocMatrix(REALSXP, nREN, nPost)); nProtect++; + zeros(REAL(betaStarSamples_r), nREN * nPost); } - // Likelihood samples for WAIC. - SEXP likeSamples_r; - PROTECT(likeSamples_r = allocMatrix(REALSXP, JN, nPost)); nProtect++; /********************************************************************** * Additional Sampler Prep @@ -620,21 +633,22 @@ extern "C" { /******************************************************************** *Get fitted values and likelihood for WAIC *******************************************************************/ - for (i = 0; i < N; i++) { - for (j = 0; j < J; j++) { - if (z[j * N + i] == 1.0) { - mu[j * N + i] = F77_NAME(ddot)(&p, &X[j], &J, &beta[i], &N) + betaStarSites[i * J + j] + - wStar[j * N + i]; - yRep[j * N + i] = rnorm(mu[j * N + i], sqrt(tauSq[i])); - like[j * N + i] = dnorm(y[j * N + i], mu[j * N + i], sqrt(tauSq[i]), 0); - } else { - mu[j * N + i] = 0.0; - yRep[j * N + i] = rnorm(mu[j * N + i], sqrt(0.0001)); - like[j * N + i] = 1.0; - } - } // j - } // i - + if (saveFitted == 1) { + for (i = 0; i < N; i++) { + for (j = 0; j < J; j++) { + if (z[j * N + i] == 1.0) { + mu[j * N + i] = F77_NAME(ddot)(&p, &X[j], &J, &beta[i], &N) + betaStarSites[i * J + j] + + wStar[j * N + i]; + yRep[j * N + i] = rnorm(mu[j * N + i], sqrt(tauSq[i])); + like[j * N + i] = dnorm(y[j * N + i], mu[j * N + i], sqrt(tauSq[i]), 0); + } else { + mu[j * N + i] = 0.0; + yRep[j * N + i] = rnorm(mu[j * N + i], sqrt(0.0001)); + like[j * N + i] = 1.0; + } + } // j + } // i + } /******************************************************************** *Save samples *******************************************************************/ @@ -647,13 +661,15 @@ extern "C" { F77_NAME(dcopy)(&pN, beta, &inc, &REAL(betaSamples_r)[sPost*pN], &inc); F77_NAME(dcopy)(&Nq, lambda, &inc, &REAL(lambdaSamples_r)[sPost*Nq], &inc); F77_NAME(dcopy)(&Jq, w, &inc, &REAL(wSamples_r)[sPost*Jq], &inc); - F77_NAME(dcopy)(&JN, mu, &inc, &REAL(muSamples_r)[sPost*JN], &inc); - F77_NAME(dcopy)(&JN, yRep, &inc, &REAL(yRepSamples_r)[sPost*JN], &inc); + if (saveFitted == 1) { + F77_NAME(dcopy)(&JN, mu, &inc, &REAL(muSamples_r)[sPost*JN], &inc); + F77_NAME(dcopy)(&JN, yRep, &inc, &REAL(yRepSamples_r)[sPost*JN], &inc); + F77_NAME(dcopy)(&JN, like, &inc, &REAL(likeSamples_r)[sPost*JN], &inc); + } if (pRE > 0) { F77_NAME(dcopy)(&pRE, sigmaSqMu, &inc, &REAL(sigmaSqMuSamples_r)[sPost*pRE], &inc); F77_NAME(dcopy)(&nREN, betaStar, &inc, &REAL(betaStarSamples_r)[sPost*nREN], &inc); } - F77_NAME(dcopy)(&JN, like, &inc, &REAL(likeSamples_r)[sPost*JN], &inc); sPost++; thinIndx = 0; } @@ -698,10 +714,12 @@ extern "C" { SET_VECTOR_ELT(result_r, 0, betaCommSamples_r); SET_VECTOR_ELT(result_r, 1, tauSqBetaSamples_r); SET_VECTOR_ELT(result_r, 2, betaSamples_r); - SET_VECTOR_ELT(result_r, 3, yRepSamples_r); - SET_VECTOR_ELT(result_r, 4, muSamples_r); + if (saveFitted == 1) { + SET_VECTOR_ELT(result_r, 3, yRepSamples_r); + SET_VECTOR_ELT(result_r, 6, likeSamples_r); + SET_VECTOR_ELT(result_r, 4, muSamples_r); + } SET_VECTOR_ELT(result_r, 5, tauSqSamples_r); - SET_VECTOR_ELT(result_r, 6, likeSamples_r); SET_VECTOR_ELT(result_r, 7, lambdaSamples_r); SET_VECTOR_ELT(result_r, 8, wSamples_r); if (pRE > 0) { @@ -713,10 +731,12 @@ extern "C" { SET_VECTOR_ELT(resultName_r, 0, mkChar("beta.comm.samples")); SET_VECTOR_ELT(resultName_r, 1, mkChar("tau.sq.beta.samples")); SET_VECTOR_ELT(resultName_r, 2, mkChar("beta.samples")); - SET_VECTOR_ELT(resultName_r, 3, mkChar("y.rep.samples")); - SET_VECTOR_ELT(resultName_r, 4, mkChar("mu.samples")); + if (saveFitted == 1) { + SET_VECTOR_ELT(resultName_r, 3, mkChar("y.rep.samples")); + SET_VECTOR_ELT(resultName_r, 4, mkChar("mu.samples")); + SET_VECTOR_ELT(resultName_r, 6, mkChar("like.samples")); + } SET_VECTOR_ELT(resultName_r, 5, mkChar("tau.sq.samples")); - SET_VECTOR_ELT(resultName_r, 6, mkChar("like.samples")); SET_VECTOR_ELT(resultName_r, 7, mkChar("lambda.samples")); SET_VECTOR_ELT(resultName_r, 8, mkChar("w.samples")); if (pRE > 0) { diff --git a/src/lfMsDS.cpp b/src/lfMsDS.cpp index 1ef3065..a92cfb9 100755 --- a/src/lfMsDS.cpp +++ b/src/lfMsDS.cpp @@ -243,48 +243,65 @@ extern "C" { // Community level SEXP betaCommSamples_r; PROTECT(betaCommSamples_r = allocMatrix(REALSXP, pAbund, nPost)); nProtect++; + zeros(REAL(betaCommSamples_r), pAbund * nPost); SEXP alphaCommSamples_r; PROTECT(alphaCommSamples_r = allocMatrix(REALSXP, pDet, nPost)); nProtect++; + zeros(REAL(alphaCommSamples_r), pDet * nPost); SEXP tauSqBetaSamples_r; PROTECT(tauSqBetaSamples_r = allocMatrix(REALSXP, pAbund, nPost)); nProtect++; + zeros(REAL(tauSqBetaSamples_r), pAbund * nPost); SEXP tauSqAlphaSamples_r; PROTECT(tauSqAlphaSamples_r = allocMatrix(REALSXP, pDet, nPost)); nProtect++; + zeros(REAL(tauSqAlphaSamples_r), pDet * nPost); // Species level SEXP betaSamples_r; PROTECT(betaSamples_r = allocMatrix(REALSXP, pAbundnSp, nPost)); nProtect++; + zeros(REAL(betaSamples_r), pAbundnSp * nPost); SEXP alphaSamples_r; PROTECT(alphaSamples_r = allocMatrix(REALSXP, pDetnSp, nPost)); nProtect++; + zeros(REAL(alphaSamples_r), pDetnSp * nPost); SEXP NSamples_r; PROTECT(NSamples_r = allocMatrix(REALSXP, JnSp, nPost)); nProtect++; + zeros(REAL(NSamples_r), JnSp * nPost); SEXP muSamples_r; PROTECT(muSamples_r = allocMatrix(REALSXP, JnSp, nPost)); nProtect++; + zeros(REAL(muSamples_r), JnSp * nPost); // Latent factor parameters SEXP lambdaSamples_r; PROTECT(lambdaSamples_r = allocMatrix(REALSXP, nSpq, nPost)); nProtect++; + zeros(REAL(lambdaSamples_r), nSpq * nPost); SEXP wSamples_r; PROTECT(wSamples_r = allocMatrix(REALSXP, Jq, nPost)); nProtect++; + zeros(REAL(wSamples_r), Jq * nPost); // Detection random effects SEXP sigmaSqPSamples_r; SEXP alphaStarSamples_r; if (pDetRE > 0) { PROTECT(sigmaSqPSamples_r = allocMatrix(REALSXP, pDetRE, nPost)); nProtect++; + zeros(REAL(sigmaSqPSamples_r), pDetRE * nPost); PROTECT(alphaStarSamples_r = allocMatrix(REALSXP, nDetREnSp, nPost)); nProtect++; + zeros(REAL(alphaStarSamples_r), nDetREnSp * nPost); } // Abundance random effects SEXP sigmaSqMuSamples_r; SEXP betaStarSamples_r; if (pAbundRE > 0) { PROTECT(sigmaSqMuSamples_r = allocMatrix(REALSXP, pAbundRE, nPost)); nProtect++; + zeros(REAL(sigmaSqMuSamples_r), pAbundRE * nPost); PROTECT(betaStarSamples_r = allocMatrix(REALSXP, nAbundREnSp, nPost)); nProtect++; + zeros(REAL(betaStarSamples_r), nAbundREnSp * nPost); } SEXP kappaSamples_r; if (family == 1) { PROTECT(kappaSamples_r = allocMatrix(REALSXP, nSp, nPost)); nProtect++; + zeros(REAL(kappaSamples_r), nSp * nPost); } SEXP yRepSamples_r; PROTECT(yRepSamples_r = allocMatrix(INTSXP, nObsFullnSp, nPost)); nProtect++; + zeros(REAL(yRepSamples_r), nObsFullnSp * nPost); SEXP piFullSamples_r; PROTECT(piFullSamples_r = allocMatrix(REALSXP, nObsFullnSp, nPost)); nProtect++; + zeros(REAL(piFullSamples_r), nObsFullnSp * nPost); /********************************************************************** * Additional Sampler Prep @@ -448,8 +465,10 @@ extern "C" { } SEXP acceptSamples_r; PROTECT(acceptSamples_r = allocMatrix(REALSXP, nAMCMC, nBatch)); nProtect++; + zeros(REAL(acceptSamples_r), nAMCMC * nBatch); SEXP tuningSamples_r; PROTECT(tuningSamples_r = allocMatrix(REALSXP, nAMCMC, nBatch)); nProtect++; + zeros(REAL(tuningSamples_r), nAMCMC * nBatch); /********************************************************************** * Prep for random effects diff --git a/src/lfMsNMix.cpp b/src/lfMsNMix.cpp index b5a11da..51d4200 100644 --- a/src/lfMsNMix.cpp +++ b/src/lfMsNMix.cpp @@ -236,43 +236,58 @@ extern "C" { // Community level SEXP betaCommSamples_r; PROTECT(betaCommSamples_r = allocMatrix(REALSXP, pAbund, nPost)); nProtect++; + zeros(REAL(betaCommSamples_r), pAbund * nPost); SEXP alphaCommSamples_r; PROTECT(alphaCommSamples_r = allocMatrix(REALSXP, pDet, nPost)); nProtect++; + zeros(REAL(alphaCommSamples_r), pDet * nPost); SEXP tauSqBetaSamples_r; PROTECT(tauSqBetaSamples_r = allocMatrix(REALSXP, pAbund, nPost)); nProtect++; + zeros(REAL(tauSqBetaSamples_r), pAbund * nPost); SEXP tauSqAlphaSamples_r; PROTECT(tauSqAlphaSamples_r = allocMatrix(REALSXP, pDet, nPost)); nProtect++; + zeros(REAL(tauSqAlphaSamples_r), pDet * nPost); // Species level SEXP betaSamples_r; PROTECT(betaSamples_r = allocMatrix(REALSXP, pAbundnSp, nPost)); nProtect++; + zeros(REAL(betaSamples_r), pAbundnSp * nPost); SEXP alphaSamples_r; PROTECT(alphaSamples_r = allocMatrix(REALSXP, pDetnSp, nPost)); nProtect++; + zeros(REAL(alphaSamples_r), pDetnSp * nPost); SEXP NSamples_r; PROTECT(NSamples_r = allocMatrix(REALSXP, JnSp, nPost)); nProtect++; + zeros(REAL(NSamples_r), JnSp * nPost); SEXP muSamples_r; PROTECT(muSamples_r = allocMatrix(REALSXP, JnSp, nPost)); nProtect++; + zeros(REAL(muSamples_r), JnSp * nPost); // Latent factor parameters SEXP lambdaSamples_r; PROTECT(lambdaSamples_r = allocMatrix(REALSXP, nSpq, nPost)); nProtect++; + zeros(REAL(lambdaSamples_r), nSpq * nPost); SEXP wSamples_r; PROTECT(wSamples_r = allocMatrix(REALSXP, Jq, nPost)); nProtect++; + zeros(REAL(wSamples_r), Jq * nPost); // Detection random effects SEXP sigmaSqPSamples_r; SEXP alphaStarSamples_r; if (pDetRE > 0) { PROTECT(sigmaSqPSamples_r = allocMatrix(REALSXP, pDetRE, nPost)); nProtect++; + zeros(REAL(sigmaSqPSamples_r), pDetRE * nPost); PROTECT(alphaStarSamples_r = allocMatrix(REALSXP, nDetREnSp, nPost)); nProtect++; + zeros(REAL(alphaStarSamples_r), nDetREnSp * nPost); } // Abundance random effects SEXP sigmaSqMuSamples_r; SEXP betaStarSamples_r; if (pAbundRE > 0) { PROTECT(sigmaSqMuSamples_r = allocMatrix(REALSXP, pAbundRE, nPost)); nProtect++; + zeros(REAL(sigmaSqMuSamples_r), pAbundRE * nPost); PROTECT(betaStarSamples_r = allocMatrix(REALSXP, nAbundREnSp, nPost)); nProtect++; + zeros(REAL(betaStarSamples_r), nAbundREnSp * nPost); } SEXP kappaSamples_r; if (family == 1) { PROTECT(kappaSamples_r = allocMatrix(REALSXP, nSp, nPost)); nProtect++; + zeros(REAL(kappaSamples_r), nSp * nPost); } /********************************************************************** @@ -485,8 +500,10 @@ extern "C" { } SEXP acceptSamples_r; PROTECT(acceptSamples_r = allocMatrix(REALSXP, nAMCMC, nBatch)); nProtect++; + zeros(REAL(acceptSamples_r), nAMCMC * nBatch); SEXP tuningSamples_r; PROTECT(tuningSamples_r = allocMatrix(REALSXP, nAMCMC, nBatch)); nProtect++; + zeros(REAL(tuningSamples_r), nAMCMC * nBatch); GetRNGstate(); diff --git a/src/msAbund.cpp b/src/msAbund.cpp index 9f91d06..25e100a 100644 --- a/src/msAbund.cpp +++ b/src/msAbund.cpp @@ -176,11 +176,14 @@ extern "C" { // Community level SEXP betaCommSamples_r; PROTECT(betaCommSamples_r = allocMatrix(REALSXP, pAbund, nPost)); nProtect++; + zeros(REAL(betaCommSamples_r), pAbund * nPost); SEXP tauSqBetaSamples_r; PROTECT(tauSqBetaSamples_r = allocMatrix(REALSXP, pAbund, nPost)); nProtect++; + zeros(REAL(tauSqBetaSamples_r), pAbund * nPost); // Species level SEXP betaSamples_r; PROTECT(betaSamples_r = allocMatrix(REALSXP, pAbundnSp, nPost)); nProtect++; + zeros(REAL(betaSamples_r), pAbundnSp * nPost); SEXP yRepSamples_r; SEXP muSamples_r; SEXP likeSamples_r; @@ -197,14 +200,16 @@ extern "C" { SEXP betaStarSamples_r; if (pAbundRE > 0) { PROTECT(sigmaSqMuSamples_r = allocMatrix(REALSXP, pAbundRE, nPost)); nProtect++; + zeros(REAL(sigmaSqMuSamples_r), pAbundRE * nPost); PROTECT(betaStarSamples_r = allocMatrix(REALSXP, nAbundREnSp, nPost)); nProtect++; + zeros(REAL(betaStarSamples_r), nAbundREnSp * nPost); } // Overdispersion SEXP kappaSamples_r; if (family == 1) { PROTECT(kappaSamples_r = allocMatrix(REALSXP, nSp, nPost)); nProtect++; + zeros(REAL(kappaSamples_r), nSp * nPost); } - // Likelihood samples for WAIC. /********************************************************************** * Additional Sampler Prep @@ -295,8 +300,10 @@ extern "C" { kappaCand = kappa[0]; SEXP acceptSamples_r; PROTECT(acceptSamples_r = allocMatrix(REALSXP, nAMCMC, nBatch)); nProtect++; + zeros(REAL(acceptSamples_r), nAMCMC * nBatch); SEXP tuningSamples_r; PROTECT(tuningSamples_r = allocMatrix(REALSXP, nAMCMC, nBatch)); nProtect++; + zeros(REAL(tuningSamples_r), nAMCMC * nBatch); GetRNGstate(); diff --git a/src/msAbundGaussian.cpp b/src/msAbundGaussian.cpp index 8fd19ce..9ff545d 100644 --- a/src/msAbundGaussian.cpp +++ b/src/msAbundGaussian.cpp @@ -66,6 +66,7 @@ extern "C" { int p = INTEGER(consts_r)[2]; int pRE = INTEGER(consts_r)[3]; int nRE = INTEGER(consts_r)[4]; + int saveFitted = INTEGER(consts_r)[5]; int pp = p * p; double *muBetaComm = REAL(muBetaComm_r); double *SigmaBetaCommInv = (double *) R_alloc(pp, sizeof(double)); @@ -190,27 +191,38 @@ extern "C" { // Community level SEXP betaCommSamples_r; PROTECT(betaCommSamples_r = allocMatrix(REALSXP, p, nPost)); nProtect++; + zeros(REAL(betaCommSamples_r), p * nPost); SEXP tauSqBetaSamples_r; PROTECT(tauSqBetaSamples_r = allocMatrix(REALSXP, p, nPost)); nProtect++; + zeros(REAL(tauSqBetaSamples_r), p * nPost); // Species level SEXP betaSamples_r; PROTECT(betaSamples_r = allocMatrix(REALSXP, pN, nPost)); nProtect++; + zeros(REAL(betaSamples_r), pN * nPost); SEXP tauSqSamples_r; PROTECT(tauSqSamples_r = allocMatrix(REALSXP, N, nPost)); nProtect++; + zeros(REAL(tauSqSamples_r), N * nPost); SEXP yRepSamples_r; - PROTECT(yRepSamples_r = allocMatrix(REALSXP, JN, nPost)); nProtect++; SEXP muSamples_r; - PROTECT(muSamples_r = allocMatrix(REALSXP, JN, nPost)); nProtect++; + SEXP likeSamples_r; + if (saveFitted == 1) { + PROTECT(yRepSamples_r = allocMatrix(REALSXP, JN, nPost)); nProtect++; + zeros(REAL(yRepSamples_r), JN * nPost); + PROTECT(muSamples_r = allocMatrix(REALSXP, JN, nPost)); nProtect++; + zeros(REAL(muSamples_r), JN * nPost); + PROTECT(likeSamples_r = allocMatrix(REALSXP, JN, nPost)); nProtect++; + zeros(REAL(likeSamples_r), JN * nPost); + } // Random effects SEXP sigmaSqMuSamples_r; SEXP betaStarSamples_r; if (pRE > 0) { PROTECT(sigmaSqMuSamples_r = allocMatrix(REALSXP, pRE, nPost)); nProtect++; + zeros(REAL(sigmaSqMuSamples_r), pRE * nPost); PROTECT(betaStarSamples_r = allocMatrix(REALSXP, nREN, nPost)); nProtect++; + zeros(REAL(betaStarSamples_r), nREN * nPost); } // Likelihood samples for WAIC. - SEXP likeSamples_r; - PROTECT(likeSamples_r = allocMatrix(REALSXP, JN, nPost)); nProtect++; /********************************************************************** * Additional Sampler Prep @@ -452,19 +464,21 @@ extern "C" { /******************************************************************** *Get fitted values and likelihood for WAIC *******************************************************************/ - for (i = 0; i < N; i++) { - for (j = 0; j < J; j++) { - if (z[j * N + i] == 1.0) { - mu[j * N + i] = F77_NAME(ddot)(&p, &X[j], &J, &beta[i], &N) + betaStarSites[i * J + j]; - yRep[j * N + i] = rnorm(mu[j * N + i], sqrt(tauSq[i])); - like[j * N + i] = dnorm(y[j * N + i], mu[j * N + i], sqrt(tauSq[i]), 0); - } else { - mu[j * N + i] = 0.0; - yRep[j * N + i] = rnorm(mu[j * N + i], sqrt(0.0001)); - like[j * N + i] = 1.0; - } - } // j - } // i + if (saveFitted == 1) { + for (i = 0; i < N; i++) { + for (j = 0; j < J; j++) { + if (z[j * N + i] == 1.0) { + mu[j * N + i] = F77_NAME(ddot)(&p, &X[j], &J, &beta[i], &N) + betaStarSites[i * J + j]; + yRep[j * N + i] = rnorm(mu[j * N + i], sqrt(tauSq[i])); + like[j * N + i] = dnorm(y[j * N + i], mu[j * N + i], sqrt(tauSq[i]), 0); + } else { + mu[j * N + i] = 0.0; + yRep[j * N + i] = rnorm(mu[j * N + i], sqrt(0.0001)); + like[j * N + i] = 1.0; + } + } // j + } // i + } /******************************************************************** *Save samples @@ -476,13 +490,15 @@ extern "C" { F77_NAME(dcopy)(&p, tauSqBeta, &inc, &REAL(tauSqBetaSamples_r)[sPost*p], &inc); F77_NAME(dcopy)(&N, tauSq, &inc, &REAL(tauSqSamples_r)[sPost*N], &inc); F77_NAME(dcopy)(&pN, beta, &inc, &REAL(betaSamples_r)[sPost*pN], &inc); - F77_NAME(dcopy)(&JN, mu, &inc, &REAL(muSamples_r)[sPost*JN], &inc); - F77_NAME(dcopy)(&JN, yRep, &inc, &REAL(yRepSamples_r)[sPost*JN], &inc); + if (saveFitted == 1) { + F77_NAME(dcopy)(&JN, mu, &inc, &REAL(muSamples_r)[sPost*JN], &inc); + F77_NAME(dcopy)(&JN, yRep, &inc, &REAL(yRepSamples_r)[sPost*JN], &inc); + F77_NAME(dcopy)(&JN, like, &inc, &REAL(likeSamples_r)[sPost*JN], &inc); + } if (pRE > 0) { F77_NAME(dcopy)(&pRE, sigmaSqMu, &inc, &REAL(sigmaSqMuSamples_r)[sPost*pRE], &inc); F77_NAME(dcopy)(&nREN, betaStar, &inc, &REAL(betaStarSamples_r)[sPost*nREN], &inc); } - F77_NAME(dcopy)(&JN, like, &inc, &REAL(likeSamples_r)[sPost*JN], &inc); sPost++; thinIndx = 0; } @@ -527,10 +543,12 @@ extern "C" { SET_VECTOR_ELT(result_r, 0, betaCommSamples_r); SET_VECTOR_ELT(result_r, 1, tauSqBetaSamples_r); SET_VECTOR_ELT(result_r, 2, betaSamples_r); - SET_VECTOR_ELT(result_r, 3, yRepSamples_r); - SET_VECTOR_ELT(result_r, 4, muSamples_r); + if (saveFitted == 1) { + SET_VECTOR_ELT(result_r, 3, yRepSamples_r); + SET_VECTOR_ELT(result_r, 4, muSamples_r); + SET_VECTOR_ELT(result_r, 6, likeSamples_r); + } SET_VECTOR_ELT(result_r, 5, tauSqSamples_r); - SET_VECTOR_ELT(result_r, 6, likeSamples_r); if (pRE > 0) { SET_VECTOR_ELT(result_r, 7, sigmaSqMuSamples_r); SET_VECTOR_ELT(result_r, 8, betaStarSamples_r); @@ -540,10 +558,12 @@ extern "C" { SET_VECTOR_ELT(resultName_r, 0, mkChar("beta.comm.samples")); SET_VECTOR_ELT(resultName_r, 1, mkChar("tau.sq.beta.samples")); SET_VECTOR_ELT(resultName_r, 2, mkChar("beta.samples")); - SET_VECTOR_ELT(resultName_r, 3, mkChar("y.rep.samples")); - SET_VECTOR_ELT(resultName_r, 4, mkChar("mu.samples")); + if (saveFitted == 1) { + SET_VECTOR_ELT(resultName_r, 3, mkChar("y.rep.samples")); + SET_VECTOR_ELT(resultName_r, 4, mkChar("mu.samples")); + SET_VECTOR_ELT(resultName_r, 6, mkChar("like.samples")); + } SET_VECTOR_ELT(resultName_r, 5, mkChar("tau.sq.samples")); - SET_VECTOR_ELT(resultName_r, 6, mkChar("like.samples")); if (pRE > 0) { SET_VECTOR_ELT(resultName_r, 7, mkChar("sigma.sq.mu.samples")); SET_VECTOR_ELT(resultName_r, 8, mkChar("beta.star.samples")); diff --git a/src/msDS.cpp b/src/msDS.cpp index 62d6e85..c818875 100755 --- a/src/msDS.cpp +++ b/src/msDS.cpp @@ -48,7 +48,6 @@ extern "C" { const double one = 1.0; const double zero = 0.0; char const *lower = "L"; - char const *ntran = "N"; char const *ytran = "T"; /********************************************************************** @@ -94,7 +93,6 @@ extern "C" { int *nAbundRELong = INTEGER(nAbundRELong_r); int *nDetRELong = INTEGER(nDetRELong_r); int K = INTEGER(K_r)[0]; - int *NLongIndx = INTEGER(NLongIndx_r); int *alphaStarIndx = INTEGER(alphaStarIndx_r); int *alphaLevelIndx = INTEGER(alphaLevelIndx_r); int *betaStarIndx = INTEGER(betaStarIndx_r); @@ -170,36 +168,26 @@ extern "C" { ********************************************************************/ int pAbundnSp = pAbund * nSp; int pDetnSp = pDet * nSp; - int nObsnSp = nObs * nSp; int nAbundREnSp = nAbundRE * nSp; int nDetREnSp = nDetRE * nSp; int JnSp = J * nSp; - int JpAbund = J * pAbund; int JpAbundRE = J * pAbundRE; int JpDetRE = J * pDetRE; - int nObspDet = nObs * pDet; - int nObspDetRE = nObs * pDetRE; int KFull = K + 1; int nObsFull = KFull * J; int nObsFullnSp = nObsFull * nSp; double tmp_0, tmp_02; - double *tmp_one = (double *) R_alloc(inc, sizeof(double)); double *tmp_ppDet = (double *) R_alloc(ppDet, sizeof(double)); double *tmp_ppAbund = (double *) R_alloc(ppAbund, sizeof(double)); double *tmp_pDet = (double *) R_alloc(pDet, sizeof(double)); double *tmp_pAbund = (double *) R_alloc(pAbund, sizeof(double)); double *tmp_pDet2 = (double *) R_alloc(pDet, sizeof(double)); double *tmp_pAbund2 = (double *) R_alloc(pAbund, sizeof(double)); - double *tmp_nObs = (double *) R_alloc(nObs, sizeof(double)); - double *tmp_JpAbund = (double *) R_alloc(JpAbund, sizeof(double)); - double *tmp_nObspDet = (double *) R_alloc(nObspDet, sizeof(double)); double *tmp_J = (double *) R_alloc(J, sizeof(double)); - double *tmp_J1 = (double *) R_alloc(J, sizeof(double)); double *tmp_KFull = (double *) R_alloc(KFull, sizeof(double)); int *tmp_KFullInt = (int *) R_alloc(KFull, sizeof(int)); // For latent abundance - double muNum; double *mu = (double *) R_alloc(JnSp, sizeof(double)); zeros(mu, JnSp); @@ -243,43 +231,58 @@ extern "C" { // Community level SEXP betaCommSamples_r; PROTECT(betaCommSamples_r = allocMatrix(REALSXP, pAbund, nPost)); nProtect++; + zeros(REAL(betaCommSamples_r), pAbund * nPost); SEXP alphaCommSamples_r; PROTECT(alphaCommSamples_r = allocMatrix(REALSXP, pDet, nPost)); nProtect++; + zeros(REAL(alphaCommSamples_r), pDet * nPost); SEXP tauSqBetaSamples_r; PROTECT(tauSqBetaSamples_r = allocMatrix(REALSXP, pAbund, nPost)); nProtect++; + zeros(REAL(tauSqBetaSamples_r), pAbund * nPost); SEXP tauSqAlphaSamples_r; PROTECT(tauSqAlphaSamples_r = allocMatrix(REALSXP, pDet, nPost)); nProtect++; + zeros(REAL(tauSqAlphaSamples_r), pDet * nPost); // Species level SEXP betaSamples_r; PROTECT(betaSamples_r = allocMatrix(REALSXP, pAbundnSp, nPost)); nProtect++; + zeros(REAL(betaSamples_r), pAbundnSp * nPost); SEXP alphaSamples_r; PROTECT(alphaSamples_r = allocMatrix(REALSXP, pDetnSp, nPost)); nProtect++; + zeros(REAL(alphaSamples_r), pDetnSp * nPost); SEXP NSamples_r; PROTECT(NSamples_r = allocMatrix(REALSXP, JnSp, nPost)); nProtect++; + zeros(REAL(NSamples_r), JnSp * nPost); SEXP muSamples_r; PROTECT(muSamples_r = allocMatrix(REALSXP, JnSp, nPost)); nProtect++; + zeros(REAL(muSamples_r), JnSp * nPost); // Detection random effects SEXP sigmaSqPSamples_r; SEXP alphaStarSamples_r; if (pDetRE > 0) { PROTECT(sigmaSqPSamples_r = allocMatrix(REALSXP, pDetRE, nPost)); nProtect++; + zeros(REAL(sigmaSqPSamples_r), pDetRE * nPost); PROTECT(alphaStarSamples_r = allocMatrix(REALSXP, nDetREnSp, nPost)); nProtect++; + zeros(REAL(alphaStarSamples_r), nDetREnSp * nPost); } // Abundance random effects SEXP sigmaSqMuSamples_r; SEXP betaStarSamples_r; if (pAbundRE > 0) { PROTECT(sigmaSqMuSamples_r = allocMatrix(REALSXP, pAbundRE, nPost)); nProtect++; + zeros(REAL(sigmaSqMuSamples_r), pAbundRE * nPost); PROTECT(betaStarSamples_r = allocMatrix(REALSXP, nAbundREnSp, nPost)); nProtect++; + zeros(REAL(betaStarSamples_r), nAbundREnSp * nPost); } SEXP kappaSamples_r; if (family == 1) { PROTECT(kappaSamples_r = allocMatrix(REALSXP, nSp, nPost)); nProtect++; + zeros(REAL(kappaSamples_r), nSp * nPost); } SEXP yRepSamples_r; PROTECT(yRepSamples_r = allocMatrix(INTSXP, nObsFullnSp, nPost)); nProtect++; + zeros(REAL(yRepSamples_r), nObsFullnSp * nPost); SEXP piFullSamples_r; PROTECT(piFullSamples_r = allocMatrix(REALSXP, nObsFullnSp, nPost)); nProtect++; + zeros(REAL(piFullSamples_r), nObsFullnSp * nPost); /********************************************************************** * Additional Sampler Prep @@ -400,8 +403,10 @@ extern "C" { } SEXP acceptSamples_r; PROTECT(acceptSamples_r = allocMatrix(REALSXP, nAMCMC, nBatch)); nProtect++; + zeros(REAL(acceptSamples_r), nAMCMC * nBatch); SEXP tuningSamples_r; PROTECT(tuningSamples_r = allocMatrix(REALSXP, nAMCMC, nBatch)); nProtect++; + zeros(REAL(tuningSamples_r), nAMCMC * nBatch); /********************************************************************** * Prep for random effects diff --git a/src/msNMix.cpp b/src/msNMix.cpp index c4ae604..8ae01d5 100644 --- a/src/msNMix.cpp +++ b/src/msNMix.cpp @@ -223,38 +223,51 @@ extern "C" { // Community level SEXP betaCommSamples_r; PROTECT(betaCommSamples_r = allocMatrix(REALSXP, pAbund, nPost)); nProtect++; + zeros(REAL(betaCommSamples_r), pAbund * nPost); SEXP alphaCommSamples_r; PROTECT(alphaCommSamples_r = allocMatrix(REALSXP, pDet, nPost)); nProtect++; + zeros(REAL(alphaCommSamples_r), pDet * nPost); SEXP tauSqBetaSamples_r; PROTECT(tauSqBetaSamples_r = allocMatrix(REALSXP, pAbund, nPost)); nProtect++; + zeros(REAL(tauSqBetaSamples_r), pAbund * nPost); SEXP tauSqAlphaSamples_r; PROTECT(tauSqAlphaSamples_r = allocMatrix(REALSXP, pDet, nPost)); nProtect++; + zeros(REAL(tauSqAlphaSamples_r), pDet * nPost); // Species level SEXP betaSamples_r; PROTECT(betaSamples_r = allocMatrix(REALSXP, pAbundnSp, nPost)); nProtect++; + zeros(REAL(betaSamples_r), pAbundnSp * nPost); SEXP alphaSamples_r; PROTECT(alphaSamples_r = allocMatrix(REALSXP, pDetnSp, nPost)); nProtect++; + zeros(REAL(alphaSamples_r), pDetnSp * nPost); SEXP NSamples_r; PROTECT(NSamples_r = allocMatrix(REALSXP, JnSp, nPost)); nProtect++; + zeros(REAL(NSamples_r), JnSp * nPost); SEXP muSamples_r; PROTECT(muSamples_r = allocMatrix(REALSXP, JnSp, nPost)); nProtect++; + zeros(REAL(muSamples_r), JnSp * nPost); // Detection random effects SEXP sigmaSqPSamples_r; SEXP alphaStarSamples_r; if (pDetRE > 0) { PROTECT(sigmaSqPSamples_r = allocMatrix(REALSXP, pDetRE, nPost)); nProtect++; + zeros(REAL(sigmaSqPSamples_r), pDetRE * nPost); PROTECT(alphaStarSamples_r = allocMatrix(REALSXP, nDetREnSp, nPost)); nProtect++; + zeros(REAL(alphaStarSamples_r), nDetREnSp * nPost); } // Abundance random effects SEXP sigmaSqMuSamples_r; SEXP betaStarSamples_r; if (pAbundRE > 0) { PROTECT(sigmaSqMuSamples_r = allocMatrix(REALSXP, pAbundRE, nPost)); nProtect++; + zeros(REAL(sigmaSqMuSamples_r), pAbundRE * nPost); PROTECT(betaStarSamples_r = allocMatrix(REALSXP, nAbundREnSp, nPost)); nProtect++; + zeros(REAL(betaStarSamples_r), nAbundREnSp * nPost); } SEXP kappaSamples_r; if (family == 1) { PROTECT(kappaSamples_r = allocMatrix(REALSXP, nSp, nPost)); nProtect++; + zeros(REAL(kappaSamples_r), nSp * nPost); } // Likelihood samples for WAIC. @@ -425,8 +438,10 @@ extern "C" { } SEXP acceptSamples_r; PROTECT(acceptSamples_r = allocMatrix(REALSXP, nAMCMC, nBatch)); nProtect++; + zeros(REAL(acceptSamples_r), nAMCMC * nBatch); SEXP tuningSamples_r; PROTECT(tuningSamples_r = allocMatrix(REALSXP, nAMCMC, nBatch)); nProtect++; + zeros(REAL(tuningSamples_r), nAMCMC * nBatch); GetRNGstate(); diff --git a/src/sfMsAbundGaussianNNGP.cpp b/src/sfMsAbundGaussianNNGP.cpp index 2057a21..5adeecd 100644 --- a/src/sfMsAbundGaussianNNGP.cpp +++ b/src/sfMsAbundGaussianNNGP.cpp @@ -119,6 +119,7 @@ extern "C" { int nRE = INTEGER(consts_r)[4]; int q = INTEGER(consts_r)[5]; int indBetas = INTEGER(consts_r)[6]; + int saveFitted = INTEGER(consts_r)[7]; int pp = p * p; double *muBetaComm = REAL(muBetaComm_r); double *SigmaBetaCommInv = (double *) R_alloc(pp, sizeof(double)); @@ -285,32 +286,44 @@ extern "C" { // Community level SEXP betaCommSamples_r; PROTECT(betaCommSamples_r = allocMatrix(REALSXP, p, nPost)); nProtect++; + zeros(REAL(betaCommSamples_r), p * nPost); SEXP tauSqBetaSamples_r; PROTECT(tauSqBetaSamples_r = allocMatrix(REALSXP, p, nPost)); nProtect++; + zeros(REAL(tauSqBetaSamples_r), p * nPost); // Species level SEXP betaSamples_r; PROTECT(betaSamples_r = allocMatrix(REALSXP, pN, nPost)); nProtect++; + zeros(REAL(betaSamples_r), pN * nPost); SEXP tauSqSamples_r; PROTECT(tauSqSamples_r = allocMatrix(REALSXP, N, nPost)); nProtect++; + zeros(REAL(tauSqSamples_r), N * nPost); SEXP yRepSamples_r; - PROTECT(yRepSamples_r = allocMatrix(REALSXP, JN, nPost)); nProtect++; SEXP muSamples_r; - PROTECT(muSamples_r = allocMatrix(REALSXP, JN, nPost)); nProtect++; + SEXP likeSamples_r; + if (saveFitted == 1) { + PROTECT(yRepSamples_r = allocMatrix(REALSXP, JN, nPost)); nProtect++; + zeros(REAL(yRepSamples_r), JN * nPost); + PROTECT(muSamples_r = allocMatrix(REALSXP, JN, nPost)); nProtect++; + zeros(REAL(muSamples_r), JN * nPost); + PROTECT(likeSamples_r = allocMatrix(REALSXP, JN, nPost)); nProtect++; + zeros(REAL(likeSamples_r), JN * nPost); + } // Spatial parameters SEXP lambdaSamples_r; PROTECT(lambdaSamples_r = allocMatrix(REALSXP, Nq, nPost)); nProtect++; + zeros(REAL(lambdaSamples_r), Nq * nPost); SEXP wSamples_r; PROTECT(wSamples_r = allocMatrix(REALSXP, Jq, nPost)); nProtect++; + zeros(REAL(wSamples_r), Jq * nPost); // Random effects SEXP sigmaSqMuSamples_r; SEXP betaStarSamples_r; if (pRE > 0) { PROTECT(sigmaSqMuSamples_r = allocMatrix(REALSXP, pRE, nPost)); nProtect++; + zeros(REAL(sigmaSqMuSamples_r), pRE * nPost); PROTECT(betaStarSamples_r = allocMatrix(REALSXP, nREN, nPost)); nProtect++; + zeros(REAL(betaStarSamples_r), nREN * nPost); } - // Likelihood samples for WAIC. - SEXP likeSamples_r; - PROTECT(likeSamples_r = allocMatrix(REALSXP, JN, nPost)); nProtect++; /********************************************************************** * Additional Sampler Prep @@ -388,6 +401,7 @@ extern "C" { } // ll SEXP thetaSamples_r; PROTECT(thetaSamples_r = allocMatrix(REALSXP, nThetaqSave, nPost)); nProtect++; + zeros(REAL(thetaSamples_r), nThetaqSave * nPost); // Species-level spatial random effects double *wStar = (double *) R_alloc(JN, sizeof(double)); zeros(wStar, JN); // Multiply Lambda %*% w[j] to get wStar. @@ -437,6 +451,7 @@ extern "C" { double *accept2 = (double *) R_alloc(nThetaq, sizeof(double)); zeros(accept2, nThetaq); SEXP tuningSamples_r; PROTECT(tuningSamples_r = allocMatrix(REALSXP, nThetaq, nBatch)); nProtect++; + zeros(REAL(tuningSamples_r), nThetaq * nBatch); // For current number of nonzero z values double *currJ = (double *) R_alloc(N, sizeof(double)); zeros(currJ, N); for (i = 0; i < N; i++) { @@ -895,19 +910,21 @@ extern "C" { /******************************************************************** *Get fitted values and likelihood for WAIC *******************************************************************/ - for (i = 0; i < N; i++) { - for (j = 0; j < J; j++) { - if (z[j * N + i] == 1.0) { - mu[j * N + i] = F77_NAME(ddot)(&p, &X[j], &J, &beta[i], &N) + wStar[j * N + i] + betaStarSites[i * J + j]; - yRep[j * N + i] = rnorm(mu[j * N + i], sqrt(tauSq[i])); - like[j * N + i] = dnorm(y[j * N + i], mu[j * N + i], sqrt(tauSq[i]), 0); - } else { - mu[j * N + i] = 0.0; - yRep[j * N + i] = rnorm(mu[j * N + i], sqrt(0.0001)); - like[j * N + i] = 1.0; - } - } // j - } // i + if (saveFitted == 1) { + for (i = 0; i < N; i++) { + for (j = 0; j < J; j++) { + if (z[j * N + i] == 1.0) { + mu[j * N + i] = F77_NAME(ddot)(&p, &X[j], &J, &beta[i], &N) + wStar[j * N + i] + betaStarSites[i * J + j]; + yRep[j * N + i] = rnorm(mu[j * N + i], sqrt(tauSq[i])); + like[j * N + i] = dnorm(y[j * N + i], mu[j * N + i], sqrt(tauSq[i]), 0); + } else { + mu[j * N + i] = 0.0; + yRep[j * N + i] = rnorm(mu[j * N + i], sqrt(0.0001)); + like[j * N + i] = 1.0; + } + } // j + } // i + } /******************************************************************** *Save samples @@ -920,15 +937,17 @@ extern "C" { F77_NAME(dcopy)(&N, tauSq, &inc, &REAL(tauSqSamples_r)[sPost*N], &inc); F77_NAME(dcopy)(&pN, beta, &inc, &REAL(betaSamples_r)[sPost*pN], &inc); F77_NAME(dcopy)(&Nq, lambda, &inc, &REAL(lambdaSamples_r)[sPost*Nq], &inc); - F77_NAME(dcopy)(&JN, mu, &inc, &REAL(muSamples_r)[sPost*JN], &inc); - F77_NAME(dcopy)(&JN, yRep, &inc, &REAL(yRepSamples_r)[sPost*JN], &inc); + if (saveFitted == 1) { + F77_NAME(dcopy)(&JN, mu, &inc, &REAL(muSamples_r)[sPost*JN], &inc); + F77_NAME(dcopy)(&JN, yRep, &inc, &REAL(yRepSamples_r)[sPost*JN], &inc); + F77_NAME(dcopy)(&JN, like, &inc, &REAL(likeSamples_r)[sPost*JN], &inc); + } F77_NAME(dcopy)(&Jq, w, &inc, &REAL(wSamples_r)[sPost*Jq], &inc); F77_NAME(dcopy)(&nThetaqSave, &theta[phiIndx * q], &inc, &REAL(thetaSamples_r)[sPost*nThetaqSave], &inc); if (pRE > 0) { F77_NAME(dcopy)(&pRE, sigmaSqMu, &inc, &REAL(sigmaSqMuSamples_r)[sPost*pRE], &inc); F77_NAME(dcopy)(&nREN, betaStar, &inc, &REAL(betaStarSamples_r)[sPost*nREN], &inc); } - F77_NAME(dcopy)(&JN, like, &inc, &REAL(likeSamples_r)[sPost*JN], &inc); sPost++; thinIndx = 0; } @@ -998,13 +1017,15 @@ extern "C" { SET_VECTOR_ELT(result_r, 0, betaCommSamples_r); SET_VECTOR_ELT(result_r, 1, tauSqBetaSamples_r); SET_VECTOR_ELT(result_r, 2, betaSamples_r); - SET_VECTOR_ELT(result_r, 3, yRepSamples_r); - SET_VECTOR_ELT(result_r, 4, muSamples_r); + if (saveFitted == 1) { + SET_VECTOR_ELT(result_r, 3, yRepSamples_r); + SET_VECTOR_ELT(result_r, 4, muSamples_r); + SET_VECTOR_ELT(result_r, 9, likeSamples_r); + } SET_VECTOR_ELT(result_r, 5, lambdaSamples_r); SET_VECTOR_ELT(result_r, 6, wSamples_r); SET_VECTOR_ELT(result_r, 7, thetaSamples_r); SET_VECTOR_ELT(result_r, 8, tauSqSamples_r); - SET_VECTOR_ELT(result_r, 9, likeSamples_r); if (pRE > 0) { SET_VECTOR_ELT(result_r, 10, sigmaSqMuSamples_r); SET_VECTOR_ELT(result_r, 11, betaStarSamples_r); @@ -1014,13 +1035,15 @@ extern "C" { SET_VECTOR_ELT(resultName_r, 0, mkChar("beta.comm.samples")); SET_VECTOR_ELT(resultName_r, 1, mkChar("tau.sq.beta.samples")); SET_VECTOR_ELT(resultName_r, 2, mkChar("beta.samples")); - SET_VECTOR_ELT(resultName_r, 3, mkChar("y.rep.samples")); - SET_VECTOR_ELT(resultName_r, 4, mkChar("mu.samples")); + if (saveFitted == 1) { + SET_VECTOR_ELT(resultName_r, 3, mkChar("y.rep.samples")); + SET_VECTOR_ELT(resultName_r, 4, mkChar("mu.samples")); + SET_VECTOR_ELT(resultName_r, 9, mkChar("like.samples")); + } SET_VECTOR_ELT(resultName_r, 5, mkChar("lambda.samples")); SET_VECTOR_ELT(resultName_r, 6, mkChar("w.samples")); SET_VECTOR_ELT(resultName_r, 7, mkChar("theta.samples")); SET_VECTOR_ELT(resultName_r, 8, mkChar("tau.sq.samples")); - SET_VECTOR_ELT(resultName_r, 9, mkChar("like.samples")); if (pRE > 0) { SET_VECTOR_ELT(resultName_r, 10, mkChar("sigma.sq.mu.samples")); SET_VECTOR_ELT(resultName_r, 11, mkChar("beta.star.samples")); diff --git a/src/sfMsAbundNNGP.cpp b/src/sfMsAbundNNGP.cpp index bb408a6..f59b4dd 100644 --- a/src/sfMsAbundNNGP.cpp +++ b/src/sfMsAbundNNGP.cpp @@ -108,6 +108,7 @@ extern "C" { int nAbundRE = INTEGER(consts_r)[5]; int q = INTEGER(consts_r)[6]; int indBetas = INTEGER(consts_r)[7]; + int saveFitted = INTEGER(consts_r)[8]; int ppAbund = pAbund * pAbund; double *muBetaComm = REAL(muBetaComm_r); double *SigmaBetaCommInv = (double *) R_alloc(ppAbund, sizeof(double)); @@ -256,35 +257,47 @@ extern "C" { // Community level SEXP betaCommSamples_r; PROTECT(betaCommSamples_r = allocMatrix(REALSXP, pAbund, nPost)); nProtect++; + zeros(REAL(betaCommSamples_r), pAbund * nPost); SEXP tauSqBetaSamples_r; PROTECT(tauSqBetaSamples_r = allocMatrix(REALSXP, pAbund, nPost)); nProtect++; + zeros(REAL(tauSqBetaSamples_r), pAbund * nPost); // Species level SEXP betaSamples_r; PROTECT(betaSamples_r = allocMatrix(REALSXP, pAbundnSp, nPost)); nProtect++; + zeros(REAL(betaSamples_r), pAbundnSp * nPost); SEXP yRepSamples_r; - PROTECT(yRepSamples_r = allocMatrix(REALSXP, nObsnSp, nPost)); nProtect++; SEXP muSamples_r; - PROTECT(muSamples_r = allocMatrix(REALSXP, nObsnSp, nPost)); nProtect++; + SEXP likeSamples_r; + if (saveFitted == 1) { + PROTECT(yRepSamples_r = allocMatrix(REALSXP, nObsnSp, nPost)); nProtect++; + zeros(REAL(yRepSamples_r), nObsnSp * nPost); + PROTECT(muSamples_r = allocMatrix(REALSXP, nObsnSp, nPost)); nProtect++; + zeros(REAL(muSamples_r), nObsnSp * nPost); + PROTECT(likeSamples_r = allocMatrix(REALSXP, nObsnSp, nPost)); nProtect++; + zeros(REAL(likeSamples_r), nObsnSp * nPost); + } // Spatial parameters SEXP lambdaSamples_r; PROTECT(lambdaSamples_r = allocMatrix(REALSXP, nSpq, nPost)); nProtect++; + zeros(REAL(lambdaSamples_r), nSpq * nPost); SEXP wSamples_r; PROTECT(wSamples_r = allocMatrix(REALSXP, Jq, nPost)); nProtect++; + zeros(REAL(wSamples_r), Jq * nPost); // Abundance random effects SEXP sigmaSqMuSamples_r; SEXP betaStarSamples_r; if (pAbundRE > 0) { PROTECT(sigmaSqMuSamples_r = allocMatrix(REALSXP, pAbundRE, nPost)); nProtect++; + zeros(REAL(sigmaSqMuSamples_r), pAbundRE * nPost); PROTECT(betaStarSamples_r = allocMatrix(REALSXP, nAbundREnSp, nPost)); nProtect++; + zeros(REAL(betaStarSamples_r), nAbundREnSp * nPost); } // Overdispersion SEXP kappaSamples_r; if (family == 1) { PROTECT(kappaSamples_r = allocMatrix(REALSXP, nSp, nPost)); nProtect++; + zeros(REAL(kappaSamples_r), nSp * nPost); } - // Likelihood samples for WAIC. - SEXP likeSamples_r; - PROTECT(likeSamples_r = allocMatrix(REALSXP, nObsnSp, nPost)); nProtect++; /********************************************************************** * Additional Sampler Prep @@ -363,6 +376,7 @@ extern "C" { } // ll SEXP thetaSamples_r; PROTECT(thetaSamples_r = allocMatrix(REALSXP, nThetaqSave, nPost)); nProtect++; + zeros(REAL(thetaSamples_r), nThetaqSave * nPost); // Species-level spatial random effects double *wStar = (double *) R_alloc(JnSp, sizeof(double)); zeros(wStar, JnSp); // Multiply Lambda %*% w[j] to get wStar. @@ -451,8 +465,10 @@ extern "C" { double *accept = (double *) R_alloc(nAMCMC, sizeof(double)); zeros(accept, nAMCMC); SEXP acceptSamples_r; PROTECT(acceptSamples_r = allocMatrix(REALSXP, nAMCMC, nBatch)); nProtect++; + zeros(REAL(acceptSamples_r), nAMCMC * nBatch); SEXP tuningSamples_r; PROTECT(tuningSamples_r = allocMatrix(REALSXP, nAMCMC, nBatch)); nProtect++; + zeros(REAL(tuningSamples_r), nAMCMC * nBatch); // Set the initial candidate values for everything to the inital values. double *betaCand = (double *) R_alloc(pAbund * nSp, sizeof(double)); // beta is sorted by parameter, then species within parameter. @@ -947,18 +963,20 @@ extern "C" { /******************************************************************** *Get fitted values *******************************************************************/ - for (r = 0; r < nObs; r++) { - // Only calculate mu if Poisson since it's already calculated in kappa update - if (family == 0) { - mu[r * nSp + i] = exp(F77_NAME(ddot)(&pAbund, &X[r], &nObs, &beta[i], &nSp) + - betaStarSites[i * nObs + r] + wStar[siteIndx[r] * nSp + i]); - yRep[r * nSp + i] = rpois(mu[r * nSp + i] * offset[r]); - like[r * nSp + i] = dpois(y[r * nSp + i], mu[r * nSp + i] * offset[r], 0); - } else { - yRep[r * nSp + i] = rnbinom_mu(kappa[i], mu[r * nSp + i] * offset[r]); - like[r * nSp + i] = dnbinom_mu(y[r * nSp + i], kappa[i], mu[r * nSp + i] * offset[r], 0); - } - } + if (saveFitted == 1) { + for (r = 0; r < nObs; r++) { + // Only calculate mu if Poisson since it's already calculated in kappa update + if (family == 0) { + mu[r * nSp + i] = exp(F77_NAME(ddot)(&pAbund, &X[r], &nObs, &beta[i], &nSp) + + betaStarSites[i * nObs + r] + wStar[siteIndx[r] * nSp + i]); + yRep[r * nSp + i] = rpois(mu[r * nSp + i] * offset[r]); + like[r * nSp + i] = dpois(y[r * nSp + i], mu[r * nSp + i] * offset[r], 0); + } else { + yRep[r * nSp + i] = rnbinom_mu(kappa[i], mu[r * nSp + i] * offset[r]); + like[r * nSp + i] = dnbinom_mu(y[r * nSp + i], kappa[i], mu[r * nSp + i] * offset[r], 0); + } + } + } } // i (species) /******************************************************************** @@ -973,13 +991,15 @@ extern "C" { if (family == 1) { F77_NAME(dcopy)(&nSp, kappa, &inc, &REAL(kappaSamples_r)[sPost*nSp], &inc); } - F77_NAME(dcopy)(&nObsnSp, yRep, &inc, &REAL(yRepSamples_r)[sPost*nObsnSp], &inc); - F77_NAME(dcopy)(&nObsnSp, mu, &inc, &REAL(muSamples_r)[sPost*nObsnSp], &inc); + if (saveFitted == 1) { + F77_NAME(dcopy)(&nObsnSp, yRep, &inc, &REAL(yRepSamples_r)[sPost*nObsnSp], &inc); + F77_NAME(dcopy)(&nObsnSp, mu, &inc, &REAL(muSamples_r)[sPost*nObsnSp], &inc); + F77_NAME(dcopy)(&nObsnSp, like, &inc, &REAL(likeSamples_r)[sPost*nObsnSp], &inc); + } F77_NAME(dcopy)(&Jq, w, &inc, &REAL(wSamples_r)[sPost*Jq], &inc); F77_NAME(dcopy)(&nSpq, lambda, &inc, &REAL(lambdaSamples_r)[sPost*nSpq], &inc); F77_NAME(dcopy)(&nThetaqSave, &theta[phiIndx * q], &inc, &REAL(thetaSamples_r)[sPost*nThetaqSave], &inc); - F77_NAME(dcopy)(&nObsnSp, like, &inc, &REAL(likeSamples_r)[sPost*nObsnSp], &inc); if (pAbundRE > 0) { F77_NAME(dcopy)(&pAbundRE, sigmaSqMu, &inc, &REAL(sigmaSqMuSamples_r)[sPost*pAbundRE], &inc); F77_NAME(dcopy)(&nAbundREnSp, betaStar, &inc, &REAL(betaStarSamples_r)[sPost*nAbundREnSp], &inc); @@ -1054,14 +1074,16 @@ extern "C" { SET_VECTOR_ELT(result_r, 0, betaCommSamples_r); SET_VECTOR_ELT(result_r, 1, tauSqBetaSamples_r); SET_VECTOR_ELT(result_r, 2, betaSamples_r); - SET_VECTOR_ELT(result_r, 3, yRepSamples_r); - SET_VECTOR_ELT(result_r, 4, muSamples_r); + if (saveFitted == 1) { + SET_VECTOR_ELT(result_r, 3, yRepSamples_r); + SET_VECTOR_ELT(result_r, 4, muSamples_r); + SET_VECTOR_ELT(result_r, 10, likeSamples_r); + } SET_VECTOR_ELT(result_r, 5, lambdaSamples_r); SET_VECTOR_ELT(result_r, 6, wSamples_r); SET_VECTOR_ELT(result_r, 7, thetaSamples_r); SET_VECTOR_ELT(result_r, 8, tuningSamples_r); SET_VECTOR_ELT(result_r, 9, acceptSamples_r); - SET_VECTOR_ELT(result_r, 10, likeSamples_r); if (pAbundRE > 0) { SET_VECTOR_ELT(result_r, 11, sigmaSqMuSamples_r); SET_VECTOR_ELT(result_r, 12, betaStarSamples_r); @@ -1078,14 +1100,16 @@ extern "C" { SET_VECTOR_ELT(resultName_r, 0, mkChar("beta.comm.samples")); SET_VECTOR_ELT(resultName_r, 1, mkChar("tau.sq.beta.samples")); SET_VECTOR_ELT(resultName_r, 2, mkChar("beta.samples")); - SET_VECTOR_ELT(resultName_r, 3, mkChar("y.rep.samples")); - SET_VECTOR_ELT(resultName_r, 4, mkChar("mu.samples")); + if (saveFitted == 1) { + SET_VECTOR_ELT(resultName_r, 3, mkChar("y.rep.samples")); + SET_VECTOR_ELT(resultName_r, 4, mkChar("mu.samples")); + SET_VECTOR_ELT(resultName_r, 10, mkChar("like.samples")); + } SET_VECTOR_ELT(resultName_r, 5, mkChar("lambda.samples")); SET_VECTOR_ELT(resultName_r, 6, mkChar("w.samples")); SET_VECTOR_ELT(resultName_r, 7, mkChar("theta.samples")); SET_VECTOR_ELT(resultName_r, 8, mkChar("tune")); SET_VECTOR_ELT(resultName_r, 9, mkChar("accept")); - SET_VECTOR_ELT(resultName_r, 10, mkChar("like.samples")); if (pAbundRE > 0) { SET_VECTOR_ELT(resultName_r, 11, mkChar("sigma.sq.mu.samples")); SET_VECTOR_ELT(resultName_r, 12, mkChar("beta.star.samples")); diff --git a/src/sfMsAbundNNGPPredict.cpp b/src/sfMsAbundNNGPPredict.cpp index b0885ca..fe3f8c9 100644 --- a/src/sfMsAbundNNGPPredict.cpp +++ b/src/sfMsAbundNNGPPredict.cpp @@ -38,10 +38,8 @@ extern "C" { int J = INTEGER(J_r)[0]; int nSp = INTEGER(nSp_r)[0]; int q = INTEGER(q_r)[0]; - int nObs = INTEGER(nObs_r)[0]; int pAbund = INTEGER(pAbund_r)[0]; int pAbundnSp = pAbund * nSp; - int JnSp = J * nSp; int Jq = J * q; int nSpq = nSp * q; int family = INTEGER(family_r)[0]; diff --git a/src/sfMsDSNNGP.cpp b/src/sfMsDSNNGP.cpp index f655bf7..5e2ee0f 100755 --- a/src/sfMsDSNNGP.cpp +++ b/src/sfMsDSNNGP.cpp @@ -307,48 +307,65 @@ extern "C" { // Community level SEXP betaCommSamples_r; PROTECT(betaCommSamples_r = allocMatrix(REALSXP, pAbund, nPost)); nProtect++; + zeros(REAL(betaCommSamples_r), pAbund * nPost); SEXP alphaCommSamples_r; PROTECT(alphaCommSamples_r = allocMatrix(REALSXP, pDet, nPost)); nProtect++; + zeros(REAL(alphaCommSamples_r), pDet * nPost); SEXP tauSqBetaSamples_r; PROTECT(tauSqBetaSamples_r = allocMatrix(REALSXP, pAbund, nPost)); nProtect++; + zeros(REAL(tauSqBetaSamples_r), pAbund * nPost); SEXP tauSqAlphaSamples_r; PROTECT(tauSqAlphaSamples_r = allocMatrix(REALSXP, pDet, nPost)); nProtect++; + zeros(REAL(tauSqAlphaSamples_r), pDet * nPost); // Species level SEXP betaSamples_r; PROTECT(betaSamples_r = allocMatrix(REALSXP, pAbundnSp, nPost)); nProtect++; + zeros(REAL(betaSamples_r), pAbundnSp * nPost); SEXP alphaSamples_r; PROTECT(alphaSamples_r = allocMatrix(REALSXP, pDetnSp, nPost)); nProtect++; + zeros(REAL(alphaSamples_r), pDetnSp * nPost); SEXP NSamples_r; PROTECT(NSamples_r = allocMatrix(REALSXP, JnSp, nPost)); nProtect++; + zeros(REAL(NSamples_r), JnSp * nPost); SEXP muSamples_r; PROTECT(muSamples_r = allocMatrix(REALSXP, JnSp, nPost)); nProtect++; + zeros(REAL(muSamples_r), JnSp * nPost); // Latent factor parameters SEXP lambdaSamples_r; PROTECT(lambdaSamples_r = allocMatrix(REALSXP, nSpq, nPost)); nProtect++; + zeros(REAL(lambdaSamples_r), nSpq * nPost); SEXP wSamples_r; PROTECT(wSamples_r = allocMatrix(REALSXP, Jq, nPost)); nProtect++; + zeros(REAL(wSamples_r), Jq * nPost); // Detection random effects SEXP sigmaSqPSamples_r; SEXP alphaStarSamples_r; if (pDetRE > 0) { PROTECT(sigmaSqPSamples_r = allocMatrix(REALSXP, pDetRE, nPost)); nProtect++; + zeros(REAL(sigmaSqPSamples_r), pDetRE * nPost); PROTECT(alphaStarSamples_r = allocMatrix(REALSXP, nDetREnSp, nPost)); nProtect++; + zeros(REAL(alphaStarSamples_r), nDetREnSp * nPost); } // Abundance random effects SEXP sigmaSqMuSamples_r; SEXP betaStarSamples_r; if (pAbundRE > 0) { PROTECT(sigmaSqMuSamples_r = allocMatrix(REALSXP, pAbundRE, nPost)); nProtect++; + zeros(REAL(sigmaSqMuSamples_r), pAbundRE * nPost); PROTECT(betaStarSamples_r = allocMatrix(REALSXP, nAbundREnSp, nPost)); nProtect++; + zeros(REAL(betaStarSamples_r), nAbundREnSp * nPost); } SEXP kappaSamples_r; if (family == 1) { PROTECT(kappaSamples_r = allocMatrix(REALSXP, nSp, nPost)); nProtect++; + zeros(REAL(kappaSamples_r), nSp * nPost); } SEXP yRepSamples_r; PROTECT(yRepSamples_r = allocMatrix(INTSXP, nObsFullnSp, nPost)); nProtect++; + zeros(REAL(yRepSamples_r), nObsFullnSp * nPost); SEXP piFullSamples_r; PROTECT(piFullSamples_r = allocMatrix(REALSXP, nObsFullnSp, nPost)); nProtect++; + zeros(REAL(piFullSamples_r), nObsFullnSp * nPost); /********************************************************************** * Additional Sampler Prep @@ -415,6 +432,7 @@ extern "C" { } // ll SEXP thetaSamples_r; PROTECT(thetaSamples_r = allocMatrix(REALSXP, nThetaqSave, nPost)); nProtect++; + zeros(REAL(thetaSamples_r), nThetaqSave * nPost); // Species-level spatial random effects double *wStar = (double *) R_alloc(JnSp, sizeof(double)); zeros(wStar, JnSp); // Multiply Lambda %*% w[j] to get wStar. @@ -584,8 +602,10 @@ extern "C" { } SEXP acceptSamples_r; PROTECT(acceptSamples_r = allocMatrix(REALSXP, nAMCMC, nBatch)); nProtect++; + zeros(REAL(acceptSamples_r), nAMCMC * nBatch); SEXP tuningSamples_r; PROTECT(tuningSamples_r = allocMatrix(REALSXP, nAMCMC, nBatch)); nProtect++; + zeros(REAL(tuningSamples_r), nAMCMC * nBatch); /********************************************************************** * Prep for random effects diff --git a/src/sfMsNMixNNGP.cpp b/src/sfMsNMixNNGP.cpp index a409146..3e22f84 100644 --- a/src/sfMsNMixNNGP.cpp +++ b/src/sfMsNMixNNGP.cpp @@ -301,43 +301,58 @@ extern "C" { // Community level SEXP betaCommSamples_r; PROTECT(betaCommSamples_r = allocMatrix(REALSXP, pAbund, nPost)); nProtect++; + zeros(REAL(betaCommSamples_r), pAbund * nPost); SEXP alphaCommSamples_r; PROTECT(alphaCommSamples_r = allocMatrix(REALSXP, pDet, nPost)); nProtect++; + zeros(REAL(alphaCommSamples_r), pDet * nPost); SEXP tauSqBetaSamples_r; PROTECT(tauSqBetaSamples_r = allocMatrix(REALSXP, pAbund, nPost)); nProtect++; + zeros(REAL(tauSqBetaSamples_r), pAbund * nPost); SEXP tauSqAlphaSamples_r; PROTECT(tauSqAlphaSamples_r = allocMatrix(REALSXP, pDet, nPost)); nProtect++; + zeros(REAL(tauSqAlphaSamples_r), pDet * nPost); // Species level SEXP betaSamples_r; PROTECT(betaSamples_r = allocMatrix(REALSXP, pAbundnSp, nPost)); nProtect++; + zeros(REAL(betaSamples_r), pAbundnSp * nPost); SEXP alphaSamples_r; PROTECT(alphaSamples_r = allocMatrix(REALSXP, pDetnSp, nPost)); nProtect++; + zeros(REAL(alphaSamples_r), pDetnSp * nPost); SEXP NSamples_r; PROTECT(NSamples_r = allocMatrix(REALSXP, JnSp, nPost)); nProtect++; + zeros(REAL(NSamples_r), JnSp * nPost); SEXP muSamples_r; PROTECT(muSamples_r = allocMatrix(REALSXP, JnSp, nPost)); nProtect++; + zeros(REAL(muSamples_r), JnSp * nPost); // Spatial parameters SEXP lambdaSamples_r; PROTECT(lambdaSamples_r = allocMatrix(REALSXP, nSpq, nPost)); nProtect++; + zeros(REAL(lambdaSamples_r), nSpq * nPost); SEXP wSamples_r; PROTECT(wSamples_r = allocMatrix(REALSXP, Jq, nPost)); nProtect++; + zeros(REAL(wSamples_r), Jq * nPost); // Detection random effects SEXP sigmaSqPSamples_r; SEXP alphaStarSamples_r; if (pDetRE > 0) { PROTECT(sigmaSqPSamples_r = allocMatrix(REALSXP, pDetRE, nPost)); nProtect++; + zeros(REAL(sigmaSqPSamples_r), pDetRE * nPost); PROTECT(alphaStarSamples_r = allocMatrix(REALSXP, nDetREnSp, nPost)); nProtect++; + zeros(REAL(alphaStarSamples_r), nDetREnSp * nPost); } // Abundance random effects SEXP sigmaSqMuSamples_r; SEXP betaStarSamples_r; if (pAbundRE > 0) { PROTECT(sigmaSqMuSamples_r = allocMatrix(REALSXP, pAbundRE, nPost)); nProtect++; + zeros(REAL(sigmaSqMuSamples_r), pAbundRE * nPost); PROTECT(betaStarSamples_r = allocMatrix(REALSXP, nAbundREnSp, nPost)); nProtect++; + zeros(REAL(betaStarSamples_r), nAbundREnSp * nPost); } SEXP kappaSamples_r; if (family == 1) { PROTECT(kappaSamples_r = allocMatrix(REALSXP, nSp, nPost)); nProtect++; + zeros(REAL(kappaSamples_r), nSp * nPost); } /********************************************************************** @@ -453,6 +468,7 @@ extern "C" { } // ll SEXP thetaSamples_r; PROTECT(thetaSamples_r = allocMatrix(REALSXP, nThetaqSave, nPost)); nProtect++; + zeros(REAL(thetaSamples_r), nThetaqSave * nPost); // Species-level spatial random effects double *wStar = (double *) R_alloc(JnSp, sizeof(double)); zeros(wStar, JnSp); // Multiply Lambda %*% w[j] to get wStar. @@ -622,8 +638,10 @@ extern "C" { } SEXP acceptSamples_r; PROTECT(acceptSamples_r = allocMatrix(REALSXP, nAMCMC, nBatch)); nProtect++; + zeros(REAL(acceptSamples_r), nAMCMC * nBatch); SEXP tuningSamples_r; PROTECT(tuningSamples_r = allocMatrix(REALSXP, nAMCMC, nBatch)); nProtect++; + zeros(REAL(tuningSamples_r), nAMCMC * nBatch); GetRNGstate(); diff --git a/src/sfMsNMixNNGPPredict.cpp b/src/sfMsNMixNNGPPredict.cpp index 960fd41..e1cb90b 100644 --- a/src/sfMsNMixNNGPPredict.cpp +++ b/src/sfMsNMixNNGPPredict.cpp @@ -39,7 +39,6 @@ extern "C" { int q = INTEGER(q_r)[0]; int pAbund = INTEGER(pAbund_r)[0]; int pAbundnSp = pAbund * nSp; - int JnSp = J * nSp; int Jq = J * q; int nSpq = nSp * q; int family = INTEGER(family_r)[0]; diff --git a/src/spAbund.cpp b/src/spAbund.cpp deleted file mode 100755 index 07ce880..0000000 --- a/src/spAbund.cpp +++ /dev/null @@ -1,793 +0,0 @@ -#define USE_FC_LEN_T -#include -#include "util.h" -#include "rpg.h" - -#ifdef _OPENMP -#include -#endif - -#include -#include -#include -#include -#include -#include -#ifndef FCONE -# define FCONE -#endif - -extern "C" { - SEXP spAbund(SEXP y_r, SEXP X_r, SEXP coordsD_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 uiIndx_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 sigmaSqIG_r, SEXP family_r){ - - /********************************************************************** - * Initial constants - * *******************************************************************/ - int i, ii, g, t, j, kk, k, jj, s, r, l, ll, info, 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); - int *XRE = INTEGER(XRE_r); - double *XRandom = REAL(XRandom_r); - // Load constants - int J = INTEGER(consts_r)[0]; - 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 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)[0]; - double phiB = REAL(phiB_r)[0]; - double nuA = REAL(nuA_r)[0]; - double nuB = REAL(nuB_r)[0]; - double sigmaSqA = REAL(sigmaSqA_r)[0]; - double sigmaSqB = REAL(sigmaSqB_r)[0]; - 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]; - int batchLength = INTEGER(batchLength_r)[0]; - int nSamples = nBatch * batchLength; - 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 *uiIndx = INTEGER(uiIndx_r); - int covModel = INTEGER(covModel_r)[0]; - std::string corName = getCorName(covModel); - int currChain = INTEGER(chainInfo_r)[0]; - double acceptRate = REAL(acceptRate_r)[0]; - double *tuning = REAL(tuning_r); - double *coordsD = REAL(coordsD_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 sigmaSqIG = INTEGER(sigmaSqIG_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){ - warning("n.omp.threads > 1, but source not compiled with OpenMP support."); - nThreads = 1; - } -#endif - - /********************************************************************** - * Print Information - * *******************************************************************/ - if(verbose){ - if (currChain == 1) { - Rprintf("----------------------------------------\n"); - Rprintf("\tModel description\n"); - Rprintf("----------------------------------------\n"); - if (family == 1) { - Rprintf("Spatial Negative Binomial Abundance model fit with %i sites.\n\n", J); - } else { - Rprintf("Spatial 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("Using the %s spatial correlation model.\n\n", corName.c_str()); -#ifdef _OPENMP - Rprintf("\nSource compiled with OpenMP support and model fit using %i thread(s).\n\n", nThreads); -#else - Rprintf("Source not compiled with OpenMP support.\n\n"); -#endif - Rprintf("Adaptive Metropolis with target acceptance rate: %.1f\n", 100*acceptRate); - } - Rprintf("----------------------------------------\n"); - Rprintf("\tChain %i\n", currChain); - Rprintf("----------------------------------------\n"); - Rprintf("Sampling ... \n"); - #ifdef Win32 - R_FlushConsole(); - #endif - } - - /********************************************************************** - * Parameters - * *******************************************************************/ - // 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]; - double* epsilon = (double *) R_alloc(nObs, sizeof(double)); ones(epsilon, nObs); - // 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(J, sizeof(double)); - F77_NAME(dcopy)(&J, REAL(wStarting_r), &inc, w, &inc); - // Latent Abundance - double *yRep = (double *) R_alloc(nObs, sizeof(double)); zeros(yRep, nObs); - - /********************************************************************** - * Return Stuff - * *******************************************************************/ - SEXP betaSamples_r; - PROTECT(betaSamples_r = allocMatrix(REALSXP, pAbund, nPost)); nProtect++; - SEXP yRepSamples_r; - PROTECT(yRepSamples_r = allocMatrix(REALSXP, nObs, nPost)); nProtect++; - SEXP muSamples_r; - PROTECT(muSamples_r = allocMatrix(REALSXP, nObs, nPost)); nProtect++; - SEXP wSamples_r; - PROTECT(wSamples_r = allocMatrix(REALSXP, J, nPost)); nProtect++; - SEXP kappaSamples_r; - if (family == 1) { - PROTECT(kappaSamples_r = allocMatrix(REALSXP, inc, nPost)); nProtect++; - } - // Abundance random effects - SEXP sigmaSqMuSamples_r; - SEXP betaStarSamples_r; - if (pAbundRE > 0) { - PROTECT(sigmaSqMuSamples_r = allocMatrix(REALSXP, pAbundRE, nPost)); nProtect++; - PROTECT(betaStarSamples_r = allocMatrix(REALSXP, nAbundRE, nPost)); nProtect++; - } - // Likelihood samples for WAIC. - SEXP likeSamples_r; - PROTECT(likeSamples_r = allocMatrix(REALSXP, nObs, nPost)); nProtect++; - - /******************************************************************** - Some constants and temporary variables to be used later - ********************************************************************/ - int JpAbund = J * pAbund; - int nObspAbund = nObs * pAbund; - int JJ = J * J; - double tmp_0; - double *tmp_one = (double *) R_alloc(inc, sizeof(double)); - double *tmp_ppAbund = (double *) R_alloc(ppAbund, sizeof(double)); - double *tmp_pAbund = (double *) R_alloc(pAbund, sizeof(double)); - double *tmp_pAbund2 = (double *) R_alloc(pAbund, sizeof(double)); - double *tmp_nObs = (double *) R_alloc(nObs, sizeof(double)); - double *tmp_nObspAbund = (double *) R_alloc(nObspAbund, sizeof(double)); - double *tmp_JpAbund = (double *) R_alloc(JpAbund, sizeof(double)); - double *tmp_J1 = (double *) R_alloc(J, sizeof(double)); - - // 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 - * *******************************************************************/ - 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; - } - double *theta = (double *) R_alloc(nTheta, sizeof(double)); - SEXP thetaSamples_r; - PROTECT(thetaSamples_r = allocMatrix(REALSXP, nTheta, nPost)); nProtect++; - double a, v, b, e, muNNGP, var, aij; - // Initiate spatial values - theta[sigmaSqIndx] = REAL(sigmaSqStarting_r)[0]; - theta[phiIndx] = REAL(phiStarting_r)[0]; - double phi = theta[phiIndx]; - double sigmaSq = theta[sigmaSqIndx]; - double nu = REAL(nuStarting_r)[0]; - if (corName == "matern") { - theta[nuIndx] = nu; - } - - double *C = (double *) R_alloc(JJ, sizeof(double)); - double *CCand = (double *) R_alloc(JJ, sizeof(double)); - double *tmp_JD = (double *) R_alloc(J, sizeof(double)); - double *tmp_JD2 = (double *) R_alloc(J, sizeof(double)); - double *R = (double *) R_alloc(JJ, sizeof(double)); - if (sigmaSqIG) { - spCorLT(coordsD, J, theta, corName, R); - } - spCovLT(coordsD, J, theta, corName, C); - F77_NAME(dpotrf)(lower, &J, C, &J, &info FCONE); - if(info != 0){error("c++ error: Cholesky failed in initial covariance matrix\n");} - F77_NAME(dpotri)(lower, &J, C, &J, &info FCONE); - if(info != 0){error("c++ error: Cholesky inverse failed in initial covariance matrix\n");} - // For sigmaSq sampler - double aSigmaSqPost = 0.5 * J + sigmaSqA; - double bSigmaSqPost = 0.0; - double *wTRInv = (double *) R_alloc(J, sizeof(double)); - - /******************************************************************** - 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(J, sizeof(double)); - double *logPostWCurr = (double *) R_alloc(J, sizeof(double)); - for (j = 0; j < J; 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, detCand, detCurr; - double phiCand = 0.0, nuCand = 0.0, sigmaSqCand = 0.0; - double *betaCand = (double *) R_alloc(pAbund, sizeof(double)); - for (j = 0; j < pAbund; j++) { - betaCand[j] = beta[j]; - } - double *wCand = (double *) R_alloc(J, sizeof(double)); - for (j = 0; j < J; j++) { - wCand[j] = w[j]; - } - 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 = nTheta + pAbund + J + nAbundRE; - } else { - nAMCMC = nTheta + pAbund + J; - } - if (family == 1) { - nAMCMC++; - } - int betaAMCMCIndx = 0; - int sigmaSqAMCMCIndx = betaAMCMCIndx + pAbund; - int phiAMCMCIndx = sigmaSqAMCMCIndx + 1; - int nuAMCMCIndx; - if (corName == "matern") { - nuAMCMCIndx = phiAMCMCIndx + 1; - } else { - nuAMCMCIndx = phiAMCMCIndx; - } - int wAMCMCIndx = nuAMCMCIndx + 1; - int betaStarAMCMCIndx = wAMCMCIndx + J; - int kappaAMCMCIndx = betaStarAMCMCIndx + nAbundRE; - double *accept = (double *) R_alloc(nAMCMC, sizeof(double)); zeros(accept, nAMCMC); - // TODO: will probably want to cut this back eventually. - SEXP acceptSamples_r; - PROTECT(acceptSamples_r = allocMatrix(REALSXP, nAMCMC, nBatch)); nProtect++; - SEXP tuningSamples_r; - PROTECT(tuningSamples_r = allocMatrix(REALSXP, nAMCMC, nBatch)); nProtect++; - - /********************************************************************** - * Prep for random effects - * *******************************************************************/ - // 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 Abundance Regression Coefficients - *******************************************************************/ - // Proposal - for (k = 0; k < pAbund; k++) { - logPostBetaCand = 0.0; - logPostBetaCurr = 0.0; - betaCand[k] = rnorm(beta[k], exp(tuning[betaAMCMCIndx + k])); - for (i = 0; i < pAbund; i++) { - logPostBetaCand += dnorm(betaCand[i], muBeta[i], sqrt(SigmaBeta[i * pAbund + i]), 1); - logPostBetaCurr += dnorm(beta[i], muBeta[i], sqrt(SigmaBeta[i * pAbund + i]), 1); - } - for (j = 0; j < nObs; j++) { - tmp_nObs[j] = exp(F77_NAME(ddot)(&pAbund, &X[j], &nObs, betaCand, &inc) + betaStarSites[j] + - w[siteIndx[j]]); - if (family == 1) { - logPostBetaCand += dnbinom_mu(y[j], kappa, tmp_nObs[j], 1); - } else { - logPostBetaCand += dpois(y[j], tmp_nObs[j], 1); - } - tmp_nObs[j] = exp(F77_NAME(ddot)(&pAbund, &X[j], &nObs, beta, &inc) + betaStarSites[j] + - w[siteIndx[j]]); - if (family == 1) { - logPostBetaCurr += dnbinom_mu(y[j], kappa, tmp_nObs[j], 1); - } else { - logPostBetaCurr += dpois(y[j], tmp_nObs[j], 1); - } - } - if (runif(0.0, 1.0) <= exp(logPostBetaCand - logPostBetaCurr)) { - beta[k] = betaCand[k]; - accept[betaAMCMCIndx + k]++; - } else { - betaCand[k] = beta[k]; - } - } - - /******************************************************************** - *Update abundance random effects variance - *******************************************************************/ - 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] + nAbundRELong[l] / 2.0, sigmaSqMuB[l] + tmp_0); - } - - /******************************************************************** - *Update abundance random effects - *******************************************************************/ - 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] + w[siteIndx[j]]); - if (family == 1) { - logPostBetaStarCand[l] += dnbinom_mu(y[j], kappa, tmp_nObs[j], 1); - } else { - logPostBetaStarCand[l] += dpois(y[j], tmp_nObs[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] + w[siteIndx[j]]); - if (family == 1) { - logPostBetaStarCurr[l] += dnbinom_mu(y[j], kappa, tmp_nObs[j], 1); - } else { - logPostBetaStarCurr[l] += dpois(y[j], tmp_nObs[j], 1); - } - } - } - 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 sigmaSq - *******************************************************************/ - if (sigmaSqIG) { - // Get inverse correlation matrix in reverse from inverse covariance matrix - // Remember: C currently contains the inverse of covariance matrix. - fillUTri(C, J); - for (j = 0; j < JJ; j++) { - R[j] = theta[sigmaSqIndx] * C[j]; - } // j - // Compute t(w) %*% R^-1 %*% w / - // t(w) %*% R^-1 - // Def a better way to do this operation. - for (j = 0; j < J; j++) { - wTRInv[j] = F77_NAME(ddot)(&J, &R[j], &J, w, &inc); - } // j - bSigmaSqPost = F77_NAME(ddot)(&J, wTRInv, &inc, w, &inc); - bSigmaSqPost /= 2.0; - bSigmaSqPost += sigmaSqB; - theta[sigmaSqIndx] = rigamma(aSigmaSqPost, bSigmaSqPost); - } - - /******************************************************************** - *Update phi (and nu if matern and sigmaSq if uniform prior) - *******************************************************************/ - if (corName == "matern") { - nu = theta[nuIndx]; - nuCand = logitInv(rnorm(logit(theta[nuIndx], nuA, nuB), exp(tuning[nuAMCMCIndx])), nuA, nuB); - theta[nuIndx] = nuCand; - } - phi = theta[phiIndx]; - phiCand = logitInv(rnorm(logit(phi, phiA, phiB), exp(tuning[phiAMCMCIndx])), phiA, phiB); - theta[phiIndx] = phiCand; - if (sigmaSqIG == 0) { - sigmaSq = theta[sigmaSqIndx]; - sigmaSqCand = logitInv(rnorm(logit(sigmaSq, sigmaSqA, sigmaSqB), - exp(tuning[sigmaSqAMCMCIndx])), sigmaSqA, sigmaSqB); - theta[sigmaSqIndx] = sigmaSqCand; - } - - // Construct covariance matrix (stored in C). - spCovLT(coordsD, J, theta, corName, CCand); - - /******************************** - * Proposal - *******************************/ - // Invert CCand and log det cov. - detCand = 0.0; - F77_NAME(dpotrf)(lower, &J, CCand, &J, &info FCONE); - if(info != 0){error("c++ error: Cholesky failed in covariance matrix\n");} - // Get log of the determinant of the covariance matrix. - for (k = 0; k < J; k++) { - detCand += 2.0 * log(CCand[k*J+k]); - } // k - F77_NAME(dpotri)(lower, &J, CCand, &J, &info FCONE); - if(info != 0){error("c++ error: Cholesky inverse failed in covariance matrix\n");} - logPostThetaCand = 0.0; - // Jacobian and Uniform prior. - logPostThetaCand += log(phiCand - phiA) + log(phiB - phiCand); - // (-1/2) * tmp_JD` * C^-1 * tmp_JD - F77_NAME(dsymv)(lower, &J, &one, CCand, &J, w, &inc, &zero, tmp_JD, &inc FCONE); - logPostThetaCand += -0.5*detCand-0.5*F77_NAME(ddot)(&J, w, &inc, tmp_JD, &inc); - if (corName == "matern"){ - logPostThetaCand += log(nuCand - nuA) + log(nuB - nuCand); - } - if (sigmaSqIG == 0) { - logPostThetaCand += log(sigmaSqCand - sigmaSqA) + log(sigmaSqB - sigmaSqCand); - } - - /******************************** - * Current - *******************************/ - if (corName == "matern") { - theta[nuIndx] = nu; - } - theta[phiIndx] = phi; - if (sigmaSqIG == 0) { - theta[sigmaSqIndx] = sigmaSq; - } - spCovLT(coordsD, J, theta, corName, C); - detCurr = 0.0; - F77_NAME(dpotrf)(lower, &J, C, &J, &info FCONE); - if(info != 0){error("c++ error: Cholesky failed in covariance matrix\n");} - for (k = 0; k < J; k++) { - detCurr += 2.0 * log(C[k*J+k]); - } // k - F77_NAME(dpotri)(lower, &J, C, &J, &info FCONE); - if(info != 0){error("c++ error: Cholesky inverse failed in covariance matrix\n");} - logPostThetaCurr = 0.0; - logPostThetaCurr += log(phi - phiA) + log(phiB - phi); - // (-1/2) * tmp_JD` * C^-1 * tmp_JD - F77_NAME(dsymv)(lower, &J, &one, C, &J, w, &inc, &zero, tmp_JD, &inc FCONE); - logPostThetaCurr += -0.5*detCurr-0.5*F77_NAME(ddot)(&J, w, &inc, tmp_JD, &inc); - if (corName == "matern"){ - logPostThetaCurr += log(nu - nuA) + log(nuB - nu); - } - if (sigmaSqIG == 0) { - logPostThetaCurr += log(sigmaSq - sigmaSqA) + log(sigmaSqB - sigmaSq); - } - - // MH Accept/Reject - if (runif(0.0, 1.0) <= exp(logPostThetaCand - logPostThetaCurr)) { - theta[phiIndx] = phiCand; - accept[phiAMCMCIndx]++; - if (corName == "matern") { - theta[nuIndx] = nuCand; - accept[nuAMCMCIndx]++; - } - if (sigmaSqIG == 0) { - theta[sigmaSqIndx] = sigmaSqCand; - accept[sigmaSqAMCMCIndx]++; - } - F77_NAME(dcopy)(&JJ, CCand, &inc, C, &inc); - } - - /******************************************************************** - *Update w (spatial random effects) - *******************************************************************/ - for (j = 0; j < J; j++) { - // Proposal - a = 0.0; - // Propose new value - logPostWCand[j] = 0.0; - wCand[j] = rnorm(w[j], exp(tuning[wAMCMCIndx + j])); - /******************************** - * Proposal - *******************************/ - // (-1/2) * tmp_JD` * C^-1 * tmp_JD - F77_NAME(dsymv)(lower, &J, &one, C, &J, wCand, &inc, &zero, tmp_JD, &inc FCONE); - logPostWCand[j] += -0.5*F77_NAME(ddot)(&J, wCand, &inc, tmp_JD, &inc); - 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] + wCand[j]); - if (family == 1) { - logPostWCand[j] += dnbinom_mu(y[i], kappa, tmp_nObs[i], 1); - } else { - logPostWCand[j] += dpois(y[i], tmp_nObs[i], 1); - } - } - } - /******************************** - * Current - *******************************/ - logPostWCurr[j] = 0.0; - // (-1/2) * tmp_JD` * C^-1 * tmp_JD - F77_NAME(dsymv)(lower, &J, &one, C, &J, w, &inc, &zero, tmp_JD, &inc FCONE); - logPostWCurr[j] += -0.5*F77_NAME(ddot)(&J, w, &inc, tmp_JD, &inc); - 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] + w[j]); - if (family == 1) { - logPostWCurr[j] += dnbinom_mu(y[i], kappa, tmp_nObs[i], 1); - } else { - logPostWCurr[j] += dpois(y[i], tmp_nObs[i], 1); - } - } - } - if (runif(0.0, 1.0) <= exp(logPostWCand[j] - logPostWCurr[j])) { - w[j] = wCand[j]; - accept[wAMCMCIndx + j]++; - } else { - wCand[j] = w[j]; - } - } - - /******************************************************************** - *Update kappa (the NB size parameter) - *******************************************************************/ - 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] + w[siteIndx[j]]); - logPostKappaCurr += dnbinom_mu(y[j], kappa, mu[j], 1); - logPostKappaCand += dnbinom_mu(y[j], kappaCand, mu[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 - *******************************************************************/ - 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] + w[siteIndx[j]]); - yRep[j] = rpois(mu[j]); - like[j] = dpois(y[j], mu[j], 0); - } else { - yRep[j] = rnbinom_mu(kappa, mu[j]); - like[j] = dnbinom_mu(y[j], kappa, mu[j], 0); - } - } - - /******************************************************************** - *Save samples - *******************************************************************/ - if (g >= nBurn) { - thinIndx++; - if (thinIndx == nThin) { - F77_NAME(dcopy)(&pAbund, beta, &inc, &REAL(betaSamples_r)[sPost*pAbund], &inc); - 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)(&nTheta, theta, &inc, &REAL(thetaSamples_r)[sPost*nTheta], &inc); - F77_NAME(dcopy)(&J, w, &inc, &REAL(wSamples_r)[sPost*J], &inc); - if (family == 1) { - REAL(kappaSamples_r)[sPost] = kappa; - } - 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); - } - F77_NAME(dcopy)(&nObs, like, &inc, - &REAL(likeSamples_r)[sPost*nObs], &inc); - sPost++; - thinIndx = 0; - } - } - R_CheckUserInterrupt(); - } // t (end batch) - /******************************************************************** - *Adjust tuning - *******************************************************************/ - 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] = 0; - } - - /******************************************************************** - *Report - *******************************************************************/ - if (verbose) { - 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])); - } - Rprintf("\tphi\t\t%3.1f\t\t%1.5f\n", 100.0*REAL(acceptSamples_r)[s * nAMCMC + phiAMCMCIndx], exp(tuning[phiAMCMCIndx])); - if (corName == "matern") { - Rprintf("\tnu\t\t%3.1f\t\t%1.5f\n", 100.0*REAL(acceptSamples_r)[s * nAMCMC + nuAMCMCIndx], exp(tuning[nuAMCMCIndx])); - } - if (sigmaSqIG == 0) { - Rprintf("\tsigmaSq\t\t%3.1f\t\t%1.5f\n", 100.0*REAL(acceptSamples_r)[s * nAMCMC + sigmaSqAMCMCIndx], exp(tuning[sigmaSqAMCMCIndx])); - } - 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(); - #endif - status = 0; - } - } - status++; - - } // all batches - if (verbose) { - Rprintf("Batch: %i of %i, %3.2f%%\n", s, nBatch, 100.0*s/nBatch); - } - PutRNGstate(); - - SEXP result_r, resultName_r; - int nResultListObjs = 6; - if (pAbundRE > 0) { - nResultListObjs += 2; - } - if (family == 1) { - nResultListObjs += 1; - } - - PROTECT(result_r = allocVector(VECSXP, nResultListObjs)); nProtect++; - PROTECT(resultName_r = 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, 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); - } - - SET_VECTOR_ELT(resultName_r, 0, mkChar("beta.samples")); - SET_VECTOR_ELT(resultName_r, 1, mkChar("y.rep.samples")); - SET_VECTOR_ELT(resultName_r, 2, mkChar("mu.samples")); - SET_VECTOR_ELT(resultName_r, 3, mkChar("like.samples")); - SET_VECTOR_ELT(resultName_r, 4, mkChar("w.samples")); - SET_VECTOR_ELT(resultName_r, 5, mkChar("theta.samples")); - if (pAbundRE > 0) { - SET_VECTOR_ELT(resultName_r, 6, mkChar("sigma.sq.mu.samples")); - SET_VECTOR_ELT(resultName_r, 7, mkChar("beta.star.samples")); - } - if (family == 1) { - SET_VECTOR_ELT(resultName_r, tmp_0, mkChar("kappa.samples")); - } - - namesgets(result_r, resultName_r); - - UNPROTECT(nProtect); - - return(result_r); - } -} - diff --git a/src/spAbundGaussianNNGP.cpp b/src/spAbundGaussianNNGP.cpp index 86f960e..8dc6814 100644 --- a/src/spAbundGaussianNNGP.cpp +++ b/src/spAbundGaussianNNGP.cpp @@ -106,6 +106,7 @@ extern "C" { int pRE = INTEGER(consts_r)[2]; int nRE = INTEGER(consts_r)[3]; int JZero = INTEGER(consts_r)[4]; + int saveFitted = INTEGER(consts_r)[5]; int pp = p * p; int JpRE = J * pRE; // Priors @@ -224,26 +225,36 @@ extern "C" { * *******************************************************************/ SEXP betaSamples_r; PROTECT(betaSamples_r = allocMatrix(REALSXP, p, nPost)); nProtect++; + zeros(REAL(betaSamples_r), p * nPost); SEXP yRepSamples_r; - PROTECT(yRepSamples_r = allocMatrix(REALSXP, J, nPost)); nProtect++; SEXP yRepZeroSamples_r; - PROTECT(yRepZeroSamples_r = allocMatrix(REALSXP, JZero, nPost)); nProtect++; + SEXP muSamples_r; + SEXP likeSamples_r; + if (saveFitted == 1) { + PROTECT(yRepSamples_r = allocMatrix(REALSXP, J, nPost)); nProtect++; + zeros(REAL(yRepSamples_r), J * nPost); + PROTECT(yRepZeroSamples_r = allocMatrix(REALSXP, JZero, nPost)); nProtect++; + zeros(REAL(yRepZeroSamples_r), JZero * nPost); + PROTECT(muSamples_r = allocMatrix(REALSXP, J, nPost)); nProtect++; + zeros(REAL(muSamples_r), J * nPost); + PROTECT(likeSamples_r = allocMatrix(REALSXP, J, nPost)); nProtect++; + zeros(REAL(likeSamples_r), J * nPost); + } SEXP wSamples_r; PROTECT(wSamples_r = allocMatrix(REALSXP, J, nPost)); nProtect++; - SEXP muSamples_r; - PROTECT(muSamples_r = allocMatrix(REALSXP, J, nPost)); nProtect++; + zeros(REAL(wSamples_r), J * nPost); // Occurrence random effects SEXP sigmaSqMuSamples_r; SEXP betaStarSamples_r; if (pRE > 0) { PROTECT(sigmaSqMuSamples_r = allocMatrix(REALSXP, pRE, nPost)); nProtect++; + zeros(REAL(sigmaSqMuSamples_r), pRE * nPost); PROTECT(betaStarSamples_r = allocMatrix(REALSXP, nRE, nPost)); nProtect++; + zeros(REAL(betaStarSamples_r), nRE * nPost); } SEXP tauSqSamples_r; PROTECT(tauSqSamples_r = allocMatrix(REALSXP, inc, nPost)); nProtect++; - // Likelihood samples for WAIC. - SEXP likeSamples_r; - PROTECT(likeSamples_r = allocMatrix(REALSXP, J, nPost)); nProtect++; + zeros(REAL(tauSqSamples_r), nPost); /********************************************************************** * Other initial starting stuff @@ -317,10 +328,13 @@ extern "C" { double phiCand = 0.0, nuCand = 0.0, sigmaSqCand = 0.0; SEXP acceptSamples_r; PROTECT(acceptSamples_r = allocMatrix(REALSXP, nTheta, nBatch)); nProtect++; + zeros(REAL(acceptSamples_r), nTheta * nBatch); SEXP tuningSamples_r; PROTECT(tuningSamples_r = allocMatrix(REALSXP, nTheta, nBatch)); nProtect++; + zeros(REAL(tuningSamples_r), nTheta * nBatch); SEXP thetaSamples_r; PROTECT(thetaSamples_r = allocMatrix(REALSXP, nTheta, nPost)); nProtect++; + zeros(REAL(thetaSamples_r), nTheta * nPost); double a, v, b, e, muNNGP, var, aij; theta[sigmaSqIndx] = sigmaSq; theta[phiIndx] = phi; @@ -618,18 +632,21 @@ extern "C" { /******************************************************************** *Get fitted values and likelihood for WAIC *******************************************************************/ - for (j = 0; j < J; j++) { - mu[j] = F77_NAME(ddot)(&p, &X[j], &J, beta, &inc) + w[j] + betaStarSites[j]; - yRep[j] = rnorm(mu[j], sqrt(tauSq)); - like[j] = dnorm(y[j], mu[j], sqrt(tauSq), 0); - } // j + if (saveFitted == 1) { + for (j = 0; j < J; j++) { + mu[j] = F77_NAME(ddot)(&p, &X[j], &J, beta, &inc) + w[j] + betaStarSites[j]; + yRep[j] = rnorm(mu[j], sqrt(tauSq)); + like[j] = dnorm(y[j], mu[j], sqrt(tauSq), 0); + } // j + } /******************************************************************** *Get fitted values and likelihood for WAIC for the zero values *******************************************************************/ - for (j = 0; j < JZero; j++) { - yRepZero[j] = rnorm(0.0, sqrt(0.0001)); - } // j - + if (saveFitted == 1) { + for (j = 0; j < JZero; j++) { + yRepZero[j] = rnorm(0.0, sqrt(0.0001)); + } // j + } /******************************************************************** *Save samples *******************************************************************/ @@ -637,21 +654,23 @@ extern "C" { 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); F77_NAME(dcopy)(&J, w, &inc, &REAL(wSamples_r)[sPost*J], &inc); REAL(tauSqSamples_r)[sPost] = tauSq; F77_NAME(dcopy)(&nTheta, theta, &inc, &REAL(thetaSamples_r)[sPost*nTheta], &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 (saveFitted == 1) { + F77_NAME(dcopy)(&J, yRep, &inc, &REAL(yRepSamples_r)[sPost*J], &inc); + F77_NAME(dcopy)(&JZero, yRepZero, &inc, &REAL(yRepZeroSamples_r)[sPost*JZero], &inc); + F77_NAME(dcopy)(&J, mu, &inc, &REAL(muSamples_r)[sPost*J], &inc); + F77_NAME(dcopy)(&J, like, &inc, + &REAL(likeSamples_r)[sPost*J], &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); } - F77_NAME(dcopy)(&J, like, &inc, - &REAL(likeSamples_r)[sPost*J], &inc); sPost++; thinIndx = 0; } @@ -716,14 +735,16 @@ extern "C" { // 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); + if (saveFitted == 1) { + SET_VECTOR_ELT(result_r, 2, yRepSamples_r); + SET_VECTOR_ELT(result_r, 3, muSamples_r); + SET_VECTOR_ELT(result_r, 8, likeSamples_r); + SET_VECTOR_ELT(result_r, 9, yRepZeroSamples_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); @@ -732,14 +753,16 @@ extern "C" { // mkChar turns a C string into a CHARSXP SET_VECTOR_ELT(resultName_r, 0, mkChar("beta.samples")); SET_VECTOR_ELT(resultName_r, 1, mkChar("tau.sq.samples")); - SET_VECTOR_ELT(resultName_r, 2, mkChar("y.rep.samples")); - SET_VECTOR_ELT(resultName_r, 3, mkChar("mu.samples")); + if (saveFitted == 1) { + SET_VECTOR_ELT(resultName_r, 2, mkChar("y.rep.samples")); + SET_VECTOR_ELT(resultName_r, 3, mkChar("mu.samples")); + SET_VECTOR_ELT(resultName_r, 8, mkChar("like.samples")); + SET_VECTOR_ELT(resultName_r, 9, mkChar("y.rep.zero.samples")); + } SET_VECTOR_ELT(resultName_r, 4, mkChar("theta.samples")); SET_VECTOR_ELT(resultName_r, 5, mkChar("w.samples")); SET_VECTOR_ELT(resultName_r, 6, mkChar("tune")); SET_VECTOR_ELT(resultName_r, 7, mkChar("accept")); - SET_VECTOR_ELT(resultName_r, 8, mkChar("like.samples")); - SET_VECTOR_ELT(resultName_r, 9, mkChar("y.rep.zero.samples")); if (pRE > 0) { SET_VECTOR_ELT(resultName_r, 10, mkChar("sigma.sq.mu.samples")); SET_VECTOR_ELT(resultName_r, 11, mkChar("beta.star.samples")); diff --git a/src/spAbundNNGP.cpp b/src/spAbundNNGP.cpp index e0e521c..160b4df 100755 --- a/src/spAbundNNGP.cpp +++ b/src/spAbundNNGP.cpp @@ -218,6 +218,7 @@ extern "C" { * *******************************************************************/ SEXP betaSamples_r; PROTECT(betaSamples_r = allocMatrix(REALSXP, pAbund, nPost)); nProtect++; + zeros(REAL(betaSamples_r), pAbund * nPost); SEXP yRepSamples_r; SEXP muSamples_r; SEXP likeSamples_r; @@ -231,16 +232,20 @@ extern "C" { } SEXP wSamples_r; PROTECT(wSamples_r = allocMatrix(REALSXP, J, nPost)); nProtect++; + zeros(REAL(wSamples_r), J * nPost); SEXP kappaSamples_r; if (family == 1) { PROTECT(kappaSamples_r = allocMatrix(REALSXP, inc, nPost)); nProtect++; + zeros(REAL(kappaSamples_r), nPost); } // Abundance random effects SEXP sigmaSqMuSamples_r; SEXP betaStarSamples_r; if (pAbundRE > 0) { PROTECT(sigmaSqMuSamples_r = allocMatrix(REALSXP, pAbundRE, nPost)); nProtect++; + zeros(REAL(sigmaSqMuSamples_r), pAbundRE * nPost); PROTECT(betaStarSamples_r = allocMatrix(REALSXP, nAbundRE, nPost)); nProtect++; + zeros(REAL(betaStarSamples_r), nAbundRE * nPost); } /******************************************************************** @@ -270,6 +275,7 @@ extern "C" { double *theta = (double *) R_alloc(nTheta, sizeof(double)); SEXP thetaSamples_r; PROTECT(thetaSamples_r = allocMatrix(REALSXP, nTheta, nPost)); nProtect++; + zeros(REAL(thetaSamples_r), nTheta * nPost); double a, b, e; // Initiate spatial values theta[sigmaSqIndx] = REAL(sigmaSqStarting_r)[0]; @@ -358,8 +364,10 @@ extern "C" { double *accept = (double *) R_alloc(nAMCMC, sizeof(double)); zeros(accept, nAMCMC); SEXP acceptSamples_r; PROTECT(acceptSamples_r = allocMatrix(REALSXP, nAMCMC, nBatch)); nProtect++; + zeros(REAL(acceptSamples_r), nAMCMC * nBatch); SEXP tuningSamples_r; PROTECT(tuningSamples_r = allocMatrix(REALSXP, nAMCMC, nBatch)); nProtect++; + zeros(REAL(tuningSamples_r), nAMCMC * nBatch); /********************************************************************** * Prep for random effects diff --git a/src/spDSNNGP.cpp b/src/spDSNNGP.cpp index 0f82707..7ea5ffe 100755 --- a/src/spDSNNGP.cpp +++ b/src/spDSNNGP.cpp @@ -250,39 +250,51 @@ extern "C" { * *******************************************************************/ SEXP betaSamples_r; PROTECT(betaSamples_r = allocMatrix(REALSXP, pAbund, nPost)); nProtect++; + zeros(REAL(betaSamples_r), pAbund * nPost); SEXP alphaSamples_r; PROTECT(alphaSamples_r = allocMatrix(REALSXP, pDet, nPost)); nProtect++; + zeros(REAL(alphaSamples_r), pDet * nPost); SEXP NSamples_r; PROTECT(NSamples_r = allocMatrix(REALSXP, J, nPost)); nProtect++; + zeros(REAL(NSamples_r), J * nPost); SEXP kappaSamples_r; if (family == 1) { PROTECT(kappaSamples_r = allocMatrix(REALSXP, inc, nPost)); nProtect++; + zeros(REAL(kappaSamples_r), nPost); } SEXP muSamples_r; PROTECT(muSamples_r = allocMatrix(REALSXP, J, nPost)); nProtect++; + zeros(REAL(muSamples_r), J * nPost); SEXP wSamples_r; PROTECT(wSamples_r = allocMatrix(REALSXP, J, nPost)); nProtect++; + zeros(REAL(wSamples_r), J * nPost); // Detection random effects SEXP sigmaSqPSamples_r; SEXP alphaStarSamples_r; if (pDetRE > 0) { PROTECT(sigmaSqPSamples_r = allocMatrix(REALSXP, pDetRE, nPost)); nProtect++; + zeros(REAL(sigmaSqPSamples_r), pDetRE * nPost); PROTECT(alphaStarSamples_r = allocMatrix(REALSXP, nDetRE, nPost)); nProtect++; + zeros(REAL(alphaStarSamples_r), nDetRE * nPost); } // Abundance random effects SEXP sigmaSqMuSamples_r; SEXP betaStarSamples_r; if (pAbundRE > 0) { PROTECT(sigmaSqMuSamples_r = allocMatrix(REALSXP, pAbundRE, nPost)); nProtect++; + zeros(REAL(sigmaSqMuSamples_r), pAbundRE * nPost); PROTECT(betaStarSamples_r = allocMatrix(REALSXP, nAbundRE, nPost)); nProtect++; + zeros(REAL(betaStarSamples_r), nAbundRE * nPost); } // Stuff for fitted values int KFull = K + 1; int nObsFull = KFull * J; SEXP yRepSamples_r; PROTECT(yRepSamples_r = allocMatrix(INTSXP, nObsFull, nPost)); nProtect++; + zeros(REAL(yRepSamples_r), nObsFull * nPost); SEXP piFullSamples_r; PROTECT(piFullSamples_r = allocMatrix(REALSXP, nObsFull, nPost)); nProtect++; + zeros(REAL(piFullSamples_r), nObsFull * nPost); /******************************************************************** Some constants and temporary variables to be used later @@ -311,6 +323,7 @@ extern "C" { double *theta = (double *) R_alloc(nTheta, sizeof(double)); SEXP thetaSamples_r; PROTECT(thetaSamples_r = allocMatrix(REALSXP, nTheta, nPost)); nProtect++; + zeros(REAL(thetaSamples_r), nTheta * nPost); double a, b, e; // Initiate spatial values theta[sigmaSqIndx] = REAL(sigmaSqStarting_r)[0]; @@ -428,8 +441,10 @@ extern "C" { } SEXP acceptSamples_r; PROTECT(acceptSamples_r = allocMatrix(REALSXP, nAMCMC, nBatch)); nProtect++; + zeros(REAL(acceptSamples_r), nAMCMC * nBatch); SEXP tuningSamples_r; PROTECT(tuningSamples_r = allocMatrix(REALSXP, nAMCMC, nBatch)); nProtect++; + zeros(REAL(tuningSamples_r), nAMCMC * nBatch); /********************************************************************** * Prep for random effects diff --git a/src/spNMixNNGP.cpp b/src/spNMixNNGP.cpp index cae47a2..216d8c1 100755 --- a/src/spNMixNNGP.cpp +++ b/src/spNMixNNGP.cpp @@ -248,31 +248,41 @@ extern "C" { * *******************************************************************/ SEXP betaSamples_r; PROTECT(betaSamples_r = allocMatrix(REALSXP, pAbund, nPost)); nProtect++; + zeros(REAL(betaSamples_r), pAbund * nPost); SEXP alphaSamples_r; PROTECT(alphaSamples_r = allocMatrix(REALSXP, pDet, nPost)); nProtect++; + zeros(REAL(alphaSamples_r), pDet * nPost); SEXP NSamples_r; PROTECT(NSamples_r = allocMatrix(REALSXP, J, nPost)); nProtect++; + zeros(REAL(NSamples_r), J * nPost); SEXP kappaSamples_r; if (family == 1) { PROTECT(kappaSamples_r = allocMatrix(REALSXP, inc, nPost)); nProtect++; + zeros(REAL(kappaSamples_r), nPost); } SEXP muSamples_r; PROTECT(muSamples_r = allocMatrix(REALSXP, J, nPost)); nProtect++; + zeros(REAL(muSamples_r), J * nPost); SEXP wSamples_r; PROTECT(wSamples_r = allocMatrix(REALSXP, J, nPost)); nProtect++; + zeros(REAL(wSamples_r), J * nPost); // Detection random effects SEXP sigmaSqPSamples_r; SEXP alphaStarSamples_r; if (pDetRE > 0) { PROTECT(sigmaSqPSamples_r = allocMatrix(REALSXP, pDetRE, nPost)); nProtect++; + zeros(REAL(sigmaSqPSamples_r), pDetRE * nPost); PROTECT(alphaStarSamples_r = allocMatrix(REALSXP, nDetRE, nPost)); nProtect++; + zeros(REAL(alphaStarSamples_r), nDetRE * nPost); } // Abundance random effects SEXP sigmaSqMuSamples_r; SEXP betaStarSamples_r; if (pAbundRE > 0) { PROTECT(sigmaSqMuSamples_r = allocMatrix(REALSXP, pAbundRE, nPost)); nProtect++; + zeros(REAL(sigmaSqMuSamples_r), pAbundRE * nPost); PROTECT(betaStarSamples_r = allocMatrix(REALSXP, nAbundRE, nPost)); nProtect++; + zeros(REAL(betaStarSamples_r), nAbundRE * nPost); } /******************************************************************** @@ -301,6 +311,7 @@ extern "C" { double *theta = (double *) R_alloc(nTheta, sizeof(double)); SEXP thetaSamples_r; PROTECT(thetaSamples_r = allocMatrix(REALSXP, nTheta, nPost)); nProtect++; + zeros(REAL(thetaSamples_r), nTheta * nPost); double a, b, e; // Initiate spatial values theta[sigmaSqIndx] = REAL(sigmaSqStarting_r)[0]; @@ -414,8 +425,10 @@ extern "C" { double *accept = (double *) R_alloc(nAMCMC, sizeof(double)); zeros(accept, nAMCMC); SEXP acceptSamples_r; PROTECT(acceptSamples_r = allocMatrix(REALSXP, nAMCMC, nBatch)); nProtect++; + zeros(REAL(acceptSamples_r), nAMCMC * nBatch); SEXP tuningSamples_r; PROTECT(tuningSamples_r = allocMatrix(REALSXP, nAMCMC, nBatch)); nProtect++; + zeros(REAL(tuningSamples_r), nAMCMC * nBatch); /********************************************************************** diff --git a/src/svcAbundNNGP.cpp b/src/svcAbundNNGP.cpp index de0ee37..c1dc938 100644 --- a/src/svcAbundNNGP.cpp +++ b/src/svcAbundNNGP.cpp @@ -226,26 +226,35 @@ extern "C" { * *******************************************************************/ SEXP betaSamples_r; PROTECT(betaSamples_r = allocMatrix(REALSXP, p, nPost)); nProtect++; + zeros(REAL(betaSamples_r), p * nPost); SEXP yRepSamples_r; PROTECT(yRepSamples_r = allocMatrix(REALSXP, J, nPost)); nProtect++; + zeros(REAL(yRepSamples_r), J * nPost); SEXP yRepZeroSamples_r; PROTECT(yRepZeroSamples_r = allocMatrix(REALSXP, JZero, nPost)); nProtect++; + zeros(REAL(yRepZeroSamples_r), JZero * nPost); SEXP wSamples_r; PROTECT(wSamples_r = allocMatrix(REALSXP, JpTilde, nPost)); nProtect++; + zeros(REAL(wSamples_r), JpTilde * nPost); SEXP muSamples_r; PROTECT(muSamples_r = allocMatrix(REALSXP, J, nPost)); nProtect++; + zeros(REAL(muSamples_r), J * nPost); // Occurrence random effects SEXP sigmaSqMuSamples_r; SEXP betaStarSamples_r; if (pRE > 0) { PROTECT(sigmaSqMuSamples_r = allocMatrix(REALSXP, pRE, nPost)); nProtect++; + zeros(REAL(sigmaSqMuSamples_r), pRE * nPost); PROTECT(betaStarSamples_r = allocMatrix(REALSXP, nRE, nPost)); nProtect++; + zeros(REAL(betaStarSamples_r), nRE * nPost); } SEXP tauSqSamples_r; PROTECT(tauSqSamples_r = allocMatrix(REALSXP, inc, nPost)); nProtect++; + zeros(REAL(tauSqSamples_r), nPost); // Likelihood samples for WAIC. SEXP likeSamples_r; PROTECT(likeSamples_r = allocMatrix(REALSXP, J, nPost)); nProtect++; + zeros(REAL(likeSamples_r), J * nPost); /********************************************************************** * Other initial starting stuff @@ -322,10 +331,13 @@ extern "C" { double phiCand = 0.0, nuCand = 0.0; SEXP acceptSamples_r; PROTECT(acceptSamples_r = allocMatrix(REALSXP, nThetapTilde, nBatch)); nProtect++; + zeros(REAL(acceptSamples_r), nThetapTilde * nBatch); SEXP tuningSamples_r; PROTECT(tuningSamples_r = allocMatrix(REALSXP, nThetapTilde, nBatch)); nProtect++; + zeros(REAL(tuningSamples_r), nThetapTilde * nBatch); SEXP thetaSamples_r; PROTECT(thetaSamples_r = 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)); diff --git a/src/svcAbundNNGPPredict.cpp b/src/svcAbundNNGPPredict.cpp index 27499bc..87653bf 100644 --- a/src/svcAbundNNGPPredict.cpp +++ b/src/svcAbundNNGPPredict.cpp @@ -50,7 +50,6 @@ extern "C" { 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); diff --git a/src/svcMsAbundGaussianNNGP.cpp b/src/svcMsAbundGaussianNNGP.cpp index 04e7a88..e04e160 100644 --- a/src/svcMsAbundGaussianNNGP.cpp +++ b/src/svcMsAbundGaussianNNGP.cpp @@ -220,7 +220,6 @@ extern "C" { int Nq = N * q; int Jp = J * p; int JpRE = J * pRE; - int JpTilde = J * pTilde; int qpTilde = q * pTilde; int JqpTilde = J * q * pTilde; int JNpTilde = J * N * pTilde; @@ -293,17 +292,23 @@ extern "C" { // Community level SEXP betaCommSamples_r; PROTECT(betaCommSamples_r = allocMatrix(REALSXP, p, nPost)); nProtect++; + zeros(REAL(betaCommSamples_r), p * nPost); SEXP tauSqBetaSamples_r; PROTECT(tauSqBetaSamples_r = allocMatrix(REALSXP, p, nPost)); nProtect++; + zeros(REAL(tauSqBetaSamples_r), p * nPost); // Species level SEXP betaSamples_r; PROTECT(betaSamples_r = allocMatrix(REALSXP, pN, nPost)); nProtect++; + zeros(REAL(betaSamples_r), pN * nPost); SEXP tauSqSamples_r; PROTECT(tauSqSamples_r = allocMatrix(REALSXP, N, nPost)); nProtect++; + zeros(REAL(tauSqSamples_r), N * nPost); SEXP yRepSamples_r; PROTECT(yRepSamples_r = allocMatrix(REALSXP, JN, nPost)); nProtect++; + zeros(REAL(yRepSamples_r), JN * nPost); SEXP muSamples_r; PROTECT(muSamples_r = allocMatrix(REALSXP, JN, nPost)); nProtect++; + zeros(REAL(muSamples_r), JN * nPost); // Spatial parameters SEXP lambdaSamples_r; PROTECT(lambdaSamples_r = allocMatrix(REALSXP, NqpTilde, nPost)); nProtect++; @@ -316,11 +321,14 @@ extern "C" { SEXP betaStarSamples_r; if (pRE > 0) { PROTECT(sigmaSqMuSamples_r = allocMatrix(REALSXP, pRE, nPost)); nProtect++; + zeros(REAL(sigmaSqMuSamples_r), pRE * nPost); PROTECT(betaStarSamples_r = allocMatrix(REALSXP, nREN, nPost)); nProtect++; + zeros(REAL(betaStarSamples_r), nREN * nPost); } // Likelihood samples for WAIC. SEXP likeSamples_r; PROTECT(likeSamples_r = allocMatrix(REALSXP, JN, nPost)); nProtect++; + zeros(REAL(likeSamples_r), JN * nPost); /********************************************************************** * Additional Sampler Prep @@ -463,6 +471,7 @@ extern "C" { double *accept2 = (double *) R_alloc(nThetaqpTilde, sizeof(double)); zeros(accept2, nThetaqpTilde); SEXP tuningSamples_r; PROTECT(tuningSamples_r = allocMatrix(REALSXP, nThetaqpTilde, nBatch)); nProtect++; + zeros(REAL(tuningSamples_r), nThetaqpTilde * nBatch); // For current number of nonzero z values double *currJ = (double *) R_alloc(N, sizeof(double)); zeros(currJ, N); for (i = 0; i < N; i++) { diff --git a/src/svcMsAbundGaussianNNGPPredict.cpp b/src/svcMsAbundGaussianNNGPPredict.cpp index e33af56..f74f576 100644 --- a/src/svcMsAbundGaussianNNGPPredict.cpp +++ b/src/svcMsAbundGaussianNNGPPredict.cpp @@ -47,7 +47,6 @@ extern "C" { int pTilde = INTEGER(pTilde_r)[0]; int family = INTEGER(family_r)[0]; int pN = p * N; - int JN = J * N; int Jq = J * q; int Nq = N * q; int NpTilde = N * pTilde; diff --git a/tests/testthat/test-sfMsNMix.R b/tests/testthat/test-sfMsNMix.R index b4204fb..63217c9 100644 --- a/tests/testthat/test-sfMsNMix.R +++ b/tests/testthat/test-sfMsNMix.R @@ -56,11 +56,11 @@ X.p <- dat$X.p[-pred.indx, , , drop = FALSE] coords <- as.matrix(dat$coords[-pred.indx, ]) coords.0 <- as.matrix(dat$coords[pred.indx, ]) # Just to keep WAIC relatively fast -y <- ifelse(y > 50, sample(1:50, 100, replace = TRUE), dat$y) +y <- ifelse(y > 50, sample(1:50, 100, replace = TRUE), y) abund.covs <- X colnames(abund.covs) <- c('int') -det.covs <- list(int = X.p[, , 1]) +det.covs <- list(int = X.p[, 1, 1]) data.list <- list(y = y, abund.covs = abund.covs, coords = coords, @@ -92,7 +92,6 @@ n.chains <- 2 abund.formula <- ~ 1 det.formula <- ~ 1 - out <- sfMsNMix(abund.formula = abund.formula, det.formula = det.formula, data = data.list, @@ -321,7 +320,7 @@ X.p <- dat$X.p[-pred.indx, , , drop = FALSE] coords <- as.matrix(dat$coords[-pred.indx, ]) coords.0 <- as.matrix(dat$coords[pred.indx, ]) # Just to keep WAIC relatively fast -y <- ifelse(y > 50, sample(1:50, 100, replace = TRUE), dat$y) +y <- ifelse(y > 50, sample(1:50, 100, replace = TRUE), y) abund.covs <- X colnames(abund.covs) <- c('int', 'abund.cov.1') @@ -549,7 +548,7 @@ X.p <- dat$X.p[-pred.indx, , , drop = FALSE] coords <- as.matrix(dat$coords[-pred.indx, ]) coords.0 <- as.matrix(dat$coords[pred.indx, ]) # Just to keep WAIC relatively fast -y <- ifelse(y > 50, sample(1:50, 100, replace = TRUE), dat$y) +y <- ifelse(y > 50, sample(1:50, 100, replace = TRUE), y) abund.covs <- X colnames(abund.covs) <- c('int') @@ -811,7 +810,7 @@ X.p <- dat$X.p[-pred.indx, , , drop = FALSE] coords <- as.matrix(dat$coords[-pred.indx, ]) coords.0 <- as.matrix(dat$coords[pred.indx, ]) # Just to keep WAIC relatively fast -y <- ifelse(y > 50, sample(1:50, 100, replace = TRUE), dat$y) +y <- ifelse(y > 50, sample(1:50, 100, replace = TRUE), y) abund.covs <- X colnames(abund.covs) <- c('int', 'abund.cov.1', 'abund.cov.2') @@ -1075,7 +1074,7 @@ X.p <- dat$X.p[-pred.indx, , , drop = FALSE] coords <- as.matrix(dat$coords[-pred.indx, ]) coords.0 <- as.matrix(dat$coords[pred.indx, ]) # Just to keep WAIC relatively fast -y <- ifelse(y > 50, sample(1:50, 100, replace = TRUE), dat$y) +y <- ifelse(y > 50, sample(1:50, 100, replace = TRUE), y) abund.covs <- X colnames(abund.covs) <- c('int', 'abund.cov.1', 'abund.cov.2') @@ -1342,7 +1341,7 @@ X.p <- dat$X.p[-pred.indx, , , drop = FALSE] coords <- as.matrix(dat$coords[-pred.indx, ]) coords.0 <- as.matrix(dat$coords[pred.indx, ]) # Just to keep WAIC relatively fast -y <- ifelse(y > 50, sample(1:50, 100, replace = TRUE), dat$y) +y <- ifelse(y > 50, sample(1:50, 100, replace = TRUE), y) abund.covs <- X colnames(abund.covs) <- c('int', 'abund.cov.1', 'abund.cov.2') @@ -1573,7 +1572,7 @@ X.p <- dat$X.p[-pred.indx, , , drop = FALSE] coords <- as.matrix(dat$coords[-pred.indx, ]) coords.0 <- as.matrix(dat$coords[pred.indx, ]) # Just to keep WAIC relatively fast -y <- ifelse(y > 50, sample(1:50, 100, replace = TRUE), dat$y) +y <- ifelse(y > 50, sample(1:50, 100, replace = TRUE), y) abund.covs <- cbind(X, X.re) colnames(abund.covs) <- c('int', 'abund.cov.1', 'abund.cov.2', @@ -1888,7 +1887,7 @@ X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] coords <- as.matrix(dat$coords[-pred.indx, ]) coords.0 <- as.matrix(dat$coords[pred.indx, ]) # Just to keep WAIC relatively fast -y <- ifelse(y > 50, sample(1:50, 100, replace = TRUE), dat$y) +y <- ifelse(y > 50, sample(1:50, 100, replace = TRUE), y) abund.covs <- cbind(X) colnames(abund.covs) <- c('int') @@ -2207,7 +2206,7 @@ X.p.re <- dat$X.p.re[-pred.indx, , , drop = FALSE] coords <- as.matrix(dat$coords[-pred.indx, ]) coords.0 <- as.matrix(dat$coords[pred.indx, ]) # Just to keep WAIC relatively fast -y <- ifelse(y > 50, sample(1:50, 100, replace = TRUE), dat$y) +y <- ifelse(y > 50, sample(1:50, 100, replace = TRUE), y) abund.covs <- cbind(X, X.re) colnames(abund.covs) <- c('int', 'abund.cov.1', 'abund.cov.2', 'abund.factor.1',