R/ConvertMeteoSD.R

In inrae/airGRiwrm: 'airGR' Integrated Water Resource Management

#' Conversion of meteorological data from basin scale to sub-basin scale
#'
#' @param x either a `GRiwrm` network description (See [CreateGRiwrm]), a [character] id of a node, or a [matrix] containing meteorological data
#' @param ... Parameters passed to the methods
#'
#' @return [matrix] a matrix containing the converted meteorological data
#' @export
#' @seealso [CreateGRiwrm()], [CreateInputsModel.GRiwrm()]
#' @rdname ConvertMeteoSD
#'
ConvertMeteoSD <- function(x, ...) {
  UseMethod("ConvertMeteoSD")
}

#' @param meteo [matrix] or [data.frame] containing meteorological data. Its [colnames] should be equal to the ID of the basins
#' @export
#' @rdname ConvertMeteoSD
ConvertMeteoSD.GRiwrm <- function(x, meteo, ...) {
  meteo <- as.matrix(meteo)
  np <- getAllNodesProperties(x)
  id_runoff <- np$id[np$RunOff]
  if (any(!id_runoff %in% colnames(meteo))) {
    stop("`meteo` column names should contain at least: ",
         paste(id_runoff, collapse = ", "))
  }
  output <- lapply(id_runoff, ConvertMeteoSD, griwrm = x, meteo = meteo, ...)
  meteoOut <- do.call(cbind, output)
  dimnames(meteoOut)[[2]] <- id_runoff
  return(meteoOut)
}

#' @param griwrm `GRiwrm` object describing the semi-distributed network (See [CreateGRiwrm])
#' @export
#' @rdname ConvertMeteoSD
ConvertMeteoSD.character <- function(x, griwrm, meteo, ...) {
  griwrm <- griwrm[getDiversionRows(griwrm, inverse = TRUE), ]
  upperIDs <- getUpstreamRunOffIds(x, griwrm)
  if (length(upperIDs) == 1) {
    return(meteo[,x])
  }
  areas <- griwrm$area[match(upperIDs, griwrm$id)]
  output <- ConvertMeteoSD(
    meteo[, upperIDs, drop = FALSE],
    areas = areas,
    ...
  )
  return(output)
}

#' @param areas [numeric] vector with the total area of the basin followed by the areas of the upstream basins in km2
#' @param temperature [logical] `TRUE` if the meteorological data contain air temperature. If `FALSE` minimum output values are bounded to zero
#' @export
#' @rdname ConvertMeteoSD
ConvertMeteoSD.matrix <- function(x, areas, temperature = FALSE, ...) {
  # Check arguments
  if (nrow(x) < 2) {
    stop("Meteorological data matrix should contain more than one row")
  }
  if (length(areas) != ncol(x)) {
    stop("'areas' length and meteo data matrix number of columns should be equal")
  }
  if (areas[1] <= sum(areas[-1])) {
    stop("Basin area 'areas[1]' should be greater than the sum of the upstream sub-basin areas")
  }
  if (ncol(x) == 1) {
    return(x)
  }
  # Convert mm to 1E3 m3
  V <- x * rep(areas, rep(nrow(x), length(areas)))
  # Sum upstream data
  if (ncol(x) > 2) {
    Vup <- rowSums(V[,-1])
  } else {
    Vup <- V[,2]
  }
  # Remove to basin to get downstream data
  Vdown <- V[,1] - Vup
  if (!temperature) Vdown[Vdown < 0] <- 0
  # Convert to mm
  meteoDown <- Vdown / (areas[1] - sum(areas[-1]))
  return(as.matrix(meteoDown, ncol = 1))
}

getUpstreamRunOffIds <- function(id, griwrm) {
  griwrm <- griwrm[getDiversionRows(griwrm, inverse = TRUE), ]
  upstreamNodeIds <- griwrm$id[griwrm$down == id & !is.na(griwrm$down)]
  upstreamRunOffIds <- griwrm$id[griwrm$id %in% upstreamNodeIds & !is.na(griwrm$area)]
  upstreamNaAreaIds <- upstreamNodeIds[!upstreamNodeIds %in% upstreamRunOffIds]
  if (length(upstreamNaAreaIds) > 0) {
    upstreamRunOffIds <-  c(
      upstreamRunOffIds,
      unlist(sapply(upstreamNaAreaIds, getUpstreamRunOffIds, griwrm = griwrm))
    )
    upstreamRunOffIds <- upstreamRunOffIds[!is.na(griwrm$area[griwrm$id %in% upstreamRunOffIds])]
  }

  if (is.na(griwrm$area[griwrm$id == id])) {
    return(upstreamRunOffIds)
  }

  return(c(id, upstreamRunOffIds))
}