FarmDynR.R

# FarmDynR.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 <- 'FarmDynRexampledata.gdx'
#' gdxbinwider(datafile, BINDir, 'map2binid', 'mapping')
#' @seealso
#' \itemize{
#' \item{\code{\link[gdxrrw]{rgdx.param}}}{Load GDX parameters}
#' \item{\code{\link[gdxrrw]{rgdx.set}}}{Load GDX sets}
#' \item{\code{\link[tidyr]{pivot_wider}}}{Make dataframes wider}
#'  }
#' @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(file.path(BINDir, filename), "p_farmData2GUI", names=fd2guicolnames, compress=FALSE, ts=FALSE,
                                   squeeze=TRUE, useDomInfo = TRUE, check.names = TRUE))

fdnl <- (gdxrrw::rgdx.param(file.path(BINDir, filename), "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...

gdxmapping <- (gdxrrw::rgdx.set(file.path(BINDir,filename), gdxmap, compress=FALSE, ts=FALSE,
                                     useDomInfo = TRUE, check.names = TRUE))

# Pick entries for non-numerical globals (1.6e+303 is code for numerical globals).

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

nonnumdummies <- dummies[dummies$value != 1.6e+303,]

# Separation of dummy 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::left_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 <- 'FarmDynRexampledata.gdx'
#' gdxbinwider(datafile, BINDir, 'map2binid', 'mapping')
#' @seealso
#' \itemize{
#' \item{\code{\link[gdxrrw]{wgdx]}}}{Write R data to GDX}
#' \item{\code{\link[gdxrrw]{wgdx.lst]}}}{Write multiple symbols to GDX}
#' \item{\code{\link[gdxrrw]{wgdx.reshape]}}}{Write multiple symbols to GDX}
#' \item{\code{\link[tidyr]{pivot_longer]}}}{Make dataframes longer}
#' }
#' @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.

  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 ----
#' Generate descriptive statistics 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 <- 'FarmDynRexampledata.gdx'
#' groupstats('FarmDynRexampledata.gdx',
#'             BINDir="inst/extdata/GAMS/",
#'             gdxmap = 'map2binid',
#'             mapping = 'mapping',
#'             cols = c('a', 'b'),
#'             w='Weight')
#' @seealso
#' \itemize{
#' \item{\code{\link{summary]}}}{summary statistics}
#' \item{\code{\link[psych]{describe}}}{Descriptive statistics}
#' \item{\code{\link[gdxrrw]{wgdx}}}{Write R data to GDX}
#' \item{\code{\link[gdxrrw]{wgdx.lst}}}{Write multiple symbols to GDX}
#' \item{\code{\link[tidyr]{pivot_longer}}}{Make dataframes longer}
#' }
#' @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)
}


<<<<<<< HEAD
## updateFarmData ----
#' Reshape from wide to long and save to GDX
=======
## samplr ----
#' Create sample farms
>>>>>>> 1ebeb0906d519cd31fea60640b1541768ae43ad8
#'
#' @description
#' `updateFarmData()` 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
#' @param cptcoeffs Logical. When this is set to `TRUE` it calculates farm-specific parameters based on CPT coefficients
#' @param farmchars GDX file containing farm characteristics
#' @param cptcoeffsxl Location of the CPT coefficients excel file
#'
#' @return A tibble `tbl_df`.
#' @examples
#' BINDir <- "inst/extdata/GAMS"
#' datafile <- 'FarmDynRexampledata.gdx'
#' updateFarmData('FarmDynRexampledata.gdx',
#'         &BINDir="inst/extdata/GAMS/",
#'         &gdxmap = 'map2binid',
#'         &mapping = 'mapping',
#'         &w='Weight')
#' @seealso
#' \itemize{
#' \item{\code{\link[FarmDynR]{gdxbinwider}}}{Widens BIN data directly from GDX}
#' \item{\code{\link[FarmDynR]{gdxreshape}}}{Lengthens data and saves to GDX}
#' \item{\code{\link[gdxrrw]{wgdx}}}{Write R data to GDX}
#' \item{\code{\link[gdxrrw]{wgdx.lst}}}{Write multiple symbols to GDX}
#' \item{\code{\link[dplyr]{summarise}}}{Make dataframes longer}
#' \item{\code{\link{weighted.mean]}}}{Calculates weighted mean}
#' }
#' @export updateFarmData
updateFarmData <- function(filename, BINDir,  gdxmap, mapping, writegdx = TRUE, cptcoeffs = FALSE, farmchars = NULL, cptcoeffsxl = NULL) {


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

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

  if (cptcoeffs == TRUE) {
    # TODO: Could be done more programatically
    farmchars <- gdxload(farmchars, 'p_farmCharBIN', symbol = 'param', symName= "p_farmCharBIN", names=c('all_binid', 'year', 'char', 'value'), compress=FALSE, ts=FALSE,
                         squeeze=TRUE, useDomInfo = TRUE, check.names = TRUE)

    cptcoeffs <- read_xlsx(cptcoeffsxl,sheet = 'dat')

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

    narabland <- map2gui %>% ungroup() %>%  select(c('all_binid', `global%nArabLand`))

    colnames(narabland)[2] <- 'ArabLand'

    farmchars <- farmchars %>% pivot_wider(id_cols = c(all_binid, year), values_from = value, names_from = char) %>%
      mutate('PropSalesArable' = 1)

    farmchars <- farmchars[!duplicated(farmchars$all_binid),]

    farmchars[is.na(farmchars)] <- 0 #NAs are produced when going from long to wide.

    farmchars <- inner_join(farmchars, narabland, by='all_binid') %>% mutate('logArabLandabs' = log(abs(ArabLand)))

    farmchars[] <- lapply(farmchars,function(x) if(is.factor(x)) factor(x) else x) %>% na.omit()

    colnames(cptcoeffs)[1]<- 'char'

    alphaprod <- farmchars[colnames(farmchars) %in% cptcoeffs$char]*cptcoeffs$b_alpha[match(names(farmchars), cptcoeffs$char)][col(farmchars)] %>% na.omit()

    betaprod <- farmchars[colnames(farmchars) %in% cptcoeffs$char]*cptcoeffs$b_beta[match(names(farmchars), cptcoeffs$char)][col(farmchars)] %>% na.omit()

    gammaprod <- farmchars[colnames(farmchars) %in% cptcoeffs$char]*cptcoeffs$b_gamma[match(names(farmchars), cptcoeffs$char)][col(farmchars)] %>% na.omit()

    deltaprod <- farmchars[colnames(farmchars) %in% cptcoeffs$char]*cptcoeffs$b_delta[match(names(farmchars), cptcoeffs$char)][col(farmchars)] %>% na.omit()

    alpha <- rowSums(alphaprod)+cptcoeffs$b_alpha[7]

    beta <- rowSums(betaprod)+cptcoeffs$b_beta[7]

    delta <- rowSums(deltaprod)+cptcoeffs$b_delta[7]

    gamma <- rowSums(gammaprod)+cptcoeffs$b_gamma[7]

    coeffs <- list(data.frame('TKAlpha' = alpha, 'all_binid' = factor(farmchars$all_binid)),data.frame('TKBeta' = beta,'all_binid' = factor(farmchars$all_binid)),
                   data.frame('TKdelta' = delta, 'all_binid' = factor(farmchars$all_binid)), data.frame('TKgamma' = gamma, 'all_binid' = factor(farmchars$all_binid)))

    map2gui <- Reduce(function(x, y) merge(x, y, by="all_binid"), list(map2gui,coeffs))
    map2gui[] <- lapply(map2gui,function(x) if(is.factor(x)) factor(x) else x)

    map2gui <- map2gui %>%
      rename('global%TKAlpha' = 'TKAlpha',
             'global%TKBeta' = 'TKBeta',
             'global%TKdelta' = 'TKdelta',
             'global%TKgamma' = 'TKgamma'
      )
    map2gui$all_binid.1 <- NULL
    map2gui$all_binid.2 <- NULL
    map2gui$all_binid.3 <- NULL
  }

  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)
}

