DESCRIPTION

@@ -16,8 +16,8 @@ Depends: R (>= 4.2.1)
 Imports: tidyverse, gdxrrw
 License: GPL (>= 3)
 Encoding: UTF-8
-LazyData: true
+LazyData: false
 URL: https://www.wur.nl/
-RoxygenNote: 7.2.1
+RoxygenNote: 7.2.2
 Suggests:
     stringr (>= 1.4.1)

NAMESPACE

@@ -2,11 +2,12 @@
 
 export(Modes)
 export(gdxbinwider)
+export(gdxload)
 export(gdxreshape)
 export(groupstats)
 export(runFarmDynfromBatch)
-export(samplr)
 export(str_firstLine_replace)
 export(str_lastLine_replace)
 export(str_line_replace)
+export(updateFarmData)
 export(writeBatch)

R/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(paste(BINDir,filename, sep="/"), gdxmap, compress=FALSE, ts=FALSE,
-                                     useDomInfo = TRUE, check.names = TRUE))
-
-# Pick entries for non-numerical globals (1.6e+303 is code for numerical globals).
-
-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::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 <- '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)
-}
-
-
-## samplr ----
-#' Create sample farms
-#'
-#' @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 <- 'FarmDynRexampledata.gdx'
-#' samplr('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 samplr
-samplr <- function(filename, BINDir,  gdxmap, mapping, writegdx = TRUE) {
-
-
-  if ("BINDir" %in% ls(envir = .GlobalEnv) & missing(BINDir)) {
-    BINDir <- get("BINDir", envir = .GlobalEnv)
-  } else {
-    BINDIR
-  }
-
-  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)
-}
-
-## 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)
-
-
-}

R/data.R

@@ -4,7 +4,7 @@
 #'
 #' @docType data
 #'
-#' @usage data(fd2gui); data(fdnl); data(gdxmapping)
+#' @usage data(samplefd2gui); data(samplefdnl); data(samplegdxmapping)
 #'
 #' @format Objects of class `tbl_df`
 #'
@@ -14,4 +14,4 @@
 #' data(fd2gui)
 #' data(fdnl)
 #' data(gdxmapping)
-'fd2gui'
+#'samplefd2gui'

README.Rmd

@@ -40,7 +40,7 @@ You can install the development version of FarmDynR like so:
 ## Workflow
 
 1. Create GDX files with the mappings, global settings per farm, farm data, and weights
-2. Use `samplr()` to create sample farms based on your selected mapping
+2. Use `updateFarmData()` to create sample farms based on your selected mapping
 3. Write batch file with `writeBatch()` and run FarmDyn with `runFarmDynfromBatch()` using the created batch file
     - Optional: Create descriptive statistics for reporting with `groupstats()`
 

README.md

@@ -33,7 +33,8 @@ You can install the development version of FarmDynR like so:
 
 1.  Create GDX files with the mappings, global settings per farm, farm
     data, and weights
-2.  Use `samplr()` to create sample farms based on your selected mapping
+2.  Use `updateFarmData()` to create sample farms based on your selected
+    mapping
 3.  Write batch file with `writeBatch()` and run FarmDyn with
     `runFarmDynfromBatch()` using the created batch file
     - Optional: Create descriptive statistics for reporting with

data/.exampledatabuilder.R

