DynR.R

# DynR.R ----
#
# Copyright (c) 2022 Hugo Scherer - Wageningen Economic Research
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <https://www.gnu.org/licenses/>.


## Modes ----

Retrieve mode of vector

This function returns the mode of a vector. If the vector contains a character or factor, the most common character/factor is returned. Numbers written as characters will be compatible with non-character numbers (i.e. doubles/numeric), but the function returns a character.

@param x vector from which to retrieve the mode from. @return same class as ‘x’. @examples Modes(x = c(1, 1, 3, 0, 2, 4, 2, 1, 5, 2, 1)) Modes(x = c(‘a’,‘b’, ‘c’, ‘a’, ‘c’, ‘a’)) Modes(x = c(‘a’, 2, ‘x’, 7895, 1, ‘2’, ‘t’, 2, 1)) @seealso [tabulate()] @export Modes

Modes <- function(x) { # Function found on StackOverflow made by Ken Williams and expanded by digEmAll
  ux <- unique(x)
  tab <- tabulate(match(x, ux))
  ux[tab == max(tab)] # Takes the highest incidence value
}


## gdxbinwider ----

Join BIN data together, make joined dataset wider, and group by a mapping

@description The gdxbinwider() function takes in a GDX file with BIN data as parameters p_farmData_NL and p_farmData2GUI, and a mapping as a set. Then the data is widened, and the output is a tibble.

@param filename Name of the GDX file with BIN data and mappings. @param BINDir Directory where the FADN data is located. @param gdxmap Name of the set in the GDX file that contains the mapping (e.g. Regs2BINID) @param mapping Column name of the characteristic/variable to be grouped by (e.g. “Regions” or “Regs”) @return A tibble tbl_df. @examples BINDir <- “inst/extdata/GAMS” datafile <- ‘DynRexampledata.gdx’ gdxbinwider(datafile, BINDir, ‘map2binid’, ‘mapping’) @seealso @export gdxbinwider

