In ecodata1/hera: Building Environmental Models Together

knitr::opts_chunk$set(
  collapse = TRUE,
  comment = "#>",
  echo = FALSE,
  warning = FALSE
)
library(hera)
library(dplyr)
library(purrr)
library(tidyr)
library(tibble)
library(magrittr)
library(testthat)

Welcome

This document has been created following the generic assessment guidance.

This is the Rapid Assessment Technique (RAT) for results from bankside invertebrates analysis to check consistency with Water Body Status.

Description

Basic details about the assessment.

description <- tribble(
  ~question, ~response,
  "name_short", "Bankside Consistency",
  "name_long", "Rapid Assessment of Bankside Consistency with Water Body Status",
  "parameter", "River Family Inverts",
  "status", "testing",
  "type", "metric"
)

knitr::kable(description)

Input

A list of questions required to run the assessment.

input <- tibble(
  location_id = c("206972", "206972"),
  sample_id = c("12345", "12345"),
  date_taken = as.Date(c("2019-11-21", "2019-11-21")),
  question = c("Taxon abundance", "Live abundance"),
  response = c("12", "21"),
  label = c("Baetidae", "Baetidae"),
  parameter = c("River Family Inverts", "BANKSIDE_INVERTS"),
  type = c("number", "number"),
  max = c(NA, NA),
  min = c(NA, NA),
  source = c("sepa_ecology_results", "sepa_ecology_results")
)
data <- input
data <- select(data, question, response)
data <- data[!duplicated(data[, c("question")]), ]

knitr::kable(data)

Assessment

Function code used to run the metric.

