EWEs and STSH – East Kangaroo Island
Identifying and quantifying the effects of extreme weather events on short-tailed shearwater colony at East Kangaroo Island
Milan Sojitra
2025-11-18
# Load libraries for data processing, modelling, and visualisation
library(tidyverse)
library(openxlsx2)
library(MASS)
library(corrplot)
library(DT)
library(climwin)
library(jtools)
library(DHARMa)
library(lavaan)
library(DiagrammeR)
library(lmtest)
library(glmmTMB)
library(scales)1 Load and Process Data
# Load daily extreme weather event (EWE) data
extreme_weather <- wb_to_df("Breeding_colony_ewes/East_Kangaroo_ewes.xlsx") %>%
dplyr::mutate(across(4:8, ~ ifelse(is.na(.), 0, .))) # Replace NA with 0 for analysis
# Create binary version: 1 = event occurred, 0 = no event, NA = missing
extreme_weather_binary <- extreme_weather %>%
dplyr::mutate(across(4:8, ~ ifelse(!is.na(.) & . != 0, 1, ifelse(is.na(.), NA, 0))))
# Note:
# Missing values in extreme weather data are replaced with zero. This is critical because the slidingwin method ("method1" and "method2") internally calculates means when NA values are present, which is not suitable when assessing extreme values. We are specifically interested in whether an extreme event occurred, not in average conditions.
# A small number of missing values are present in the dataset, and replacing them with zero ensures consistency without introducing bias in this context.
# Load Short-tailed Shearwater breeding data
breeding_data <- wb_to_df("Breeding_data/STSH.xlsx", sheet = "East_Kangaroo_Island") %>%
dplyr::filter(!is.na(bs)) # Remove seasons without breeding success data
# Record sample size
sample_size <- nrow(breeding_data)
# Assess normality of response variable
# If p > 0.05, the data does not significantly deviate from normality.
shapiro.test(breeding_data$bs)##
## Shapiro-Wilk normality test
##
## data: breeding_data$bs
## W = 0.90963, p-value = 0.02586# Histogram with density curve
hist(breeding_data$bs,
main = "Histogram of Breeding Success",
xlab = "Breeding Success",
col = "#a6d6fa",
border = "white",
prob = TRUE
)
# Overlay kernel density estimate
lines(density(breeding_data$bs, na.rm = TRUE), col = "#0D92F4", lwd = 2)
# Q-Q plot
ggplot(breeding_data, aes(sample = bs)) +
stat_qq() +
stat_qq_line(colour = "red") +
labs(title = "Q-Q Plot of Breeding Success",
x = "Theoretical Quantiles",
y = "Sample Quantiles") +
theme_classic()
The Shapiro–Wilk test indicated a significant deviation from normality (W = 0.90963, p = 0.02586); therefore, we reject the null hypothesis that the data are normally distributed.
2 Sliding window analysis
2.1 Actual above threshold values
# Run the sliding window analysis using actual (non-binary) values
output1 <- slidingwin(xvar = list(wet_day = extreme_weather$wet_day,
heavy_rain_day = extreme_weather$heavy_rain_day,
very_heavy_rain_day = extreme_weather$very_heavy_rain_day,
ewdp = extreme_weather$ewdp,
vwdp = extreme_weather$vwdp),
cdate = extreme_weather$date, # Climate date
bdate = breeding_data$date, # Biological event date
baseline = lm(bs ~ 1,
data = breeding_data), # Baseline model
cohort = breeding_data$season, # Group by season
cinterval = "day", # Daily resolution
range = c(96, 0), # Check windows from 1 December to 7 March
refday = c(07, 03), # Reference date: 7 March
type = "absolute", # Absolute window type
stat = "sum", # Sum values within each window
func = "lin" # For linear relationship
)2.2 Binary above threshold values
# Run the sliding window analysis using binary event indicators
output2 <- slidingwin(xvar = list(wet_day_bi = extreme_weather_binary$wet_day,
heavy_rain_day_bi = extreme_weather_binary$heavy_rain_day,
very_heavy_rain_day_bi = extreme_weather_binary$very_heavy_rain_day,
ewdp_bi = extreme_weather_binary$ewdp,
vwdp_bi = extreme_weather_binary$vwdp),
cdate = extreme_weather_binary$date, # Climate date
bdate = breeding_data$date, # Biological event date
baseline = lm(bs ~ 1,
data = breeding_data), # Baseline model
cohort = breeding_data$season, # Group by season
cinterval = "day", # Daily resolution
range = c(96, 0), # Check windows from 1 December to 7 March
refday = c(07, 03), # Reference date: 7 March
type = "absolute", # Absolute window type
stat = "sum", # Sum values within each window
func = "lin" # For linear relationship
)2.3 Merge the results
# Combine output from actual and binary sliding window analyses
output <- merge_results(output1, output2)
# View merged model combinations with calculated window duration
datatable(output$combos %>%
dplyr::mutate(WindowDuration = WindowOpen - WindowClose + 1),
options = list(pageLength = 10, orderClasses = TRUE))2.4 Check best model for each variable
Before running the randomisation process, we need to identify the best-performing model for each extreme weather variable. This ensures that we are testing the most likely biologically relevant window against random expectation.
What we are doing here: For each weather variable (e.g., heavy rain, wet days), we extract the model with:
The lowest AIC value, and
A window duration longer than 14 days, to focus on ecologically meaningful timeframes.
These best models represent the strongest climate–breeding success relationships, and will be used for the randomisation test to assess whether the relationship is likely to have occurred by chance.
2.4.1 Heavy rain***
# Summarise the best model
summary(output[[7]]$BestModel)##
## Call:
## lm(formula = yvar ~ climate, data = modeldat)
##
## Residuals:
## Min 1Q Median 3Q Max
## -0.31691 -0.09577 -0.01380 0.15151 0.24405
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 0.75506 0.04701 16.061 2.43e-14 ***
## climate -0.09268 0.02197 -4.218 0.000304 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.1709 on 24 degrees of freedom
## Multiple R-squared: 0.4257, Adjusted R-squared: 0.4017
## F-statistic: 17.79 on 1 and 24 DF, p-value: 0.0003037# Calculate the median window from models within 95% confidence interval of the best model
medwin(output[[7]]$Dataset)## $`Median Window Open`
## [1] 83
##
## $`Median Window Close`
## [1] 37# Randomisation test to assess if the detected signal is likely by chance
heavy_rain_randwin <- randwin(repeats = 10,
window = "sliding",
xvar = list(heavy_rain_day_bi = extreme_weather_binary$heavy_rain_day),
cdate = extreme_weather_binary$date,
bdate = breeding_data$date,
baseline = lm(bs ~ 1,
data = breeding_data),
cohort = breeding_data$season,
cinterval = "day",
range = c(96, 0),
refday = c(07, 03),
type = "absolute",
stat = c("sum"),
func = c("lin")
)# Calculate the p-value using Climwin Metric C
climwin::pvalue(dataset = output[[7]]$Dataset,
datasetrand = heavy_rain_randwin[[1]],
metric = "C",
sample.size = sample_size
)## [1] 0.02650329# Plot sliding window and randomisation result
climwin::plotall(dataset = output[[7]]$Dataset,
datasetrand = heavy_rain_randwin[[1]],
bestmodel = output[[7]]$BestModel,
bestmodeldata = output[[7]]$BestModelData,
arrow = TRUE
)
2.4.2 Very heavy rain
# Summarise the best model
summary(output[[8]]$BestModel)##
## Call:
## lm(formula = yvar ~ climate, data = modeldat)
##
## Residuals:
## Min 1Q Median 3Q Max
## -0.48790 -0.14486 0.02705 0.15649 0.34315
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 0.56328 0.04517 12.469 5.63e-12 ***
## climate 0.22863 0.09404 2.431 0.0229 *
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.202 on 24 degrees of freedom
## Multiple R-squared: 0.1976, Adjusted R-squared: 0.1642
## F-statistic: 5.911 on 1 and 24 DF, p-value: 0.02288# Calculate the median window from models within 95% confidence interval of the best model
medwin(output[[8]]$Dataset)## $`Median Window Open`
## [1] 66
##
## $`Median Window Close`
## [1] 25# Randomisation test to assess if the detected signal is likely by chance
very_heavy_rain_randwin <- randwin(repeats = 10,
window = "sliding",
xvar = list(very_heavy_rain_day_bi = extreme_weather_binary$very_heavy_rain_day),
cdate = extreme_weather_binary$date,
bdate = breeding_data$date,
baseline = lm(bs ~ 1,
data = breeding_data),
cohort = breeding_data$season,
cinterval = "day",
range = c(96, 0),
refday = c(07, 03),
type = "absolute",
stat = "sum",
func = "lin"
)# Calculate the p-value using Climwin Metric C
climwin::pvalue(dataset = output[[8]]$Dataset,
datasetrand = very_heavy_rain_randwin[[1]],
metric = "C",
sample.size = sample_size
)
# Plot sliding window and randomisation result
climwin::plotall(dataset = output[[8]]$Dataset,
datasetrand = very_heavy_rain_randwin[[1]],
bestmodel = output[[8]]$BestModel,
bestmodeldata = output[[8]]$BestModelData,
arrow = TRUE
)2.4.3 VWDP***
# Summarise the best model
summary(output[[10]]$BestModel)##
## Call:
## lm(formula = yvar ~ climate, data = modeldat)
##
## Residuals:
## Min 1Q Median 3Q Max
## -0.32626 -0.07710 -0.01194 0.11587 0.20288
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 0.80697 0.04701 17.166 5.56e-15 ***
## climate -0.10342 0.01957 -5.284 2.03e-05 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.1533 on 24 degrees of freedom
## Multiple R-squared: 0.5377, Adjusted R-squared: 0.5185
## F-statistic: 27.92 on 1 and 24 DF, p-value: 2.028e-05# Calculate the median window from models within 95% confidence interval of the best model
medwin(output[[10]]$Dataset)## $`Median Window Open`
## [1] 86
##
## $`Median Window Close`
## [1] 39# Randomisation test to assess if the detected signal is likely by chance
vwdp_randwin <- randwin(repeats = 10,
window = "sliding",
xvar = list(vwdp_bi = extreme_weather_binary$vwdp),
cdate = extreme_weather_binary$date,
bdate = breeding_data$date,
baseline = lm(bs ~ 1,
data = breeding_data),
cohort = breeding_data$season,
cinterval = "day",
range = c(96, 0),
refday = c(07, 03),
type = "absolute",
stat = "sum",
func = "lin"
)# Calculate the p-value using Climwin Metric C
climwin::pvalue(dataset = output[[10]]$Dataset,
datasetrand = vwdp_randwin[[1]],
metric = "C",
sample.size = sample_size
)## [1] 0.007345548# Plot sliding window and randomisation result
climwin::plotall(dataset = output[[10]]$Dataset,
datasetrand = vwdp_randwin[[1]],
bestmodel = output[[10]]$BestModel,
bestmodeldata = output[[10]]$BestModelData,
arrow = TRUE
)
# k-fold cross-validation allows to improve the accuracy of the R^2 estimate as R^2 estimates using slidingwin can be biased at low sample size and/or effect size
vwdp_k_fold <- slidingwin(k = 10,
xvar = list(vwdp_bi = extreme_weather_binary$vwdp),
cdate = extreme_weather_binary$date,
bdate = breeding_data$date,
baseline = lm(bs ~ 1,
data = breeding_data),
cohort = breeding_data$season,
cinterval = "day",
range = c(96, 0),
refday = c(07, 03),
type = "absolute",
stat = "sum",
func = "lin"
)# Summary of the best model from k-fold cross-validation
summary(vwdp_k_fold[[1]]$BestModel)##
## Call:
## lm(formula = yvar ~ climate, data = modeldat)
##
## Residuals:
## Min 1Q Median 3Q Max
## -0.35358 -0.10166 0.02714 0.13206 0.24376
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 0.83429 0.05815 14.347 2.85e-13 ***
## climate -0.08106 0.01791 -4.525 0.000139 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.1657 on 24 degrees of freedom
## Multiple R-squared: 0.4604, Adjusted R-squared: 0.4379
## F-statistic: 20.48 on 1 and 24 DF, p-value: 0.00013893 Colinearity
Check for colinearity between the climate signals.
# Add identified significant climate signals to the original breeding data
breeding_data <- breeding_data %>%
dplyr::mutate(heavy_rain_signal = output[[7]]$BestModelData$climate,
vwdp_signal = output[[10]]$BestModelData$climate)
# Plot correlation matrix
corrplot(breeding_data %>%
dplyr::select(heavy_rain_signal, vwdp_signal) %>%
cor(use = "complete.obs"),
method = "number",
type = "upper",
tl.col = "black",
tl.srt = 45
)
They have high correlation (r = 0.9), which exceeds our threshold (r < 0.7) for retaining both variables but we will keep both in the full model for now.
4 Full model
# Full model
model <- glm(bs ~ 1 + heavy_rain_signal + vwdp_signal,
data = breeding_data)
# Summary of the full model
summary(model)##
## Call:
## glm(formula = bs ~ 1 + heavy_rain_signal + vwdp_signal, data = breeding_data)
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 0.808075 0.048534 16.650 2.52e-14 ***
## heavy_rain_signal 0.007196 0.046738 0.154 0.8790
## vwdp_signal -0.109863 0.046400 -2.368 0.0267 *
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for gaussian family taken to be 0.02451074)
##
## Null deviance: 1.22082 on 25 degrees of freedom
## Residual deviance: 0.56375 on 23 degrees of freedom
## AIC: -17.828
##
## Number of Fisher Scoring iterations: 2We evaluated multiple extreme weather indices as predictors of pup productivity. Both vwdp_signal and heavy_rain_signal were statistically significant in the sliding window model and did not appear to be false positives. However, due to their strong correlation (r = 0.9), which exceeds our threshold (r < 0.7) for retaining both variables, we further assessed their individual contributions. After adjusting for vwdp_signal, heavy_rain_signal was no longer significant (p = 0.879), suggesting it does not explain additional variation. Therefore, we excluded it from the final model to reduce multicollinearity and improve interpretability.
5 Final model
# Final model
final_model <- glm(bs ~ 1 + vwdp_signal,
data = breeding_data)
# Summary of the final model
summary(final_model)##
## Call:
## glm(formula = bs ~ 1 + vwdp_signal, data = breeding_data)
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 0.80697 0.04701 17.166 5.56e-15 ***
## vwdp_signal -0.10342 0.01957 -5.284 2.03e-05 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for gaussian family taken to be 0.02351366)
##
## Null deviance: 1.22082 on 25 degrees of freedom
## Residual deviance: 0.56433 on 24 degrees of freedom
## AIC: -19.801
##
## Number of Fisher Scoring iterations: 25.1 Model diagnostics
# Simulate residuals
simulationOutput <- simulateResiduals(fittedModel = final_model, plot = TRUE)
# Test for over/underdispersion
testDispersion(simulationOutput, plot = TRUE)
##
## DHARMa nonparametric dispersion test via sd of residuals fitted vs.
## simulated
##
## data: simulationOutput
## dispersion = 0.96381, p-value = 0.944
## alternative hypothesis: two.sided5.2 Visualise the signal
# Plot the fitted effect
effect_plot(final_model, pred = vwdp_signal, interval = TRUE, plot.points = TRUE,
main.title = "Relationship between Breedin success and Very wet precipitation days",
x.label = "No. of very wet precipitation days",
y.label = "Indicative breeding success",
colors = c("#7B8FA1"),
line.colors = c("#0D92F4"),
line.thickness = 1,
point.size = 2.5,
point.alpha = 0.5,
rug = TRUE) +
drop_gridlines() +
theme_classic()
5.3 Save data
# Save final model data
write_xlsx(breeding_data, "Output_data/STSH/STSH_East_Kangaroo_signal.xlsx")
# Save 95% confidence set for each climate signal
saveRDS(output[[10]]$Dataset, "Output_data/STSH/East_Kangaroo_vwdp_dataset.rds")6 Check for temporal trends
6.1 Prepare data
# Checking trends in cumulative intensity, frequency, and duration for each climate signal (using row data)
# Only interested during identified median climate window (95% CI from the best model) from reference date
# Fixed reference date: 7 March each year
ref_day <- "03-07"
# Create yearly open/close window lookup
window_dates <- data.frame(
season = 1970:2024,
window_open = as.Date(paste0(1970:2024, "-", ref_day)) - 86,
window_close = as.Date(paste0(1970:2024, "-", ref_day)) - 39
)
# Add month-day format for easy matching
window_dates <- window_dates %>%
mutate(
window_open_md = format(window_open, "%m-%d"),
window_close_md = format(window_close, "%m-%d")
)
# Summarise extreme events per season within the fixed median window
summarised_vwdp <- extreme_weather %>%
filter(season >= 1970 & season <= 2024) %>%
# Join to add window dates per season
left_join(window_dates, by = "season") %>%
# Filter rows within the per-season open/close window
filter(
format(date, "%m-%d") >= window_open_md | format(date, "%m-%d") <= window_close_md
) %>%
group_by(season) %>%
arrange(season, date) %>%
summarise(
# Extract daily index values for the current season
values = list(vwdp),
# Identify run lengths of contiguous non-zero values
rle_obj = list(rle(values[[1]] > 0)),
# Compute event-level summaries
extreme_event_summaries = list({
vals <- values[[1]]
runs <- rle_obj[[1]]
if (any(runs$values)) {
starts <- cumsum(c(1, head(runs$lengths, -1)))[runs$values]
lengths <- runs$lengths[runs$values]
event_sums <- mapply(function(start, len) sum(vals[start:(start + len - 1)], na.rm = TRUE),
starts, lengths)
tibble::tibble(
event_intensity = event_sums,
event_duration = lengths
)
} else {
tibble::tibble(event_intensity = numeric(0), event_duration = numeric(0))
}
}),
# Derived summaries
vwdp_frequency = nrow(extreme_event_summaries[[1]]),
vwdp_cum_intensity = sum(extreme_event_summaries[[1]]$event_intensity, na.rm = TRUE),
vwdp_tot_duration = sum(extreme_event_summaries[[1]]$event_duration, na.rm = TRUE),
.groups = "drop"
) %>%
dplyr::select(season, vwdp_frequency, vwdp_cum_intensity, vwdp_tot_duration)6.2 Check for autocorrelation
############################## Write function to run Durbin-Watson test ##############################
# Run Durbin-Watson test for autocorrelation
run_dw_test <- function(data, vars) {
results <- lapply(vars, function(var) {
formula_obj <- as.formula(paste(var, "~ season"))
model <- lm(formula_obj, data = data)
dw <- dwtest(model)
data.frame(
variable = var,
DW_statistic = round(dw$statistic[[1]], 3),
p_value = round(dw$p.value, 4),
autocorrelation = ifelse(dw$p.value < 0.05,
ifelse(dw$statistic < 2, "positive", "negative"),
"none"),
row.names = NULL
)
})
do.call(rbind, results)
}
# Check for autocorrelation in breeding success
run_dw_test(breeding_data, c("bs"))## variable DW_statistic p_value autocorrelation
## 1 bs 1.999 0.4123 none# Check for autocorrelation in extreme weather variables
run_dw_test(summarised_vwdp, c("vwdp_cum_intensity", "vwdp_frequency", "vwdp_tot_duration"))## variable DW_statistic p_value autocorrelation
## 1 vwdp_cum_intensity 2.211 0.7414 none
## 2 vwdp_frequency 2.064 0.5380 none
## 3 vwdp_tot_duration 2.039 0.5018 none6.3 Trend in response variable
# Function to fit glmmTMB without autocorrelation
fit_glmmTMB_no_ar1 <- function(data, variables_families) {
for (entry in variables_families) {
var <- entry$var
fam <- entry$family
model <- tryCatch({
glmmTMB::glmmTMB(as.formula(paste(var, "~ season")), data = data, family = fam)
}, error = function(e) {
message("Could not fit model for ", var, ": ", e$message)
return(NULL)
})
if (is.null(model)) next
# Summary
cat("\n============================\n")
cat("Model summary for:", var, "\n")
print(summary(model))
# Extract p-value safely
coefs <- summary(model)$coefficients$cond
season_row <- grep("^season$", rownames(coefs))
p <- coefs[season_row, "Pr(>|z|)"]
# Base plot
p_plot <- ggplot(data, aes(x = season, y = .data[[var]])) +
geom_point(shape = 19, size = 2.5, color = "#7B8FA1") +
geom_line(linewidth = 0.5, color = "#7B8FA1", na.rm = TRUE)
# Add model trend and annotation only if p < 0.05
if (!is.na(p) && p < 0.05) {
# Predictions
newdata <- data.frame(season = seq(min(data$season), max(data$season)))
preds <- predict(model, newdata = newdata, se.fit = TRUE, type = "response")
# Annotation
p_label <- if (p < 0.001) "p < 0.001" else paste0("p = ", round(p, 3))
n <- nrow(data)
ann_text <- paste0("n = ", n, "\n", p_label)
p_plot <- p_plot +
geom_ribbon(data = data.frame(
season = newdata$season,
ymin = preds$fit - 1.96 * preds$se.fit,
ymax = preds$fit + 1.96 * preds$se.fit
), aes(x = season, ymin = ymin, ymax = ymax),
fill = "#B6D0E2", alpha = 0.4, inherit.aes = FALSE) +
geom_line(data = data.frame(
season = newdata$season,
fit = preds$fit
), aes(x = season, y = fit),
color = "#0D92F4", linewidth = 0.75, inherit.aes = FALSE) +
annotate("text",
x = Inf, y = Inf,
hjust = 1.1, vjust = 1.2,
size = 3, color = "#1a1a1a",
label = ann_text)
}
# Final styling and print
p_plot <- p_plot +
scale_x_continuous(breaks = scales::pretty_breaks(n = 5),
expand = ggplot2::expansion(mult = c(0.02, 0.02))) +
scale_y_continuous(breaks = scales::pretty_breaks(n = 5),
expand = ggplot2::expansion(mult = c(0.02, 0.02))) +
labs(
title = paste("Trend in", gsub("_", " ", var)),
x = "Season", y = var
) +
theme_classic(base_family = "Helvetica") +
theme(
plot.title = element_text(size = 10, margin = margin(b = 1), colour = "#0d0d0d"),
axis.title = element_text(size = 9, colour = "#0d0d0d"),
axis.text = element_text(size = 8),
axis.ticks.length = unit(1, "pt"),
axis.ticks = element_line(linewidth = 0.5),
axis.line = element_blank(),
panel.border = element_rect(color = "#1a1a1a", fill = NA, size = 0.25)
)
print(p_plot)
}
}
# Fit glmmTMB and plot
fit_glmmTMB_no_ar1(breeding_data,
variables_families = list(list(var = "bs",
family = gaussian())
)
)##
## ============================
## Model summary for: bs
## Family: gaussian ( identity )
## Formula: bs ~ season
## Data: data
##
## AIC BIC logLik -2*log(L) df.resid
## -1.8 1.9 3.9 -7.8 23
##
##
## Dispersion estimate for gaussian family (sigma^2): 0.0433
##
## Conditional model:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -13.927457 9.844686 -1.415 0.157
## season 0.007233 0.004896 1.477 0.140
6.4 Trend in EWE signals
# Fit glmmTMB and plot
fit_glmmTMB_no_ar1(summarised_vwdp %>% dplyr::mutate(
vwdp_cum_intensity = ifelse(vwdp_cum_intensity == 0, 1e-6, vwdp_cum_intensity)),
variables_families = list(
list(var = "vwdp_frequency", family = poisson()),
list(var = "vwdp_cum_intensity", family = Gamma(link = "log")),
list(var = "vwdp_tot_duration", family = poisson())
)
)##
## ============================
## Model summary for: vwdp_frequency
## Family: poisson ( log )
## Formula: vwdp_frequency ~ season
## Data: data
##
## AIC BIC logLik -2*log(L) df.resid
## 182.0 186.1 -89.0 178.0 53
##
##
## Conditional model:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) 20.782914 11.754696 1.768 0.0771 .
## season -0.010040 0.005893 -1.704 0.0885 .
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## ============================
## Model summary for: vwdp_cum_intensity
## Family: Gamma ( log )
## Formula: vwdp_cum_intensity ~ season
## Data: data
##
## AIC BIC logLik -2*log(L) df.resid
## 528.8 534.8 -261.4 522.8 52
##
##
## Dispersion estimate for Gamma family (sigma^2): 1.9
##
## Conditional model:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) 16.418222 24.417301 0.672 0.501
## season -0.006252 0.012227 -0.511 0.609
##
## ============================
## Model summary for: vwdp_tot_duration
## Family: poisson ( log )
## Formula: vwdp_tot_duration ~ season
## Data: data
##
## AIC BIC logLik -2*log(L) df.resid
## 208.8 212.8 -102.4 204.8 53
##
##
## Conditional model:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) 20.818045 10.776044 1.932 0.0534 .
## season -0.009970 0.005403 -1.845 0.0650 .
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
7 Structural equation model
# Standardise each numeric column to have mean zero and standard deviation of one
breeding_data_standardised <- breeding_data %>%
mutate(across(where(is.numeric), ~ ( . - mean(.) ) / sd(.)))
# Extract individual regressions from SEM
m1 <- lm(vwdp_signal ~ season, data = breeding_data_standardised)
m2 <- lm(bs ~ vwdp_signal + season, data = breeding_data_standardised)
# Summarise individual regressions
summary(m1)##
## Call:
## lm(formula = vwdp_signal ~ season, data = breeding_data_standardised)
##
## Residuals:
## Min 1Q Median 3Q Max
## -1.4744 -0.6581 -0.2627 0.4890 2.8910
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -1.783e-15 1.917e-01 0.000 1.000
## season -2.885e-01 1.954e-01 -1.476 0.153
##
## Residual standard error: 0.9772 on 24 degrees of freedom
## Multiple R-squared: 0.08321, Adjusted R-squared: 0.04501
## F-statistic: 2.178 on 1 and 24 DF, p-value: 0.153summary(m2)##
## Call:
## lm(formula = bs ~ vwdp_signal + season, data = breeding_data_standardised)
##
## Residuals:
## Min 1Q Median 3Q Max
## -1.49678 -0.32377 -0.03867 0.56561 0.96993
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 4.939e-16 1.383e-01 0.000 1.000
## vwdp_signal -7.123e-01 1.473e-01 -4.836 7e-05 ***
## season 7.280e-02 1.473e-01 0.494 0.626
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.7051 on 23 degrees of freedom
## Multiple R-squared: 0.5426, Adjusted R-squared: 0.5028
## F-statistic: 13.64 on 2 and 23 DF, p-value: 0.000124# Check model assumptions for individual regressions
par(mfrow = c(2, 2))
plot(m1)
plot(m2)
# Define SEM model with direct and indirect effects
sem_model <- '
# Regress breeding success on climate signals and time
bs ~ vwdp_signal + season
# Regress climate signals on time
vwdp_signal ~ season
# Define intercept for breeding success
bs ~ 1
'
# Fit SEM using bootstrapped standard errors with 1000 iterations
set.seed(666)
fit <- lavaan::sem(sem_model, data = breeding_data_standardised, se = "bootstrap", bootstrap = 1000)
# SEM summary
summary(fit, fit.measures = TRUE, rsquare=TRUE)## lavaan 0.6-20 ended normally after 1 iteration
##
## Estimator ML
## Optimization method NLMINB
## Number of model parameters 7
##
## Number of observations 26
##
## Model Test User Model:
##
## Test statistic 0.000
## Degrees of freedom 0
##
## Model Test Baseline Model:
##
## Test statistic 22.596
## Degrees of freedom 3
## P-value 0.000
##
## User Model versus Baseline Model:
##
## Comparative Fit Index (CFI) 1.000
## Tucker-Lewis Index (TLI) 1.000
##
## Loglikelihood and Information Criteria:
##
## Loglikelihood user model (H0) -61.467
## Loglikelihood unrestricted model (H1) -61.467
##
## Akaike (AIC) 136.934
## Bayesian (BIC) 145.740
## Sample-size adjusted Bayesian (SABIC) 124.013
##
## Root Mean Square Error of Approximation:
##
## RMSEA 0.000
## 90 Percent confidence interval - lower 0.000
## 90 Percent confidence interval - upper 0.000
## P-value H_0: RMSEA <= 0.050 NA
## P-value H_0: RMSEA >= 0.080 NA
##
## Standardized Root Mean Square Residual:
##
## SRMR 0.000
##
## Parameter Estimates:
##
## Standard errors Bootstrap
## Number of requested bootstrap draws 1000
## Number of successful bootstrap draws 1000
##
## Regressions:
## Estimate Std.Err z-value P(>|z|)
## bs ~
## vwdp_signal -0.712 0.133 -5.362 0.000
## season 0.073 0.133 0.548 0.584
## vwdp_signal ~
## season -0.288 0.216 -1.335 0.182
##
## Intercepts:
## Estimate Std.Err z-value P(>|z|)
## .bs 0.000 0.134 0.000 1.000
## .vwdp_signal -0.000 0.191 -0.000 1.000
##
## Variances:
## Estimate Std.Err z-value P(>|z|)
## .bs 0.440 0.101 4.347 0.000
## .vwdp_signal 0.882 0.315 2.798 0.005
##
## R-Square:
## Estimate
## bs 0.543
## vwdp_signal 0.083# Extract parameter estimates and standard errors using parameterEstimates()
params <- lavaan::parameterEstimates(fit)
relationships <- params[params$op == "~", ]
# Create a data frame
results <- data.frame(
SEM_int = params$est[params$lhs == "bs" & params$op == "~1"],
SEM_beta_vwdp = params$est[params$lhs == "bs" & params$rhs == "vwdp_signal"],
SEM_beta_season = params$est[params$lhs == "bs" & params$rhs == "season"],
SEM_SE_vwdp = params$se[params$lhs == "bs" & params$rhs == "vwdp_signal"],
SEM_SE_season = params$se[params$lhs == "bs" & params$rhs == "season"],
Yr_beta_vwdp = params$est[params$lhs == "vwdp_signal" & params$rhs == "season"],
Yr_SE_vwdp = params$se[params$lhs == "vwdp_signal" & params$rhs == "season"]
) %>%
mutate(
EWE_pathway = SEM_beta_vwdp * Yr_beta_vwdp,
Total_effect_season = SEM_beta_season + EWE_pathway,
change_due_to_EWE_pathway = (EWE_pathway / Total_effect_season) * 100
)
# Print results
print(results)## SEM_int SEM_beta_vwdp SEM_beta_season SEM_SE_vwdp SEM_SE_season
## 1 4.776267e-16 -0.7123124 0.07280103 0.1328434 0.132844
## Yr_beta_vwdp Yr_SE_vwdp EWE_pathway Total_effect_season
## 1 -0.2884672 0.2160964 0.2054787 0.2782798
## change_due_to_EWE_pathway
## 1 73.83891### SEM path diagram visualisation ###
# Add arrow colors, line styles, and significance stars based on significance and direction
relationships <- relationships %>%
mutate(
color = case_when(
as.numeric(est) > 0 & as.numeric(pvalue) < 0.05 ~ "#0079FF", # Positive and significant = blue
as.numeric(est) < 0 & as.numeric(pvalue) < 0.05 ~ "#FF2929", # Negative and significant = red
TRUE ~ "#B7B7B7" # Non-significant = grey
),
style = ifelse(as.numeric(pvalue) < 0.05, "solid", "dashed"), # Significant = solid, Non-significant = dashed
unit = case_when(
lhs == "bs" & rhs == "season" ~ "/season",
lhs == "bs" & rhs == "vwdp_signal" ~ "/mm",
lhs == "vwdp_signal" ~ "mm/season",
TRUE ~ "unit" # Default unit for other relationships
),
stars = case_when( # Add stars based on significance level
pvalue < 0.001 ~ "***",
pvalue < 0.01 ~ "**",
pvalue < 0.05 ~ "*",
TRUE ~ ""
)
)
# Extract R² values
rsq <- lavaan::inspect(fit, "rsquare")
node_labels <- c(
bs = paste0("Breeding success\nr² = ", round(rsq["bs"], 2)),
vwdp_signal = paste0("Very wet day precipitation\nr² = ", round(rsq["vwdp_signal"], 2)),
season = "Season"
)
# Construct edges for regressions, adding significance stars in the label
edges <- apply(relationships, 1, function(row) {
paste0(
"\"", row["rhs"], "\" -> \"", row["lhs"], "\" ", # Add double quotes to handle special characters in node names
"[color=\"", row["color"], "\", style=", row["style"],
", label=\"", round(as.numeric(row["est"]), 2), row["stars"], "\n(", row["unit"], ")\", fontsize=10]"
)
})
# Generate DiagrammeR graph with rectangular nodes and custom labels
graph_code <- paste0(
"digraph SEM {",
"\nnode [shape=rectangle, style=filled, fillcolor=white];",
"\n", paste(edges, collapse = "\n"),
"\n", paste0(
"\"bs\" [label=\"", node_labels["bs"], "\", fontsize=12];",
"\n\"vwdp_signal\" [label=\"", node_labels["vwdp_signal"], "\", fontsize=12];",
"\n\"season\" [label=\"", node_labels["season"], "\", fontsize=12];"
),
"\n}"
)
# Render the DiagrammeR graph
DiagrammeR::grViz(graph_code)