gdxbinwider <- function(filename, BINDir, gdxmap, mapping){

  if ('BINDir' %in% ls(envir = .GlobalEnv) & missing(BINDir)) { # Checks if BINDir is in Global Environment and uses it
    BINDir <- get('BINDir', envir = .GlobalEnv)
  } else {
    BINDir
  }


fd2guicolnames <- c("all_binid", "item1", "item2", "value")

fdnlcolnames <- c("all_binid", "year", "item1", "value")

fd2gui <- (gdxrrw::rgdx.param(paste(BINDir,filename, sep="/"), "p_farmData2GUI", names=fd2guicolnames, compress=FALSE, ts=FALSE,
                                   squeeze=TRUE, useDomInfo = TRUE, check.names = TRUE))

fdnl <- (gdxrrw::rgdx.param(paste(BINDir,filename, sep="/"), "p_farmData_NL", names=fdnlcolnames, compress=FALSE, ts=FALSE,
                                 squeeze=TRUE, useDomInfo = TRUE, check.names = TRUE))

#TODO Make gdxmapping compatible with multiple mappings, with lapply? for loop?
# first idea: gdxmapping[] <- lapply(gdxmapping, rgdx.set(...)); gdxmapping <- list(), for i in gdxmap...
# Note: for loops used to be bad in R, but now they are quick, even quicker than lapply, but for some applications
# such as defining an object several times they are much slower and memory inefficient than lapply.
# For small data maybe no problem.

gdxmapping <- (gdxrrw::rgdx.set(paste(BINDir,filename, sep="/"), gdxmap, compress=FALSE, ts=FALSE,
                                     useDomInfo = TRUE, check.names = TRUE))

# Values of "dummy" are turned into number codes when loading into R. This changes the values to the original ones.

dummies <- fd2gui[which(fd2gui$all_binid=="dummy"),]
dummies$value[which(dummies$value==1.6e+303)] <- "num"
dummies$value[which(dummies$value==1.59e+303)] <- "TRUE"
dummies$value[which(dummies$value==1.56e+303)] <- "on"

# Restrict to only those that have value num (i.e. numeric). Numerical values may change.
# Pick entries for numerical non-numerical globals with the highest incidence.

nonnumdummies <- dummies[dummies$value != "num",]

# Separation of dummy and misc from fd2gui

fd2gui <- fd2gui[which(fd2gui$all_binid!="dummy"),]

# Widening of the data for better and easier viewing and handling

fd2gui <- fd2gui %>%
  tidyr::pivot_wider(id_cols = "all_binid", names_from = c("item1", "item2"), values_from = "value", names_sep = "%")


fdnl <- fdnl %>%
  tidyr::pivot_wider(id_cols = c("all_binid", "year"), names_from = c("item1"), values_from = "value", names_sep = "%")

# Since subsetting with !duplicated() is done following the data order, reorder the data to start from youngest to oldest
# Result: all_binids are preserved for youngest years (2020, 2019...) and removed from oldest years (2013, 2014...)

fdnl <- fdnl[order(-as.numeric(fdnl$year)),]

fdnl <- fdnl[!duplicated(fdnl$all_binid),] # Note: Some of the Weights appear in 2019 (n-1), but not 2020 (n = earliest data year), leading to NAs later on. Make sure at least the latest year has weights.

# Keep list of variables that are NOT numeric, BUT binary or other variables with other meanings.

tokeep <- c(paste("global", nonnumdummies$item2, sep = "%"), "global%soilTypeFirm", "global%derogatie")

# Finding index of global to keep only NON-numerical values based on "tokeep"

keepmatch <- match(tokeep, colnames(fd2gui))

# Making these factors
fd2gui[keepmatch] <- lapply(fd2gui[keepmatch], as.factor)

# Joining all data together

fdnl2gui <- dplyr::right_join(fd2gui, fdnl[,c('all_binid', 'Weight')], by='all_binid')

fdnl2gui[] <- lapply(fdnl2gui, function(x) if(is.factor(x)) as.factor(x) else x)

map2gui <- dplyr::right_join(fdnl2gui, gdxmapping, by='all_binid')

map2gui <- map2gui %>% dplyr::group_by(dplyr::across(dplyr::all_of({{ mapping }})))

return(map2gui)
}


## gdxreshape ----

Reshape from wide to long and save to GDX

@description gdxreshape() formats the data to be saved in GDX into long format. It is imported from the gdxrrw package with a few improvements for performance and usability, since there is a risk of it being removed from the gdxrrw package in the future. We would like to thank the R GAMS team for this useful function.

@param inDF wide dataframe. @param symDim wide dataframe. @param symName wide dataframe. @param tName wide dataframe. @param gdxName wide dataframe. @param setsToo wide dataframe. @param order wide dataframe. @param setNames wide dataframe.

@return A tibble tbl_df. @examples BINDir <- “inst/extdata/GAMS” datafile <- ‘DynRexampledata.gdx’ gdxbinwider(datafile, BINDir, ‘map2binid’, ‘mapping’) @seealso @export gdxreshape

