In bcgov/bcgwlreports: Create BC Groundwater Level Reports

htmltools::img(src = knitr::image_uri(file.path("BCID_V_cmyk_pos_smaller.jpg")),
               alt = 'logo',
               style = 'float:right;position: relative; top:0; right:0; padding:0px;')

```{css, echo=FALSE} h2 { padding-top: 0.2em; padding-left: 0.2em; margin-top: 30px; background-color: #337ab7; border-top: 2px solid grey; color: white; }

h3 { margin-top: 35px; }

body { font-size: 12pt }

.leaflet { margin: auto; }

summary { padding-bottom:10px; }

.bcgwl-table { color: black; border-top: 2px solid black; border-bottom: 2px solid black; }

.bcgwl-table th { padding-top: 7px; }

.bcgwl-table td { padding-top: 5px; padding-bottom: 3px; }

.lightable-classic tfoot tr:first-child td { border-top: 2px solid black; }

```r
# options(warn=2)  # Turn warnings to errors for troubleshooting

library(dplyr)
library(ggplot2)
library(gt)
library(glue)
library(lubridate)
library(stringr)
library(patchwork)

knitr::opts_chunk$set(echo = FALSE)
options(knitr.kable.NA = '')

w_full_all <- params$w_full_all
w_full <- params$w_full
w_hist <- params$w_hist
w_comp <- params$w_comp
w_perc <- params$w_perc
w_dates <- params$w_dates
n_days <- params$n_days
report_dates <- params$report_dates
years_min <- params$years_min

ows <- unique(w_full$ow)

window <- w_perc %>%
  filter(window) %>%
  pull(report_dates) %>%
  unique()

max_report_date <- max(params$report_dates, na.rm = TRUE)
full_window <- seq.Date(from = max_report_date - lubridate::days(n_days), 
                        to = max_report_date + lubridate::days(n_days), 
                        by = "day")

range1 <- length(report_dates)/2
range2 <- (range1 + 1):(range1 * 2)
range1 <- 1:range1

remarks <- tibble(ow = NA_character_, remarks = NA_character_, .rows = 0)
if(!is.null(params$remarks)) remarks <- params$remarks

# Get Water Year
wy <- ifelse(lubridate::month(max_report_date) < 10,
               lubridate::year(max_report_date),
               lubridate::year(max_report_date) + 1)

if(!is.null(params$description) && params$description != "") {
  cat(params$description)
}

This report was generated on r format(Sys.Date(), "%B %d, %Y").

