::opts_chunk$set(fig.width = 6, fig.height = 4, fig.path = 'Figs/',
knitrecho = TRUE, message = FALSE, warning = FALSE)
library(dplyr)
library(rgdal)
library(raster)
library(here)
library(ggridges)
library(ggplot2)
library(tidyverse)
library(terra)
source(here('workflow/R/common.R'))
region_data()
<- rgns_eez %>%
rgns_global ::select(rgn_id) %>%
dplyr::filter(rgn_id != 213) dplyr
We use the methods and code from Casey O’Hara: https://github.com/oharac/spp_risk_dists to prepare the data for the species subgoal.
Reference:
Spatial species range data and extinction risk data from IUCN is used to generate regional scores for the Species subgoal (part of the Biodiversity goal) and resilience layers.
Mean risk status per cell: Species ranges are converted to a global spatial raster of 10 km resolution.
The mean extinction risk for each cell, \(\bar{R}_{cell}\), is calculated by averaging the IUCN extinction risk of the species with ranges overlapping the cell.
Risk is a scaled value representing the species extinction risk category: * ‘LC’ = 0.0, ‘NT’ = 0.2, ‘VU’ = 0.4, ‘EN’ = 0.6, ‘CR’ = 0.8, ‘EX’ = 1.0
\[\bar{R}_{cell} = \frac{\displaystyle\sum_{species}(Risk)}{n_{spp}}\]
Mean risk status per region: The mean extinction risk for a region, \(\bar{R}_{SPP}\), is estimated by averaging the risk values of the raster cells falling within each OHI region, with each cell’s contribution weighted by the number of species in the cell.
Species goal model
The regional risk values are converted to species status scores by subtracting the risk values from 1 and rescaling so a risk value of $ $ receives a score of zero.
From Halpern et al (2012):
The target for the Species sub-goal is to have all species at a risk status of Least Concern. We scaled the lower end of the biodiversity goal to be 0 when 75% species are extinct, a level comparable to the five documented mass extinctions and would constitute a catastrophic loss of biodiversity.
\[X_{SPP} = \frac{((1 - \bar{R}_{SPP}) - 0.25)}{(1 - 0.25)} * 100%\]
where:
Trend is calculated using time series of risk categories based on current and past assessments.
Additional year of data
Reference: IUCN and UNEP-WCMC (2021), The World Database on Protected Areas (WDPA) [On-line], February 2021. Cambridge, UK: UNEP-WCMC. Available at: www.protectedplanet.net.
Downloaded: August 15, 2022
Description: Shapefile of World Database on Protected Areas
Time range: 1819 - 2022; some protected areas do not have an associated “status year” and are reported as year 0.
Format: Shapefile
File location:
Mazu:git-annex/globalprep/_raw_data/wdpa_mpa/d2021/WDPA_WDOECM_wdpa_shp/
There are several steps that need to be taken to get to this point in the data prep.
Here is an overview of the organization of files and data that are run prior to this:
spp/v20XX/_setup
In this directory are a sequence of files used to generate the bits and pieces that are later assembled into the rasters of biodiversity risk.
.Rmd files are sequenced with a prefix number (and letter) to indicate the order of operations. Briefly:
spp_risk_dists/_spatial
directory.
v2022
At this level there are several scripts, prefixed
1x_biodiversity_maps
, that collate the various taxonomic
group level files (generated in setup
part 6) and summarize
to the global level. These need to be run before spp_data_prep.Rmd! *
1a_biodiversity_maps_comp_assessed.Rmd *
1c_biodiversity_maps_all_spp.Rmd * spp_data_prep.Rmd
_output
folder.The spp_risk_dists/_data
folder contains tabular data
about IUCN species used throughout the processing of this analysis.
These files are generated by scripts in the setup directory.
The spp_risk_dists/_spatial
folder contains general
spatial data generated and/or used in the setup
scripts.
These include:
The spp_risk_dists/_output
folder contains the rasters
of biodiversity risk, species richness, variance of risk, etc generated
from the scripts in the base directory.
In the past, we have used all species with IUCN risk assessments to calculate the species subgoal. However, some of Casey’s work suggests it is better to use the taxa groups that have been comprehensively assessed by IUCN (> 90% of species assessed). The general concern is that IUCN tends to oversample species in the Atlantic portion of the ocean, relative to other regions. This is indicated by the larger number of species with IUCN status in this region. However, the Atlantic falls in line with the other regions when looking at the comprehensively assessed species.
# devtools::install_github("dill/beyonce")
library(beyonce)
<- beyonce_palette(129, 100, type = "continuous")
cols
#2022
<- terra::rast(here("globalprep/spp/v2022/_output/n_spp_risk_raster_comp.tif"))
n_comp <- log(n_comp)
log_n_comp plot(log_n_comp, col=cols)
#2021
<- terra::rast(here("globalprep/spp/v2021/_output/n_spp_risk_raster_comp.tif"))
n_comp <- log(n_comp)
log_n_comp plot(log_n_comp, col=cols)
#2022
<- terra::rast(here("globalprep/spp/v2022/_output/n_spp_risk_raster_all.tif"))
n_all <- log(n_all)
log_n_all plot(log_n_all, col=cols)
#2021
<- terra::rast(here("globalprep/spp/v2021/_output/n_spp_risk_raster_all.tif"))
n_all <- log(n_all)
log_n_all plot(log_n_all, col=cols)
<- n_comp/n_all
prop_comp plot(prop_comp, col=rev(cols))
#this makes sense. For some reason Damselfish and a few reptiles were classified as "non comprehensive", but they are actually comprehensive.
For each cell, we multiply the average species risk by the number of species in order to weight each cells contribution by the number of species. We sum these values for each region and calculate: (average species risk * number species)/number of species
<- terra::rast(here("globalprep/spp/v2022/_output/mean_risk_raster_comp.tif"))
mean_risk_comp
<- terra::rast(here("globalprep/spp/v2022/_output/n_spp_risk_raster_comp.tif"))
n_comp
<- terra::rast(here("globalprep/spp/v2022/_spatial/eez_rast.tif"))
regions_ohi
<- c(regions_ohi, mean_risk_comp, n_comp)
risk_stack_comp plot(risk_stack_comp)
<- terra::values(risk_stack_comp) %>%
risk_vals_comp data.frame()
<- filter(risk_vals_comp, !is.na(eez_rast))
risk_vals_comp <- filter(risk_vals_comp, !is.na(mean_risk_raster_comp))
risk_vals_comp
<- rgn_risk_comp %>%
rgn_risk_comp ::rowwise() %>%
dplyr::mutate(mean_risk = rgn_risk_weight/rgn_n_species) %>%
dplyr::select(rgn_id = eez_rast, mean_risk) dplyr
We use the trend data to estimate risk values for previous years (vs. using the same values for all assessment years). The change in species status across years is based on a linear model.
Trend is calculated using the same method as the risk calculation. For each cell, we multiply the average species trend by the number of species in order to weight each cell’s contribution by the number of species in the cell. We sum these values for each OHI region and calculate for each region: (average species trend * number species)/number of species
<- terra::rast(here("globalprep/spp/v2022/_output/trend_raster_comp.tif"))
trend_comp
<- terra::rast(here("globalprep/spp/v2022/_output/n_trend_raster_comp.tif"))
n_trend_comp
<- terra::rast(here("globalprep/spp/v2022/_spatial/eez_rast.tif"))
regions_ohi
<- c(regions_ohi, trend_comp, n_trend_comp)
trend_stack_comp <- terra::values(trend_stack_comp) %>%
trend_vals_comp data.frame()
<- filter(trend_vals_comp, !is.na(eez_rast))
trend_vals_comp <- filter(trend_vals_comp, !is.na(trend_raster_comp))
trend_vals_comp
<- trend_vals_comp %>%
rgn_trend_comp rowwise() %>%
::mutate(trend_weight = trend_raster_comp * n_trend_raster_comp) %>%
dplyrgroup_by(eez_rast) %>%
summarize(rgn_trend_weight = sum(trend_weight),
rgn_n_species = sum(n_trend_raster_comp)) %>%
rename(rgn_id = eez_rast) %>%
ungroup()
<- rgn_trend_comp %>%
rgn_trend_comp ::rowwise() %>%
dplyr::mutate(mean_trend = rgn_trend_weight/rgn_n_species) %>%
dplyr::select(rgn_id, mean_trend) dplyr
We estimate previous risk for each region, using the trend data. We assume change in risk is linear.
<- 2012:2022
assess_years <- expand.grid(rgn_id = unique(rgn_risk_comp$rgn_id), year=assess_years)
years
# this is what the trend will be multiplied by to get a risk estimate for each year:
<- data.frame(year=assess_years, multiplier = rev(0:(length(assess_years)-1)))
year_multiplier
<- rgn_risk_comp %>%
rgn_risk_comp_yrs ::left_join(rgn_trend_comp, by = "rgn_id") %>%
dplyr::left_join(years, by = "rgn_id") %>%
dplyr::left_join(year_multiplier, by="year") %>%
dplyr::rowwise() %>%
dplyr::mutate(mean_risk_per_year = mean_risk - mean_trend*multiplier) %>%
dplyr::select(rgn_id, year, mean_risk = mean_risk_per_year) dplyr
We rescale the data so a risk factor of 0.75 is equal to zero.
<- rgn_risk_comp_yrs %>%
rgn_status mutate(spp_status = (0.75 - mean_risk)/0.75)
Region 232 (Bosnia) does not have a value, which is not surprising because their coast is super small and results are erratic for this region. We gapfill with surrounding regions.
<- rgns_global %>%
status_gf left_join(rgn_status) %>%
::select(-mean_risk)
dplyrsummary(status_gf)
filter(status_gf, is.na(spp_status))
<- filter(status_gf, rgn_id == 187)
croatia <- filter(status_gf, rgn_id == 186)
mont
<- bind_rows(croatia, mont) %>%
bosnia group_by(year) %>%
summarize(spp_status = mean(spp_status)) %>%
mutate(rgn_id = 232)
<- status_gf %>%
status_gf filter(rgn_id !=232) %>%
bind_rows(bosnia)
<- status_gf %>%
status ::select(rgn_id, year, score = spp_status)
dplyrdim(status) #220*length(assess_years)
summary(status) # should be no NA values
write.csv(status, here("globalprep/spp/v2022/output/sp_status_global.csv"), row.names=FALSE)
<- read_csv(here("globalprep/spp/v2022/output/sp_status_global.csv"))
status
<- read.csv(here("globalprep/spp/v2021/output/sp_status_global.csv")) %>%
old_spp filter(year == max(year)) %>%
rename(old_score = score) %>%
mutate(year = 2021) %>%
left_join(status) %>%
rename(new_score = score)
plot(old_spp$old_score, old_spp$new_score, xlab = "old", ylab = "new")
abline(0,1, col="red")
<- old_spp %>%
old_spp_gather ::select(rgn_id, old_score, new_score) %>%
dplyr::gather("assessment", "score", -1) %>%
tidyr::filter(rgn_id <= 250)
dplyr
ggplot(old_spp_gather, aes(y=assessment, x=score)) +
geom_density_ridges()
ggplot(old_spp, aes(x = old_score, y = new_score)) +
geom_point() +
geom_abline(intercept = 0)
Getting proportional trend requires the status data (trend/status). Proportional trend is multiplied by 5 to get estimated change in five years.
# proportional trend requires status data
<- read.csv(here("globalprep/spp/v2022/output/sp_status_global.csv")) %>%
status ::filter(year==max(year)) %>%
dplyr::select(rgn_id, score)
dplyr
# Calculated in above section: Trend data
<- rgn_trend_comp %>%
rgn_trend_score mutate(spp_trend_adj = -mean_trend/0.75) %>% # puts in comparable units to status
left_join(status, by="rgn_id") %>%
::mutate(trend_score = spp_trend_adj/score * 5) dplyr
Check there are data for every region. Region 232 (Bosnia) does not have a value which is not surprising because their coast is super small and results are erratic for this region. We estimate this using the mean of the 2 surrounding regions.
<- rgns_global %>%
trend left_join(rgn_trend_score)
summary(trend)
filter(trend, is.na(trend_score))
<- filter(trend, rgn_id == 187)
croatia <- filter(trend, rgn_id == 186)
mont <- mean(c(croatia$trend_score, mont$trend_score))
bosnia
$trend_score[trend$rgn_id == 232] <- bosnia trend
<- trend %>%
trend ::select(rgn_id, score = trend_score)
dplyrdim(trend) # should be 220
summary(trend) # should be no NAs
write.csv(trend, here("globalprep/spp/v2022/output/sp_trend_global.csv"), row.names=FALSE)
Previously we used proxy data rather than actual change in IUCN status over time. Our previous method overestimated the magnitude of the trend. It is not surprising there is poor correlation with trend estimates in previous years (before 2019), but it is reassuring the the values mainly fall in the same quadrant, and trends are largely the same now (2019 - present)
<- read.csv(here("globalprep/spp/v2022/output/sp_trend_global.csv"))
trend
<- read.csv(here("globalprep/spp/v2021/output/sp_trend_global.csv")) %>%
old_spp rename(old_score = score) %>%
left_join(trend)
plot(old_spp$old_score, old_spp$score)# xlim=c(-0.35, 0.05))
abline(h=0, col="red")
abline(v=0, col="red")
abline(0,1, col="red")
ggplot(old_spp, aes(x = old_score, y = score)) +
geom_point() +
geom_abline(intercept = 0) +
geom_hline(yintercept = 0) +
geom_vline(xintercept = 0)
<- read.csv(here("globalprep/spp/v2022/output/sp_status_global.csv")) %>%
status mutate(gapfilled = ifelse(rgn_id == 232, 1, 0)) %>%
mutate(method = ifelse(rgn_id == 232, "mean of neighbors", NA)) %>%
::select(rgn_id, year, gapfilled, method)
dplyrwrite.csv(status, here("globalprep/spp/v2022/output/sp_status_global_gf.csv"), row.names=FALSE)
<- read.csv(here("globalprep/spp/v2022/output/sp_trend_global.csv")) %>%
trend mutate(gapfilled = ifelse(rgn_id == 232, 1, 0)) %>%
mutate(method = ifelse(rgn_id == 232, "mean of neighbors", NA)) %>%
::select(rgn_id, gapfilled, method)
dplyrwrite.csv(trend, here("globalprep/spp/v2022/output/sp_trend_global_gf.csv"), row.names=FALSE)
We use species condition data as a resilience measure as well. We also calculate species condition at 3nm of shoreline, because for some goals, nearshore species condition is the relevant metric.
We reproject the data to have higher resolution in order to more
easily extract the data at the 3nm scale.
We modify the method a bit from above due to size of the rasters.
#3nm raster file
<- raster(file.path(dir_M, "git-annex/globalprep/spatial/v2018/rgns_3nm_offshore_mol.tif"))
rgns plot(rgns)
# relevant species files
<- raster(here("globalprep/spp/v2022/_output/mean_risk_raster_comp.tif"))
mean_risk_comp plot(mean_risk_comp)
<- raster(here("globalprep/spp/v2022/_output/n_spp_risk_raster_comp.tif"))
n_comp plot(n_comp)
<- mean_risk_comp*n_comp
risk_x_n plot(risk_x_n)
# project rasters to moll
# saved in Mazu:spp/v2022
::projectRaster(risk_x_n, rgns, method="ngb", overwrite=TRUE,
rasterfilename=file.path(dir_M, "git-annex/globalprep/spp/v2022/int/risk_x_n_comp_mol.tif"), progress = "text")
projectRaster(n_comp, rgns, method="ngb", overwrite=TRUE,
filename=file.path(dir_M, "git-annex/globalprep/spp/v2022/int/n_comp_mol.tif"), progress = "text")
Extract species risk data that corresponds to 3nm regions.
#3nm raster file
<- rast(file.path(dir_M, "git-annex/globalprep/spatial/v2018/rgns_3nm_offshore_mol.tif"))
rgns # plot(rgns)
<- rast(file.path(dir_M, "git-annex/globalprep/spp/v2022/int/risk_x_n_comp_mol.tif"))
risk_x_n_mol # plot(risk_x_n_mol)
<- rast(file.path(dir_M, "git-annex/globalprep/spp/v2022/int/n_comp_mol.tif"))
n_mol # plot(n_mol)
<- c(rgns, risk_x_n_mol, n_mol)
risk_stack
<- terra::values(risk_stack)
risk_df
<- as.data.frame(risk_df) %>%
risk_df_2 filter(!is.na(rgns_3nm_offshore_mol)) %>%
filter(!is.na(risk_x_n_comp_mol))
<- risk_df_2 %>%
rgn_3nm_risk rowwise() %>%
group_by(rgns_3nm_offshore_mol) %>%
summarize(risk_x_n_comp_mol = sum(risk_x_n_comp_mol),
n_comp_mol = sum(n_comp_mol)) %>%
ungroup() %>%
rename(zone = 1) %>%
::mutate(rgn_wt_risk = risk_x_n_comp_mol/n_comp_mol) %>%
dplyr::select(rgn_id = zone, rgn_wt_risk) dplyr
We use the trend data to estimate risk values for previous years (vs. using the same values for all assessment years). The change in species status across years is based on a linear model.
Trend is calculated using the same method as the risk calculation. For each cell, we multiply the average species trend by the number of species in order to weight each cell’s contribution by the number of species in the cell. We sum these values for each OHI region and calculate for each region: (average species trend * number species)/number of species
We reproject the data to have higher resolution in order to more easily extract the data at the 3nm scale.
<- raster(file.path(dir_M, "git-annex/globalprep/spatial/v2018/rgns_3nm_offshore_mol.tif"))
rgns
<- raster::raster(here("globalprep/spp/v2022/_output/trend_raster_comp.tif"))
trend_comp
<- raster::raster(here("globalprep/spp/v2022/_output/n_trend_raster_comp.tif"))
n_trend_comp
<- trend_comp*n_trend_comp
trend_x_n
# project rasters to moll
# saved in Mazu:spp/v2022
projectRaster(trend_x_n, rgns, method="ngb", overwrite=TRUE,
filename=file.path(dir_M, "git-annex/globalprep/spp/v2022/int/trend_x_n_comp_mol.tif"),
progress="text")
projectRaster(n_trend_comp, rgns, method="ngb", over=TRUE,
filename=file.path(dir_M, "git-annex/globalprep/spp/v2022/int/n_trend_comp_mol.tif"),
progress="text")
Extract species risk data that corresponds to 3nm regions.
#3nm raster file
<- rast(file.path(dir_M, "git-annex/globalprep/spatial/v2018/rgns_3nm_offshore_mol.tif"))
rgns_3nm plot(rgns_3nm)
<- rast(file.path(dir_M, "git-annex/globalprep/spp/v2022/int/trend_x_n_comp_mol.tif"))
trend_3nm_mol <- rast(file.path(dir_M, "git-annex/globalprep/spp/v2022/int/n_trend_comp_mol.tif"))
n_trend_3nm_mol
<- c(rgns_3nm, trend_3nm_mol, n_trend_3nm_mol)
trend_stack
# trend_df <- terra::zonal(trend_stack, rgns_3nm, fun='sum')
<- terra::values(trend_stack)
trend_df
<- as.data.frame(trend_df) %>%
trend_df_2 filter(!is.na(rgns_3nm_offshore_mol)) %>%
filter(!is.na(trend_x_n_comp_mol))
<- trend_df_2 %>%
rgn_3nm_trend data.frame() %>%
rowwise() %>%
group_by(rgns_3nm_offshore_mol) %>%
summarize(trend_x_n_comp_mol = sum(trend_x_n_comp_mol),
n_trend_comp_mol = sum(n_trend_comp_mol)) %>%
ungroup() %>%
rename(zone = 1) %>%
::mutate(rgn_wt_trend = trend_x_n_comp_mol/n_trend_comp_mol) %>%
dplyr::select(rgn_id = zone, rgn_wt_trend) dplyr
We estimate previous risk for each region, using the trend data. We assume change in risk is linear.
<- 2012:2022
assess_years <- expand.grid(rgn_id = unique(rgn_3nm_trend$rgn_id), year=assess_years)
years
# this is what the trend will be multiplied by to get a risk estimate for each year:
<- data.frame(year=assess_years, multiplier = rev(0:(length(assess_years)-1)))
year_multiplier
<- rgn_3nm_risk %>%
rgn_risk_3nm left_join(rgn_3nm_trend, by = "rgn_id") %>%
left_join(years, by = "rgn_id") %>%
left_join(year_multiplier, by="year") %>%
rowwise() %>%
mutate(mean_risk_per_year = rgn_wt_risk - rgn_wt_trend*multiplier) %>%
::select(rgn_id, year, mean_risk = mean_risk_per_year) dplyr
We rescale the data so a risk factor of 0.75 is equal to zero.
<- rgn_risk_3nm %>%
rgn_3nm_res mutate(spp_status = (0.75 - mean_risk)/0.75)
# quick check
hist(rgn_3nm_res$spp_status)
Region 19 (Tuvalu) does not have a value. This is an island. We gapfill with the value from the entire eez.
<- rgns_global %>%
res_gf left_join(rgn_3nm_res) %>%
::select(-mean_risk)
dplyr
summary(res_gf)
filter(res_gf, is.na(spp_status))
# get eez value:
<- read.csv(here("globalprep/spp/v2022/output/sp_status_global.csv")) %>%
eez_status filter(rgn_id == 19) %>%
rename(spp_status = score)
<- res_gf %>%
res_gf filter(!is.na(spp_status)) %>%
bind_rows(eez_status)
summary(res_gf)
<- res_gf %>%
resilience ::select(rgn_id, year, score = spp_status)
dplyr
summary(resilience) # should be no NA values
write.csv(resilience, here("globalprep/spp/v2022/output/sp_status_3nm.csv"), row.names=FALSE)
<- read.csv(here("globalprep/spp/v2022/output/sp_status_3nm.csv")) %>%
res mutate(gapfilled = ifelse(rgn_id == 19, 1, 0)) %>%
mutate(method = ifelse(rgn_id == 19, "eez scale data used", NA)) %>%
::select(rgn_id, year, gapfilled, method)
dplyrwrite.csv(res, here("globalprep/spp/v2022/output/sp_status_3nm_gf.csv"), row.names=FALSE)
Compared to the entire EEZ, most (but not all) coastal areas have higher species condition scores. The correlation with last year is better than it was last year.
# compare to eez values
<- read.csv(here("globalprep/spp/v2022/output/sp_status_global.csv")) %>%
eez_status filter(year == max(year)) %>%
::select(rgn_id, eez_score = score)
dplyr
<- read.csv(here("globalprep/spp/v2022/output/sp_status_3nm.csv")) %>%
status ::select(rgn_id, year, nm3_score = score) %>%
dplyrfilter(year == max(year)) %>%
left_join(eez_status, by = "rgn_id")
plot(status$nm3_score, status$eez_score)
abline(0,1)
ggplot(status, aes(x = nm3_score, y = eez_score)) +
geom_point() +
geom_abline(intercept = 0) +
labs(x = "3nm score", y = "eez score")
# compare to last year's values
<- read.csv(here("globalprep/spp/v2022/output/sp_status_3nm.csv")) %>%
status filter(year == max(year)) %>%
::select(-year)
dplyr
<- read.csv(here("globalprep/spp/v2021/output/sp_status_3nm.csv")) %>%
old_spp filter(year == max(year)) %>%
rename(old_score = score) %>%
# mutate(year = 2020) %>%
::select(-year) %>%
dplyrleft_join(status) %>%
rename(new_score = score) %>%
mutate(difference = new_score - old_score) %>%
left_join(rgns_eez)
plot(old_spp$old_score, old_spp$new_score)
abline(0,1, col="red")
ggplot(old_spp, aes(x = old_score, y = new_score)) +
geom_point() +
geom_abline(intercept = 0) +
labs(x = "v2021 resilience", y = "v2021 resilience")
<- old_spp %>%
old_spp_gather ::select(rgn_id, old_score, new_score) %>%
dplyr::gather("assessment", "score", -1) %>%
tidyrfilter(rgn_id <= 250)
ggplot(old_spp_gather, aes(y=assessment, x=score)) +
geom_density_ridges()
<- old_spp %>%
check_3nm_old filter(new_score > 0.85, old_score > 0.79, old_score <0.87) %>%
mutate(diff = old_score - new_score)