R/spatSB.R

#' Spatial Solow & Beet Estimator
#'
# "It's easy to think that as a result of the extinction of the dodo, we are now sadder and wiser, but there's a lot of evidence to suggest that we are merely sadder and better informed." - Douglas Adams, \emph{Last Chance to See}
#'
#' @description
#' This function interpolates the Solow & Beet model in a spatial format using a base grid and a sighting data frame. The Solow & Beet method uses a Bayesian model to evaluate the extinction date of a species, using mixed certainty datsets. The \code{spat.SB} function can be used to implement model 1 (which assumes invalid sightings aren't generated until after a species is extinct) or model 2 (which assumes that valid and invalid sightings could be mixed before the true extinction date). Both models treat valid and invalid sightings as separate processes, and make inference on the likelihood of the extinction date based on what sighting rates would have generated the dataset in hand.
#'
#' @param sightings Data frame of sightings with columns "year", "longitude", "latitude", and "sighting" which gives quality. Long/lats must be given in decimal coordinates. Year records the date of a sighting (though it could be any continuous units of time) and sighting records the quality of the sighting. A "1" is a certain sighting (guaranteed valid) while a "2" or anything higher is uncertain. Uncertain sightings are not necessarily invalid, and researchers may want to differentiate within uncertain sightings by quality. We typically use three categories: 1 is physical evidence or certain expert sightings, 2 are plausible expert sightings, and 3 are dubious or novice sightings without strong evidence.
#' @param grid Blank 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. N must be greater than k.
#' @param T.bound The outer bound the model runs to; 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
#'
#' @export
#'
#' @examples
#' # EXAMPLE 1: NO INVALID SIGHTINGS
#' 
#' x <- makeSims(10,2)
#' sb <- spat.SB(x$sightings,x$grid$blank,T.bound=55,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,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(x$sightings,x$grid$layer.2,T.bound=55,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)
#' sb <- spat.SB(x$sightings,x$grid$blank,T.bound=55,model.num=2,parallel=TRUE,setCores=TRUE,cores=4)
#' sb2 <- spat.SB(x$sightings,x$grid$blank,T.bound=55,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,main='True Extinction Date')
#' plot(sb[[1]], main='100 Reps')
#' plot(sb[[2]], main='Variance')
#' plot(sb2[[1]], main='Adaptive')
#' plot(sb2[[2]], main='Variance')
#' 
#' 

spat.SB <- 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$plotobj$integrand_prob <- out2$plotobj$integrand/sum(out2$plotobj$integrand)
        out2$plotobj[out2$plotobj$integrand==max(out2$plotobj$integrand),]$year
      }
      
      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$plotobj[out2$plotobj$integrand==max(out2$plotobj$integrand),]$year
			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)
	                                    out2$plotobj$integrand_prob <- out2$plotobj$integrand/sum(out2$plotobj$integrand)
	                                    sandbs <- c(sandbs,out2$plotobj[out2$plotobj$integrand==max(out2$plotobj$integrand),]$year)
	                                    
	                                  }
	                                  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)
        out2$plotobj$integrand_prob <- out2$plotobj$integrand/sum(out2$plotobj$integrand)
        sandbs <- c(sandbs,out2$plotobj[out2$plotobj$integrand==max(out2$plotobj$integrand),]$year)
        
      }
      
      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)
        out2$plotobj$integrand_prob <- out2$plotobj$integrand/sum(out2$plotobj$integrand)
        est <- out2$plotobj[out2$plotobj$integrand==max(out2$plotobj$integrand),]$year
        
        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))
        }
      
        
        
      }
      
      
      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)
        out2$plotobj$integrand_prob <- out2$plotobj$integrand/sum(out2$plotobj$integrand)
        sandbs <- c(sandbs,out2$plotobj[out2$plotobj$integrand==max(out2$plotobj$integrand),]$year)
      }
      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.