## str_firstlast ----
#' @name str_line_replace
#' @rdname str_line_replace
#'
#' @title Replace first or last line in strings
#'
#' @description
#' These functions serve to change the first or last line of strings which match a specific pattern (regex).
#' `str_firstLine_replace()` replaces the first line that matches the pattern.
#' `str_lastLine_replace()` replaces the last line that matches the pattern
#' They are useful, for example, when reading a text file with many lines and you want to preserve the lines of that text file.
#' When `which='all'`, it is a wrapper for `stringr::str_replace()`.
#'
#' @param str String with pattern to make replacement
#' @param pattern Regular expression to replace
#' @param replacement What to replace the pattern with
#' @param which which one? first, last, all or the poles (first AND last)
#'
#' @return string
#' @examples
#'
#' somelines <- c('AAAAA', 'textytext', 'BBBBB', 'AAAAA', 'writingwriting', 'AAAAA', 'etc', 'etc', 'BBBBB')
#'
#' str_firstLine_replace(somelines, 'AAAAA', 'changedfirstline')
#'
#' str_lastLine_replace(somelines, 'AAAAA', 'changedlastline')
#'
#' str_line_replace(somelines, 'AAAAA', 'changedpoles', which='poles')
#'
#' str_line_replace(somelines, 'AAAAA', 'changedall', which='all')
#'
#' @seealso
#' [stringr::str_replace()]
#' @export
str_line_replace <- function(str, pattern, replacement, which=c('first', 'last', 'poles', 'all')) {

  if (which=='first') {
    str_firstLine_replace(str, pattern, replacement)
  }
  if (which=='last') {
    str_lastLine_replace(str, pattern, replacement)
  }
  if (which=='all') {
    return(stringr::str_replace(str, pattern, replacement))
  }
  if (which=='poles') {
    str_lastLine_replace(str_firstLine_replace(str, pattern, replacement), pattern, replacement)
  }
}

