library(tbeptools)
library(tidyverse)
# otb data ------------------------------------------------------------------------------------
load(file = here::here("data/otb_subseg_sites.RData"))
otbdat <- epcdata |>
filter(bay_segment == 'OTB') |>
mutate(
epchc_station = as.character(epchc_station)
) |>
left_join(otb_subseg_sites, by = c('epchc_station' = 'site')) |>
filter(yr >= 2000 & yr <= 2021)# ranges --------------------------------------------------------------------------------------
otbdat |>
reframe(
min = min(chla, na.rm = T),
max = max(chla, na.rm = T),
.by = subsegment
) |>
knitr::kable()| subsegment | min | max |
|---|---|---|
| SE | 1.100 | 50.100 |
| SW | 1.000 | 52.800 |
| CE | 0.681 | 333.400 |
| NW | 0.900 | 117.100 |
| NE | 1.000 | 94.600 |
| CW | 1.100 | 140.848 |
# all subsegments -----------------------------------------------------------------------------
otbcei1 <- otbdat |>
nest() |>
crossing(
chlmax = seq(0, 50, length.out = 100)
) |>
mutate(
data = purrr::pmap(list(chlmax, data), function(chlmax, data){
data |>
mutate(
chla = pmin(chla, chlmax)
)
}),
attain = purrr::map(data, function(x){
anlz_avedat(x)$ann |>
dplyr::filter(var %in% 'mean_chla') %>%
dplyr::left_join(targets, by = 'bay_segment') %>%
dplyr::select(bay_segment, yr, var, val, thresh = chla_thresh) %>%
dplyr::mutate(
attain = val < thresh
)
}),
allattain = purrr::map(attain, function(x){
sum(x$attain) / nrow(x)
}),
lastra = purrr::map(attain, function(x){
attain <- x |> filter(yr >= 2017) |> pull(attain) |> sum()
attain / 5
})
)
toplo1 <- otbcei1 |>
select(chlmax, allattain, lastra) |>
unnest(allattain) |>
unnest(lastra) |>
pivot_longer(-chlmax) |>
mutate(
name = factor(name, levels = c('allattain', 'lastra'), labels = c('Since 2000', '2017-2021 RA'))
)
# percent attained
ggplot(toplo1, aes(x = chlmax, y = value, color = name)) +
geom_line() +
geom_vline(xintercept = 9.3, linetype = 'dashed') +
scale_y_continuous(labels = scales::percent) +
theme_minimal() +
theme(
panel.grid.minor = element_blank(),
legend.position = 'top'
) +
labs(
x = 'Upper limit of chlorophyll-a (ug/L)',
y = '% years',
title = 'Percent of years attaining the chlorophyll-a threshold for OTB',
subtitle = 'All subsegments not to exceed value on x-axis',
caption = 'Dashed lines show threshold and target',
color = NULL
)
# NW, CW -------------------------------------------------------------------------------------
otbcei2 <- otbdat |>
nest() |>
crossing(
chlmax = seq(0, 50, length.out = 100)
) |>
mutate(
data = purrr::pmap(list(chlmax, data), function(chlmax, data){
data |>
mutate(
chla = case_when(
subsegment %in% c('CW', 'NW') ~ pmin(chla, chlmax),
T ~ chla
)
)
}),
attain = purrr::map(data, function(x){
anlz_avedat(x)$ann |>
dplyr::filter(var %in% 'mean_chla') %>%
dplyr::left_join(targets, by = 'bay_segment') %>%
dplyr::select(bay_segment, yr, var, val, thresh = chla_thresh) %>%
dplyr::mutate(
attain = val < thresh
)
}),
allattain = purrr::map(attain, function(x){
sum(x$attain) / nrow(x)
}),
lastra = purrr::map(attain, function(x){
attain <- x |> filter(yr >= 2017) |> pull(attain) |> sum()
attain / 5
})
)
toplo2 <- otbcei2 |>
select(chlmax, allattain, lastra) |>
unnest(allattain) |>
unnest(lastra) |>
pivot_longer(-chlmax) |>
mutate(
name = factor(name, levels = c('allattain', 'lastra'), labels = c('Since 2000', '2017-2021 RA'))
)
# percent attained
ggplot(toplo2, aes(x = chlmax, y = value, color = name)) +
geom_line() +
geom_vline(xintercept = 9.3, linetype = 'dashed') +
scale_y_continuous(labels = scales::percent) +
theme_minimal() +
theme(
panel.grid.minor = element_blank(),
legend.position = 'top'
) +
labs(
x = 'Upper limit of chlorophyll-a (ug/L)',
y = '% years',
title = 'Percent of years attaining the chlorophyll-a threshold for OTB',
subtitle = 'NW, CW subsegments not to exceed value on x-axis',
caption = 'Dashed lines show threshold and target',
color = NULL
)
# all subsegments by month --------------------------------------------------------------------
otbcei3 <- otbdat |>
nest() |>
crossing(
chlmax = seq(0, 50, length.out = 100),
season = list(1:3, 4:6, 7:9, 10:12)
) |>
mutate(
data = purrr::pmap(list(chlmax, season, data), function(chlmax, season, data){
data |>
mutate(
chla = case_when(
mo %in% season ~ pmin(chla, chlmax),
T ~ chla
)
)
}),
attain = purrr::map(data, function(x){
anlz_avedat(x)$ann |>
dplyr::filter(var %in% 'mean_chla') %>%
dplyr::left_join(targets, by = 'bay_segment') %>%
dplyr::select(bay_segment, yr, var, val, thresh = chla_thresh) %>%
dplyr::mutate(
attain = val < thresh
)
}),
allattain = purrr::map(attain, function(x){
sum(x$attain) / nrow(x)
}),
lastra = purrr::map(attain, function(x){
attain <- x |> filter(yr >= 2017) |> pull(attain) |> sum()
attain / 5
})
)
toplo3 <- otbcei3 |>
select(chlmax, season, allattain, lastra) |>
unnest(allattain) |>
unnest(lastra) |>
unnest(season) |>
mutate(
season = case_when(
season %in% 1:3 ~ 'JFM',
season %in% 4:6 ~ 'AMJ',
season %in% 7:9 ~ 'JAS',
season %in% 10:12 ~ 'OND'
)
) |>
distinct() |>
pivot_longer(-c(chlmax, season)) |>
mutate(
name = factor(name, levels = c('allattain', 'lastra'), labels = c('Since 2000', '2017-2021 RA')),
season = factor(season, levels = c('JFM', 'AMJ', 'JAS', 'OND'))
)
# percent attained
ggplot(toplo3, aes(x = chlmax, y = value, color = name)) +
geom_line() +
geom_vline(xintercept = 9.3, linetype = 'dashed') +
scale_y_continuous(labels = scales::percent) +
theme_minimal() +
facet_wrap(~season, ncol = 4) +
theme(
panel.grid.minor = element_blank(),
legend.position = 'top'
) +
labs(
x = 'Upper limit of chlorophyll-a (ug/L)',
y = '% years',
title = 'Percent of years attaining the chlorophyll-a threshold for OTB',
subtitle = 'All subsegments not to exceed value on x-axis, within the season',
caption = 'Dashed lines show threshold and target',
color = NULL
)
# CW, NW by month -----------------------------------------------------------------------------
otbcei4 <- otbdat |>
nest() |>
crossing(
chlmax = seq(0, 50, length.out = 100),
season = list(1:3, 4:6, 7:9, 10:12)
) |>
mutate(
data = purrr::pmap(list(chlmax, season, data), function(chlmax, season, data){
data |>
mutate(
chla = case_when(
mo %in% season & subsegment %in% c('CW', 'NW') ~ pmin(chla, chlmax),
T ~ chla
)
)
}),
attain = purrr::map(data, function(x){
anlz_avedat(x)$ann |>
dplyr::filter(var %in% 'mean_chla') %>%
dplyr::left_join(targets, by = 'bay_segment') %>%
dplyr::select(bay_segment, yr, var, val, thresh = chla_thresh) %>%
dplyr::mutate(
attain = val < thresh
)
}),
allattain = purrr::map(attain, function(x){
sum(x$attain) / nrow(x)
}),
lastra = purrr::map(attain, function(x){
attain <- x |> filter(yr >= 2017) |> pull(attain) |> sum()
attain / 5
})
)
toplo4 <- otbcei4 |>
select(chlmax, season, allattain, lastra) |>
unnest(allattain) |>
unnest(lastra) |>
unnest(season) |>
mutate(
season = case_when(
season %in% 1:3 ~ 'JFM',
season %in% 4:6 ~ 'AMJ',
season %in% 7:9 ~ 'JAS',
season %in% 10:12 ~ 'OND'
)
) |>
distinct() |>
pivot_longer(-c(chlmax, season)) |>
mutate(
name = factor(name, levels = c('allattain', 'lastra'), labels = c('Since 2000', '2017-2021 RA')),
season = factor(season, levels = c('JFM', 'AMJ', 'JAS', 'OND'))
)
# percent attained
ggplot(toplo4, aes(x = chlmax, y = value, color = name)) +
geom_line() +
geom_vline(xintercept = 9.3, linetype = 'dashed') +
scale_y_continuous(labels = scales::percent) +
theme_minimal() +
facet_wrap(~season, ncol = 4) +
theme(
panel.grid.minor = element_blank(),
legend.position = 'top'
) +
labs(
x = 'Upper limit of chlorophyll-a (ug/L)',
y = '% years',
title = 'Percent of years attaining the chlorophyll-a threshold for OTB',
subtitle = 'NW, CW subsegments not to exceed value on x-axis, within the season',
caption = 'Dashed lines show threshold and target',
color = NULL
)