R/spatSB-probs.R
In cjcarlson/spatExtinct: A Package for Spatial Interpolation of Extinction Dates from Sighting Data
#' Spatial Solow & Beet probability of persistence
#'
# Ernest: Where did you put my wife?
#
# Doctor: She's dead, sir. They took her to the morgue.
#
# Ernest: The morgue? She'll be furious!
#
# --\emph{Death Becomes Her} (1992)
#
# --------
#'
#' @description
#' This function interpolates the Solow & Beet model in a spatial format using a base grid and a sighting data frame. Unlike \code{spat.SB} or \code{spat.SB.par}, which both return the most likely year of extinction, \code{spat.SB.probs} returns the probability of persistence for a cell for a given year of interest.
#'
#' @param sightings Data frame of sightings with columns 'year', 'longitude', 'latitude', and 'sighting' which gives quality
#' @param grid Raster onto which to interpolate your results
#' @param k.nn The k nearest neighbors to pull (nonrandom method) or the k points to sample in every iteration from the N nearest neighbors (random method)
#' @param N.nn The N nearest neighbors to pull from in the randomized method
#' @param T.bound The year used as the test year for probability of persistence (different from in spat.SB); MUST be later than (T_last + increment2*(T_last-T_first))
#' @param model.num Model 1 or 2 from Solow & Beet?
#' @param prior Options are uniform ("Unif"), linear ("Tri"), or negative exponential ("Exp").
#' @param gamma.exp Gamma for exponential prior. Defaults to 6 from Solow & Beet study.
#' @param randomize Implement the random method
#' @param reps How many iterations are used in the randomized method
#' @param parallel Do you want to parallelize the function?
#' @param setCores Do you want to manually set the number of cores to run the function on? Defaults to FALSE, and runs the function on all but one core detected automatically. Adaptive sampling and parallel processing cannot be turned on at the same time, and parallel supercedes adaptive.
#' @param cores Manually specify how many cores.
#' @param adaptive Do you want to run the model with adaptive estimation? Uses epsilon argument to set a convergence threshold, and after the first 10 runs in a cell, waits for the difference in the running mean before and after adding an iteration (delta) to drop below the convergence threshold (epsilon). Adaptive sampling and parallel processing cannot be turned on at the same time, and parallel supercedes adaptive.
#' @param epsilon Convergence threshold for adaptive estimation.
#' @param verbose Incredibly stupid, don't turn on (dead dove do not eat)
#'
#' @keywords Solow & Beet, Bayesian model, spatial extinction date estimator, SEDE, probability of persistence
#'
#' @export
#'
#' @examples
#'# EXAMPLE 1: NO INVALID SIGHTINGS
#'
#' x <- makeSims(10,2)
#' x$sightings <- x$sightings[x$sightings$year<25,]
#' sb <- spat.SB.probs(x$sightings,x$grid$blank,k.nn=10,N.nn=15,T.bound=26,model.num=2)
#' rbPal <- colorRampPalette(c('blue','red'))
#' x$sightings$Col <- rbPal(10)[as.numeric(cut(x$sightings[,3],breaks = 10))]
#' par(mfrow=c(2,2))
#' plot(x$grid$blank,main='Sightings')
#' points(x$sightings[,c(1:2)], col=x$sightings$Col,pch=16)
#' plot(x$grid$real>=25,main='True Extinction Date')
#' plot(sb[[1]], main='Estimate')
#' plot(sb[[2]], main='Variance')
#'
#' # EXAMPLE 2: MIXED VALIDITY
#'
#' x <- errorSims(n=10,pts=2,ipts=5,p=0.1)
#' sb <- spat.SB.probs(x$sightings,x$grid$layer.2,k.nn=10,N.nn=15,T.bound=26,model.num=2)
#' rbPal <- colorRampPalette(c('blue','red'))
#' x$sightings$Col <- rbPal(10)[as.numeric(cut(x$sightings[,3],breaks = 10))]
#' par(mfrow=c(2,2))
#' plot(x$grid$layer.2,main='Sightings')
#' points(x$sightings[x$sightings$real==1,c(1:2)], col=x$sightings$Col,pch=16,cex=1.5)
#' points(x$sightings[x$sightings$real==0,c(1:2)], col='black',pch=19,cex=1.5)
#' plot(x$grid$layer.1,main='True Extinction Date')
#' plot(sb[[1]], main='Estimate')
#' plot(sb[[2]], main='Variance')
#'
#' # EXAMPLE 3: ADAPTIVE RESAMPLING
#'
#' x <- makeSims(10,2)
#' x$sightings <- x$sightings[x$sightings$year<25,]
#' sb <- spat.SB.probs(x$sightings,x$grid$blank,k.nn=10,N.nn=15,T.bound=26,model.num=2,parallel=TRUE,setCores=TRUE,cores=4)
#' sb2 <- spat.SB.probs(x$sightings,x$grid$blank,k.nn=10,N.nn=15,T.bound=26,model.num=2,adaptive=TRUE, epsilon=0.005)
#' rbPal <- colorRampPalette(c('blue','red'))
#' x$sightings$Col <- rbPal(10)[as.numeric(cut(x$sightings[,3],breaks = 10))]
#' par(mfrow=c(3,2))
#' plot(x$grid$blank,main='Sightings')
#' points(x$sightings[,c(1:2)], col=x$sightings$Col,pch=16)
#' plot(x$grid$real>=25,main='True Extinction Date')
#' plot(sb[[1]], main='100 Reps')
#' plot(sb[[2]], main='Variance')
#' plot(sb2[[1]], main='Adptive')
#' plot(sb2[[2]], main='Variance')
spat.SB.probs <- function(sightings, grid, k.nn=5, N.nn=10,
T.bound, model.num, prior="Unif", gamma.exp=6,
randomize=TRUE, reps=100,
parallel=FALSE, setCores=FALSE, cores=1,
adaptive=FALSE, epsilon=0.001,
verbose=FALSE){
if(!(T.bound>(max(sightings$year)+0.01*(max(sightings$year)-min(sightings$year))))) {
stop("Make your T.bound later")
}
if(class(grid)=='RasterStack') {grid <- grid[[1]]}
inputs <- list(dataStr = "Scrumpus", T = T.bound, posteriorPrior = prior) ## 'T' is end of period
pts <- rasterToPoints(grid, spatial=TRUE)
pts@data <- data.frame(pts@data, long=coordinates(pts)[,1],
lat=coordinates(pts)[,2])
pts@data$extyear <- 0
# Your k nearest neighbors gets set here
nearest <- nn2(sightings[,c('longitude','latitude')],pts@data[,2:3],k=N.nn)
idx <- nearest$nn.idx
dists <- nearest$nn.dists
dists <- 1/dists
for (i in 1:nrow(dists)){
d.vector <- dists[i,]
d.vector[!(d.vector==Inf)] <- d.vector[!(d.vector==Inf)]/sum(d.vector[!(d.vector==Inf)])
d.vector[(d.vector==Inf)] <- 1
dists[i,] <- d.vector
}
pb <- txtProgressBar(style=3, min=1, max=nrow(idx))
if(randomize==FALSE){
if(parallel==TRUE) {
if(setCores==FALSE) { num_cores <- detectCores()-1 } else { num_cores <- cores }
cl<-makeCluster(num_cores)
registerDoParallel(cl)
pts@data$extyear <- foreach(i=1:nrow(idx), .combine='c',.export=ls(.GlobalEnv),
.packages = c("spatExtinct")) %dopar% {
row.list <- idx[i,c(1:k.nn)]
sub <- sightings[row.list,]
sub <- sub[,c('year','sighting')]
out2 <- solowbeet(sub, inputs, modelnumber = model.num, gamma=gamma.exp,verbose=verbose)
out2$Results[2]
}
stopCluster(cl)
} else {
for (i in 1:nrow(idx)){
row.list <- idx[i,c(1:k.nn)]
sub <- sightings[row.list,]
sub <- sub[,c('year','sighting')]
out2 <- solowbeet(sub, inputs, modelnumber = model.num, gamma=gamma.exp,verbose=verbose)
out2$plotobj$integrand_prob <- out2$plotobj$integrand/sum(out2$plotobj$integrand)
pts@data$extyear[i] <- out2$Results[2]
setTxtProgressBar(pb, i)
}
}
} else{
if(parallel==TRUE) {
if(setCores==FALSE) { num_cores <- detectCores()-1 } else { num_cores <- cores }
cl<-makeCluster(num_cores)
registerDoParallel(cl)
df.res <- foreach(i=1:length(pts@data$extyear), .combine=data.frame,
.export=ls(.GlobalEnv), .packages = c("spatExtinct")) %dopar% {
sandbs <- c()
# nreps = j
for (j in 1:reps) {
row.list <- sample(idx[i,],k.nn,prob=dists[i,],replace=FALSE)
sub <- sightings[row.list,]
sub <- sub[,c('year','sighting')]
out2 <- solowbeet(sub, inputs, modelnumber = model.num, gamma=gamma.exp,verbose)
sandbs <- c(sandbs,out2$Results[2])
}
if (verbose==FALSE) {print.noquote(i)}
data.frame(run=c(mean(sandbs[!is.na(sandbs)]),var(sandbs[!is.na(sandbs)])))
}
pts@data$extyear <- t(df.res[1,])
pts@data$var <- t(df.res[2,])
stopCluster(cl)
} else {
for (i in 1:nrow(idx)){
sandbs <- c()
if (adaptive==TRUE) {
for (j in 1:10) {
row.list <- sample(idx[i,],k.nn,prob=dists[i,],replace=FALSE)
sub <- sightings[row.list,]
sub <- sub[,c('year','sighting')]
out2 <- solowbeet(sub, inputs, modelnumber = model.num, gamma=gamma.exp,verbose=verbose)
sandbs <- c(sandbs,out2$Results[2])
}
mean1 <- mean(sandbs)
delta <- 1
while (delta > epsilon) {
row.list <- sample(idx[i,],k.nn,prob=dists[i,],replace=FALSE)
sub <- sightings[row.list,]
sub <- sub[,c('year','sighting')]
out2 <- solowbeet(sub, inputs, modelnumber = model.num, gamma=gamma.exp,verbose=verbose)
est <- out2$Results[2]
mean1 <- mean(na.omit(sandbs))
sandbs <- c(sandbs,est)
mean2 <- mean(na.omit(sandbs))
if(mean1==min(sandbs)) {
delta <- 1
} else {
delta <- abs(mean2-mean1)/(mean1-min(sandbs))
}
}
pts@data$extyear[i] <- mean(na.omit(sandbs))
pts@data$var[i] <- var(na.omit(sandbs))
setTxtProgressBar(pb, i)
} else {
# nreps = j
for (j in 1:reps){
row.list <- sample(idx[i,],k.nn,prob=dists[i,],replace=FALSE)
sub <- sightings[row.list,]
sub <- sub[,c('year','sighting')]
out2 <- solowbeet(sub, inputs, modelnumber = model.num, gamma=gamma.exp,verbose=verbose)
sandbs <- c(sandbs,out2$Results[2])
}
setTxtProgressBar(pb, i)
pts@data$extyear[i] <- mean(na.omit(sandbs))
pts@data$var[i] <- var(na.omit(sandbs))
}
}
}
}
sb.grid <- rasterize(pts, grid, pts$extyear, fun = mean)
if(randomize==FALSE) {
return(sb.grid)
} else {
sb.var.grid <- rasterize(pts, grid, pts$var, fun = mean)
stack <- stack(sb.grid,sb.var.grid)
names(stack) <- c('Mean SB', 'Variogram')
return(stack)
}
}
cjcarlson/spatExtinct documentation built on May 25, 2019, 3:26 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
#' Spatial Solow & Beet probability of persistence
#'
# Ernest: Where did you put my wife?
#
# Doctor: She's dead, sir. They took her to the morgue.
#
# Ernest: The morgue? She'll be furious!
#
# --\emph{Death Becomes Her} (1992)
#
# --------
#'
#' @description
#' This function interpolates the Solow & Beet model in a spatial format using a base grid and a sighting data frame. Unlike \code{spat.SB} or \code{spat.SB.par}, which both return the most likely year of extinction, \code{spat.SB.probs} returns the probability of persistence for a cell for a given year of interest.
#'
#' @param sightings Data frame of sightings with columns 'year', 'longitude', 'latitude', and 'sighting' which gives quality
#' @param grid Raster onto which to interpolate your results
#' @param k.nn The k nearest neighbors to pull (nonrandom method) or the k points to sample in every iteration from the N nearest neighbors (random method)
#' @param N.nn The N nearest neighbors to pull from in the randomized method
#' @param T.bound The year used as the test year for probability of persistence (different from in spat.SB); MUST be later than (T_last + increment2*(T_last-T_first))
#' @param model.num Model 1 or 2 from Solow & Beet?
#' @param prior Options are uniform ("Unif"), linear ("Tri"), or negative exponential ("Exp").
#' @param gamma.exp Gamma for exponential prior. Defaults to 6 from Solow & Beet study.
#' @param randomize Implement the random method
#' @param reps How many iterations are used in the randomized method
#' @param parallel Do you want to parallelize the function?
#' @param setCores Do you want to manually set the number of cores to run the function on? Defaults to FALSE, and runs the function on all but one core detected automatically. Adaptive sampling and parallel processing cannot be turned on at the same time, and parallel supercedes adaptive.
#' @param cores Manually specify how many cores.
#' @param adaptive Do you want to run the model with adaptive estimation? Uses epsilon argument to set a convergence threshold, and after the first 10 runs in a cell, waits for the difference in the running mean before and after adding an iteration (delta) to drop below the convergence threshold (epsilon). Adaptive sampling and parallel processing cannot be turned on at the same time, and parallel supercedes adaptive.
#' @param epsilon Convergence threshold for adaptive estimation.
#' @param verbose Incredibly stupid, don't turn on (dead dove do not eat)
#'
#' @keywords Solow & Beet, Bayesian model, spatial extinction date estimator, SEDE, probability of persistence
#'
#' @export
#'
#' @examples
#'# EXAMPLE 1: NO INVALID SIGHTINGS
#'
#' x <- makeSims(10,2)
#' x$sightings <- x$sightings[x$sightings$year<25,]
#' sb <- spat.SB.probs(x$sightings,x$grid$blank,k.nn=10,N.nn=15,T.bound=26,model.num=2)
#' rbPal <- colorRampPalette(c('blue','red'))
#' x$sightings$Col <- rbPal(10)[as.numeric(cut(x$sightings[,3],breaks = 10))]
#' par(mfrow=c(2,2))
#' plot(x$grid$blank,main='Sightings')
#' points(x$sightings[,c(1:2)], col=x$sightings$Col,pch=16)
#' plot(x$grid$real>=25,main='True Extinction Date')
#' plot(sb[[1]], main='Estimate')
#' plot(sb[[2]], main='Variance')
#'
#' # EXAMPLE 2: MIXED VALIDITY
#'
#' x <- errorSims(n=10,pts=2,ipts=5,p=0.1)
#' sb <- spat.SB.probs(x$sightings,x$grid$layer.2,k.nn=10,N.nn=15,T.bound=26,model.num=2)
#' rbPal <- colorRampPalette(c('blue','red'))
#' x$sightings$Col <- rbPal(10)[as.numeric(cut(x$sightings[,3],breaks = 10))]
#' par(mfrow=c(2,2))
#' plot(x$grid$layer.2,main='Sightings')
#' points(x$sightings[x$sightings$real==1,c(1:2)], col=x$sightings$Col,pch=16,cex=1.5)
#' points(x$sightings[x$sightings$real==0,c(1:2)], col='black',pch=19,cex=1.5)
#' plot(x$grid$layer.1,main='True Extinction Date')
#' plot(sb[[1]], main='Estimate')
#' plot(sb[[2]], main='Variance')
#'
#' # EXAMPLE 3: ADAPTIVE RESAMPLING
#'
#' x <- makeSims(10,2)
#' x$sightings <- x$sightings[x$sightings$year<25,]
#' sb <- spat.SB.probs(x$sightings,x$grid$blank,k.nn=10,N.nn=15,T.bound=26,model.num=2,parallel=TRUE,setCores=TRUE,cores=4)
#' sb2 <- spat.SB.probs(x$sightings,x$grid$blank,k.nn=10,N.nn=15,T.bound=26,model.num=2,adaptive=TRUE, epsilon=0.005)
#' rbPal <- colorRampPalette(c('blue','red'))
#' x$sightings$Col <- rbPal(10)[as.numeric(cut(x$sightings[,3],breaks = 10))]
#' par(mfrow=c(3,2))
#' plot(x$grid$blank,main='Sightings')
#' points(x$sightings[,c(1:2)], col=x$sightings$Col,pch=16)
#' plot(x$grid$real>=25,main='True Extinction Date')
#' plot(sb[[1]], main='100 Reps')
#' plot(sb[[2]], main='Variance')
#' plot(sb2[[1]], main='Adptive')
#' plot(sb2[[2]], main='Variance')
spat.SB.probs <- function(sightings, grid, k.nn=5, N.nn=10,
T.bound, model.num, prior="Unif", gamma.exp=6,
randomize=TRUE, reps=100,
parallel=FALSE, setCores=FALSE, cores=1,
adaptive=FALSE, epsilon=0.001,
verbose=FALSE){
if(!(T.bound>(max(sightings$year)+0.01*(max(sightings$year)-min(sightings$year))))) {
stop("Make your T.bound later")
}
if(class(grid)=='RasterStack') {grid <- grid[[1]]}
inputs <- list(dataStr = "Scrumpus", T = T.bound, posteriorPrior = prior) ## 'T' is end of period
pts <- rasterToPoints(grid, spatial=TRUE)
pts@data <- data.frame(pts@data, long=coordinates(pts)[,1],
lat=coordinates(pts)[,2])
pts@data$extyear <- 0
# Your k nearest neighbors gets set here
nearest <- nn2(sightings[,c('longitude','latitude')],pts@data[,2:3],k=N.nn)
idx <- nearest$nn.idx
dists <- nearest$nn.dists
dists <- 1/dists
for (i in 1:nrow(dists)){
d.vector <- dists[i,]
d.vector[!(d.vector==Inf)] <- d.vector[!(d.vector==Inf)]/sum(d.vector[!(d.vector==Inf)])
d.vector[(d.vector==Inf)] <- 1
dists[i,] <- d.vector
}
pb <- txtProgressBar(style=3, min=1, max=nrow(idx))
if(randomize==FALSE){
if(parallel==TRUE) {
if(setCores==FALSE) { num_cores <- detectCores()-1 } else { num_cores <- cores }
cl<-makeCluster(num_cores)
registerDoParallel(cl)
pts@data$extyear <- foreach(i=1:nrow(idx), .combine='c',.export=ls(.GlobalEnv),
.packages = c("spatExtinct")) %dopar% {
row.list <- idx[i,c(1:k.nn)]
sub <- sightings[row.list,]
sub <- sub[,c('year','sighting')]
out2 <- solowbeet(sub, inputs, modelnumber = model.num, gamma=gamma.exp,verbose=verbose)
out2$Results[2]
}
stopCluster(cl)
} else {
for (i in 1:nrow(idx)){
row.list <- idx[i,c(1:k.nn)]
sub <- sightings[row.list,]
sub <- sub[,c('year','sighting')]
out2 <- solowbeet(sub, inputs, modelnumber = model.num, gamma=gamma.exp,verbose=verbose)
out2$plotobj$integrand_prob <- out2$plotobj$integrand/sum(out2$plotobj$integrand)
pts@data$extyear[i] <- out2$Results[2]
setTxtProgressBar(pb, i)
}
}
} else{
if(parallel==TRUE) {
if(setCores==FALSE) { num_cores <- detectCores()-1 } else { num_cores <- cores }
cl<-makeCluster(num_cores)
registerDoParallel(cl)
df.res <- foreach(i=1:length(pts@data$extyear), .combine=data.frame,
.export=ls(.GlobalEnv), .packages = c("spatExtinct")) %dopar% {
sandbs <- c()
# nreps = j
for (j in 1:reps) {
row.list <- sample(idx[i,],k.nn,prob=dists[i,],replace=FALSE)
sub <- sightings[row.list,]
sub <- sub[,c('year','sighting')]
out2 <- solowbeet(sub, inputs, modelnumber = model.num, gamma=gamma.exp,verbose)
sandbs <- c(sandbs,out2$Results[2])
}
if (verbose==FALSE) {print.noquote(i)}
data.frame(run=c(mean(sandbs[!is.na(sandbs)]),var(sandbs[!is.na(sandbs)])))
}
pts@data$extyear <- t(df.res[1,])
pts@data$var <- t(df.res[2,])
stopCluster(cl)
} else {
for (i in 1:nrow(idx)){
sandbs <- c()
if (adaptive==TRUE) {
for (j in 1:10) {
row.list <- sample(idx[i,],k.nn,prob=dists[i,],replace=FALSE)
sub <- sightings[row.list,]
sub <- sub[,c('year','sighting')]
out2 <- solowbeet(sub, inputs, modelnumber = model.num, gamma=gamma.exp,verbose=verbose)
sandbs <- c(sandbs,out2$Results[2])
}
mean1 <- mean(sandbs)
delta <- 1
while (delta > epsilon) {
row.list <- sample(idx[i,],k.nn,prob=dists[i,],replace=FALSE)
sub <- sightings[row.list,]
sub <- sub[,c('year','sighting')]
out2 <- solowbeet(sub, inputs, modelnumber = model.num, gamma=gamma.exp,verbose=verbose)
est <- out2$Results[2]
mean1 <- mean(na.omit(sandbs))
sandbs <- c(sandbs,est)
mean2 <- mean(na.omit(sandbs))
if(mean1==min(sandbs)) {
delta <- 1
} else {
delta <- abs(mean2-mean1)/(mean1-min(sandbs))
}
}
pts@data$extyear[i] <- mean(na.omit(sandbs))
pts@data$var[i] <- var(na.omit(sandbs))
setTxtProgressBar(pb, i)
} else {
# nreps = j
for (j in 1:reps){
row.list <- sample(idx[i,],k.nn,prob=dists[i,],replace=FALSE)
sub <- sightings[row.list,]
sub <- sub[,c('year','sighting')]
out2 <- solowbeet(sub, inputs, modelnumber = model.num, gamma=gamma.exp,verbose=verbose)
sandbs <- c(sandbs,out2$Results[2])
}
setTxtProgressBar(pb, i)
pts@data$extyear[i] <- mean(na.omit(sandbs))
pts@data$var[i] <- var(na.omit(sandbs))
}
}
}
}
sb.grid <- rasterize(pts, grid, pts$extyear, fun = mean)
if(randomize==FALSE) {
return(sb.grid)
} else {
sb.var.grid <- rasterize(pts, grid, pts$var, fun = mean)
stack <- stack(sb.grid,sb.var.grid)
names(stack) <- c('Mean SB', 'Variogram')
return(stack)
}
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.