From 836f4b9ab6b6e359da653ea546770f04fa7ba4bd Mon Sep 17 00:00:00 2001
From: biopsichas <svajunas.plunge@gmail.com>
Date: Wed, 15 Feb 2023 17:33:01 +0200
Subject: [PATCH] added bug fixes in mgt_report and print out for
schedule_report, bug fixes for point sources (if there is none case)
---
NAMESPACE | 5 ++++
R/helper.R | 29 +++++++++++++++++++
R/plot_ps_tile.R | 69 ++++++++++++++++++++++++---------------------
R/print_mgt.R | 31 ++++++++++++++++----
R/run_swat_verify.R | 8 ++++--
man/remove_tail.Rd | 32 +++++++++++++++++++++
man/report_mgt.Rd | 5 +++-
7 files changed, 138 insertions(+), 41 deletions(-)
create mode 100644 man/remove_tail.Rd
diff --git a/NAMESPACE b/NAMESPACE
index eccd27e..bbff974 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -25,7 +25,9 @@ importFrom(dplyr,arrange)
importFrom(dplyr,bind_rows)
importFrom(dplyr,case_when)
importFrom(dplyr,distinct)
+importFrom(dplyr,ends_with)
importFrom(dplyr,filter)
+importFrom(dplyr,full_join)
importFrom(dplyr,group_by)
importFrom(dplyr,group_map)
importFrom(dplyr,group_split)
@@ -36,6 +38,7 @@ importFrom(dplyr,mutate_all)
importFrom(dplyr,mutate_at)
importFrom(dplyr,n)
importFrom(dplyr,rename)
+importFrom(dplyr,rename_with)
importFrom(dplyr,row_number)
importFrom(dplyr,select)
importFrom(dplyr,slice)
@@ -81,7 +84,9 @@ importFrom(purrr,map_df)
importFrom(purrr,map_int)
importFrom(purrr,set_names)
importFrom(readr,read_lines)
+importFrom(readr,write_delim)
importFrom(readr,write_lines)
+importFrom(stringr,str_remove)
importFrom(stringr,str_replace)
importFrom(stringr,str_replace_all)
importFrom(stringr,str_split)
diff --git a/R/helper.R b/R/helper.R
index fde56bb..ad06264 100644
--- a/R/helper.R
+++ b/R/helper.R
@@ -75,3 +75,32 @@ hide_show <- function(graph){
args = list("visible", "legendonly"),
label = "hide all")))))
}
+
+#' Remove tail endings for management, plant community, land use classes
+#'
+#' This function is required for SWATfarmR generated management files
+#' as management.sch, plant.ini, landuse.lum and hru-data.hru can get too
+#' long names for swat executable.
+#'
+#' @param f multiline character
+#' @param pattern pattern after which to remove tail
+#' @return corrected multiline character
+#' @keywords internal
+#'
+#' @examples
+#' \dontrun{
+#' library(readr)
+#' landuse <- read_lines(paste0(project_path,'/landuse.lum'), lazy = FALSE)
+#' landuse <- remove_tail(landuse, "lum")
+#' landuse <- remove_tail(landuse, "comm")
+#' landuse <- remove_tail(landuse, "mgt")
+#' write_lines(landuse, paste0(project_path,'/landuse_new.lum'))
+#' }
+
+remove_tail <- function(f, pattern){
+ ind <- grep(paste0("_", pattern,"_"), f)
+ for(i in ind){
+ f[i] <- gsub(paste0("(_", pattern, ").*?\\s"), "\\1 ", f[i])
+ }
+ return(f)
+}
diff --git a/R/plot_ps_tile.R b/R/plot_ps_tile.R
index 1ec966a..bf7d5b4 100644
--- a/R/plot_ps_tile.R
+++ b/R/plot_ps_tile.R
@@ -17,40 +17,45 @@
#' }
plot_ps <- function(sim_verify, conc = FALSE){
- df <- sim_verify$recall_yr[, -c(1:3,6)] %>%
- .[, colSums(.!= 0) > 0] %>%
- mutate(yr = as.factor(yr),
- name = gsub("hru00", "ps", name))
- if(conc){
- df <- df %>%
- pivot_longer(-c(yr, name, flo), names_to = 'var', values_to = 'Values') %>%
- mutate(Values = ifelse(var == "sed", (Values/flo)*(1000000/(24*69*60*365.25)),
- (Values/flo)*(1000/(24*69*60*365.25)))) %>%
- select(yr, name, var, Values) %>%
- bind_rows(df[c("yr", "name", "flo")] %>% mutate(var = "flo") %>% rename(Values = flo)) %>%
- mutate(var = case_when(var == 'flo' ~ "flo m3/s",
- var %in% c("orgn", "no3", "nh3", "no2") ~ paste(var, "N mg/y"),
- var %in% c("sedp", "solp") ~ paste(var, "P mg/y"),
- TRUE ~ paste(var, "mg/l")))
+ if(!is.null(sim_verify$recall_yr)){
+ df <- sim_verify$recall_yr[, -c(1:3,6)] %>%
+ .[, colSums(.!= 0) > 0] %>%
+ mutate(yr = as.factor(yr),
+ name = gsub("hru00", "ps", name))
+ if(conc){
+ df <- df %>%
+ pivot_longer(-c(yr, name, flo), names_to = 'var', values_to = 'Values') %>%
+ mutate(Values = ifelse(var == "sed", (Values/flo)*(1000000/(24*69*60*365.25)),
+ (Values/flo)*(1000/(24*69*60*365.25)))) %>%
+ select(yr, name, var, Values) %>%
+ bind_rows(df[c("yr", "name", "flo")] %>% mutate(var = "flo") %>% rename(Values = flo)) %>%
+ mutate(var = case_when(var == 'flo' ~ "flo m3/s",
+ var %in% c("orgn", "no3", "nh3", "no2") ~ paste(var, "N mg/y"),
+ var %in% c("sedp", "solp") ~ paste(var, "P mg/y"),
+ TRUE ~ paste(var, "mg/l")))
+ } else {
+ df <- df %>%
+ pivot_longer(-c(yr, name), names_to = 'var', values_to = 'Values') %>%
+ mutate(var = case_when(var == 'flo' ~ "flo m3/s",
+ var == 'sed' ~ "sed t/y",
+ var %in% c("orgn", "no3", "nh3", "no2") ~ paste(var, "N kg/y"),
+ var %in% c("sedp", "solp") ~ paste(var, "P kg/y"),
+ TRUE ~ paste(var, "kg/y")))
+ }
+ fig <- ggplot(df, aes(x=yr, y=Values, group=name, colour=name))+
+ geom_line(size=1.5)+
+ facet_wrap(~var, scales = "free_y")+
+ labs(color='Point sources', x = 'Year') +
+ theme_bw()+
+ theme(strip.background = element_rect(fill = "deepskyblue3", colour = "azure3"),
+ strip.text = element_text(color = "white", face="bold"),
+ panel.border = element_rect(colour = "azure3"),
+ axis.text.x = element_text(angle = 25, hjust=1))
+
+ return(fig)
} else {
- df <- df %>%
- pivot_longer(-c(yr, name), names_to = 'var', values_to = 'Values') %>%
- mutate(var = case_when(var == 'flo' ~ "flo m3/s",
- var == 'sed' ~ "sed t/y",
- var %in% c("orgn", "no3", "nh3", "no2") ~ paste(var, "N kg/y"),
- var %in% c("sedp", "solp") ~ paste(var, "P kg/y"),
- TRUE ~ paste(var, "kg/y")))
+ print("No point sources exists in this model setup!!!")
}
- fig <- ggplot(df, aes(x=yr, y=Values, group=name, colour=name))+
- geom_line(size=1.5)+
- facet_wrap(~var, scales = "free_y")+
- labs(color='Point sources', x = 'Year') +
- theme_bw()+
- theme(strip.background = element_rect(fill = "deepskyblue3", colour = "azure3"),
- strip.text = element_text(color = "white", face="bold"),
- panel.border = element_rect(colour = "azure3"),
- axis.text.x = element_text(angle = 25, hjust=1))
- return(fig)
}
#' Print the average annual qtile for HRUs
diff --git a/R/print_mgt.R b/R/print_mgt.R
index 7bff2eb..5555bee 100644
--- a/R/print_mgt.R
+++ b/R/print_mgt.R
@@ -42,18 +42,21 @@ print_triggered_mgt <- function(sim_verify, hru_id, years = 1900:2100) {
#' @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()}
+#' @param write_report (optional) Boolean TRUE for writing output to 'schedule_report.txt' file,
+#' FALSE - not preparing this file. Default \code{write_report = FALSE}.
#'
#' @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 dplyr filter group_by group_split lead left_join mutate rename select slice_sample summarise %>% rename_with full_join ends_with
#' @importFrom purrr map
-#' @importFrom stringr str_sub
+#' @importFrom stringr str_sub str_remove
+#' @importFrom readr write_delim write_lines
#'
#' @export
#'
-report_mgt <- function(sim_verify) {
+report_mgt <- function(sim_verify, write_report = FALSE) {
yr_start <- min(sim_verify$mgt_out$year)
mgt_lbl <- unique(sim_verify$lum_mgt$mgt)
mgt_lbl <- mgt_lbl[!is.na(mgt_lbl)]
@@ -90,12 +93,14 @@ report_mgt <- function(sim_verify) {
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")) %>%
+ schdl_join <- full_join(schdl_mgt, mgt_i,
+ by = c("schedule", "year", "mon", "day", "op_typ", "op_data1" = "op_data1_trig"), keep = TRUE) %>%
+ select(-ends_with(".y")) %>%
+ rename_with(~str_remove(., '.x')) %>%
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)
+ filter(op_issue & year <= max(sim_verify$mgt_out$year) - yr_start)
schdl_report <- schdl_join %>%
select(schedule, op_issue) %>%
@@ -112,6 +117,20 @@ report_mgt <- function(sim_verify) {
schdl_report <- schdl_report %>%
mutate(schedule_report = ops_detail)
+ if(write_report){
+ print("Writing schedule_report.txt")
+ write(paste("File was written with SWATdoctR at", Sys.time( )), file = "schedule_report.txt")
+ for (i in seq(1, length(schdl_report$schedule_report))){
+ mgt <- schdl_report$schedule[[i]]
+ id <- get_hru_id_by_attribute(sim_verify, mgt = mgt)$id[1]
+ write_lines(" ", "schedule_report.txt", append = TRUE)
+ write_lines(paste("HRU number -", id, "- management name:", mgt), "schedule_report.txt", append = TRUE)
+ write_lines(" ", "schedule_report.txt", append = TRUE)
+ write_delim(schdl_report$schedule_report[[i]], "schedule_report.txt", delim = "\t", append = TRUE, col_names = TRUE)
+ }
+ print(paste("The file schedule_report.txt was written in", getwd( ), "directory."))
+ }
+
return(schdl_report)
}
diff --git a/R/run_swat_verify.R b/R/run_swat_verify.R
index b3a94a4..58d4d1c 100644
--- a/R/run_swat_verify.R
+++ b/R/run_swat_verify.R
@@ -69,7 +69,6 @@ run_swat_verification <- function(project_path, outputs = c('wb', 'mgt', 'plt'),
model_output <- err_msg
} else if(nchar(msg$stderr) == 0) {
model_output <- list()
-
if ('plt' %in% outputs) {
model_output$hru_pw_day <- read_tbl('hru_pw_day.txt', run_path, 3)
}
@@ -77,7 +76,12 @@ run_swat_verification <- function(project_path, outputs = c('wb', 'mgt', 'plt'),
model_output$basin_wb_day <- read_tbl('basin_wb_day.txt', run_path, 3)
model_output$basin_pw_day <- read_tbl('basin_pw_day.txt', run_path, 3)
model_output$hru_wb_aa <- read_tbl('hru_wb_aa.txt', run_path, 3)
- model_output$recall_yr <- read_tbl('recall_yr.txt', run_path, 3)
+ tryCatch({
+ model_output$recall_yr <- read_tbl('recall_yr.txt', run_path, 3)
+ },
+ error = function(e) {
+ model_output$recall_yr <- NULL
+ })
}
if ('mgt' %in% outputs) {
model_output$mgt_out <- read_mgt(run_path)
diff --git a/man/remove_tail.Rd b/man/remove_tail.Rd
new file mode 100644
index 0000000..faa1f40
--- /dev/null
+++ b/man/remove_tail.Rd
@@ -0,0 +1,32 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/helper.R
+\name{remove_tail}
+\alias{remove_tail}
+\title{Remove tail endings for management, plant community, land use classes}
+\usage{
+remove_tail(f, pattern)
+}
+\arguments{
+\item{f}{multiline character}
+
+\item{pattern}{pattern after which to remove tail}
+}
+\value{
+corrected multiline character
+}
+\description{
+This function is required for SWATfarmR generated management files
+as management.sch, plant.ini, landuse.lum and hru-data.hru can get too
+long names for swat executable.
+}
+\examples{
+\dontrun{
+library(readr)
+landuse <- read_lines(paste0(project_path,'/landuse.lum'), lazy = FALSE)
+landuse <- remove_tail(landuse, "lum")
+landuse <- remove_tail(landuse, "comm")
+landuse <- remove_tail(landuse, "mgt")
+write_lines(landuse, paste0(project_path,'/landuse_new.lum'))
+}
+}
+\keyword{internal}
diff --git a/man/report_mgt.Rd b/man/report_mgt.Rd
index 467be71..357c6d5 100644
--- a/man/report_mgt.Rd
+++ b/man/report_mgt.Rd
@@ -4,12 +4,15 @@
\alias{report_mgt}
\title{Generate a report table that compares the scheduled and triggered managements}
\usage{
-report_mgt(sim_verify)
+report_mgt(sim_verify, write_report = FALSE)
}
\arguments{
\item{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()}}
+
+\item{write_report}{(optional) Boolean TRUE for writing output to 'schedule_report.txt' file,
+FALSE - not preparing this file. Default \code{write_report = FALSE}.}
}
\value{
Returns a tibble that summarises all management schedules for
--
GitLab