-library(dplyr)
-library(tidyr)
-library(arsenal)
-library(gdxrrw)
-GAMSDir     = "C:/GAMS/40" # Change to your GAMS Version!
-
-igdx(GAMSDir)
-
-set.seed(1234)
-abcd <- c(stringi::stri_rand_strings(80,5))
-
-mapping <- rep(LETTERS[5:9], times = c(10, 10, 40, 60, 68))
-set.seed(1234)
-all_binid <- c(sample(1:187), 'dummy')
-set.seed(1234)
-item <- c('global', 'yields', 'maxrot', 'misc')
-set.seed(1234)
-value <- rnorm(15040, mean = 0, sd=100)
-
-a <- data.frame(item,abcd) %>% tibble()
-
-a[a$item=='global',]$abcd[19:20] <- c('soilTypeFirm', 'derogatie')
-
-
-map2id <- data.frame(all_binid = as.factor(all_binid), grouping = as.factor(mapping))
-fadat2gui <- data.frame(all_binid = as.factor(all_binid), a, value=value)
-
-test<- fadat2gui[fadat2gui$item=='global',]$value
-
-#fadat2gui[fadat2gui$all_binid=='dummy',]$item <- 'global'
-set.seed(1234)
-fadat2gui[fadat2gui$all_binid=='dummy',]$value[sample(nrow(fadat2gui[fadat2gui$all_binid=='dummy',]),3)] <- c(1.6e+303, 1.59e+303, 1.56e+303)
-
-set.seed(1234)
-fdnl <- data.frame(all_binid = as.factor(all_binid[1:94]),
-                   year = rep(2017:2020, c(5, 11, 15, 16)),
-                   items = c(stringi::stri_rand_strings(94,5),rep('Weight', 94)),
-                   value = rnorm(94, mean=0, sd=40)
-)
-set.seed(1234)
-fdnl[fdnl$items == 'Weight',]$value <- runif(94, min = 0.01)
-
-write.csv(fadat2gui, 'inst/extdata/GAMS/fadat2gui.csv')
-write.csv(fdnl, 'inst/extdata/GAMS/fdnl.csv')
-
-write.csv(map2id, 'inst/extdata/GAMS/map2id.csv')
-
-
-# Run GAMS
-
-# After running GAMS
-
-fd2gui <- (gdxrrw::rgdx.param("inst/extdata/GAMS/DynRexampledata.gdx", "p_farmData2GUI", names=c("all_binid", 'items', "varias", "value"), compress=FALSE, ts=FALSE,
-                              squeeze=TRUE, useDomInfo = TRUE, check.names = TRUE))
-
-fdnl <- (gdxrrw::rgdx.param("inst/extdata/GAMS/DynRexampledata.gdx", "p_farmData_NL", names=c("all_binid", 'years', "items2", "value"), compress=FALSE, ts=FALSE,
-                            squeeze=TRUE, useDomInfo = TRUE, check.names = TRUE))
-
-gdxmapping <- (rgdx.set("inst/extdata/GAMS/DynRexampledata.gdx", 'map2binid',names = c('all_binid', 'mapping'), compress=FALSE, ts=FALSE,
-                        useDomInfo = TRUE, check.names = TRUE))
-
-save(fd2gui, file = 'data/fd2gui.RData')
-save(fdnl, file = 'data/fdnl.RData')
-save(gdxmapping, file = 'data/gdxmapping.RData')
-
-groupstats('DynRexampledata.gdx', BINDir="inst/extdata/GAMS/", gdxmap = 'map2binid', mapping = 'mapping', cols = c('d0EfV', 'hXHvI'), w='Weight')
-
-
-

inst/extdata/GAMS/fakesampleconstruct.gms

-Set
-    items 'set of fake items'
-    all_binid 'fake id numbers'
-    mapping 'fake mapping used'
-    map2binid 'fake mapping to fake bin id'
-    varias 'fake variables used'
-    year 'fake years'
-    items2 'fdnl items';
-    
-
-
-$gdxIn fd2gui.gdx
-
-$load all_binid
-$load varias
-$load items
-
-
-Parameter p_farmData2GUI(all_binid, items, varias) 'Fake Random farmdata2gui';
-$LOAD p_farmData2GUI
-$gdxIn
-
-$gdxIn fdnl.gdx
-
-
-$load year
-$load items2
-
-
-Parameter p_farmData_NL(all_binid, year, items2) 'Fake Random farmData NL';
-$LOAD p_farmData_NL
-$gdxIn
-
-
-$gdxIn map2id.gdx
-$LOAD mapping
-$LOAD map2binid
-
-execute_unload 'DynRexampledata.gdx'
-all_binid
-year
-items
-items2
-mapping
-map2binid
-varias
-p_farmData_NL
-p_farmData2GUI

inst/extdata/GAMS/fd2gui.gms

