R/utils.R

In KVHEM/CatCa: The package serves as proxy for CZ waterbodies calibration with BILAN model

#' Zjisti plochu povodi v km2
#'
#' @md
#' @param id UPOV_ID
#' @param upov_only jen pro UPOV nebo pro cele povodi od pramene?
#'
#' @return Plocha v km2
#' @export A
#'
#' @examples
A = Vectorize(function(id, upov_only = FALSE){
  a = TABA[FROM == id, if(upov_only)(PLOCHA_UPOV)else(PLOCHA_CELKEM)]
  a
})


#' Prevody mezi vyskami a objemy
#'
#' @param q odtok v m3/s
#' @param mm odtok v mm
#' @param u uzivani v tis. m3
#' @param id UPOV_ID
#' @param ... parametry pro A (tj. momentalne upov_only)
#'
#' @return
#' @export q2mm_day
#'
#' @examples
q2mm_day = Vectorize(function(q, id, ...){

  area = A(id, ...) * 1000000

 unname((1000 * q * 3600 * 24) / (area))

})

#' @describeIn q2mm_day
#' @export mm_day2q
mm_day2q = Vectorize(function(mm, id, ...){

  area = A(id, ...) * 1000000
  unname((mm * area) / (1000 * 3600 * 24))

})

#' @describeIn q2mm_day
#' @export u2mm_day
u2mm_day = function(u, id, dtm = NA, ...){

  area = A(id, ...) * 1000000

  uu = u / area
  if (any(is.na(dtm))) return(uu/30.4375)

  uu/days_in_month(dtm)

}

#' @describeIn q2mm_day
#' @export u2mm_month
u2mm_month = function(u, id, ...){

  area = A(id, ...) * 1000000

  uu = u / area

  uu

}

#' Ziskej charakteristiky pro UPOV
#'
#' @param id UPOV_ID
#'
#' @return charakteristiky: prumerny odtok, srazky, m-denni vody apod.
#' @export char
#'
#' @examples
char = function(id){
  CHARS[UPOV_ID %in% id]
}

#' Extrahuj z tabulky CHARS
#'
#' @param ... nazev pozadovane veliciny, nemusi byt v uvozovkach
#'
#' @return funkci s parametrem id = UPOV_ID
#' @export ch
#'
#' @examples
#' ch(Qa)
#'
#' \dontrun{
#' ch(Qa)(id = c('BER_0100', 'BER_0010'))
#' }
ch = function(...){
  n = c(as.character(substitute(list(...))[-1L]))
  function(id){
    e = parse(text = n)
    CHARS[UPOV_ID %in% id, eval(e)]
  }
}

#' Extrahuj m-denni vody z tabulky chars
#'
#' @param m pocet dni
#'
#' @return funkce s parametry id = UPOV_ID a mm_day: TRUE = Qmd je v mm_den jinak m3/s
#' @export qmd
#'
#' @examples
qmd = function(m){
  Vectorize(function(id, mm_day = TRUE){
    ch = char(id)
    e = parse(text = paste0('Q', m, 'd'))
    if (mm_day) ch[,  eval(e)/ 365.25] else ch[, mm_day2q(eval(e), id) / 365.25]
  })
}



#' Vypocti minimalni zustatkovy prutok
#'
#' @param id UPOV_ID
#' @param mm_day (logical) ma byt vysledek v mm_den nebo m3/s
#'
#' @return
#' @export MZP
#'
#' @examples
MZP = Vectorize(function(id, mm_day = TRUE){

  ch = char(id)
  if (nrow(ch)==0) return(NA_real_)
  Q355d = qmd(355)(id, mm_day = FALSE) #ch[, mm_day2q(Q355d, id) / 365.25]
  if (is.na(Q355d)) return(NA_real_)

  if (Q355d <= 0.05) return(qmd(330)(id, mm_day = mm_day))
  if (Q355d <= 0.50) return(0.5 * (qmd(330)(id, mm_day = mm_day) + qmd(355)(id, mm_day = mm_day)))
  if (Q355d <= 5.00) return(qmd(355)(id, mm_day = mm_day))
  return(0.5 * (qmd(355)(id, mm_day = mm_day) + qmd(364)(id, mm_day = mm_day)))
})


#' Vypocti m-denni vody
#'
#' @param RM modelovany/pozorovany prutok
#' @param M vektor m dnu
#' @param return jak vratit vysledek - jedno z \code{c('vector', 'matrix', 'data.table')}
#'
#' @return hodnoty m-dennich vod (vektor/matice/data.table)
#' @export mdq
#'
#' @examples
mdq <- function(RM, M = c(30, 60, 90, 120, 150, 180, 210, 240, 270, 300, 330, 355, 364), return = 'vector') {
  q = quantile(RM, 1-M/365.25)
  n = paste0('Q', M, 'd')
  switch(return,
    'vector' =  {
      names(q) = n
      return(q)},
    'matrix' =
      return(matrix(c(M = M, qm = q), ncol = 2, dimnames = list(n, c('M', 'QM')) )),
    'data.table' =
      return(data.table(LAB = n, M = M, qm = q))
  )

  names(q) = paste0('Q', M, 'd')
  q
}

#' Vytvori cluster pro foreach
#'
#' Vytvori cluster pro foreach podle platformy, vrati stopovaci funkci.
#'
#' @return Funkce zastavujici cluster.
#' @export create_cluster
#'
#' @examples
#'
#' stop_cluster <- create_cluster()
#' getDoParWorkers()
#' stop_cluster()
#'
create_cluster <- function() {
  if (.where == 'unix') {
    registerDoParallel(cores = .Options$cores_num)
    return(function() message("Cluster zastaven."))
  } else {
    cl <- makeCluster(.Options$cores_num)
    registerDoParallel(cl)
    message("Vytvoren cluster.")
    return(function() {
      stopCluster(cl)
      message("Cluster zastaven.")
    })

  }
}