inst/doc/subsampling-vignette.R

In divvy: Spatial Subsampling of Biodiversity Occurrence Data

## ----include = FALSE----------------------------------------------------------
knitr::opts_chunk$set(
  collapse = FALSE,
  comment = "#>"
)

## ----setup, message=FALSE-----------------------------------------------------
library(divvy) 
library(units)
library(sf)
library(terra)
library(vegan)
library(iNEXT)

## ----attached data------------------------------------------------------------
data(bivalves)
head(bivalves)
nrow(bivalves)
length(unique(bivalves$genus))

## ----rasterise----------------------------------------------------------------
# initialise Equal Earth projected coordinates
rWorld <- rast()
prj <- 'EPSG:8857'
rPrj <- project(rWorld, prj, res = 200000) # 200,000m is approximately 2 degrees
values(rPrj) <- 1:ncell(rPrj)

# coordinate column names for the current and target coordinate reference system
xyCartes <- c('paleolng','paleolat')
xyCell   <- c('cellX','cellY')

# retrieve coordinates of raster cell centroids
llOccs <- vect(bivalves, geom = xyCartes, crs = 'epsg:4326')
prjOccs <- project(llOccs, prj)
bivalves$cell <- cells(rPrj, prjOccs)[,'cell']
bivalves[, xyCell] <- xyFromCell(rPrj, bivalves$cell)

## ----map data, fig.width=6, fig.align='center', message=FALSE-----------------
occUniq <- uniqify(bivalves, xyCell)
ptsUniq <- st_as_sf(occUniq, coords = xyCell, crs = prj)

library(rnaturalearth)
library(rnaturalearthdata)
library(ggplot2) # for plot visualisation
world <- ne_countries(scale = "medium", returnclass = "sf")
worldP <- ggplot(data = world) +
  theme_bw() +
  geom_sf() +
  geom_sf(data = ptsUniq, shape = 17, color = 'blue')

plot(worldP)

## ----circ subsample-----------------------------------------------------------
set.seed(1)
circLocs <- cookies(dat = bivalves,  
                    xy = xyCell,
                    iter = 500, 
                    nSite = 12, 
                    r = 1500, # radial distance in km
                    weight = TRUE, # probabilistically aggregate subsampling sites
                    crs = prj, # Equal Earth projection
                    output = 'locs')
length(circLocs)
circLocs[[1]]

## ----map subsample, fig.width=6, fig.align='center'---------------------------
# over-plot the subsample locations
smplPts <- st_as_sf(circLocs[[1]], coords = xyCell, crs = prj)
worldP +
  geom_sf(data = smplPts, shape = 17, color = 'red')

## ----count pool size, fig.width=6, fig.align='center'-------------------------
cntr <- smplPts[1,]
# distances inferred to be meters based on lat-long coord system
r <- 1500
buf <- st_buffer(cntr, dist = r*1000)

# over-plot subsample boundary region and included sites
worldP +
  geom_sf(data = smplPts, shape = 17, color = 'red') +
  geom_sf(data = buf, fill = NA, linewidth = 1, color = 'red')

## ----tally pool size----------------------------------------------------------
inBuf <- st_intersects(ptsUniq, buf, sparse = FALSE) 
sum(inBuf)

## ----circ subsample variation-------------------------------------------------
set.seed(7)
# same parameter values as above except for 'output'
circOccs <- cookies(dat = bivalves, 
                    xy = xyCell, 
                    iter = 500, 
                    nSite = 12, 
                    r = 1500, 
                    weight = TRUE, 
                    crs = prj,
                    output = 'full')
head( circOccs[[8]] )

## ----unique occs--------------------------------------------------------------
bivUniq <- uniqify(bivalves, taxVar = 'genus', xyCell)
nrow(bivUniq)

## ----MST subsample------------------------------------------------------------
set.seed(2)
nnLocs <- clustr(dat = bivalves, 
                 xy = xyCell, 
                 iter = 500, 
                 distMax = 3000, # diameter = 2x the circular radius set above
                 nSite = 12,
                 crs = prj
                 )
nnLocs[[1]]

## ----MST all sites------------------------------------------------------------
set.seed(2)
nnAllSites <- clustr(dat = bivalves, 
                     xy = xyCell, 
                     iter = 500,
                     distMax = 3000, # diameter = 2x the circular radius set above
                     nMin = 3,
                     crs = prj
                     )
nrow( nnAllSites[[1]] )

## ----lat subsample------------------------------------------------------------
bandLocs <- bandit(dat = bivalves,
                   xy = xyCell,
                   iter = 100, nSite = 12, 
                   bin = 20, # interval width in degrees
                   crs = prj
                   # ,absLat = TRUE # optional
                   )
nrow(bandLocs[[1]]) # number of sites in one subsampled band
length(bandLocs) # number of subsamples, tallied across all bands
unique(names(bandLocs)) # latitudinal degrees of subsampled intervals

## ----meta data----------------------------------------------------------------
unsamp <- sdSumry(dat = bivalves, 
                  taxVar = 'genus',
                  collections = 'collection_no',
                  xy = xyCell,
                  quotaQ = 0.8, quotaN = 100,
                  omitDom = TRUE,
                  crs = prj)
unsamp

samp1 <- sdSumry(dat = circOccs[[1]], 
                 taxVar = 'genus',
                 collections = 'collection_no',
                 xy = xyCell,
                 quotaQ = 0.8, quotaN = 100, 
                 omitDom = TRUE,
                 crs = prj)
samp1

## ----summary over subsamples--------------------------------------------------
# warning - it's slow to rarefy diversity for hundreds of subsamples!
# this code chunk skips it for quick demonstration purposes
sampsMeta <- sdSumry(dat = circOccs, 
                     taxVar = 'genus',
                     collections = 'collection_no',
                     xy = xyCell,
                     crs = prj
                     )
quantile(sampsMeta$nTax, c(0.25, 0.5, 0.75))