R/climate_index.R

In mitmon/SRS: Suitability Rating System Version 6

# Climate index

# This library contains the climate index parameters.

# Creation date: Feb 23, 2022
# Last updated: Nov 29, 2022

#' Climate Index Main
#'
#' The climate index main calls all required function and produces the rating
#' for climate over the study site.
#' @param ratingTableArrayMC Rating table lower and upper bounds for deduction for the moisture component.
#' @param ratingTableArrayTF Rating table lower and upper bounds for deduction for temperature factors.
#' @param ratingTableArrayESM Rating table lower and upper bounds for deduction for early spring moisture.
#' @param ratingTableArrayEFM Rating table lower and upper bounds for deduction for excess fall moisture.
#' @param ppe Precipitation minus potential evapotranspiration
#' @param temperatureFactor Input effective growing degree days or crop heat
#' units for the study site.
#' @param ppeSpring Precipitation minus potential evapotranspiration for spring/April
#' @param ppeFall Precipitation minus potential evapotranspiration for fall/October
#' @param type If the crop uses effective growing degree days (EGDD) use EGDD else
#' if the crop uses crop heat units (CHU) use CHU.
#' @return Deduction points for the basic climate rating.
#' @export
climateIndexMain <- function(ratingTableArrayMC,ratingTableArrayTF,ratingTableArrayESM,ratingTableArrayEFM, ppe, temperatureFactor, ppeSpring, ppeFall, type){

  one <- mapply(basicClimateRating,ratingTableArrayMC,ratingTableArrayTF,ppe,temperatureFactor,type)
  two <- mapply(climateModifyingFactors,ratingTableArrayESM,ratingTableArrayEFM, ppeSpring, ppeFall)
  add1 <- mapply(moistureComponentRating, ratingTableArrayMC,ppe)
  add2 <- mapply(temperatureComponentRating, ratingTableArrayTF,temperatureFactor,type)
  add3 <- mapply(earlySpringMoistureComponentRating, ratingTableArrayESM, ppeSpring)
  add4 <- mapply(excessFallMoistureComponentRating, ratingTableArrayEFM, ppeFall)
  results <- mapply(climateRating, one, two, add1, add2, add3, add4)

  return(results)


}

################ Climate Indices Tools ################
#' Basic climate rating
#'
#' The basic climate rating is a designed to return the point deduction
#' for the moisture component and temperature factors. The max deduction is
#' taken for between the moisture factor and the temperature factor.
#' @param ratingTableArrayMC Rating table lower and upper bounds for deduction for the moisture component.
#' @param ratingTableArrayTF Rating table lower and upper bounds for deduction for temperature factors.
#' @param ppe Precipitation minus potential evapotranspiration
#' @param temperatureFactor Input effective growing degree days or crop heat units for
#' the study site.
#' @param type If the crop uses effective growing degree days (EGDD) use EGDD else
#' if the crop uses crop heat units (CHU) use CHU.
#' @return Deduction points for the basic climate rating.
#' @export
basicClimateRating <- function(ratingTableArrayMC,ratingTableArrayTF,ppe,temperatureFactor,type){

  moistureFactor <- moistureComponent(ratingTableArrayMC, ppe)

  # Need to determine if it's EGDD or CHU
  if(type == "EGDD"){
    temperatureFactor <- egddComponent(ratingTableArrayTF, temperatureFactor)
  } else if(type == "CHU"){
    temperatureFactor <- chuComponent(ratingTableArrayTF, temperatureFactor)
  } else {
    stop("Error determining if the crop uses effective growing degree days or
         crop heat units. Please specify EGDD or CHU")
  }

  tempCalc <- (100 - min(moistureFactor,temperatureFactor))

  return(tempCalc)

}

#' Climate modifying factors
#'
#' The climate modifying factors is a designed to return the percentage deduction
#' for early spring moisture, excess fall moisture, and early fall frost. Max
#' deduction for each modifying factor is limited to 10% max modification.
#' @param ratingTableArrayESM Rating table lower and upper bounds for deduction for ESM.
#' @param ratingTableArrayEFM Rating table lower and upper bounds for deduction for EFM.
#' @param ppeSpring Precipitation minus potential evapotranspiration for spring
#' @param ppeFall Precipitation minus potential evapotranspiration for fall
#' @return Climate modifying factors
#' @export
climateModifyingFactors <- function(ratingTableArrayESM,ratingTableArrayEFM, ppeSpring, ppeFall){

  # Early spring moisture
  esm <- esmComponent(ratingTableArrayESM, ppeSpring)
  # Excess fall moisture
  efm <- efmComponent(ratingTableArrayEFM, ppeFall)
  # Early fall frost
  # Not being used right now. Adding in future versions.
  # eff <- effComponent(inputArray, temperatureFall)

  return(sum(esm,efm))
  # Future versions use this
  # return(sum(esm,efm,eff))

}

#' Climate rating
#'
#' The climate rating calculates the rating class for the climate index.
#' @param climateFactor Basic climate rating calculated
#' @param modifiers Modifying factors.
#' @param add1 Additional data 1.
#' @param add2 Additional data 2.
#' @param add3 Additional data 3.
#' @param add4 Additional data 4.
#' @return The climate rating.
#' @export
climateRating <- function(climateFactor, modifiers, add1, add2, add3, add4){

  # Basic climate rating is lower of moisture component and temperature factor.
  # The basicClimateRating function returns the minimum of the two so no further
  # calculations are required.
  a <- climateFactor
  # Modifiers is the percentage deduction for spring moisture, fall moisture and fall frost.
  # Each individual modifier should not exceed 10% deduction. The
  # climateModifyingFactors returns the sum of the modifiers. Divide by 100 to get %.
  b <- a * (modifiers / 100)
  # Climate rating
  rating <- (a - b)

  # Climate rating
  rating[rating <= 0] <- 1
  rating[rating > 100] <- 100


  ## Dev tools ##
  # These tools add additional information to the rating. See moisture component
  # rating and temperature component rating for more details.
  if(typeof(add1) != "double") {
    rating1 <- 8
  } else {
    rating1 <- ratingTable(add1) * 1000
  }

  if(typeof(add2) != "double") {
    rating2 <- 8
  } else {
    rating2 <- ratingTable(add2) * 10000
  }

  if(typeof(add3) != "double") {
    rating3 <- 8
  } else {
    rating3 <- ratingTable(add3) * 100000
  }

  if(typeof(add4) != "double") {
    rating4 <- 8
  } else {
    rating4 <- ratingTable(add4) * 1000000
  }

  rating <- rating + rating1 + rating2 + rating3 + rating4

  return(rating)

}