R/echse_prep_runs.R

In tpilz/WasaEchseTools: Title: Handy tools for preprocessing and analysis of the hydrological models WASA-SED and ECHSE (limited to the WASA engine). Currently only meant for internal use! If you want to try it, handle with care!

#' Preparation of input for the WASA engine of the ECHSE simulation environment
#'
#' Makes use of spatial model input prepared with the \code{\link[lumpR]{lumpR}} package,
#' pre-processed meteorological data, and further input to this function to generate a
#' directory for the model ready to run simulations.
#'
#' @param sp_input_dir Character string of the directory containing the spatial input.
#' E.g. the output of \code{\link[lumpR]{db_echse_input}}.
#'
#' @param wgt_file Character string specifying the name of the file containing the
#' weighting of input locations of meteorological data. Should be the output of function
#' \code{\link[geostat]{externalInputLocationsTable}} (argument 'file_result').
#'
#' @param meteo_ext_datafiles Data.frame containing information of ECHSE's external
#' datafile input. Requires the variables 'variable', 'sums', 'past', and 'file'
#' (see the ECHSE manual for more information).
#'
#' @param prep_tpl Logical. Shall template parameter files be created? If \code{TRUE},
#'  files sharedParamNum_WASA_svc_tpl.dat, sharedParamNum_WASA_lu_tpl.dat, and
#'  sharedParamNum_WASA_rch_tpl.dat will be created (and the old files be deleted
#'  accordingly) where all choice_* parameter values will be replaced by placeholders
#'  to be adjusted, for instance, within a multi-hypothesis study employing different
#'  model structures (i.e. using different choice_* parameter realisations). Default: \code{FALSE}.
#'
#' @param echse_sim_dir Character string of the location the output shall be written
#' to (directory will be created if it does not exist).
#'
#' @return Function returns nothing.
#'
#' @author Tobias Pilz \email{tpilz@@uni-potsdam.de}
#'
#' @export
echse_prep_runs <- function(
  sp_input_dir = NULL,
  wgt_file = NULL,
  meteo_ext_datafiles = NULL,
  prep_tpl = FALSE,
  echse_sim_dir = getwd()) {

  # create echse simulation directory for current project
  dir.create(echse_sim_dir, recursive = T, showWarnings = F)

  # copy created echse input data
  file.copy(paste0(sp_input_dir, "/."), echse_sim_dir, recursive = T, overwrite=T)

  # dynamic variables #
  # get objDecl (created by lumpR::db_echse_input)
  objDecl_file <- paste(echse_sim_dir, "data/catchment/objDecl.dat", sep="/")

  # external location table from vegetation parameter time series (created by lumpR::db_echse_input)
  file_wgt_veg <- paste(echse_sim_dir, "data/vegPar_time_series/input_ext_locs.dat", sep="/")

  # Output file from interolation: external locations and weights table for meteo input
  file_ext_wgt <- paste(echse_sim_dir, "data/forcing/inputs_ext_locations.dat", sep="/")

  # external data locations file compiled from information given to meteo_ts_echse
  file_ext_datafiles <- paste(echse_sim_dir, "data/forcing/inputs_ext_datafiles.dat", sep="/")



  # METEO DATA #
  # prepare forcing sub-directory in echse dir
  dir.create(paste(echse_sim_dir, "data/forcing/", sep="/"))

  # Read obj declaration
  objDecl_dat <- read.table(objDecl_file, header=T)

  # read weights data
  dat_wgt <- read.table(wgt_file, header = T, sep = "\t")

  # get SVCs for each subbasin (name scheme: svc_{id_subbasin}_{id_lu}_{id_tc}_{id_svc})
  svc <- objDecl_dat$object[grep("WASA_svc", objDecl_dat$objectGroup)]

  # put SVCs into weights table replacing corresponding subbasin
  sub <- unlist(strsplit(as.character(svc), "_"))
  sub <- sub[seq(2, length(sub), 5)]
  wgt_out <- NULL
  for(s in unique(sub)) {
    r_decl <- which(sub == s)
    r_wgt <- which(dat_wgt$object == s)

    wgt_out <- rbind(wgt_out, merge(dat_wgt[r_wgt,], svc[r_decl]))
  }

  wgt_out <- wgt_out[,c("y", "variable", "location", "weight")]
  names(wgt_out)[1] <- "object"

  # read weights file of vegetation parameter time series
  wgt_veg <- read.table(file_wgt_veg, header=T)

  # combine wgt data
  wgt_out <- rbind(wgt_out, wgt_veg)

  # Create result
  write.table(x=wgt_out, file=file_ext_wgt, sep="\t", col.names=TRUE, row.names=FALSE, quote=FALSE)

  write.table(meteo_ext_datafiles, file_ext_datafiles, col.names = T, row.names = F, sep="\t", quote=F)



  # ADJUST PARAMFUN #
  # replace old path in paramFun_WASA_*.dat by new one
  par_files <- dir(paste(echse_sim_dir, "data/parameter/", sep="/"), pattern = "paramFun_", full.names = T)
  for(f in par_files) {
    # in some cases the file can be empty (e.g. no rch classes if the set-up consists of only one subbasin): go to next iteration
    dat <- try(read.table(f, header = T, check.names = F), silent = T)
    if(inherits(dat, "try-error")) next
    # replace file path to paramFun files
    path_parfun <- gsub(normalizePath(sp_input_dir), "", normalizePath(as.character(dat$file)))
    dat$file <- paste(echse_sim_dir, path_parfun, sep="/")
    write.table(dat, f, row.names = F, sep="\t", quote=F)
  }
  # adjust parameter functions; if there is only one line in a look-up table ECHSE will complain
  horpar_files <- list.files(paste(echse_sim_dir, "data/parameter/parFun_horpars", sep="/"))
  pos2area_files <- list.files(paste(echse_sim_dir, "data/parameter/parFun_pos2area", sep="/"))
  uh_files <- list.files(paste(echse_sim_dir, "data/parameter/parFun_uh", sep="/"))
  for (j in horpar_files) {
    dat <- read.table(paste(echse_sim_dir, "data/parameter/parFun_horpars", j, sep="/"), header=T, sep="\t")
    if(nrow(dat) > 1) {
      next
    } else {
      dat <- rbind(dat, rep(9999, ncol(dat)))
      write.table(dat, paste(echse_sim_dir, "data/parameter/parFun_horpars", j, sep="/"),
                  col.names = T, row.names = F, quote = F, sep="\t")
    }
  }
  for (j in pos2area_files) {
    dat <- read.table(paste(echse_sim_dir, "data/parameter/parFun_pos2area", j, sep="/"), header=T, sep="\t")
    if(nrow(dat) > 1) {
      next
    } else {
      dat <- rbind(dat, rep(9999, ncol(dat)))
      write.table(dat, paste(echse_sim_dir, "data/parameter/parFun_pos2area", j, sep="/"),
                  col.names = T, row.names = F, quote = F, sep="\t")
    }
  }
  for (j in uh_files) {
    dat <- read.table(paste(echse_sim_dir, "data/parameter/parFun_uh", j, sep="/"), header=T, sep="\t")
    if(nrow(dat) > 1) {
      next
    } else {
      dat <- rbind(dat, rep(9999, ncol(dat)))
      write.table(dat, paste(echse_sim_dir, "data/parameter/parFun_uh", j, sep="/"),
                  col.names = T, row.names = F, quote = F, sep="\t")
    }
  }



  if(prep_tpl) {
    # SHARED PARAMETERS #
    # SVC
    # prepare multi runs by introducing falgs into shared parameter file
    sharedpar_dat <- read.table(paste(echse_sim_dir, "data/parameter/sharedParamNum_WASA_svc.dat", sep="/"),
                                header=T, sep="\t")
    # flags into data
    sharedpar_dat$value[grep("choice_odesolve", sharedpar_dat$parameter)] <- "ODESOLVE"
    sharedpar_dat$value[grep("choice_inf", sharedpar_dat$parameter)] <- "INFIL"
    sharedpar_dat$value[grep("choice_et", sharedpar_dat$parameter)] <- "EVAP"
    sharedpar_dat$value[grep("choice_rcs", sharedpar_dat$parameter)] <- "RCS"
    sharedpar_dat$value[grep("choice_roughLen", sharedpar_dat$parameter)] <- "ROUGHL"
    sharedpar_dat$value[grep("choice_plantDispl", sharedpar_dat$parameter)] <- "DISPL"
    sharedpar_dat$value[grep("choice_gloradmax", sharedpar_dat$parameter)] <- "GLOMAX"
    sharedpar_dat$value[grep("choice_perc", sharedpar_dat$parameter)] <- "PERC"
    sharedpar_dat$value[grep("choice_soilmod", sharedpar_dat$parameter)] <- "SOILMOD"
    # write table
    write.table(sharedpar_dat, paste(echse_sim_dir, "data/parameter/sharedParamNum_WASA_svc_tpl.dat", sep="/"),
                col.names = T, row.names = F, sep="\t", quote=F)
    # remove old file
    invisible(file.remove(paste(echse_sim_dir, "data/parameter/sharedParamNum_WASA_svc.dat", sep="/")))

    # LU
    # prepare multi runs by introducing falgs into shared parameter file
    sharedparlu_dat <- read.table(paste(echse_sim_dir, "data/parameter/sharedParamNum_WASA_lu.dat", sep="/"),
                                  header=T, sep="\t")
    # flags into data
    sharedparlu_dat$value[grep("choice_runconc", sharedparlu_dat$parameter)] <- "RUNCONC"
    sharedparlu_dat$value[grep("choice_gw", sharedparlu_dat$parameter)] <- "GROUNDWATER"
    # write table
    write.table(sharedparlu_dat, paste(echse_sim_dir, "data/parameter/sharedParamNum_WASA_lu_tpl.dat", sep="/"),
                col.names = T, row.names = F, sep="\t", quote=F)
    # remove old file
    invisible(file.remove(paste(echse_sim_dir, "data/parameter/sharedParamNum_WASA_lu.dat", sep="/")))

    # RCH
    # prepare multi runs by introducing falgs into shared parameter file
    sharedparrch_dat <- read.table(paste(echse_sim_dir, "data/parameter/sharedParamNum_WASA_rch.dat", sep="/"),
                                   header=T, sep="\t")
    # flags into data
    sharedparrch_dat$value[grep("choice_route", sharedparrch_dat$parameter)] <- "ROUTING"
    sharedparrch_dat$value[grep("choice_transloss", sharedparrch_dat$parameter)] <- "TRANSLOSS"
    # write table
    write.table(sharedparrch_dat, paste(echse_sim_dir, "data/parameter/sharedParamNum_WASA_rch_tpl.dat", sep="/"),
                col.names = T, row.names = F, sep="\t", quote=F)
    # remove old file
    invisible(file.remove(paste(echse_sim_dir, "data/parameter/sharedParamNum_WASA_rch.dat", sep="/")))
  }

} # EOF