gdxreshape <- function (inDF, symDim, symName=NULL, tName="time",
                        gdxName=NULL, setsToo=TRUE, order=NULL,
                        setNames=NULL) {
  # Function based on gdxrrw::wgdx.reshape of the gdxrrw package, modified for performance and usability by Hugo Scherer.
  # 23-09-2022 hugo.scherer@wur.nl

  nCols <- ncol(inDF)
  timeIdx <- symDim                     # default index position for time aggregate
  if (is.null(order)) {
    idCols <- 1:(symDim-1)

    inDF[idCols] <- lapply(inDF[idCols], as.factor)

    outDF <- (tidyr::pivot_longer(inDF, cols=-dplyr::all_of(idCols)))
  }
  else if ((! is.vector(order)) || (symDim != length(order))) {
    stop ("specified order must be a vector of length symDim")
  }
  else {
    timeIdx <- -1
    if (is.character(order)) {
      stop ("order must be numeric for now")
    }
    else if (! is.numeric(order)) {
      stop ("optional order vector must be numeric or character")
    }

    idCols <- 1:(symDim-1)                                   # for k in 1:symDim
    if (any(duplicated(order))) {
      stop ('duplicate entry in order vector: nonsense')
    }

    if ((symDim-1) != sum(order>0)) {
      stop ('order vector must specify symDim-1 ID columns')
    }
    if (all(order>0)) {
      stop ('order vector must have a non-positive entry to specify the "time" index')
    }

    timeIdx <- match(0, order)

    oo <- c(idCols,(1:nCols)[-idCols])
    df2 <- inDF[oo]
    idCols <- 1:(symDim-1)

    df2[idCols] <- lapply(df2[idCols], factor)

    if (symDim == timeIdx) {     # no need to re-order after reshaping
      outDF <- tidyr::pivot_longer(df2, cols=-dplyr::all_of(idCols))
    }
    else {
      df3 <- tidyr::pivot_longer(df2, cols=-dplyr::all_of(idCols))
      oo <- vector(mode="integer",length=symDim+1)

      oo[1:(timeIdx-1)] = 1:(timeIdx-1)

      oo[timeIdx] = symDim

      oo[(timeIdx+1):symDim] = (timeIdx+1):symDim-1

      oo[symDim+1] = symDim+1
      outDF <- (df3[oo])
    }
  }
  outDF$name <- as.factor(outDF$name)
  if (is.null(symName)) {
    symName <- attr(inDF, "symName", exact=TRUE)
  }
  if (! is.character(symName)) {
    stop ("symName must be a string")
  }
  attr(outDF,"symName") <- symName
  symText <- attr(inDF, "ts", exact=TRUE)
  if (is.character(symText)) {
    attr(outDF,"ts") <- symText
  }
  if (is.character(tName)) {
    names(outDF)[timeIdx] <- tName
  }
  else {
    names(outDF)[timeIdx] <- 'time'
  }
  names(outDF)[symDim+1] <- "value"
  # str(outDF)
  if (setsToo) {
    ## write index sets first, then symName
    outLst <- list()

    length(outLst) <- symDim + 1
    setNamesLen <- 0
    if (! is.null(setNames)) {
      if (! is.character(setNames)) {
        stop ("setNames must be a string or string vector")
      }
      else if (! is.vector(setNames)) {
        stop ("setNames must be a string or string vector")
      }
      else {
        ## guard against zero-length vector
        setNamesLen <- length(setNames)
      }
    }
    kk <- 0

    for (i in 1:symDim) {
      lvls <- levels(as.factor(outDF[[i]]))
      outLst[[i]] <- list(name=names(outDF)[[i]], type='set', uels=c(list(lvls)))
      if (setNamesLen > 0) {            # tack on the next set text
        kk <- kk + 1
        outLst[[i]]$ts <- setNames[[kk]]
        if (kk >= setNamesLen)
          kk <- 0
      }
    }
    outLst[[symDim+1]] <- (outDF)

    if (is.character(gdxName)) {
      gdxrrw::wgdx.lst(gdxName,outLst)
    }
    else {
      return(outLst)
    }
  }
  else {
    if (is.character(gdxName)) {
      gdxrrw::wgdx.lst(gdxName,outDF)
    }
    else {
      return(list(outDF))
    }
  }
} # gdxreshape


## groupstats ----

Reshape from wide to long and save to GDX

@description groupstats() returns descriptive statistics per group based on the mapping given. For example, if your mapping is ‘regions’, this function will give you the weighted mean, median, min, max, number of observations per variable for each region based on the individual farm data. When writegdx is TRUE, it writes the GDX in the format ‘farmStats_(mapping).gdx’

@inheritParams gdxbinwider @param cols Which columns to derive descriptive statistics from @param w Column with the Weights for the weighted mean @param writegdx Logical. If TRUE, it writes a GDX with the descriptive statistics. @param filtern Logical. If TRUE, results will be limited to more than 15 observations per variable for reporting

@return A tibble tbl_df. @examples BINDir <- “inst/extdata/GAMS” datafile <- ‘DynRexampledata.gdx’ groupstats(‘DynRexampledata.gdx’, BINDir=“inst/extdata/GAMS/”, gdxmap = ‘map2binid’, mapping = ‘mapping’, cols = c(‘a’, ‘b’), w=‘Weight’) @seealso @export groupstats