assessment_function <- function(data, ...) {
  # Some calculated a statistic...
  # Note, any non-standard base R library must be call using require().
  require(dplyr)
  require(tidyr)
  require(magrittr)
  require(tibble)
  require(whpt)
  require(macroinvertebrateMetrics)
  data$date_taken <- as.character(format.Date(data$date_taken, "%Y/%m/%d"))
  catalogue <- hera::catalogue
  metric_function <- catalogue[catalogue$assessment ==
    "Macroinvertebrate Metrics", 3][[1]]
  output <- metric_function[[1]](data)
  output <- filter(output, question %in% c("WHPT_ASPT", "WHPT_NTAXA"))
  predictors <- utils::read.csv(system.file("extdat",
    "gis-predictors.csv",
    package = "whpt"
  ), check.names = FALSE)

# Downgrade Typical class for testing worst-case scenario
#   predictors$`Typical ASPT Class`[predictors$`Typical ASPT Class` == "Poor"] <- "Bad"
#     predictors$`Typical ASPT Class`[predictors$`Typical ASPT Class` == "Moderate"] <- "Poor"
#       predictors$`Typical ASPT Class`[predictors$`Typical ASPT Class` == "Good"] <- "Moderate"
#         predictors$`Typical ASPT Class`[predictors$`Typical ASPT Class` == "Good"] <- "Moderate"
#           predictors$`Typical ASPT Class`[predictors$`Typical ASPT Class` == "High"] <- "Good"
# 
# 
# predictors$`Typical NTAXA Class`[predictors$`Typical NTAXA Class` == "Poor"] <- "Bad"
#     predictors$`Typical NTAXA Class`[predictors$`Typical NTAXA Class` == "Moderate"] <- "Poor"
#       predictors$`Typical NTAXA Class`[predictors$`Typical NTAXA Class` == "Good"] <- "Moderate"
#         predictors$`Typical NTAXA Class`[predictors$`Typical NTAXA Class` == "Good"] <- "Moderate"
#           predictors$`Typical NTAXA Class`[predictors$`Typical NTAXA Class` == "High"] <- "Good"


  predictors$location_id <- as.character(predictors$location_id)
  predict_data <- filter(predictors, location_id %in% unique(data$location_id))
  output_location <- inner_join(output,
    data[, c(
      "location_id",
      "sample_id",
      "date_taken"
    )],
    by = "sample_id",
    relationship = "many-to-many"
  )
  output_location$location_id <-
    as.character(output_location$location_id)
  whpt_input <- inner_join(output_location,
    predict_data,
    by = "location_id"
  )
  whpt_input$question[whpt_input$question == "WHPT_ASPT"] <-
    "WHPT ASPT Abund"
  whpt_input$question[whpt_input$question == "WHPT_NTAXA"] <-
    "WHPT NTAXA Abund"
  if (nrow(whpt_input) < 1) {
    return(NULL)
  } else {
    whpt_input <- unique(whpt_input)
    whpt_input$response <- as.numeric(whpt_input$response)
    consistency_check <- whpt::whpts(whpt_input)
    consistency_check$response <-
      as.character(consistency_check$response)
  }

report <- tidyr::pivot_wider(consistency_check, names_from = question, values_from = response)
vars <- c("location_id", "location_description", "sample_id", "date_taken")
location_ids <- dplyr::select(data, any_of(vars)) %>%  unique()
location_ids$season <- hera:::season(location_ids$date_taken, output = "shortname")
report <- inner_join(report, location_ids, by = join_by(sample_id))

new_predictors <- read.csv(
  system.file("extdat", "gis-predictors.csv", package = "whpt"),
  check.names = FALSE)

report <- dplyr::inner_join(report, new_predictors, by = join_by(location_id))

whpt_wide <- tidyr::pivot_wider(output, names_from = question, values_from = response)
report <- dplyr::inner_join(report, whpt_wide, by = join_by(sample_id))

vars <- c(
"water body sampled",
"sample_id", 
"date_taken",
"location_id",
"location_description",
"season",
"Reference NTAXA",
"Reference ASPT", 
"assessment",
"driver", 
"WHPT_NTAXA",
"WHPT_ASPT",
"Typical ASPT Class",
"Typical NTAXA Class",
"Reported WHPT Class Year"
)


report <- dplyr::select(report, any_of(vars))
vars <- c(
"season",
"Reference NTAXA",
"Reference ASPT", 
"assessment",
"driver", 
"WHPT_NTAXA",
"WHPT_ASPT",
"Typical ASPT Class",
"Typical NTAXA Class",
"Reported WHPT Class Year",
"water body sampled"
)
report$`water body sampled` <- as.character(report$`water body sampled`)
report$`Reported WHPT Class Year` <- as.character(report$`Reported WHPT Class Year`)
consistency_check <- pivot_longer(report, cols = all_of(vars), names_to = "question", values_to = "response")
 consistency_check$date_taken <- as.Date(consistency_check$date_taken)
  consistency_check$parameter <- "Bankside Consistency"
  return(consistency_check)
}

Outcome

The outcome of your assessment.

outcome <- assessment_function(input)
outcome_table <- select(outcome, question, response)
outcome_table <- outcome_table[!duplicated(outcome_table[, c("question")]), ]
knitr::kable(outcome_table)

Check

Run checks on the assessment.

# No need to edit this code
# Format description
standard_format <- hera:::hera_format(description = description)
# Check description
check_list <- hera:::hera_test(description = description)
knitr::kable(check_list$standard_check)

Update

Update the catalogue of assessments to make them available.

# No need to edit this code
hera:::update_catalogue(
  description = description,
  input = input,
  assessment_function = assessment_function,
  output = outcome
)

After updating the catalogue, rebuild the package, click on Build > Install and Restart menu or 'Install and Restart' button in the Build pane.

Test

This section tests if this assessment is usable using assess function.

Using demo data:

# For some reason not working on CI / github actions:
# No need to edit this code
# data_out <- assess(
#   data = hera::demo_data,
#   name = description$response[description$question == "name_short"]
# )
# knitr::kable(head(data_out))

Using converted data:

# For some reason not working on CI / github actions:
# lims_data <- hera:::convert(hera::lims_data)
# lims_out <- assess(
#   data = lims_data,
#   name = description$response[description$question == "name_short"]
# )
# knitr::kable(head(lims_data))

Launch app

Below is an interactive application displaying the results of your assessment.

# No need to edit this code
# launch_app(new_catalogue = catalogue, data = data)

ecodata1/hera documentation built on April 5, 2025, 1:48 a.m.