R/IFNproducts.R

In miquelcaceres/IFNdyn: IFN forest dynamics and scenario analysis

#' Wood product amounts
#'
#' Estimation of the biomass (kg/ha) or volume (m3/ha) corresponding to wood products obtained from a set of plots, given a tree list of cuts
#'
#' @param x A data frame with tree records in rows and columns 'Species', 'DBH' (in cm), 'H' (in m) and 'N' (ha-1)
#' @param productDestination Data frame of product destination by species and diameter class
#' @param variable Either 'biomass' (default) or 'volume'
#' @param ... Additional parameters for \code{\link{IFNbiomass}} or \code{\link{IFNvolume}}
#'
#'
#' @details Calls either \code{\link{IFNbiomass}} or \code{\link{IFNvolume}} using diameter classes and then translates the result into products
#' using table \code{productDestination}. Biomass values include different products, stumps as well as fine (leaves, needles, bark), medium (branches) and coarse (stems) slash.
#' Volume values refer to coarse slash (stems) and the volume of different products.
#'
#' @name IFNproducts
#' @return Function \code{IFNproducts} returns a data frame with the biomass (kg/ha) or volume (m3/ha) of products (as well as that of slash), assuming trees have been felled down.
#'
#' @examples
#' data(exampleTreeData)
#' data(defaultProductsCAT)
#'
#' # Translation into product biomass (kg dry/ha)
#' IFNproducts(exampleTreeData, defaultProductsCAT)
#'
#' # Translation into product volume (m3/ha)
#' IFNproducts(exampleTreeData, defaultProductsCAT, variable = "volume")
IFNproducts<-function(x, productDestination, variable = "biomass",...) {

  variable = match.arg(variable, c("biomass", "volume"))

  DBHclasslimits = seq(2.5,102.5, by=5)
  DBHmid = seq(5,100, by=5)

  sp_vec = as.character(productDestination$species)
  ss = strsplit(sp_vec, split=",")

  products = names(productDestination)[-c(1:4)]

  if(variable=="biomass") destination = c("stumps","coarse_slash","medium_slash", "fine_slash", products)
  else destination = c("slash", products)

  getStemProductProps<-function(sp, DC) {
    sprows = which(unlist(lapply(ss, function(x){sp %in% x})))
    if(length(sprows)==0) return(NULL)
    DCs = productDestination$DC[sprows]
    if(length(sprows)==1) return(as.list(productDestination[sprows,-c(1:3)]))
    if(DC %in% DCs)  return(as.list(productDestination[which(DCs==DC),-c(1:3)]))
    return(as.list(productDestination[which(DCs==max(DCs)),-c(1:3)]))
  }

  translateBiomassToDestiny<-function(Bs) {

    Bs$DBHmid = DBHmid[as.numeric(Bs$DBHclass)]
    Bs$DBHmid[is.na(Bs$DBHmid)] = 100
    res = data.frame(matrix(0, nrow=nrow(Bs), ncol = length(destination)))
    names(res)<- destination
    row.names(res)<-1:nrow(res)
    #Set missing values to zero
    Bs$Roots[is.na(Bs$Roots)] = 0
    Bs$Needles[is.na(Bs$Needles)] = 0
    Bs$Leaves[is.na(Bs$Leaves)] = 0
    Bs$Bark[is.na(Bs$Bark)] = 0
    Bs$Branches[is.na(Bs$Branches)] = 0
    Bs$Stem[is.na(Bs$Stem)] = 0
    #assign
    res$stumps =Bs$Roots
    res$fine_slash = Bs$Leaves + Bs$Needles + Bs$Bark + Bs$Branches
    res$medium_slash = Bs$Bark + Bs$Branches
    for(i in 1:nrow(Bs)) {
      p = getStemProductProps(Bs$Species[i], Bs$DBHmid[i])
      if(!is.null(p)) {
        res[i,"coarse_slash"] = Bs$Stem[i]*as.numeric(p["slash"])
        res[i, products] = Bs$Stem[i]*(1-as.numeric(p["slash"]))*as.numeric(p[products])
      }
    }
    return(res)
  }

  translateVolumeToDestiny<-function(Vs) {

    Vs$DBHmid = DBHmid[as.numeric(Vs$DBHclass)]
    Vs$DBHmid[is.na(Vs$DBHmid)] = 100
    res = data.frame(matrix(0, nrow=nrow(Vs), ncol = length(destination)))
    names(res)<- destination
    row.names(res)<-1:nrow(res)
    #assign
    for(i in 1:nrow(Vs)) {
      p = getStemProductProps(Vs$Species[i], Vs$DBHmid[i])
      if(!is.null(p)) {
        res[i,"slash"] = Vs$VCC[i]*as.numeric(p["slash"])
        res[i, products] = Vs$VCC[i]*(1-as.numeric(p["slash"]))*as.numeric(p[products])
      }
    }
    return(res)
  }

  isSteps = "Step" %in% names(x)
  if(isSteps) {
    steps = unique(x$Step)
    numSteps = length(steps)
    res = NULL
    res_ha = NULL
    for(i in 1:length(steps)) {
      if(variable == "biomass") {
        Bs = IFNbiomass(x[x$Step==steps[i],], DBHclasses = DBHclasslimits, ...)
        prodi = translateBiomassToDestiny(Bs)
        y = cbind(Bs[,1:6], prodi)
        res_i = y%>% dplyr::group_by(ID, Species, Name, SpeciesAllom, NameAllom) %>%
          dplyr::summarize_at(destination, sum, na.rm=T) %>%
          tibble::add_column(Step = steps[i], .before = "Species")
      } else {
        Vs = IFNvolume(x[x$Step==steps[i],], DBHclasses = DBHclasslimits, ...)
        prodi = translateVolumeToDestiny(Vs)
        y = cbind(Vs[,1:4], prodi)
        res_i = y%>% dplyr::group_by(ID, Species, Name) %>%
          dplyr::summarize_at(destination, sum, na.rm=T) %>%
          tibble::add_column(Step = steps[i], .before = "Species")
      }
      if(is.null(res)) {
        res = res_i
      } else {
        res = dplyr::bind_rows(res, res_i)
      }
    }
  } else {
    if(variable=="biomass") {
      Bs = IFNbiomass(x, DBHclasses = DBHclasslimits, ...)
      prod = translateBiomassToDestiny(Bs)
      y = cbind(Bs[,1:6], prod)
      res = y%>% dplyr::group_by(ID, Species, Name, SpeciesAllom, NameAllom) %>%
        dplyr::summarize_at(destination, sum, na.rm=T)
    } else {
      Vs = IFNvolume(x, DBHclasses = DBHclasslimits, ...)
      prod = translateVolumeToDestiny(Vs)
      y = cbind(Vs[,1:4], prod)
      res = y%>% dplyr::group_by(ID, Species, Name) %>%
        dplyr::summarize_at(destination, sum, na.rm=T)
    }
  }
  return(as.data.frame(res))
}