knitr::opts_chunk$set( fig.width = 11, fig.height = 8.5, # fig.path=paste0("figs/", spp, "/"), echo = FALSE, warning = FALSE, message = FALSE ) library(dplyr) library(ggplot2) library(gfplot) library(gfdata) library(sdmTMB) library(gfranges) theme_set( gfplot::theme_pbs(base_size = 14) )
if(params$covs == "-sand-depth-roms"){ mod.formula <- as.formula(paste0( "density ~ 0 + as.factor(year_pair) + s(sandy_scaled, k = 3) + s(depth_scaled, k = 3) + s(roms_scaled, k = 3)" )) clim_cov <- "roms" } if(params$covs == "-depth-roms"){ mod.formula <- as.formula(paste0( "density ~ 0 + as.factor(year_pair) + s(depth_scaled, k = 3) + s(roms_scaled, k = 3)" )) clim_cov <- "roms" } if(params$covs == "-depth-temp"){ mod.formula <- as.formula(paste0( "density ~ 0 + as.factor(year_pair) + s(depth_scaled, k = 3) + s(temp_scaled, k = 3)" )) clim_cov <- "temp" } if(params$covs == "-sand-depth-temp"){ mod.formula <- as.formula(paste0( "density ~ 0 + as.factor(year_pair) + sandy_scaled + s(depth_scaled, k = 3) + s(temp_scaled, k = 3)" )) clim_cov <- "temp" } if(params$covs == "-sand-shallow-depth-temp"){ mod.formula <- as.formula(paste0( "density ~ 0 + as.factor(year_pair) + sandy_scaled * shallow + s(depth_scaled, k = 3) + s(temp_scaled, k = 3)" )) clim_cov <- "temp" } # s(sandy_scaled, k = 3) + # s(sandy_scaled, by = shallow, k = 3) + if(params$covs == "-mud-depth-temp"){ mod.formula <- as.formula(paste0( "density ~ 0 + as.factor(year_pair) + muddy_scaled + s(depth_scaled, k = 3) + s(temp_scaled, k = 3)" )) clim_cov <- "temp" } if(params$covs == "-mud-sand-depth-temp"){ mod.formula <- as.formula(paste0( "density ~ 0 + as.factor(year_pair) + muddy_scaled + sandy_scaled + s(depth_scaled, k = 3) + s(temp_scaled, k = 3)" )) clim_cov <- "temp" } if(params$covs == "-sand-x-depth-temp"){ mod.formula <- as.formula(paste0( "density ~ 0 + as.factor(year_pair) + sandy_scaled + s(depth_scaled, k = 3) + te(depth_scaled, sandy_scaled, k = 3, m=1) + s(temp_scaled, k = 3)" )) clim_cov <- "temp" }
species <- params$species region <- params$region covs <- params$covs knots <- params$knots # REML <- params$REML # AR1 <- params$AR1 paste("region =", params$region) paste("climate covariate =", clim_cov) paste("model label =", params$covs) paste("knots =", params$knots) paste("REML =", params$REML) paste("AR1 =", params$AR1) paste("fixed spatial =", params$fixed_spatial) paste("formula =", mod.formula[3])
spp <- gsub(" ", "-", gsub("\\/", "-", tolower(species))) # folder to hold figs for this species dir.create(file.path("figs", spp)) dir.create(file.path("data", spp)) if (region == "Both odd year surveys") { survey <- c("SYN QCS", "SYN HS") model_ssid <- c(1, 3) ssid_string <- paste0(model_ssid, collapse = "n") years <- NULL } if (region == "West Coast Vancouver Island") { survey <- c("SYN WCVI") model_ssid <- c(4) ssid_string <- paste0(model_ssid, collapse = "n") years <- NULL } if (region == "Non-HG surveys") { survey <- c("SYN QCS", "SYN HS", "SYN WCVI") model_ssid <- c(1, 3, 4) ssid_string <- paste0(model_ssid, collapse = "n") years <- NULL }
Load and filter data
# # if on dfo network trawl data can be retrieved # events <- gfdata::get_survey_sets(species, ssid = c(1, 3, 4, 16)) # saveRDS(events, file = paste0("data/event-data-", spp, "")) # biomass <- readRDS(paste0("data/event-data-", spp, "")) # on PE's system biomass <- readRDS(paste0("../VOCC/raw/event-data-", spp, "")) # trace samples aren't always recorded in 'density_kgpm2' variable # but are recorded in 'catch_count' # likewise larger catches are recorded as 0 in 'catch_count' biomass <- biomass %>% mutate( present = if_else(density_kgpm2 > 0, 1, if_else(catch_count > 0, 1, 0)), density = (if_else(density_kgpm2 > 0, density_kgpm2, # use roughly the min recorded density for these trace samples if_else(catch_count > 0, 1e-07, 0))) * 10000 # convert kgpm2 to kg per ha ) %>% select(fishing_event_id, year, present, density) %>% # don't currently have covariate layers for 2019 filter(year < 2019) # get substrate data covars <- readRDS("data/event-covariates.rds") %>% select(-geometry) data <- dplyr::left_join(biomass, covars) # get ctd sensor data sensor <- readRDS("~/github/dfo/gfranges/analysis/tmb-sensor-explore/data/all-sensor-data-processed.rds") %>% select(-X, -Y, -lat, -lon) data <- left_join(data, sensor) %>% # remove depth data to bring in complete set later select(-exclude, -akima_depth, -depth_edit, -log_depth, -depth_bath) # get ROMS mean temperature for April through September each year roms <- readRDS("~/github/dfo/gfranges/analysis/tmb-sensor-explore/data/roms_temp_by_events2.rds") %>% select(fishing_event_id, roms) data <- left_join(data, roms) # get interpolated bathymetry data for comparison with sensor recorded depths bath <- readRDS("data/bathymetry-data") bath <- bath$data %>% select(X,Y, ssid, fishing_event_id, depth_bath = depth) d <- left_join(data, bath) %>% mutate( depth_sam = depth,# rename sensor depth depth = coalesce(depth, depth_bath),# use bath depth if sensor depth missing raw_depth = depth, # create 'depth' var that's actually log depth for scaling log_depth = log(depth), depth = log(raw_depth), shallow = if_else(raw_depth < 100, 1, 0) ) %>% rename(temp = temperature_c, do = do_mlpl) # scale predictors before filtering to ensure mean and SD are global d <- gfranges::scale_predictors(d, predictors = c(quo(depth), quo(sandy), quo(muddy), quo(temp), quo(do), quo(roms)) ) # # rename raw_depth for plots # d <- d %>% mutate(depth = raw_depth) %>% # filter(ssid %in% model_ssid) ### trim for the climate variable of interest if (clim_cov %in% "temp"){ d <- d[!is.na(d$temp), ]} if (clim_cov %in% "roms"){ d <- d[!is.na(d$roms), ]} if (clim_cov %in% "do"){ d <- d[!is.na(d$do), ]} data <- d # merge survey pairs such that even year surveys are modelled as though they occured in the previous odd year data <- data %>% filter(year > 2003) %>% # trick to round to odd years # 0.8 is required to avoid 5's always rounding to even in R mutate(year_pair = (2 * round((year+0.8)/2))-1) %>% filter(year < 2019)
Plots illustrating year pairs and location of samples where species was caught
ggplot() + geom_point(data = filter(data, present == 0), aes(X, Y, colour = sandy), # color absent points with proportion sandy shape= 1, alpha=0.5, size=2) + geom_point(data = filter(data, present == 1), aes(X, Y, size = density), shape = 4) + scale_color_viridis_c(trans=fourth_root_power, option = "A", begin = 0.4) + facet_wrap(~year) ggplot() + geom_point(data = filter(data, present == 0), aes(X, Y, colour = sandy), shape= 1, alpha=0.5, size=2) + geom_point(data = filter(data, present == 1), aes(X, Y, size = density), shape = 4) + scale_color_viridis_c(trans=fourth_root_power, option = "A", begin = 0.4) + facet_wrap(~year_pair)
All years plotted at once
ggplot() + geom_point(data = filter(data, present == 0), aes(X, Y, colour = sandy), shape= 1, alpha=0.65, size=2) + geom_point(data = filter(data, present == 1), aes(X, Y, size = density), shape = 4) + scale_color_viridis_c(option = "A", trans=fourth_root_power, begin = 0.4) + geom_abline(intercept = 0, slope = 1)
# depth diff = difference between bath and sample depths # depth range is difference between start and end sample depths ggplot(data, aes(depth_sam, depth_bath, colour = depth_range)) + geom_point(alpha=0.75) + scale_color_viridis_c(trans=fourth_root_power, direction = -1) + geom_abline(intercept = 0, slope = 1) # # current data set includes only sampled depths with no bathymetry based depths # ggplot(data, aes(raw_depth, depth_bath, colour = depth_range)) + # geom_point(alpha=0.75) + # scale_color_viridis_c(trans=fourth_root_power, direction = -1) + # geom_abline(intercept = 0, slope = 1) ggplot(data, aes(depth_sam, depth_range, colour = as.factor(ssid))) + geom_point(alpha=0.75) + scale_color_viridis_d()
Check ROMS vs. CTD temperature measurements
# differences between bath and sample depths doesn't seem to explain differences between sample values and roms # these roms values are an average of April through September vs. single CTD measurements ggplot(data, aes(roms, temp, colour = depth_diff)) + geom_point(alpha=0.75, size=0.5) + scale_color_viridis_c(trans=fourth_root_power, direction = -1) + geom_abline(intercept = 0, slope = 1) + xlab("ROMS mean (April - September)") + ylab("ctd temperature") # differences between start and end depths also don't seem to explain differences between sample values and roms ggplot(data, aes(roms, temp, colour = depth_range)) + geom_point(alpha=0.75, size=0.5) + scale_color_viridis_c(trans=fourth_root_power, direction = -1) + geom_abline(intercept = 0, slope = 1) + xlab("ROMS mean (April - September)") + ylab("ctd temperature")
Check for substrate correlations -- sandy somewhat correlated with depth
ggplot(data, aes(raw_depth, sandy, colour = raw_depth)) + geom_point(alpha=0.75, size=0.5) + scale_color_viridis_c(trans=fourth_root_power, direction = -1) ggplot(filter(data, raw_depth < 100), aes(raw_depth, sandy, colour = raw_depth)) + geom_point(alpha=0.75, size=0.5) + scale_color_viridis_c(trans=fourth_root_power, direction = -1) ggplot(data, aes(raw_depth, muddy, colour = raw_depth)) + geom_point(alpha=0.75, size=0.5) + scale_color_viridis_c(trans=fourth_root_power, direction = -1) # ggplot(data, aes(raw_depth, sandy-muddy, colour = raw_depth)) + # geom_point(alpha=0.75, size=0.5) + # scale_color_viridis_c(trans=fourth_root_power, direction = -1)
Make mesh
data <- data %>% filter(ssid %in% model_ssid) if (region == "Both odd year surveys") { spde <- sdmTMB::make_spde(data$X, data$Y, n_knots = 250) } if (region == "West Coast Vancouver Island") { spde <- sdmTMB::make_spde(data$X, data$Y, n_knots = 200) } if (region == "All synoptic surveys") { spde <- sdmTMB::make_mesh(data, c("X", "Y"), n_knots = knots) } if (region == "Non-HG surveys") { spde <- sdmTMB::make_mesh(data, c("X", "Y"), n_knots = knots) } plot(spde)
Run sdmTMB model
if (params$update_model) { total_biomass <- sdmTMB::sdmTMB( data = data, mod.formula, time = "year_pair", spde = spde, family = tweedie(link = "log"), ar1_fields = params$AR1, reml = params$REML, include_spatial = params$fixed_spatial ) saveRDS(total_biomass, file = paste0( "models/", spp, "/mod-tot-biomass-", spp, covs, "-", ssid_string, "-ar1-", params$AR1, "-reml-", params$REML, params$knots, ".rds" )) }
if(params$update_model_check) { m <- readRDS(paste0( "models/", spp, "/mod-tot-biomass-", spp, covs, "-", ssid_string, "-ar1-", params$AR1, "-reml-", params$REML, params$knots, ".rds" )) point_predictions <- predict(m) point_predictions$residuals <- residuals(m) saveRDS(point_predictions, file = paste0( "data/", spp, "/check-mod-predictions-", spp, covs, "-", ssid_string, "-ar1-", params$AR1, "-reml-", params$REML, params$knots, ".rds" )) }
pred <- readRDS(paste0( "data/", spp, "/check-mod-predictions-", spp, covs, "-", ssid_string, "-ar1-", params$AR1, "-reml-", params$REML, params$knots, ".rds" )) qqnorm(pred$residuals);abline(a = 0, b = 1)
g <- ggplot(pred, aes(density, residuals, colour = as.factor(ssid))) + geom_point() + scale_x_continuous(trans = "log10") + facet_wrap(~year_pair) g
g1 <- ggplot(pred, aes(density+0.01, exp(est), colour = as.factor(ssid))) + geom_abline(slope=1, intercept = 0) + scale_x_continuous(trans = 'log10') + scale_y_continuous(trans = 'log10') + geom_point(alpha = 0.2) g1
g2 <- ggplot(pred, aes(exp(est), residuals, colour = density)) + geom_point(alpha = 0.2) + scale_x_continuous(trans = 'log10') + facet_wrap(~year) g2
# ggplot(pred, aes(X, Y, colour = (residuals))) + # geom_point() + # scale_colour_gradient2() + # scale_x_continuous(trans = "log10") + # facet_wrap(~year) ggplot(pred, aes(X, Y, colour = residuals)) + geom_point(size=0.5) + scale_colour_gradient2() + facet_wrap(~year_pair)
if(!exists("m")){ m <- readRDS(paste0( "models/", spp, "/mod-tot-biomass-", spp, covs, "-", ssid_string, "-ar1-", params$AR1, "-reml-", params$REML, params$knots, ".rds" )) } m max(m$gradients)
threshold <- quantile(data$density, 0.999) if(params$update_model_check){ nd_depth <- data.frame( depth_scaled = seq(min(data$depth_scaled), max(data$depth_scaled), length.out = 30), shallow = 1, sandy_scaled = 0, muddy_scaled = 0, temp_scaled = 0, roms_scaled = 0, year_pair = 2011 # a chosen year ) p_depth <- predict(m, newdata = nd_depth, se_fit = TRUE, re_form = NA) p_depth$depth <- exp((p_depth$depth_scaled*data$depth_sd[1])+ data$depth_mean[1]) max_CI <- max(exp(p_depth$est + 1.96 * p_depth$est_se)) max_Y <- if_else(threshold > max_CI, max_CI, threshold) (g_depth <- ggplot(p_depth, aes(depth, exp(est), ymin = exp(est - 1.96 * est_se), ymax = exp(est + 1.96 * est_se))) + coord_cartesian(ylim = c(0, max_Y), xlim = c(0, 150)) + geom_line() + geom_ribbon(alpha = 0.4)) ggsave(paste0("figs/depth-", spp, covs, ".png"), width = 5, height = 5) } try({g_depth}, silent = TRUE)
if(clim_cov == "roms"){ nd_roms <- data.frame( depth_scaled = min(data$depth_scaled), # use min depth for estimated prob at most relevant depth shallow = 1, sandy_scaled = 0, muddy_scaled = 0, roms_scaled = seq(min(data$roms_scaled), max(data$roms_scaled), length.out = 50), year_pair = 2011 # a chosen year ) p_roms <- predict(m, newdata = nd_roms, se_fit = TRUE, re_form = NA) p_roms$roms <- (p_roms$roms_scaled*data$roms_sd[1])+ data$roms_mean[1] max_CI <- max(exp(p_roms$est + 1.96 * p_roms$est_se)) max_Y <- if_else(threshold > max_CI, max_CI, threshold) (g_roms <- ggplot(p_roms, aes(roms, exp(est), ymin = exp(est - 1.96 * est_se), ymax = exp(est + 1.96 * est_se))) + coord_cartesian(ylim = c(0, max(exp(p_roms$est))*20)) + geom_line() + geom_ribbon(alpha = 0.4)) ggsave(paste0("figs/roms-", spp, covs, ".png"), width = 5, height = 5) } try({g_roms}, silent = TRUE)
if(clim_cov == "temp"){ nd_temp <- data.frame( depth_scaled = min(data$depth_scaled), shallow = 1, sandy_scaled = 0, muddy_scaled = 0, temp_scaled = seq(min(data$temp_scaled), max(data$temp_scaled), length.out = 50), year_pair = 2011 # a chosen year ) p_temp <- predict(m, newdata = nd_temp, se_fit = TRUE, re_form = NA) p_temp$temp <- (p_temp$temp_scaled*data$temp_sd[1])+ data$temp_mean[1] max_CI <- max(exp(p_temp$est + 1.96 * p_temp$est_se)) max_Y <- if_else(threshold > max_CI, max_CI, threshold) (g_temp <- ggplot(p_temp, aes(temp, exp(est), ymin = exp(est - 1.96 * est_se), ymax = exp(est + 1.96 * est_se))) + coord_cartesian(ylim = c(0, max_Y)) + geom_line() + geom_ribbon(alpha = 0.4)) ggsave(paste0("figs/temp-", spp, covs, ".png"), width = 5, height = 5) } try({g_temp}, silent = TRUE)
if(covs %in% c("-sand-depth-roms", "-sand-depth-temp", "-mud-sand-depth-temp", "-sand-shallow-depth-temp")){ nd_sand <- data.frame( depth_scaled = min(data$depth_scaled), shallow = 1, sandy_scaled = seq(min(data$sandy_scaled), max(data$sandy_scaled), length.out = 50), muddy_scaled = min(data$muddy_scaled), roms_scaled = 0, temp_scaled = 0, year_pair = 2011 # a chosen year ) p_sand <- predict(m, newdata = nd_sand, se_fit = TRUE, re_form = NA) p_sand$sandy <- (p_sand$sandy_scaled*data$sandy_sd[1])+ data$sandy_mean[1] (g_sand <- ggplot(p_sand, aes(sandy, exp(est), ymin = exp(est - 1.96 * est_se), ymax = exp(est + 1.96 * est_se))) + coord_cartesian(ylim = c(0, max_Y)) + geom_line() + geom_ribbon(alpha = 0.4)) ggsave(paste0("figs/sand-", spp, covs, ".png"), width = 5, height = 5) } try({g_sand}, silent = TRUE)
if(covs %in% c("-mud-depth-roms", "-mud-depth-temp","-mud-sand-depth-temp")){ nd_mud <- data.frame( depth_scaled = min(data$depth_scaled), shallow = 1, muddy_scaled = seq(min(data$muddy_scaled), max(data$muddy_scaled), length.out = 50), sandy_scaled = max(data$sandy_scaled), roms_scaled = 0, temp_scaled = 0, year_pair = 2011 # a chosen year ) p_mud <- predict(m, newdata = nd_mud, se_fit = TRUE, re_form = NA) p_mud$muddy <- (p_mud$muddy_scaled*data$muddy_sd[1])+ data$muddy_mean[1] max_CI <- max(exp(p_mud$est + 1.96 * p_mud$est_se)) max_Y <- if_else(threshold > max_CI, max_CI, threshold) (g_mud <- ggplot(p_mud, aes(muddy, exp(est), ymin = exp(est - 1.96 * est_se), ymax = exp(est + 1.96 * est_se))) + coord_cartesian(ylim = c(0, max_Y)) + geom_line() + geom_ribbon(alpha = 0.4)) ggsave(paste0("figs/mud-", spp, covs, ".png"), width = 5, height = 5) } try({g_mud}, silent = TRUE)
Save predictions for spatial grid
rm(ad_predictions) rm(im_predictions) rm(predicted) if(params$update_predictions) { newcov <- readRDS("data/new_covariates.rds") %>% dplyr::select(X, Y, sandy, muddy, rocky, mixed) nd_all <- readRDS( here::here("analysis/VOCC/data/predicted-all-temp-with-roms.rds") # paste0("data/predicted-DO-2020-06-20-more2016-roms.rds") ) %>% dplyr::select(X, Y, year, ssid, depth, roms = roms_temp, temp) scaledata <- data %>% dplyr::select(depth_mean, depth_sd, sandy_mean, sandy_sd, muddy_mean, muddy_sd, roms_mean, roms_sd, temp_mean, temp_sd) nd_all <- left_join(nd_all, newcov) nd_all$depth_mean <- scaledata$depth_mean[1] nd_all$depth_sd <- scaledata$depth_sd[1] nd_all$sandy_mean <- scaledata$sandy_mean[1] nd_all$sandy_sd <- scaledata$sandy_sd[1] nd_all$muddy_mean <- scaledata$muddy_mean[1] nd_all$muddy_sd <- scaledata$muddy_sd[1] nd_all$roms_mean <- scaledata$roms_mean[1] nd_all$roms_sd <- scaledata$roms_sd[1] nd_all$temp_mean <- scaledata$temp_mean[1] nd_all$temp_sd <- scaledata$temp_sd[1] nd_all <- nd_all %>% mutate( depth_scaled = (log(depth) - depth_mean)/depth_sd, sandy_scaled = (sandy - sandy_mean)/sandy_sd, muddy_scaled = (muddy - muddy_mean)/muddy_sd, roms_scaled = (roms - roms_mean)/roms_sd, temp_scaled = (temp - temp_mean)/temp_sd ) nd_all <- nd_all %>% filter(year > 2003) %>% # merge survey pairs such that even year surveys are pooled w the previous odd year # 0.8 is required to avoid 5s rounding to even in R mutate(year_pair = (2 * round((year+0.8)/2))-1, shallow = if_else(depth < 100, 1, 0)) %>% filter(year < 2019) m <- readRDS(paste0("models/", spp, "/mod-tot-biomass-", spp, covs, "-", ssid_string, "-ar1-", params$AR1, "-reml-", params$REML, params$knots, ".rds" )) nd <- nd_all %>% filter(ssid %in% model_ssid) %>% filter(year %in% unique(m$data$year)) nd <- na.omit(nd) # nd$year <- as.integer(nd$year) predicted <- predict(m, newdata = nd, se_fit = F, return_tmb_object = T) saveRDS(predicted, file = paste0( "data/", spp, "/predictions-", spp, covs, "-", ssid_string, "-tot-biomass-ar1-", params$AR1, "-reml-", params$REML, params$knots, ".rds" )) }
Transform estimates to biomass density in kg/ha
rm(predictions) rm(predicted) predicted <- readRDS(paste0("data/", spp, "/predictions-", spp, covs, "-", ssid_string, "-tot-biomass-ar1-", params$AR1, "-reml-", params$REML, params$knots, ".rds" )) predictions <- predicted$data predictions$total_bio <- exp(predictions$est) max_raster <- quantile(predictions$total_bio, 0.999) max_bio <- signif(quantile(predictions$total_bio, 1), digits = 2) predictions$prop_max <- predictions$total_bio/max_raster saveRDS(predictions, file = paste0( "data/", spp, "/just-predictions-", spp, covs, "-total-biomass-ar1-", params$AR1, "-reml-", params$REML, params$knots, ".rds" ))
legend_coords <- c(0.12, 0.2) #"none" p_mean <- predictions %>% group_by(X, Y) %>% mutate(mean_est = mean(exp(est))) %>% filter(year_pair == 2011) %>% mutate(year = "all years") %>% plot_facet_map("mean_est", raster_limits = c(0, max_raster), transform_col = fourth_root_power, legend_position = legend_coords ) + labs(fill = "kg/ha") + ggtitle(paste0("Estimated biomass density of ", species, " \n(max = ", max_bio, " kg/ha)")) print(p_mean) ggsave(paste0("figs/map-", spp, covs, "-mean-biomass.png"), width = 5, height = 5)
Spatial random field - captures variance not explained by depth and temperature
legend_coords <- c(0.12, 0.2) #"none" p_omega <- predictions %>% filter(year_pair == 2011) %>% mutate(x = X, y = Y, year = year_pair) %>% filter(year_pair == 2011) %>% mutate(year = "all years") %>% plot_facet_map("omega_s", # raster_limits = c(0, 1), # transform_col = fourth_root_power, legend_position = legend_coords ) + ggtitle(paste0("Spatial random field")) print(p_omega) ggsave(paste0("figs/map-", spp, covs, "-spatial-rf.png"), width = 5, height = 5)
Spatiotemporal random fields
legend_coords <- c(0.9, 0.12) #"none" p_st <- predictions %>% mutate(x = X, y = Y) %>% plot_facet_map("epsilon_st", legend_position = legend_coords, transform_col = fourth_root_power ) + ggtitle(paste0("Spatiotemporal random fields")) print(p_st) ggsave(paste0("figs/map-", spp, covs, "-spatiotemporal-rf.png"), width = 5, height = 5)
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.