Add function to get overview of triggered management

DESCRIPTION

 Package: SWATdoctR
 Type: Package
 Title: Finding the right diagnoses and treatments for SWAT+ models
-Version: 0.1.1
+Version: 0.1.2
 Author: c(person("Svajunas", "Plunge",
              email = "svajunas_plunge@sggw.edu.pl",
              role = c("aut")),

NAMESPACE

@@ -38,12 +38,17 @@ importFrom(lubridate,year)
 importFrom(lubridate,ymd)
 importFrom(processx,run)
 importFrom(purrr,map)
+importFrom(purrr,map2)
 importFrom(purrr,map2_chr)
+importFrom(purrr,map2_df)
+importFrom(purrr,map_chr)
 importFrom(purrr,map_df)
+importFrom(purrr,map_int)
 importFrom(purrr,set_names)
 importFrom(readr,read_lines)
 importFrom(readr,write_lines)
 importFrom(stringr,str_replace)
+importFrom(stringr,str_replace_all)
 importFrom(stringr,str_split)
 importFrom(stringr,str_sub)
 importFrom(stringr,str_trim)
@@ -51,4 +56,3 @@ importFrom(tibble,as_tibble)
 importFrom(tibble,tibble)
 importFrom(tidyr,pivot_longer)
 importFrom(tidyselect,all_of)
-importFrom(vroom,vroom_lines)

R/plot_mgt_harv.R

@@ -16,6 +16,7 @@
 #' @importFrom dplyr filter group_by mutate n rename select ungroup %>%
 #' @importFrom ggplot2 aes ggplot geom_boxplot geom_hline labs theme_bw
 #' @importFrom purrr set_names
+#'
 #' @export
 #'
 plot_variable_at_harvkill <- function(sim_verify, variable, years = 1900:2100) {

R/print_mgt.R

@@ -15,6 +15,7 @@
 #' @return Prints a tibble with triggered operations to the R console.
 #'
 #' @importFrom dplyr filter mutate rename select %>%
+#'
 #' @export
 #'
 print_triggered_mgt <- function(sim_verify, hru_id, start_year = 1900, end_year = 2100) {
@@ -31,3 +32,105 @@ print_triggered_mgt <- function(sim_verify, hru_id, start_year = 1900, end_year
     select(., year, mon, day, phuplant, operation, op_data1, op_data3) %>%
     print(., n = Inf)
 }
+
+#' Generate a report table that compares the scheduled and triggered managements
+#'
+#' report_mgt compares the scheduled management operations for all schedules
+#' with the triggered management operations. Therefore HRUs are randomly
+#' selected for each schedule where one of the schedules is implemented.
+#'
+#' @param sim_verify Simulation output of the function \code{run_swat_verification()}.
+#'   To print the management at least the output option \code{outputs = 'mgt'} must
+#'   be set in  \code{run_swat_verification()}
+#'
+#' @return Returns a tibble that summarises all management schedules for
+#'   which operations where scheduled, that were either not triggered of
+#'   for which operation properties differ..
+#'
+#' @importFrom dplyr filter group_by group_split lead left_join mutate rename select slice_sample summarise %>%
+#' @importFrom purrr map
+#' @importFrom stringr str_sub
+#'
+#' @export
+#'
+report_mgt <- function(sim_verify) {
+  yr_start <- min(sim_verify$mgt_out$year)
+  mgt_lbl <- unique(sim_verify$lum_mgt$mgt)
+  mgt_lbl <- mgt_lbl[!is.na(mgt_lbl)]
+
+  schdl_mgt <- sim_verify$mgt_sch %>%
+    filter(schedule %in% mgt_lbl) %>%
+    filter(!is.na(op_typ)) %>%
+    group_by(schedule) %>%
+    mutate(rm_skp = lead(op_typ, 1),
+           rm_skp = ifelse(op_typ == 'skip' &
+                             rm_skp  != 'skip' |
+                             is.na(rm_skp), TRUE, FALSE)) %>%
+    filter(!rm_skp) %>%
+    select(-rm_skp) %>%
+    mutate(year = c(NA, diff(mon)),
+           year = ifelse(is.na(year) | year >= 0, 0, 1),
+           year = cumsum(year) + yr_start) %>%
+    ungroup(.)
+
+  mgt_lbl <- unique(schdl_mgt$schedule)
+
+  hru_sel <- sim_verify$lum_mgt %>%
+    filter(mgt %in% mgt_lbl) %>%
+    group_by(mgt) %>%
+    slice_sample(., n = 1)
+
+  mgt_i <- sim_verify$mgt_out %>%
+    filter(hru %in% hru_sel$id) %>%
+    left_join(., hru_sel, by = c('hru' = 'id')) %>%
+    rename(schedule = mgt,
+           op_typ = operation,
+           op_data1_trig = op_typ) %>%
+    select(., schedule, year, mon, day, op_typ, op_data1_trig) %>%
+    mutate(op_typ = str_sub(op_typ, 1, 4) %>%  tolower(.),
+           op_typ = ifelse(op_typ == 'plan', 'plnt', op_typ))
+
+  schdl_join <- left_join(schdl_mgt, mgt_i,
+                          by = c("schedule", "year",  "mon", "day", "op_typ")) %>%
+    select(schedule, year, mon, day, op_typ, op_data1_trig, starts_with('op_data')) %>%
+    mutate(op_issue = is.na(op_data1_trig) | op_data1_trig != op_data1,
+           year = year - yr_start + 1) %>%
+    filter(op_issue)
+
+  schdl_report <- schdl_join %>%
+    select(schedule, op_issue) %>%
+    group_by(schedule) %>%
+    summarise(op_issue = sum(op_issue),
+              .groups = 'drop')
+
+  ops_detail <- schdl_join %>%
+    group_by(schedule) %>%
+    group_split() %>%
+    map(., ~ filter(.x, op_issue)) %>%
+    map(., ~ select(.x, year, mon, day, op_typ, op_data1_trig, starts_with('op_data')))
+
+  schdl_report <- schdl_report %>%
+    mutate(schedule_report = ops_detail)
+
+  return(schdl_report)
+}
+
+
+#' Transform x to a matrix with 7 columns and fill up with NA values
+#'
+#' @param x character vector or NULL
+#'
+#' @keywords internal
+#'
+as_mtx_null <- function(x) {
+  if(is.null(x)) {
+    matrix(rep(NA_character_, 7), ncol = 7)
+  } else {
+    matrix(x, nrow = 7) %>%
+      t(.)
+  }
+}
+
+
+
+

R/run_swat_verify.R

@@ -80,6 +80,7 @@ run_swat_verification <- function(project_path, outputs = c('wb', 'mgt', 'plt'),
     }
     if ('mgt' %in% outputs) {
       model_output$mgt_out <- read_mgt(run_path)
+      model_output$mgt_sch <- read_sch(run_path)
 
       hru_data <- read_tbl('hru-data.hru', run_path, 2)
       landuse_lum <- read_tbl('landuse.lum', run_path, 2)
@@ -203,9 +204,9 @@ read_tbl <- function(file, run_path, n_skip) {
 #'
 #' @importFrom dplyr %>%
 #' @importFrom purrr map map_df set_names
+#' @importFrom readr read_lines
 #' @importFrom stringr str_trim str_split
 #' @importFrom tibble as_tibble
-#' @importFrom vroom vroom_lines
 #'
 #' @keywords internal
 #'
@@ -231,6 +232,53 @@ read_mgt <- function(run_path) {
   return(mgt)
 }
 
+#' Read SWAT+ management schedule file and return the read file in a tibble
+#'
+#' @param run_path Path to the folder where simulations are performed
+#'
+#' @importFrom dplyr mutate %>%
+#' @importFrom purrr map map_int map_chr map2 map2_df map_df set_names
+#' @importFrom readr read_lines
+#' @importFrom stringr str_replace_all str_trim str_split
+#' @importFrom tibble as_tibble
+#'
+#' @keywords internal
+#'
+read_sch <- function(run_path) {
+  schdl_path <- paste0(run_path, '/management.sch')
+
+  schdl <- read_lines(schdl_path, skip = 2, lazy = FALSE) %>%
+    str_trim(.) %>%
+    str_replace_all(., '\t', ' ') %>%
+    str_split(., '[:space:]+')
+
+  n_elem <- map_int(schdl, length)
+  schdl <- schdl[n_elem != 1]
+  n_elem <- map_int(schdl, length)
+  schdl_def_pos <- which(n_elem == 3)
+
+  schdl_name <- map_chr(schdl_def_pos, ~ schdl[[.x]][1])
+
+  schdl_start <- schdl_def_pos + 1
+  schdl_end <- c(schdl_def_pos[2:length(schdl_def_pos)] - 1, length(schdl))
+  no_entry <- schdl_start > schdl_end
+  schdl_start[no_entry] <- length(schdl) + 1
+  schdl_end[no_entry] <- length(schdl) + 1
+  schdl_start[no_entry] <- 1e9
+  schdl_end[no_entry] <- 1e9
+
+  schdl_mgt <- map2(schdl_start, schdl_end, ~ schdl[.x:.y]) %>%
+    map(., unlist) %>%
+    map(., as_mtx_null) %>%
+    map(., ~ as_tibble(.x, .name_repair = 'minimal')) %>%
+    map(., ~ set_names(.x, c('op_typ', 'mon', 'day', 'hu_sch', paste0('op_data', 1:3)))) %>%
+    map2_df(., schdl_name, ~ mutate(.x, schedule = .y, .before = 1))
+
+  schdl_mgt[,c(3:5, 8)] <- map_df(schdl_mgt[,c(3:5, 8)], as.numeric)
+
+  return(schdl_mgt)
+}
+
 #' Generate folder structure for SWAT execution
 #'
 #' @param project_path Path to the SWAT project folder (i.e. TxtInOut)

man/read_sch.Rd

+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/run_swat_verify.R
+\name{read_sch}
+\alias{read_sch}
+\title{Read SWAT+ management schedule file and return the read file in a tibble}
+\usage{
+read_sch(run_path)
+}
+\arguments{
+\item{run_path}{Path to the folder where simulations are performed}
+}
+\description{
+Read SWAT+ management schedule file and return the read file in a tibble
+}
+\keyword{internal}