-* Nothing here is real data, purely fiction
-$call csv2gdx fadat2gui.csv id='p_farmData2GUI' index=2,3,4 useHeader=Y colCount=5 value=lastCol
-
-Set
-    items 'set of fake items'
-    all_binid 'fake id numbers'
-    varias 'fake variables used'
-
-
-$gdxIn fadat2gui.gdx
-$load all_binid = Dim1
-$load items = Dim2
-$load varias = Dim3
-
-Parameter p_farmData2GUI(all_binid, items, varias) 'Fake Random farmdata2gui';
-$load p_farmData2GUI
-$gdxIn
-
-execute_unloaddi "fd2gui.gdx"
-all_binid
-items
-varias
-p_farmData2GUI
\ No newline at end of file

inst/extdata/GAMS/fdnl.csv

-"","all_binid","year","items","value"
-"1","28",2017,"7cbcr",-43.1016849103772
-"2","80",2017,"d0EfV",-129.326085316925
-"3","150",2017,"hXHvI",-10.1949861061814
-"4","101",2017,"pHGBE",1.18071321285919
-"5","111",2017,"JI92D",23.7709509644205
-"6","137",2018,"oWup2",2.36540672715187
-"7","133",2018,"SGIVB",16.5359557894818
-"8","166",2018,"lCGzo",-43.9108869828168
-"9","144",2018,"YeJcK",28.4470102908176
-"10","132",2018,"VfUFl",28.7555491941657
-"11","98",2018,"4JiV9",10.0660427611587
-"12","103",2018,"VUkAq",54.290977446071
-"13","90",2018,"r2J0E",16.1787388511443
-"14","70",2018,"hJV3Z",10.5745707935175
-"15","79",2018,"7t0m5",10.7217561657479
-"16","116",2018,"WN4Jf",17.4772230815793
-"17","14",2019,"vT8XC",42.4049562194946
-"18","126",2019,"tOJ9t",18.0876158611486
-"19","62",2019,"At886",26.5279446274826
-"20","4",2019,"VI1Jk",-45.4549421596334
-"21","178",2019,"2ZHC8",-14.8199006836847
-"22","149",2019,"K98R2",59.0787835916988
-"23","40",2019,"i6w7D",-48.9561500205502
-"24","93",2019,"uwH7n",10.3227354958442
-"25","122",2019,"kuzwU",16.2001122173407
-"26","181",2019,"HFVUJ",39.032132872378
-"27","66",2019,"xd7Qu",-13.9550694615964
-"28","123",2019,"Tubdr",6.3450175796505
-"29","48",2019,"VyKTM",-70.5302026616461
-"30","108",2019,"cjZyZ",13.5438418839962
-"31","131",2019,"RE5qE",-26.6626011823709
-"32","87",2020,"zbzNY",-9.54586497310576
-"33","41",2020,"QZQD5",-47.5106112982878
-"34","115",2020,"dQ4nK",15.3974128707431
-"35","72",2020,"kahQL",26.6631806261792
-"36","42",2020,"lQY7I",-12.1845555783094
-"37","43",2020,"TLb4x",73.0004425634518
-"38","2",2020,"1qdJk",26.8223748227035
-"39","117",2020,"dz7so",37.9453029302061
-"40","173",2020,"opjyd",81.9761200668364
-"41","49",2020,"eWJlW",-26.0445443695014
-"42","102",2020,"jJPCz",32.3447709138517
-"43","51",2020,"ZHBkZ",39.4632245581825
-"44","134",2020,"vdhTq",-0.246831843628001
-"45","147",2020,"Q1GK8",12.7620943172765
-"46","143",2020,"UnKVU",-40.4728761096738
-"47","57",2020,"nZ6oZ",18.8067019090556
-"48","136",2017,"DkJUz",-28.0388132651639
-"49","26",2017,"QFDgy",32.5473145010597
-"50","160",2017,"TlZxn",-32.4572313597109
-"51","8",2017,"WaGH4",12.7758994839784
-"52","96",2017,"YG0aW",-33.860906126545
-"53","22",2018,"q1bG7",-9.8305271651493
-"54","35",2018,"6k03k",-62.1143604442184
-"55","155",2018,"MlNn1",5.13736131703013
-"56","157",2018,"VoXGL",39.4177355761947
-"57","86",2018,"MQumj",7.32990092268766
-"58","141",2018,"HSHho",-70.6491685372183
-"59","10",2018,"ePxFb",-24.8213478646377
-"60","55",2018,"kh7dJ",66.2417214799494
-"61","135",2018,"LyXRw",72.3922154233551
-"62","120",2018,"SBzYl",-47.0014707204854
-"63","109",2018,"ugPP9",-14.6681303531056
-"64","25",2019,"CBPLp",14.1450179570915
-"65","3",2019,"CrO9L",12.7662488347159
-"66","83",2019,"MQBev",-23.1982795607761
-"67","50",2019,"jsxCT",-38.1311480778763
-"68","180",2019,"NN1vP",-7.17714347782484
-"69","175",2019,"xGWyM",40.3923285977721
-"70","156",2019,"J2fv2",0.945064596856353
-"71","174",2019,"Ck8hz",-25.961128783356
-"72","20",2019,"wajUl",-20.1749688819276
-"73","162",2019,"0YSKp",64.5756598183345
-"74","63",2019,"yeEoi",-17.8783924502265
-"75","71",2019,"yGsUI",30.5270704445326
-"76","61",2019,"Ol6Qe",58.868747447432
-"77","140",2019,"IC06D",17.7465961474966
-"78","145",2019,"7gBzw",-16.8688748028076
-"79","170",2020,"gjjeA",-1.60006504824295
-"80","184",2020,"vZX1M",-19.6911987291155
-"81","27",2020,"gPkmZ",49.1086846925101
-"82","76",2020,"Bl5cP",-5.98214260977569
-"83","153",2020,"moxDr",61.9993353592985
-"84","159",2020,"PVm8P",-22.4645014152525
-"85","60",2020,"fuL6v",-25.8846900252944
-"86","65",2020,"C3QLH",5.72528636201707
-"87","36",2020,"fmRvG",0.967545919642049
-"88","187",2020,"eNvja",-20.1780609832348
-"89","19",2020,"oskVz",-63.2558723972136
-"90","9",2020,"Ysdc2",1.20265685021672
-"91","30",2020,"Fmzxk",-28.6630679628281
-"92","114",2020,"gFbZ3",43.3044382190448
-"93","17",2020,"NtOWA",-38.1074181975717
-"94","167",2020,"BXOcZ",45.0593091603663
-"95","28",2017,"Weight",0.12256637719227
-"96","80",2017,"Weight",0.626076410766691
-"97","150",2017,"Weight",0.613181985551491
-"98","101",2017,"Weight",0.627145647259895
-"99","111",2017,"Weight",0.862306229721289
-"100","137",2018,"Weight",0.64390749923652
-"101","133",2018,"Weight",0.0194007987924851
-"102","166",2018,"Weight",0.240225000954233
-"103","144",2018,"Weight",0.66942292064894
-"104","132",2018,"Weight",0.519108629929833
-"105","98",2018,"Weight",0.696655378865544
-"106","103",2018,"Weight",0.549525087233633
-"107","90",2018,"Weight",0.289906247754116
-"108","70",2018,"Weight",0.924199149433989
-"109","79",2018,"Weight",0.299392681852914
-"110","116",2018,"Weight",0.83892267187126
-"111","14",2019,"Weight",0.293361051820684
-"112","126",2019,"Weight",0.274152572201565
-"113","62",2019,"Weight",0.194855561761651
-"114","4",2019,"Weight",0.239903651422355
-"115","178",2019,"Weight",0.32344633028144
-"116","149",2019,"Weight",0.309666437022388
-"117","40",2019,"Weight",0.167455542867538
-"118","93",2019,"Weight",0.0495959588699043
-"119","122",2019,"Weight",0.226611545595806
-"120","181",2019,"Weight",0.812492566935252
-"121","66",2019,"Weight",0.530440571310464
-"122","123",2019,"Weight",0.915511584342457
-"123","48",2019,"Weight",0.833031596401706
-"124","108",2019,"Weight",0.0553125606663525
-"125","131",2019,"Weight",0.461530567600857
-"126","87",2020,"Weight",0.272534805147443
-"127","41",2020,"Weight",0.311625480996445
-"128","115",2020,"Weight",0.512233801372349
-"129","72",2020,"Weight",0.189285246198997
-"130","42",2020,"Weight",0.762073929097969
-"131","43",2020,"Weight",0.209235557252541
-"132","2",2020,"Weight",0.266221720466856
-"133","117",2020,"Weight",0.992228913353756
-"134","173",2020,"Weight",0.809278816911392
-"135","49",2020,"Weight",0.557800254831091
-"136","102",2020,"Weight",0.649942033137195
-"137","51",2020,"Weight",0.318706064007711
-"138","134",2020,"Weight",0.625601006150246
-"139","147",2020,"Weight",0.336472473982722
-"140","143",2020,"Weight",0.506977498221677
-"141","57",2020,"Weight",0.680323582014535
-"142","136",2017,"Weight",0.490141326759476
-"143","26",2017,"Weight",0.251489539071918
-"144","160",2017,"Weight",0.767805189690553
-"145","8",2017,"Weight",0.0830420812685043
-"146","96",2017,"Weight",0.316589735841844
-"147","22",2018,"Weight",0.720099025908858
-"148","35",2018,"Weight",0.509500453025103
-"149","155",2018,"Weight",0.161468969357666
-"150","157",2018,"Weight",0.508894153276924
-"151","86",2018,"Weight",0.499021313819103
-"152","141",2018,"Weight",0.753688195061404
-"153","10",2018,"Weight",0.182903325683437
-"154","55",2018,"Weight",0.849908486332279
-"155","135",2018,"Weight",0.866185493699741
-"156","120",2018,"Weight",0.0514387024287134
-"157","109",2018,"Weight",0.324010333772749
-"158","25",2019,"Weight",0.0236124397651292
-"159","3",2019,"Weight",0.246635469414759
-"160","83",2019,"Weight",0.709429671103135
-"161","50",2019,"Weight",0.315013809571974
-"162","180",2019,"Weight",0.513462090010289
-"163","175",2019,"Weight",0.0611301531433128
-"164","156",2019,"Weight",0.568924141575117
-"165","174",2019,"Weight",0.130265385296661
-"166","20",2019,"Weight",0.893908017864451
-"167","162",2019,"Weight",0.0244809831748717
-"168","63",2019,"Weight",0.785289892617147
-"169","71",2019,"Weight",0.0990617196378298
-"170","61",2019,"Weight",0.523998081004247
-"171","140",2019,"Weight",0.39042402068153
-"172","145",2019,"Weight",0.0793519723485224
-"173","170",2020,"Weight",0.327437977979425
-"174","184",2020,"Weight",0.671810443112627
-"175","27",2020,"Weight",0.927136471604463
-"176","76",2020,"Weight",0.47719062393764
-"177","153",2020,"Weight",0.151189189779107
-"178","159",2020,"Weight",0.548827057466842
-"179","60",2020,"Weight",0.204212905331515
-"180","65",2020,"Weight",0.899594684322365
-"181","36",2020,"Weight",0.395604786833283
-"182","187",2020,"Weight",0.317762071881443
-"183","19",2020,"Weight",0.168428376368247
-"184","9",2020,"Weight",0.89722399106482
-"185","30",2020,"Weight",0.174729842578527
-"186","114",2020,"Weight",0.901420350193512
-"187","17",2020,"Weight",0.142737413134892
-"188","167",2020,"Weight",0.140297992839478

inst/extdata/GAMS/fdnl.gms

-$call csv2gdx fdnl.csv id='p_farmData_NL' index=2,3,4 useHeader=Y colCount=5 value=lastCol
-Set
-    items 'set of fake items'
-    all_binid 'fake id numbers'
-*    mapping 'fake mapping used'
-*    map2binid 'fake mapping to fake bin id'
-*    varias 'fake variables used'
-    year 'fake years'
-    items2 'items of fdnl';
-
-
-$gdxIn fdnl.gdx
-$load all_binid = Dim1
-$load year = Dim2
-$load items2 = Dim3
-
-Parameter p_farmData_NL(all_binid, year, items2) 'Fake Random farmData NL';
-$load p_farmData_NL
-$gdxIn
-
-execute_unload "fdnl.gdx"
-all_binid
-items2
-year
-p_farmData_NL
\ No newline at end of file