#' @rdname str_line_replace
#' @export str_firstLine_replace
str_firstLine_replace <- function(str, pattern, replacement) {
  str[grepl(pattern=pattern, x=str)][1] <- replacement
  return(str)
}
#' @rdname str_line_replace
#' @export str_lastLine_replace
str_lastLine_replace <- function(str, pattern, replacement) {
  str[grepl(pattern=pattern, x=str)][length(str[grepl(pattern=pattern, x=str)])] <- replacement
  return(str)
}

## writeBatch ----
#' Write batch file for batch file execution mode in FarmDyn
#'
#' @description
#' This function writes the batch file for you. It directly takes the necessary information from runInc.gms in FarmDyn, so the GUI
#' settings remain the same as you have set them.
#'
#' @inheritParams runFarmDynfromBatch
#' @inheritParams gdxbinwider
#'
#' @return Writes batch file necessary to run FarmDyn
#' @examples
#' TODO write example
#'
#' @seealso
#' \code{\link[FarmDynR]{runFarmDynfromBatch}}
#'
#' @export writeBatch

writeBatch <- function(FarmDynDir, mapping, farmIds) {

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

  readLines(
    file.path(FarmDynDir, 'gams', 'incgen', 'runInc.gms')
  )[((which(readLines(file.path('/FARMDYNTRUNK', 'gams', 'incgen', 'runInc.gms'))=='* Setting for executing the task in batch file mode'))-1):which(readLines(file.path('/FARMDYNTRUNK', 'gams', 'incgen', 'runInc.gms'))=='* end batch execution file')] %>%
    str_replace(pattern = 'Scenario description = \\w*', replacement = paste0('Scenario description = ', mapping)) %>%
    str_firstLine_replace(pattern='Farm sample file = \\w*', replacement = paste0('  Farm sample file = ', 'farmData_', mapping)) %>%
    str_lastLine_replace(pattern='Farm sample file = \\w*', replacement = paste0('  Farm sample file = ', 'farmData_', mapping, '\n  macro = ', paste(farmIds, collapse = '\\'))) %>%
    str_replace('farmIds = \\w*', replacement = paste0('farmIds = ', farmIds[length(farmIds)])) %>%
    str_replace('execute=Gamsrun', replacement = '  startparallel
    FOR farmidinloop = %allfarms%
      farmIds  = %farmidinloop%
      execute = Gamsrun
    ENDFOR
  collectparallel
*  execute=Gamsrun
') %>%
    writeLines(con = paste(mapping, 'batch.txt', sep = '_', collapse = ''))
}


## 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)


}

## gdxload ----
#' Load from GDX
#'
#' @description
#' `gdxload()` is a wrapper for gdxrrw::rgdx. It fixes the issue of having all UELs as factor levels for variables for which they do not belong.
#'
#' @param filename Name of the GDX file and its location
#' @param symbol The symbol type to be loaded (set, parameter, scalar)
#' @param symName The name of the symbol to be loaded
#' @param names Column names of the symbol
#' @param ...  Arguments to be passed to gdxrrw::rgdx(...)
#'
#' @return A dataframe
#'
#' @seealso
#' *gdxrrw::rgdx.set()
#' *gdxrrw::rgdx.param()
#' *gdxrrw::rgdx.scalar()
#'
#' @export gdxload

gdxload <- function(filename, symbol=c('set', 'param', 'scalar'), symName, names = NULL, ...) {
  if (symbol=='set') {
    symb <- gdxrrw::rgdx.set(filename, symName, names)
  }
  if (symbol=='param') {
    symb <- gdxrrw::rgdx.param(filename, symName, names)
  }
  if (symbol=='scalar') {
    symb <- gdxrrw::rgdx.scalar(filename, symName)
  }

  symb[] <- lapply(symb, function(x) if(is.factor(x)) factor(x) else x)
  return(symb)
}