A notebook for the analysis of flight feather stable isotopes of Eurasian wigeon Mareca penelope harvested in Finland
Antti Piironen
28 March 2024
Overview
This notebook contains the script for analysis and visualisation for the manuscript: Holopainen, S., Piironen, A., Hobson, K., Kusack, J., Sørensen, I.H., Ellis, M. & Laaksonen, T. (2024). Broad geographic variation in age- and sex-dependent origin of harvested Eurasian wigeon (Mareca penelope) in Finland revealed by stable-hydrogen (δ 2H) isotope analyses of feathers.
The notebook shows the fitting of a Gaussian process model to the stable isotope values and the geographical assignment of origins. For the description and justification of the methods, see the manuscript and references therein.
First, set working directory, load needed packages and empty memory
setwd('C:/Users/hrx301/OneDrive - University of Saskatchewan/R/haapana')
library("ggplot2")
library("stringr")
library("stringi")
library("maps")
library("readxl")
library("grid")
library("gridExtra")
library("dplyr")
library("hrbrthemes")
library("rnaturalearth")
library('terra')
library('sf')
library('sp')
library('rasterVis')
library('lubridate')
library('raster')
library('ggpubr')
library('patchwork')
library('lattice')
library('egg')
library('tidyterra')
library('tidyverse')
library('patchwork')
rm(list=ls())Load, clean and scale the data
data <- read.table("wigeon-isotope-samples-clean.csv", header = TRUE, sep = ";", dec = ".", quote = "", na.strings = "NA")
data_iso <- read_excel("ISO_Finland_Feathers_Results.xlsx")
colnames(data_iso) <- c("ISO_ID", "sample", "WSMOW")
data <- merge(data, data_iso, by = "sample", all.x = TRUE)
data <- data[complete.cases(data$sex), ]
data$date <- as.Date(data$date, format = "%d.%m.%Y")
data <- data[complete.cases(data$date), ]
data$WSMOW <- round(data$WSMOW, digits = 1)
data$date_num <- as.numeric(data$date)
data$WSMOW_scaled <- (data$WSMOW - mean(data$WSMOW))/sd(data$WSMOW)
data$date_num_scaled <- data$date_num - min(data$date_num) + 1
data$age <- as.factor(data$age)
data$sex <- as.factor(data$sex)1. Fit a GP model with neural network kernel
library("gplite")
# Split the data into age- and sex-dependent variables
ad.f <- data[which(data$sex == 'female' & data$age == 'ad'),]
ad.m <- data[which(data$sex == 'male' & data$age == 'ad'),]
juv <- data[which(data$age == 'juv'),]
# Fit
restarts = 3
tol = 0.01
gp <- gp_init(cfs = cf_nn(),
lik = lik_gaussian())
fit.ad.f <- gp_optim(gp, x = ad.f$date_num, y = ad.f$WSMOW_scaled, restarts = restarts, tol_param = tol)
fit.ad.m <- gp_optim(gp, x = ad.m$date_num, y = ad.m$WSMOW_scaled, restarts = restarts, tol_param = tol)
fit.juv <- gp_optim(gp, x = juv$date_num, y = juv$WSMOW_scaled, restarts = restarts, tol_param = tol)
# Predict at the standardized scale
grid <- seq(min(data$date_num), max(data$date_num), by = 1)
pred.ad.f <- gp_pred(fit.ad.f, grid, var = TRUE)
pred.ad.m <- gp_pred(fit.ad.m, grid, var = TRUE)
pred.juv <- gp_pred(fit.juv, grid, var = TRUE)Backtransform predictions to the original scale
# ad female
orig.mu.adf <- pred.ad.f$mean*sd(data$WSMOW) + mean(data$WSMOW)
orig.low.adf <- (pred.ad.f$mean - 2*sqrt(pred.ad.f$var))*sd(data$WSMOW) + mean(data$WSMOW)
orig.upper.adf <- (pred.ad.f$mean + 2*sqrt(pred.ad.f$var))*sd(data$WSMOW) + mean(data$WSMOW)
# ad male
orig.mu.adm <- pred.ad.m$mean*sd(data$WSMOW) + mean(data$WSMOW)
orig.low.adm <- (pred.ad.m$mean - 2*sqrt(pred.ad.m$var))*sd(data$WSMOW) + mean(data$WSMOW)
orig.upper.adm <- (pred.ad.m$mean + 2*sqrt(pred.ad.m$var))*sd(data$WSMOW) + mean(data$WSMOW)
# juv
orig.mu.juv <- pred.juv$mean*sd(data$WSMOW) + mean(data$WSMOW)
orig.low.juv <- (pred.juv$mean - 2*sqrt(pred.juv$var))*sd(data$WSMOW) + mean(data$WSMOW)
orig.upper.juv <- (pred.juv$mean + 2*sqrt(pred.juv$var))*sd(data$WSMOW) + mean(data$WSMOW)
df.pred.orig <- data.frame("x" = grid,
"mu_adf" = orig.mu.adf, "upper_adf" = orig.upper.adf, "lower_adf" = orig.low.adf,
"mu_adm" = orig.mu.adm, "upper_adm" = orig.upper.adm, "lower_adm" = orig.low.adm,
"mu_juv" = orig.mu.juv, "upper_juv" = orig.upper.juv, "lower_juv" = orig.low.juv)Visualize the model fit at the original scale
alpha_data = 0.4
title_size = 28
text_size = 26
num_size = 24
alpha_ci = 0.3
col_data = 'grey'
col_adf <- '#440154FF'
col_adm <- '#39568CFF'
col_juv <- '#55C667FF'
# Adult females
plot.orig.adf <- ggplot() + theme_ipsum() + ylim(c(-200, -120)) +
geom_point(data = ad.f, aes(x = as.Date(date_num, origin = '1970-01-01'), y = WSMOW), col = col_data, size = 3, alpha = alpha_data) +
geom_ribbon(data = df.pred.orig, aes(x = as.Date(x, origin = '1970-01-01'), ymin = orig.low.adf, ymax = orig.upper.adf),
fill = col_adf, col = col_adf, alpha = alpha_ci) +
geom_line(data = df.pred.orig, aes(x = as.Date(x, origin = '1970-01-01'), y = mu_adf), col = col_adf, linewidth = 1.3) +
theme(axis.title.x = element_blank(),
axis.title.y = element_text(size = text_size, color = 'black'),
axis.text.x = element_text(size = num_size, color = 'black'),
axis.text.y = element_text(size = num_size, color = 'black'),
plot.title = element_text(size = title_size)) +
labs(y = expression(delta ^2*H[f]), title = "A. Adult females")
# Adult males
plot.orig.adm <- ggplot() + theme_ipsum() + ylim(c(-200, -120)) +
geom_point(data = ad.m, aes(x = as.Date(date_num, origin = '1970-01-01'), y = WSMOW), col = col_data, size = 3, alpha = alpha_data) +
geom_ribbon(data = df.pred.orig, aes(x = as.Date(x, origin = '1970-01-01'), ymin = orig.low.adm, ymax = orig.upper.adm),
fill = col_adm, col = col_adm, alpha = alpha_ci) +
geom_line(data = df.pred.orig, aes(x = as.Date(x, origin = '1970-01-01'), y = mu_adm), col = col_adm, linewidth = 1.3) +
theme(axis.title.x = element_blank(),
axis.title.y = element_text(size = text_size, color = 'black'),
axis.text.x = element_text(size = num_size, color = 'black'),
axis.text.y = element_text(size = num_size, color = 'black'),
plot.title = element_text(size = title_size)) +
labs(y = expression(delta ^2*H[f]), title = "B. Adult males")
# Juveniles
plot.orig.juv <- ggplot() + theme_ipsum() + ylim(c(-200, -120)) +
geom_point(data = juv, aes(x = as.Date(date_num, origin = '1970-01-01'), y = WSMOW), col = col_data, size = 3, alpha = alpha_data) +
geom_ribbon(data = df.pred.orig, aes(x = as.Date(x, origin = '1970-01-01'), ymin = orig.low.juv, ymax = orig.upper.juv),
fill = col_juv, col = col_juv, alpha = alpha_ci) +
geom_line(data = df.pred.orig, aes(x = as.Date(x, origin = '1970-01-01'), y = mu_juv), col = col_juv, linewidth = 1.3) +
theme(axis.title.x = element_blank(),
axis.title.y = element_text(size = text_size, color = 'black'),
axis.text.x = element_text(size = num_size, color = 'black'),
axis.text.y = element_text(size = num_size, color = 'black'),
plot.title = element_text(size = title_size)) +
labs(y = expression(delta ^2*H[f]), title = "C. Juveniles")
plot.fit <- ggarrange(plot.orig.adf +
theme(axis.title.x = element_blank(),
plot.margin = margin(t = 10, b = 10, l = 10, r = 2)),
plot.orig.adm +
theme(axis.text.y = element_blank(),
axis.ticks.y = element_blank(),
axis.title.y = element_blank(),
axis.title.x = element_blank(),
plot.margin = margin(t = 10, b = 10, l = 2, r = 2)),
plot.orig.juv +
theme(axis.text.y = element_blank(),
axis.ticks.y = element_blank(),
axis.title.y = element_blank(),
plot.margin = margin(t = 10, b = 10, l = 2, r = 10)),
nrow = 1)
2. Assign isotope values to the origin
library("assignR")
# Subset the data
af.early <- subset(ad.f, date <= as.Date("2021-09-08", origin = "1970-01-01"))
af.late <- subset(ad.f, date > as.Date("2021-09-08", origin = "1970-01-01"))
am.early <- subset(ad.m, date <= as.Date("2021-09-08", origin = "1970-01-01"))
am.late <- subset(ad.m, date > as.Date("2021-09-08", origin = "1970-01-01"))
juv.early <- subset(juv, date <= as.Date("2021-09-08", origin = "1970-01-01"))
juv.late <- subset(juv, date > as.Date("2021-09-08", origin = "1970-01-01"))
# Map of Europe
europe <- ne_countries(continent = "Europe", scale = 50, returnclass = "sf") %>%
st_transform(st_crs('EPSG:4326'))
# Wigeon breeding range in Europe and Asia
breeding_range <- read_sf("Haapana_pesima_BirdLife_siivottu_Antille.shp", as_tibble = FALSE)
# Isoscape
isoscape <- getIsoscapes(isoType = "GlobalPrecipGS")
isoscape <- project(isoscape, "EPSG:4326", method = "near")
isoscape <- isoscape[[1:2]]
plot(isoscape)
Calibrate the mean d2Hp values to tissue relevant values. Here, we use calibration values from mallards from the paper van Dijk et al. 2014 (the dataset number 12 in subOrigData). Other relevant choice would be the data from lesser scaups (Clark et al. 2006, Clark et al. 2009), but the mallard dataset has samples from Europe, so well go with it
mallard <- subOrigData(marker = 'd2H', dataset = 12, ref_scale = NULL)
mallard$data <- project(mallard$data, 'EPSG:4326')
# Calibrate the isoscape values to the tissue relevant scale
r <- calRaster(known = mallard, isoscape = isoscape, interpMethod = 1, verboseLM = F, genplot = F)
r.model <- r$lm.model
summary(r.model)
# Visualize the model fit
ggplot(data = r$lm.data, aes(y = tissue.iso, x = isoscape.iso)) +
geom_point() +
stat_smooth(method = "lm", formula = 'y ~ x') +
theme_classic()
# Remove everything else except the breeding range and visualize the re-scaled isoscape
r$isoscape.rescale <- mask((r$isoscape.rescale), breeding_range) %>%
crop(extent(breeding_range)) %>%
c()
plot(r$isoscape.rescale, xlab = "Longitude", ylab = "Latitude")
Prior surface based on GPS tracking and ring recoveries. Note, that the prior here is a uniform prior with value 1 within the possible origins based on GPS tracking and ring-recovery data. Hence, the prior leaves out all origins outside this range, but does not weight the probability of origin within the range
prior <- read_sf("GPS_EURING_kapea_Ruotsi.shp", as_tibble = FALSE) %>% st_transform(st_crs('EPSG:4326'))
prior$prob <- 1
# Clip the isoscape to the extent of the prior and plot
isoscape.scaled.mask <- mask((r$isoscape.rescale), prior) %>%
crop(extent(prior)) %>%
c()
is_high = '#DEC319FF'
is_low = '#440154FF'
ylim = c(58, 77)
xlim = c(8, 110)
leg_text = 20
tag_size = 35
leg_height = 10
ggplot() +
theme(panel.background = element_blank(),
axis.title.x = element_blank(),
axis.title.y = element_blank(),
axis.text = element_blank(),
axis.ticks = element_blank(),
plot.title = element_text(size = title_size, margin = margin(t = 15, b = 0, l = 0, r = 0)),
legend.text = element_text(size = leg_text),
legend.title = element_blank(),
plot.margin = margin(t = 0, b = 10, l = 0, r = 10),
legend.margin = margin(t = 0, b = 0, r = 0, l = 0)) +
geom_spatraster(data = isoscape.scaled.mask[[1]]) +
coord_sf(crs = 4326) +
scale_fill_gradient(low = is_low, high = is_high, na.value = "transparent") +
geom_sf(data = europe, fill = "transparent") +
coord_sf(xlim = xlim, ylim = ylim, expand = TRUE) +
guides(fill = guide_colourbar(barheight = leg_height))
# Rasterize the polygons to match the calibrated isoscape
prior <- rasterize(prior, r$isoscape.rescale[[1]], values = "prob") %>%
mask(breeding_range)
# Assign to the origin
orig.af.early <- pdRaster(r, data.frame('sample' = af.early$sample, 'WSMOW' = af.early$WSMOW), mask = as(breeding_range, 'Spatial'), prior = prior, genplot = F)
orig.af.late <- pdRaster(r, data.frame('sample' = af.late$sample, 'WSMOW' = af.late$WSMOW), mask = as(breeding_range, 'Spatial'), prior = prior, genplot = F)
orig.am.early <- pdRaster(r, data.frame('sample' = am.early$sample, 'WSMOW' = am.early$WSMOW), mask = as(breeding_range, 'Spatial'), prior = prior, genplot = F)
orig.am.late <- pdRaster(r, data.frame('sample' = am.late$sample, 'WSMOW' = am.late$WSMOW), mask = as(breeding_range, 'Spatial'), prior = prior, genplot = F)
orig.juv.early <- pdRaster(r, data.frame('sample' = juv.early$sample, 'WSMOW' = juv.early$WSMOW), mask = as(breeding_range, 'Spatial'), prior = prior, genplot = F)
orig.juv.late <- pdRaster(r, data.frame('sample' = juv.late$sample, 'WSMOW' = juv.late$WSMOW), mask = as(breeding_range, 'Spatial'), prior = prior, genplot = F)
# Use a few random samples ped data set to check that probabilities sum up to 1
global(orig.af.early[[1]], fun = 'sum', na.rm = TRUE)
global(orig.af.late[[10]], fun = 'sum', na.rm = TRUE)
global(orig.am.early[[2]], fun = 'sum', na.rm = TRUE)
global(orig.am.late[[23]], fun = 'sum', na.rm = TRUE)
global(orig.juv.early[[6]], fun = 'sum', na.rm = TRUE)
global(orig.juv.late[[13]], fun = 'sum', na.rm = TRUE)
# Create binary surfaces using upper 67 % probability of origin for all individuals (odds ratio 2:1)
odds <- 2/3
bin.orig.af.early <- qtlRaster(orig.af.early, threshold = odds, thresholdType = "prob", genplot = F)
bin.orig.af.late <- qtlRaster(orig.af.late, threshold = odds, thresholdType = "prob", genplot = F)
bin.orig.am.early <- qtlRaster(orig.am.early, threshold = odds, thresholdType = "prob", genplot = F)
bin.orig.am.late <- qtlRaster(orig.am.late, threshold = odds, thresholdType = "prob", genplot = F)
bin.orig.juv.early <- qtlRaster(orig.juv.early, threshold = odds, thresholdType = "prob", genplot = F)
bin.orig.juv.late <- qtlRaster(orig.juv.late, threshold = odds, thresholdType = "prob", genplot = F)Sum all surfaces to raster (cell values represents the number of individuals assigned to that cell given the odds ratio (here 2:1)
comb.af.early <- app(bin.orig.af.early, fun = sum)
comb.af.late <- app(bin.orig.af.late, fun = sum)
comb.am.early <- app(bin.orig.am.early, fun = sum)
comb.am.late <- app(bin.orig.am.late, fun = sum)
comb.juv.early <- app(bin.orig.juv.early, fun = sum)
comb.juv.late <- app(bin.orig.juv.late, fun = sum)Visualize the origins
df.af.early <- as.data.frame(comb.af.early, xy = TRUE)
df.af.late <- as.data.frame(comb.af.late, xy = TRUE)
df.am.early <- as.data.frame(comb.am.early, xy = TRUE)
df.am.late <- as.data.frame(comb.am.late, xy = TRUE)
df.juv.early <- as.data.frame(comb.juv.early, xy = TRUE)
df.juv.late <- as.data.frame(comb.juv.late, xy = TRUE)
col_low = 'white'
col_high = '#440154FF'
title_size = 30
leg_text = 20
tag_size = 35
leg_height = 10
plot.af.early <- ggplot() +
theme(panel.background = element_blank(),
axis.title.x = element_blank(),
axis.title.y = element_blank(),
axis.text = element_blank(),
axis.ticks = element_blank(),
plot.title = element_text(size = title_size, margin = margin(t = 15, b = 0, l = 0, r = 0)),
legend.text = element_text(size = leg_text),
legend.title = element_blank(),
plot.margin = margin(t = 0, b = 10, l = 0, r = 10),
legend.margin = margin(t = 0, b = 0, r = 0, l = 0)) +
geom_spatraster(data = comb.af.early, aes(fill = sum)) +
coord_sf(crs = 4326) +
scale_fill_gradient(low = col_low, high = col_high, na.value = "transparent") +
geom_sf(data = europe, fill = "transparent") +
coord_sf(xlim = xlim, ylim = ylim, expand = TRUE) +
labs(title = "A. Adult females, early") +
guides(fill = guide_colourbar(barheight = leg_height))
plot.af.late <- ggplot() +
theme(panel.background = element_blank(),
axis.title.x = element_blank(),
axis.title.y = element_blank(),
axis.text = element_blank(),
axis.ticks = element_blank(),
plot.title = element_text(size = title_size, margin = margin(t = 15, b = 0, l = 0,r = 0)),
legend.text = element_text(size = leg_text),
legend.title = element_blank(),
plot.margin = margin(t = 0, b = 10, l = 10, r = 0),
legend.margin = margin(t = 0, b = 0, r = 0, l = 0)) +
geom_spatraster(data = comb.af.late, aes(fill = sum)) +
coord_sf(crs = 4326) +
scale_fill_gradient(low = col_low, high = col_high, na.value = "transparent") +
geom_sf(data = europe, fill = "transparent") +
coord_sf(xlim = xlim, ylim = ylim, expand = TRUE) +
labs(title = 'B. Adult females, late') +
guides(fill = guide_colourbar(barheight = leg_height))
plot.am.early <- ggplot() +
theme(panel.background = element_blank(),
axis.title.x = element_blank(),
axis.title.y = element_blank(),
axis.text = element_blank(),
axis.ticks = element_blank(),
plot.title = element_text(size = title_size, margin = margin(t = 15, b = 0, l = 0,r = 0)),
legend.text = element_text(size = leg_text),
legend.title = element_blank(),
plot.margin = margin(t = 0, b = 10, l = 0, r = 10),
legend.margin = margin(t = 0, b = 0, r = 0, l = 0)) +
geom_spatraster(data = comb.am.early, aes(fill = sum)) +
coord_sf(crs = 4326) +
scale_fill_gradient(low = col_low, high = col_high, na.value = "transparent") +
geom_sf(data = europe, fill = "transparent") +
coord_sf(xlim = xlim, ylim = ylim, expand = TRUE) +
labs(title = 'C. Adult males, early') +
guides(fill = guide_colourbar(barheight = leg_height))
plot.am.late <- ggplot() +
theme(panel.background = element_blank(),
axis.title.x = element_blank(),
axis.title.y = element_blank(),
axis.text = element_blank(),
axis.ticks = element_blank(),
legend.text = element_text(size = leg_text),
plot.title = element_text(size = title_size, margin = margin(t = 15, b = 0, l = 0,r = 0)),
legend.title = element_blank(),
plot.margin = margin(t = 0, b = 10, l = 10, r = 0),
legend.margin = margin(t = 0, b = 0, r = 0, l = 0)) +
geom_spatraster(data = comb.am.late, aes(fill = sum)) +
coord_sf(crs = 4326) +
scale_fill_gradient(low = col_low, high = col_high, na.value = "transparent") +
geom_sf(data = europe, fill = "transparent") +
coord_sf(xlim = xlim, ylim = ylim, expand = TRUE) +
labs(title = 'D. Adult males, late') +
guides(fill = guide_colourbar(barheight = leg_height))
plot.juv.early <- ggplot() +
theme(panel.background = element_blank(),
axis.title.x = element_blank(),
axis.title.y = element_blank(),
axis.text = element_blank(),
axis.ticks = element_blank(),
plot.title = element_text(size = title_size, margin = margin(t = 15, b = 0, l = 0,r = 0)),
legend.text = element_text(size = leg_text),
legend.title = element_blank(),
plot.margin = margin(t = 0, b = 0, l = 0, r = 10),
legend.margin = margin(t = 0, b = 0, r = 0, l = 0)) +
geom_spatraster(data = comb.juv.early, aes(fill = sum)) +
coord_sf(crs = 4326) +
scale_fill_gradient(low = col_low, high = col_high, na.value = "transparent") +
geom_sf(data = europe, fill = "transparent") +
coord_sf(xlim = xlim, ylim = ylim, expand = TRUE) +
labs(title = 'E. Juveniles, early') +
guides(fill = guide_colourbar(barheight = leg_height))
plot.juv.late <- ggplot() +
theme(panel.background = element_blank(),
axis.title.x = element_blank(),
axis.title.y = element_blank(),
axis.text = element_blank(),
axis.ticks = element_blank(),
legend.text = element_text(size = leg_text),
legend.title = element_blank(),
plot.title = element_text(size = title_size, margin = margin(t = 15, b = 0, l = 0,r = 0)),
plot.margin = margin(t = 0, b = 0, l = 10, r = 0),
legend.margin = margin(t = 0, b = 0, r = 0, l = 0)) +
geom_spatraster(data = comb.juv.late, aes(fill = sum)) +
coord_sf(crs = 4326) +
scale_fill_gradient(low = col_low, high = col_high, na.value = "transparent") +
geom_sf(data = europe, fill = "transparent") +
coord_sf(xlim = xlim, ylim = ylim, expand = TRUE) +
labs(title = 'F. Juveniles, late') +
guides(fill = guide_colourbar(barheight = leg_height))
combined <- plot.af.early + plot.af.late + plot.am.early + plot.am.late + plot.juv.early + plot.juv.late
fig <- combined +
plot_layout(ncol = 2) +
plot_annotation() &
theme(plot.margin = margin(t = 0, b = 0, l = 0, r = 0))
fig