R/write_crop_parms.R

In femiguez/agroibis: Interaction with Agro-IBIS terrestrial ecosystem model

#'
#' Write an Agro-IBIS crop parameter file
#' 
#' @title Write an Agro-IBIS crop parameter file
#' @name write_crop_parms
#' @param crop.parms.lst list object with the structure are generated by 'read_crop_parms'
#' @param file default 'params_text.crp'
#' @param wrt.dir write directory
#' @return does not return anything but writes a file to disk
#' @export
#' @examples 
#' \donttest{
#' extd.dir <- system.file("extdata", package = "agroibis")
#' cpp <- read_crop_parms(file = "params_text.crp", src.dir = extd.dir)
#' ## Edit it using edit_parms
#' cpp2 <- edit_parms(cpp, table.name = "wheat_growth_control",
#'                    col = 2, row = 1, value = 0.812)
#' write_crop_parms(cpp2, file = "params_text.crp")
#' }
#' 
write_crop_parms <- function(crop.parms.lst, 
                             file = "params_text.crp",
                             wrt.dir = "."){
  
  ## Preliminaries
  cgpp.start <- "###<crop_growth_physiology_properties_start>###"
  cgpp.end <- "###<crop_growth_physiology_properties_end>###"
  laca.start <- "###<crop_growth_leafarea_c_allocation_start>###"
  laca.end <- "###<crop_growth_leafarea_c_allocation_end>###"
  clmp.start <- "###<climatic_managed_planting_control_start>###"
  clmp.end <- "###<climatic_managed_planting_control_end>###"
  gdd.start <- "###<gdd_phenology_control_start>###"
  gdd.end <- "###<gdd_phenology_control_end>###"
  wheat.start <- "###<wheat_growth_start>###"
  wheat.end <- "###<wheat_growth_end>###"
  misc.start <- "###<misc_crop_control_start>###"
  misc.end <- "###<misc_crop_control_end>###"
  sugar.start <- "###<sugarcane_control_start>###"
  sugar.end <- "###<sugarcane_control_end>###"
  residue.start <- "###<crop_residue_control_start>###"
  residue.end <- "###<crop_residue_control_end>###"
  
  ## Open connection
  zz <- file(description = file, open = "w")
  ## First write to disk all lines until cgpp.i.1 - 1
  header <- crop.parms.lst[["parms"]][1:c(crop.parms.lst$indexes[1]-1)]
  writeLines(header, con = zz)
  
  ## Write start of crop growth physiology properties
  writeLines(cgpp.start, con = zz)
  cgpp.unpacked <- unpack_matrix(crop.parms.lst[["crop_growth_physiology_properties"]])
  writeLines(cgpp.unpacked, con = zz)
  writeLines(cgpp.end, con = zz)
  
  ## Write comments between cgpp and laca
  cgpp.laca <- crop.parms.lst[["parms"]][c(crop.parms.lst$indexes[2]+1):c(crop.parms.lst$indexes[3]-1)]
  writeLines(cgpp.laca, con = zz)
  
  ## Write start of leaf area and carbon allocation
  writeLines(laca.start, con = zz)
  laca.unpacked <- unpack_matrix(crop.parms.lst[["crop_growth_leafarea_c_allocation"]])
  writeLines(laca.unpacked, con = zz)
  writeLines(laca.end, con = zz)
  
  ## Write comments between laca and clmp
  laca.clmp <- crop.parms.lst[["parms"]][c(crop.parms.lst$indexes[4]+1):c(crop.parms.lst$indexes[5]-1)]
  writeLines(laca.clmp, con = zz)
  
  ## Write start of climatic
  writeLines(clmp.start, con = zz)
  clmp.unpacked <- unpack_matrix(crop.parms.lst[["climatic_manage_planting_control"]])
  writeLines(clmp.unpacked, con = zz)
  writeLines(clmp.end, con = zz)
  
  ## Write comments between clmp and gdd
  clmp.gdd <- crop.parms.lst[["parms"]][c(crop.parms.lst$indexes[6]+1):c(crop.parms.lst$indexes[7]-1)]
  writeLines(clmp.gdd, con = zz)
  
  ## Write start of gdd
  writeLines(gdd.start, con = zz)
  gdd.unpacked <- unpack_matrix(crop.parms.lst[["gdd_phenology_control"]])
  writeLines(gdd.unpacked, con = zz)
  writeLines(gdd.end, con = zz)
  
  ## Write comments between gdd and wheat
  gdd.wheat <- crop.parms.lst[["parms"]][c(crop.parms.lst$indexes[8]+1):c(crop.parms.lst$indexes[9]-1)]
  writeLines(gdd.wheat, con = zz)
  
  ## Write start of wheat
  writeLines(wheat.start, con = zz)
  wheat.unpacked <- unpack_matrix(crop.parms.lst[["wheat_growth_control"]])
  writeLines(wheat.unpacked, con = zz)
  writeLines(wheat.end, con = zz)
  
  ## Write comments between wheat and misc
  wheat.misc <- crop.parms.lst[["parms"]][c(crop.parms.lst$indexes[10]+1):c(crop.parms.lst$indexes[11]-1)]
  writeLines(wheat.misc, con = zz)
  
  ## Write start of misc
  writeLines(misc.start, con = zz)
  misc.unpacked <- unpack_matrix(crop.parms.lst[["misc_crop_control"]])
  writeLines(misc.unpacked, con = zz)
  writeLines(misc.end, con = zz)
  
  ## Write comments between misc and sugar
  misc.sugar <- crop.parms.lst[["parms"]][c(crop.parms.lst$indexes[12]+1):c(crop.parms.lst$indexes[13]-1)]
  writeLines(misc.sugar, con = zz)
  
  ## Write start of misc
  writeLines(sugar.start, con = zz)
  sugar.unpacked <- unpack_matrix(crop.parms.lst[["sugarcane_control"]])
  writeLines(sugar.unpacked, con = zz)
  writeLines(sugar.end, con = zz)
  
  ## Write comments between sugar and residue
  sugar.residue <- crop.parms.lst[["parms"]][c(crop.parms.lst$indexes[14]+1):c(crop.parms.lst$indexes[15]-1)]
  writeLines(sugar.residue, con = zz)
  
  ## Write start of residue
  writeLines(residue.start, con = zz)
  residue.unpacked <- unpack_matrix(crop.parms.lst[["crop_residue_control"]])
  writeLines(residue.unpacked, con = zz)
  writeLines(residue.end, con = zz) ## Last line of the file
  
  close(zz)
}

## Turn a matrix with parameters 
## to a vector of characters for writing out
unpack_matrix <- function(x){
  
  ans <- NULL
  
  m.col <- ncol(x)
  m.row <- nrow(x)
  
  for(i in 1:m.col){
    for(j in 1:m.row){
      if(j == 1){
        ans <- c(ans, paste0("#",colnames(x)[i]))
        ans <- c(ans, paste(as.character(x[j,i]), "!", rownames(x)[j]))
      }else{
        ans <- c(ans, paste(as.character(x[j,i]), "!", rownames(x)[j]))
      }
    }
    ans <- c(ans, "")
  }
  return(ans)
}