#FIXME fix the example data!! Not working
groupstats <- function(filename, BINDir, gdxmap, mapping, cols, w, writegdx = TRUE, filtern = FALSE) {

  if ("BINDir" %in% ls(envir = .GlobalEnv) & missing(BINDir)) {
    BINDir <- get("BINDir", envir = .GlobalEnv)
  } else {
    BINDir
  }


  data <- gdxbinwider(filename, BINDir, gdxmap, mapping)
  names(data) <- gsub(x=names(data), pattern = "\\w*%", '')
  groupmap <- data %>%
    dplyr::select(dplyr::all_of(mapping), dplyr::all_of(cols), dplyr::all_of(w))  %>%
    dplyr::summarise(weightedmean = dplyr::across(dplyr::all_of(cols),~ weighted.mean(as.numeric(as.character(.x)), w=.data[[w]],na.rm=TRUE)), # Make a new column named weightedmean where the values are the weighted means of only the numeric columns (otherwise error)
                     min = dplyr::across(dplyr::all_of(cols),~ min(as.numeric(as.character(.x))), na.rm =TRUE), # Same as weightedmean but with min
                     max = dplyr::across(dplyr::all_of(cols),~ max(as.numeric(as.character(.x))), na.rm =TRUE), # Idem
                     median = dplyr::across(dplyr::all_of(cols),~ median(as.numeric(as.character(.x))), na.rm =TRUE), # Idem
                     mode = dplyr::across(dplyr::all_of(cols),~ Modes(as.numeric(as.character(.x)))),
                     n = dplyr::across(dplyr::all_of(cols),~ sum(!is.na(.x))), # Make a column with n of each variable in the group
                     .groups = 'keep' # .keep is to keep the grouped groups as in the original mapping (otherwise it will group with only one group, but the results are the same)
  )


  groupmap <- groupmap %>% tidyr::unpack(cols = c(weightedmean, min, max, median, mode, n), names_sep = "%") %>% # Data cleaning activities and making a simple table
    tidyr::pivot_longer(cols = -dplyr::all_of(mapping), names_to = c('item1', 'variable'), names_sep = "%") %>%
    tidyr::pivot_wider(id_cols = c(dplyr::all_of(mapping), variable), names_from = item1, values_from = value)

  groupmap[] <- lapply(groupmap, function(x) if(is.numeric(x)) round(x, digits = 2) else x) # Rounding the results, comment if not needed
  groupmap[] <- lapply(groupmap, function(x) if(is.factor(x)) as.factor(x) else x) # For some reason, factors include ALL factors  (BIN_IDs, soil type, random things),
  # this results in gdx file with 1000s of unwanted data that serves no use, factor(x) eliminates that.

  if (filtern == TRUE) {
    groupmap <- dplyr::filter(groupmap, n >= 15) # Keep variables that have more than 15 observations (as seen in column 'n', created earlier)
  } # Should GROUPS be filtered or VARIABLES?
  if (writegdx == TRUE) {
    allmaps <- paste0(mapping[1:length(mapping)], '.gdx')
    gdxfilename <- paste('farmStats', allmaps, sep = '_')

    gdxreshape(gdxName = gdxfilename, as.data.frame(groupmap), sum(length(mapping), 2), symName = 'p_farmStats',
                 tName = 'colsFarmStats', order = c(1:sum(length(mapping),1),0)
    )
    return(groupmap)
  } else
    return(groupmap)
}


## samplr ----

Reshape from wide to long and save to GDX

@description samplr() creates sample farms by aggregating data based on the weighted mean and the selected mapping for use in FarmDyn. For non-numerical globals, it summarises based on the mode using the Modes() function. When writegdx is TRUE, it writes the GDX in the format ‘farmData_(mapping).gdx’.

@inheritParams groupstats