Background {#background}

The province maintains a network of groundwater observation wells to monitor water levels in priority aquifers. These observation wells (OW) record water level fluctuations which allow for improved understanding of how aquifers respond to changes in climate, precipitation, and effects from pumping. Many of the observation wells are equipped with satellite telemetry to provide real time information on water levels.

The following summaries compare recent groundwater levels to all historical continuous daily records to determine percentile classes, with a minimum of r years_min years of data. Historical monthly water level samples (before ~2004) are not included. A percentile is on a scale of 100 and indicates the percent of a distribution that is equal to or below it. For example, a groundwater level at the 10th percentile is equal to or greater than 10% of the water level values recorded on this day of the year during all previous years of data.

In general, a groundwater level value that is:

• the highest ever measured for the day of year is considered High
• greater than the 90th percentile is considered Much Above Normal
• between 75th percentile and 90th percentile is considered Above Normal
• between 25th and 75th percentiles is considered Normal
• less than the 25 percentile is considered Below Normal
• less than 10 percentile is considered Much Below Normal
• the lowest ever measured for the day of year is considered Low

Wells classified as "Not Available" in this report do not have recent groundwater level data within the past r n_days days or do not have sufficient data (less than r years_min years continuous data).

Groundwater Level Conditions {#map}

details <- well_table_summary(w_dates, w_hist, perc_values, full_window)
well_map(details)

Wells by Percentile Class

t <- well_table_status(w_perc, perc_values, window)

# Get footnotes needed
missing_dates <- str_subset(names(t), "\\*") %>% str_remove("\\*")
missing_data <- any(t == "" | is.na(t))

t %>%
  rename_with(~str_remove(., "\\*")) %>%
  gt(rowname_col = "class") %>%
  gt_perc_colours(perc_col = "stub") %>%
  cols_align("center") %>%
  tab_spanner(label = "Current Year", columns = 1 + !!range1) %>%
  tab_spanner(label = "Last Year", columns = 1 + !!range2) %>%
  #footnotes_below_normal(missing_dates, missing_data, n_days = n_days) %>%
  gt_bcgwl_style()

Wells Below Normal {#wells-below-normal .tabset}

This section reports on the number and total proportion of wells below normal or lower (i.e. 25th percentile or lower) on a given reporting date and one year prior for comparison.

All Wells

t <- well_table_below_norm(w_perc, window, which = "totals")

# Get footnotes needed
missing_dates <- str_subset(names(t), "\\*") %>% str_remove("\\*")
missing_data <- any(t == "" | is.na(t))
t %>%
  rename_with(~str_remove(., "\\*")) %>%
  gt() %>%
  tab_spanner(label = "Current Year", columns = !!range1) %>%
  tab_spanner(label = "Last Year", columns = !!range2) %>%
  footnotes_below_normal(missing_dates, missing_data, n_days = n_days) %>%
  gt_bcgwl_style()

By Aquifer Type

t <- well_table_below_norm(w_perc, window, which = "type")

# Get footnotes needed
missing_dates <- str_subset(names(t), "\\*") %>% str_remove("\\*")
missing_data <- any(t == "" | is.na(t))

t %>%
  rename_with(~str_remove(., "\\*")) %>%
  gt() %>%
  tab_spanner(label = "Current Year", columns = 1 + !!range1) %>%
  tab_spanner(label = "Last Year", columns = 1 + !!range2) %>%
  footnotes_below_normal(missing_dates, missing_data, n_days = n_days) %>%
  gt_bcgwl_style()

Latest Details {#details .tabset}

Latest details on observation wells in Water Year r wy-1 - r wy

foot1 <- "n is the number of years included in the percentile calculation."
foot2 <- "Values with an Approval Status of ‘Working’"

max_dates <- w_full %>% 
  dplyr::group_by(ow) %>% 
  dplyr::summarise(date2 = max(Date))
details <- dplyr::left_join(details, max_dates, by = "ow")
details <- dplyr::mutate(details, date = date2)
details <- dplyr::select(details, -date2)

for(r in unique(details$region)) {

  if(length(unique(details$region)) > 1) {
    glue("\n\n\n### {r}\n\n",
         "<details open>\n\n<summary>Show/Hide</summary>\n\n") %>%
      cat()
  } else {
    cat("\n\n<details open>\n\n<summary>Show/Hide</summary>\n\n")
  }



  details %>%
    mutate(percentile = if_else(
      !is.na(percentile), 
      glue("{class} ({percentile}%)<br><small>(n = {n_years})</small>"),
      glue("Not Available<br><small>(n = {n_years})</small>")),
      percentile = purrr::map(percentile, html)) %>%
    filter(region == r) %>%
    select(area, location, ow, #hydraulic_connectivity, 
           aquifer_type, date, percentile, class, approval) %>%
    #left_join(remarks, by = "ow") %>%
    group_by(.data$area) %>%
    gt() %>%
    cols_hide(c("approval", "class")) %>%
    cols_label("location" = "Location",
               #"hydraulic_connectivity" = "Hydraulic Connection", 
               "aquifer_type" = "Aquifer Type",
               "date" = "Latest Date" , 
               "percentile" = "Percentile",
               "ow" = "Obs. Well"#, 
               #"remarks" = "Remarks"
               ) %>%
    cols_align("center", columns = "ow") %>%
    gt_perc_colours() %>%
    sub_missing(dplyr::everything(), missing_text = "") %>%
   # fmt_missing(dplyr::everything(), missing_text = "") %>%
    tab_footnote(foot1, locations = cells_column_labels("percentile")) %>%
    tab_footnote(foot2, locations = cells_body(columns = "date",
                                               rows = approval == "Working")) %>%
    opt_footnote_marks(marks = c("a", "**")) %>%
    text_transform(locations = cells_body(columns = "ow"),
                   fn = function(x) ow_link(x, format = "html")) %>% #ow_fish(x) %>% 
    #cols_align("left", columns = "remarks") %>%
    gt_bcgwl_style() %>%
    knitr::knit_print() %>%
    cat()

  cat("</details>")
}

Historical Water Level Plots {#plots .tabset}

Description

Annual hydrographs and historical records for the observation wells summarized above can be found in this section.

Current conditions for provincial groundwater observation wells can be accessed any time through the Groundwater Level Data Interactive Map.

Note: ‘Working’ data are preliminary and have not yet been finalized as ‘Approved’ data with approved corrections and data grades for quality assurance. Quality assurance procedures may result in differences between what is displayed as 'Working' and what will become the official record.

latest_date <- w_dates %>% 
  group_by(ow) %>% 
  filter(!is.na(Value)) %>%
  filter(Date == max(Date)) #%>%
# filter(CurrentYear) #Keep only ones that are in Table 4?

w_meta <- w_dates %>%
  well_meta() %>%
  select(ow, "aquifer_id", "region", "area", "location", "location_long", 
         "subtype", "type",# "hydraulic_connectivity"
         ) %>%
  distinct() %>%
  arrange(.data$region, .data$ow)

for(r in unique(w_meta$region)) {

  if(length(unique(w_meta$region)) > 1) {
    glue("\n\n\n### {r}\n\n") %>%
      cat()
  }

  for(ow in w_meta$ow[w_meta$region == r]) {

    w_meta %>%
      filter(.data$ow %in% !!ow) %>%
      select("ow", "location_long", "type"#, "hydraulic_connectivity"
             ) %>%
      distinct() %>%
      #mutate(ow_fish = ow_fish(ow),
      #       ow = ifelse(is.na(ow_fish),ow, ow_fish)) %>%
      glue_data("\n\n\n#### {ow}\n\n",  # Map title e.g., OW008
                "**{location_long}** | **[Map](#map)**   \n",
                "{ifelse(!is.na(type),type,'No listed')} aquifer"#,
                #"{ifelse(!is.na(type),paste0(' | ', stringr::str_to_sentence(hydraulic_connectivity),' hydraulically connected\n\n') ,'')} "
                ) %>%
      cat()
    full <- filter(w_full, ow == !!ow)
    full_all <- filter(w_full_all, ow == !!ow)
    hist <- filter(w_hist, ow == !!ow)
    date <- filter(latest_date, ow == !!ow)

    min_daily_date <- dplyr::case_when(min(full_all$WaterYear) != min(full$WaterYear) ~ min(full$Date, na.rm = TRUE),
                                       TRUE ~ NA)

    g1 <- well_plot_perc(full, hist, date, years_min, water_year = wy)
    g2 <- well_plot_hist(full_all, hist, vline_date = min_daily_date)

    g <- g1 / g2
    print(g)
  }
}

Disclaimer

Warranty Disclaimer

This information is provided as a public service by the Government of British Columbia, Box 9411, Victoria, British Columbia, Canada V8W 9V1.

This website and all of the information it contains are provided "as is" without warranty of any kind, whether express or implied. All implied warranties, including, without limitation, implied warranties of merchantability, fitness for a particular purpose, and non-infringement, are hereby expressly disclaimed. Links and references to any other websites are provided for information only and listing shall not be taken as endorsement of any kind. The Government of British Columbia is not responsible for the content or reliability of the linked websites and does not endorse the content, products, services or views expressed within them.

Limitation of Liabilities

Under no circumstances will the Government of British Columbia be liable to any person or business entity for any direct, indirect, special, incidental, consequential, or other damages based on any use of this website or any other website to which this site is linked, including, without limitation, any lost profits, business interruption, or loss of programs or information, even if the Government of British Columbia has been specifically advised of the possibility of such damages.

Appendices {#appendices .tabset}

A - Dates

If data isn't available for an exact reporting date, dates up to r n_days days before and r n_days days after the report date are examined for non-missing data. Thus, an alternative date is chosen within a r n_days * 2 + 1-day window, centred on the reporting date.

If there are multiple dates with data, the dates are ranked based on their historical data quality (for calculating percentiles) and their nearness to the original date indicated. The top date is then chosen for that well and that reporting date.

This table lists the original reporting dates, and the actual dates used for each observation well.

w_dates %>%
  well_meta() %>%
  dplyr::select("region", "area", "location", "ow", "report_dates", "Date") %>%
  dplyr::arrange(.data$region, .data$area, .data$location,
                 .data$ow, dplyr::desc(.data$report_dates)) %>%
  tidyr::pivot_wider(names_from = "report_dates", values_from = "Date") %>%
  group_by(region) %>%
  gt() %>%
  cols_label("area" = "Area", "location" = "Location Name", 
             "ow" = "Obs. Well") %>%
  tab_spanner(label = "Report Dates vs. Measurement Dates", 
              columns = -c("area", "location", "ow")) %>%
  text_transform(locations = cells_body(columns = "ow"),
                 fn = function(x) ow_link(x, format = "html")) %>% #ow_fish(x) %>% 
  gt_bcgwl_style()

B - Calculations

General details

• Water year starts in October
• Well measurements are all in Depth Below Ground in metres

Percentiles

• Percentiles are calculated individually for each day of the year for each well
• Percentiles are calculated only with "Approved" data
• 366th day in leap years is omitted
• "Good" quality data have 'Approved' historical values for >= r years_min years
• "Poor" quality data have 'Approved' historical values for < r years_min years and are not used (percentiles for that well on that day of the year are missing from the figures and tables).

C - Run info

Parameters

• Observation Wells (ows): r glue_collapse(ows, ", ")
• Report Dates (report_dates): r glue_collapse(report_dates[1:2], ", ")
• No. Days on either side of report date in which search for alternate date (n_days): r n_days
• Total window around (and including) a reporting date is r n_days * 2 + 1 days
• Percentile Calculations
• Min number of years (years_min) - r years_min

Session Info

Platform

sessioninfo::platform_info()

Packages

sessioninfo::package_info()

bcgov/bcgwlreports documentation built on Aug. 9, 2024, 10:47 p.m.