@return A tibble tbl_df. @examples BINDir <- “inst/extdata/GAMS” datafile <- ‘DynRexampledata.gdx’ samplr(‘DynRexampledata.gdx’,\ &BINDir=“inst/extdata/GAMS/”,\ &gdxmap = ‘map2binid’,\ &mapping = ‘mapping’,\ &w=‘Weight’) @seealso @export samplr

samplr <- function(filename, BINDir,  gdxmap, mapping, writegdx = TRUE) {


  if ("BINDir" %in% ls(envir = .GlobalEnv) & missing(BINDir)) {
    BINDir <- get("BINDir", envir = .GlobalEnv)
  } else {
    x
  }

  map2gui <- gdxbinwider(filename, BINDir, gdxmap, mapping)

  map2gui <- map2gui %>% dplyr::select(-all_binid) %>%
    summarise(dplyr::across(everything(),~ if(is.numeric(.)) weighted.mean(., w=.data[['Weight']], na.rm = TRUE) else Modes(.)))
  # In RStudio, ignore the (X) error unmatched bracket, everything is fine and all works.

  map2gui$Weight <- NULL

  map2gui[!colnames(map2gui) %in% mapping] <- lapply(map2gui[!colnames(map2gui) %in% mapping], function(x) if(is.factor(x)) (as.numeric(as.character(x))) else x)

  map2gui <- map2gui %>% tidyr::pivot_longer(cols = where(is.numeric), names_to = c('item1', 'item2'), names_sep = "%") %>%
    tidyr::pivot_wider(id_cols = c(dplyr::all_of(mapping), 'item1'), names_from = 'item2', values_from = 'value')
  map2gui[] <- lapply(map2gui, function(x) if(is.numeric(x)) round(x, digits = 2) else x) # Rounding the results, comment if not needed
  map2gui[is.na(map2gui)] <- 0 # By bringing these values from long to wide, there are undefined values and, therefore, NAs. BUT these are not real NAs, plus it's for modelling purposes on GAMS, which will ignore the 0s, so we can safely assign a 0 to the NAs.


  if (writegdx == TRUE) {
    allmaps <- paste0(mapping[1:length(mapping)], '.gdx')
    gdxfilename <- paste('farmData', allmaps, sep = '_')

    gdxreshape(map2gui, symDim = 3, order = c(1,2,0), gdxName = gdxfilename, symName = 'p_farmData')

    return(map2gui)
  } else
      return(map2gui)
}


## runFarmDynfromBatch ----

Execute FarmDyn

@description runFarmDynfromBatch() does as it says in the function.

@param FarmDynDir Directory where FarmDyn is located @param IniFile Name of the IniFile @param XMLFile Name of the XML file @param BATCHDir Directory where the .batch file is located @param BATCHFile Name of the .batch file

@return Executes FarmDyn from R @examples TODO write example

@seealso *Globiom?

@export runFarmDynfromBatch

runFarmDynfromBatch <- function(FarmDynDir, IniFile, XMLFile, BATCHDir, BATCHFile) {

  # make sub directories
  GUIDir <- paste(FarmDynDir,"GUI",sep="/")
  BATCHFilePath <- paste(BATCHDir, BATCHFile, sep = "\\")

  # General JAVA command
  javacmdstrg <- r"(java -Xmx1G -Xverify:none -XX:+UseParallelGC -XX:PermSize=20M -XX:MaxNewSize=32M -XX:NewSize=32M -Djava.library.path=jars -classpath jars\gig.jar de.capri.ggig.BatchExecution)"

  # append specific files to JAVA command
  javacmdparac <- paste(javacmdstrg,IniFile,XMLFile,BATCHFilePath,sep = " ")

  # create bat file
  runbat   = paste0(GUIDir,"/runfarmdyn.bat")
  if (file.exists(runbat)) x=file.remove(runbat)

  b = substr(runbat,1,2)
  b = c(b,paste('cd',gsub("/", "\\\\",GUIDir)))
  b = c(b,c("SET PATH=%PATH%;./jars"))
  b = c(b,javacmdparac)
  writeLines(b,runbat)
  rm(b)

  # execute farmdyn in batch mode
  system(runbat)


}