... @@ -40,6 +40,8 @@ Modes <- function(x) { # Function found on StackOverflow made by Ken Williams an
... @@ -40,6 +40,8 @@ Modes <- function(x) { # Function found on StackOverflow made by Ken Williams an
#' Join BIN data together, make joined dataset wider, and group by a mapping
#' Join BIN data together, make joined dataset wider, and group by a mapping
#'
#'
#' @description
#' @description
#' This function has been conceived with the Dutch FADN in mind, please use `fadn2fd()` for EU FADN data.
#'
#' 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.
#' 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.
#' Then the data is widened, and the output is a tibble.
#'
#'
... @@ -155,16 +157,12 @@ return(map2gui)
... @@ -155,16 +157,12 @@ return(map2gui)
#' @param setNames wide dataframe.
#' @param setNames wide dataframe.
#'
#'
#' @return A tibble `tbl_df`.
#' @return A tibble `tbl_df`.
#' @examples
#' BINDir <- "inst/extdata/GAMS"
#' datafile <- 'FarmDynRexampledata.gdx'
#' gdxbinwider(datafile, BINDir, 'map2binid', 'mapping')
#' @seealso
#' @seealso
#' \itemize{
#' \itemize{
#' \item{\code{\link[gdxrrw]{wgdx] }}}{Write R data 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[gdxrrw]{wgdx.lst}}}{Write multiple symbols to GDX}
#' \item{\code{\link[gdxrrw]{wgdx.reshape] }}}{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}
#' \item{\code{\link[tidyr]{pivot_longer}}}{Make dataframes longer}
#' }
#' }
#' @export gdxreshape
#' @export gdxreshape
gdxreshape <- function (inDF, symDim, symName=NULL, tName="time",
gdxreshape <- function (inDF, symDim, symName=NULL, tName="time",
... @@ -304,6 +302,8 @@ gdxreshape <- function (inDF, symDim, symName=NULL, tName="time",
... @@ -304,6 +302,8 @@ gdxreshape <- function (inDF, symDim, symName=NULL, tName="time",
#' Generate descriptive statistics and save to GDX
#' Generate descriptive statistics and save to GDX
#'
#'
#' @description
#' @description
#' This function has been conceived with the Dutch FADN in mind, please use `fd_dec()` for EU FADN data.
#'
#' `groupstats()` returns descriptive statistics per group based on the mapping given. For example, if your mapping
#' `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
#' 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'
#' region based on the individual farm data. When `writegdx` is `TRUE`, it writes the GDX in the format 'farmStats_(mapping).gdx'
... @@ -326,7 +326,7 @@ gdxreshape <- function (inDF, symDim, symName=NULL, tName="time",
... @@ -326,7 +326,7 @@ gdxreshape <- function (inDF, symDim, symName=NULL, tName="time",
#' w='Weight')
#' w='Weight')
#' @seealso
#' @seealso
#' \itemize{
#' \itemize{
#' \item{\code{\link{summary] }}}{summary statistics}
#' \item{\code{\link{summary}}}{summary statistics}
#' \item{\code{\link[psych]{describe}}}{Descriptive statistics}
#' \item{\code{\link[psych]{describe}}}{Descriptive statistics}
#' \item{\code{\link[gdxrrw]{wgdx}}}{Write R data 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[gdxrrw]{wgdx.lst}}}{Write multiple symbols to GDX}
... @@ -350,10 +350,10 @@ groupstats <- function(filename, BINDir, gdxmap, mapping, cols, w, writegdx = TR
... @@ -350,10 +350,10 @@ groupstats <- function(filename, BINDir, gdxmap, mapping, cols, w, writegdx = TR
groupmap <- data %>%
groupmap <- data %>%
dplyr::select(dplyr::all_of(mapping), dplyr::all_of(cols), dplyr::all_of(w)) %>%
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)
dplyr::summarise(weightedmean = dplyr::across(dplyr::all_of(cols),~ stats:: 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
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
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
median = dplyr::across(dplyr::all_of(cols),~ stats:: median(as.numeric(as.character(.x))), na.rm =TRUE), # Idem
mode = dplyr::across(dplyr::all_of(cols),~ Modes(as.numeric(as.character(.x)))[1]),
mode = dplyr::across(dplyr::all_of(cols),~ Modes(as.numeric(as.character(.x)))[1]),
n = dplyr::across(dplyr::all_of(cols),~ sum(!is.na(.x))), # Make a column with n of each variable in the group
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)
.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)
... @@ -390,6 +390,8 @@ groupstats <- function(filename, BINDir, gdxmap, mapping, cols, w, writegdx = TR
... @@ -390,6 +390,8 @@ groupstats <- function(filename, BINDir, gdxmap, mapping, cols, w, writegdx = TR
#>>>>>>> 1ebeb0906d519cd31fea60640b1541768ae43ad8
#>>>>>>> 1ebeb0906d519cd31fea60640b1541768ae43ad8
#'
#'
#' @description
#' @description
#' This function has been conceived with the Dutch FADN in mind, please use `fadn2fd()` for EU FADN data.
#'
#' `updateFarmData()` creates sample farms by aggregating data based on the weighted mean and the selected mapping for use in FarmDyn.
#' `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'.
#' 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'.
#'
#'
... @@ -413,8 +415,8 @@ groupstats <- function(filename, BINDir, gdxmap, mapping, cols, w, writegdx = TR
... @@ -413,8 +415,8 @@ groupstats <- function(filename, BINDir, gdxmap, mapping, cols, w, writegdx = TR
#' \item{\code{\link[FarmDynR]{gdxreshape}}}{Lengthens data and saves to 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}}}{Write R data to GDX}
#' \item{\code{\link[gdxrrw]{wgdx.lst}}}{Write multiple symbols to GDX}
#' \item{\code{\link[gdxrrw]{wgdx.lst}}}{Write multiple symbols to GDX}
#' \item{\code{\link[dplyr]{summarise}}}{Make dataframes longer }
#' \item{\code{\link[dplyr]{summarise}}}{Summarises data and aggregates to group }
#' \item{\code{\link{weighted.mean] }}}{Calculates weighted mean}
#' \item{\code{\link[stats] {weighted.mean}}}{Calculates weighted mean}
#' }
#' }
#' @export updateFarmData
#' @export updateFarmData
updateFarmData <- function(filename, BINDir, gdxmap, mapping, writegdx = TRUE, cptcoeffs = FALSE, farmchars = NULL, cptcoeffsxl = NULL) {
updateFarmData <- function(filename, BINDir, gdxmap, mapping, writegdx = TRUE, cptcoeffs = FALSE, farmchars = NULL, cptcoeffsxl = NULL) {
... @@ -450,17 +452,17 @@ updateFarmData <- function(filename, BINDir, gdxmap, mapping, writegdx = TRUE,
... @@ -450,17 +452,17 @@ updateFarmData <- function(filename, BINDir, gdxmap, mapping, writegdx = TRUE,
farmchars <- inner_join(farmchars, narabland, by='all_binid') %>% mutate('logArabLandabs' = log(abs(ArabLand)))
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 ()
farmchars[] <- lapply(farmchars,function(x) if(is.factor(x)) factor(x) else x) %>% stats:: na.omit()
colnames(cptcoeffs)[1]<- 'char'
colnames(cptcoeffs)[1]<- 'char'
alphaprod <- farmchars [ colnames ( farmchars ) %in% cptcoeffs $ char ] * cptcoeffs $ b_alpha [ match ( names ( farmchars ), cptcoeffs $ char )][ col ( farmchars )] %>% na.omit ()
alphaprod <- farmchars[colnames(farmchars) %in% cptcoeffs$char]*cptcoeffs$b_alpha[match(names(farmchars), cptcoeffs$char)][col(farmchars)] %>% stats:: na.omit()
betaprod <- farmchars [ colnames ( farmchars ) %in% cptcoeffs $ char ] * cptcoeffs $ b_beta [ 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)] %>% stats:: na.omit()
gammaprod <- farmchars [ colnames ( farmchars ) %in% cptcoeffs $ char ] * cptcoeffs $ b_gamma [ 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)] %>% stats:: na.omit()
deltaprod <- farmchars [ colnames ( farmchars ) %in% cptcoeffs $ char ] * cptcoeffs $ b_delta [ 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)] %>% stats:: na.omit()
alpha <- rowSums(alphaprod)+cptcoeffs$b_alpha[7]
alpha <- rowSums(alphaprod)+cptcoeffs$b_alpha[7]
... @@ -488,7 +490,7 @@ updateFarmData <- function(filename, BINDir, gdxmap, mapping, writegdx = TRUE,
... @@ -488,7 +490,7 @@ updateFarmData <- function(filename, BINDir, gdxmap, mapping, writegdx = TRUE,
}
}
map2gui <- map2gui %>% dplyr::select(-all_binid) %>%
map2gui <- map2gui %>% dplyr::select(-all_binid) %>%
summarise ( dplyr :: across ( everything (), ~ if ( is.numeric ( . )) weighted.mean ( . , w = .data [[ 'Weight' ]], na.rm = TRUE ) else Modes ( . )))
summarise(dplyr::across(everything(),~ if(is.numeric(.)) stats:: weighted.mean(., w=.data[['Weight']], na.rm = TRUE) else Modes(.)))
# In RStudio, ignore the (X) error unmatched bracket, everything is fine and all works.
# In RStudio, ignore the (X) error unmatched bracket, everything is fine and all works.
map2gui$Weight <- NULL
map2gui$Weight <- NULL
... @@ -534,7 +536,9 @@ updateFarmData <- function(filename, BINDir, gdxmap, mapping, writegdx = TRUE,
... @@ -534,7 +536,9 @@ updateFarmData <- function(filename, BINDir, gdxmap, mapping, writegdx = TRUE,
#' @return string
#' @return string
#' @examples
#' @examples
#'
#'
#' somelines <- c('AAAAA', 'textytext', 'BBBBB', 'AAAAA', 'writingwriting', 'AAAAA', 'etc', 'etc', 'BBBBB')
#' somelines <- c('AAAAA', 'textytext', 'BBBBB', \n
#' 'AAAAA', 'writingwriting', 'AAAAA', \n
#' 'etc', 'etc', 'BBBBB')
#'
#'
#' str_firstLine_replace(somelines, 'AAAAA', 'changedfirstline')
#' str_firstLine_replace(somelines, 'AAAAA', 'changedfirstline')
#'
#'
... @@ -585,10 +589,9 @@ str_lastLine_replace <- function(str, pattern, replacement) {
... @@ -585,10 +589,9 @@ str_lastLine_replace <- function(str, pattern, replacement) {
#'
#'
#' @inheritParams runFarmDynfromBatch
#' @inheritParams runFarmDynfromBatch
#' @inheritParams gdxbinwider
#' @inheritParams gdxbinwider
#' @param farmIds Individual farm Identifiers. This is usually the aggregation (mapping) of your p_farmData file. Whereas here the mapping is just the name of the aggregation, farmIds is a vector of the names of the different farm samples made. For example, if mapping = NUTS0, then famrIds would be AT, BE, BG... etc.
#'
#'
#' @return Writes batch file necessary to run FarmDyn
#' @return Writes batch file necessary to run FarmDyn
#' @examples
#' TODO write example
#'
#'
#' @seealso
#' @seealso
#' \code{\link[FarmDynR]{runFarmDynfromBatch}}
#' \code{\link[FarmDynR]{runFarmDynfromBatch}}
... @@ -626,7 +629,7 @@ writeBatch <- function(FarmDynDir, mapping, farmIds) {
... @@ -626,7 +629,7 @@ writeBatch <- function(FarmDynDir, mapping, farmIds) {
#' Execute FarmDyn
#' Execute FarmDyn
#'
#'
#' @description
#' @description
#' `runFarmDynfromBatch()` does as it says in the function.
#' `runFarmDynfromBatch()` makes it possible to run FarmDyn from R us ing the batch file
#'
#'
#' @param FarmDynDir Directory where FarmDyn is located
#' @param FarmDynDir Directory where FarmDyn is located
#' @param IniFile Name of the IniFile
#' @param IniFile Name of the IniFile
... @@ -635,11 +638,6 @@ writeBatch <- function(FarmDynDir, mapping, farmIds) {
... @@ -635,11 +638,6 @@ writeBatch <- function(FarmDynDir, mapping, farmIds) {
#' @param BATCHFile Name of the .batch file
#' @param BATCHFile Name of the .batch file
#'
#'
#' @return Executes FarmDyn from R
#' @return Executes FarmDyn from R
#' @examples
#' TODO write example
#'
#' @seealso
#' *Globiom?
#'
#'
#' @export runFarmDynfromBatch
#' @export runFarmDynfromBatch
... @@ -777,7 +775,7 @@ vars_dump <- function(res_fold, varname, scen_name) {
... @@ -777,7 +775,7 @@ vars_dump <- function(res_fold, varname, scen_name) {
})
})
# Add farm ids (4 last letters and numbers of the file name) to the data.table
# Add farm ids (4 last letters and numbers of the file name) to the data.table
var_call[[y]] <-
var_call[[y]] <-
var_call [[ y ]] <- scen_call [[ y ]] %>% rbindlist ( )
var_call[[y]] <- rbindlist( scen_call[[y]])
var_call[[y]]$sims <- scen_name[y]
var_call[[y]]$sims <- scen_name[y]
}
}
return(var_call)
return(var_call)
... @@ -794,7 +792,7 @@ scen_analysis <- function(res_fold, scen_name) {
... @@ -794,7 +792,7 @@ scen_analysis <- function(res_fold, scen_name) {
# Then, select the columns "farmIds", "scen", "resItem1", "resItem2", "value" from the data.table
# Then, select the columns "farmIds", "scen", "resItem1", "resItem2", "value" from the data.table
scen_call <- list()
scen_call <- list()
for (i in seq_along(scen_name)) {
for (i in seq_along(scen_name)) {
scen_call [[ i ]] <- r gdx. param(
scen_call[[i]] <- gdxrrw:: param(
paste(
paste(
res_fold, paste0("res_", scen_name[i], "_until_2010.gdx"),
res_fold, paste0("res_", scen_name[i], "_until_2010.gdx"),
sep = "/"
sep = "/"
... @@ -860,7 +858,7 @@ load_dumps <- function(res_fold, scen_name) {
... @@ -860,7 +858,7 @@ load_dumps <- function(res_fold, scen_name) {
scen_call <- list()
scen_call <- list()
for (i in seq_along(scen_name)) {
for (i in seq_along(scen_name)) {
scen_call[[i]] <- lapply(files[[i]], function(x) {
scen_call[[i]] <- lapply(files[[i]], function(x) {
r gdx. param(
gdxrrw:: param(
paste(
paste(
res_fold, x,
res_fold, x,
sep = "/"
sep = "/"
... @@ -893,7 +891,7 @@ load_dump_par <- function(res_fold, scen_name, param, names = NULL) {
... @@ -893,7 +891,7 @@ load_dump_par <- function(res_fold, scen_name, param, names = NULL) {
scen_call <- list()
scen_call <- list()
for (i in seq_along(scen_name)) {
for (i in seq_along(scen_name)) {
scen_call[[i]] <- lapply(files[[i]], function(x) {
scen_call[[i]] <- lapply(files[[i]], function(x) {
r gdx. param(
gdxrrw:: param(
paste(
paste(
res_fold, x,
res_fold, x,
sep = "/"
sep = "/"
... @@ -994,18 +992,18 @@ fd_desc <- function(farm_data, type = c("arable", "dairy"), csv = FALSE, dir = N
... @@ -994,18 +992,18 @@ fd_desc <- function(farm_data, type = c("arable", "dairy"), csv = FALSE, dir = N
descstats <- farm_data %>%
descstats <- farm_data %>%
group_by(NUTS0) %>%
group_by(NUTS0) %>%
summarise(
summarise(
`Land [ha]` = weighted.mean ( `global%nArabLand` , `misc%weights` , na.rm = TRUE ),
`Land [ha]` = stats:: weighted.mean(`global%nArabLand`, `misc%weights`, na.rm = TRUE),
SummerCere = weighted.mean ( `misc%SummerCere` , `misc%weights` , na.rm = TRUE ),
SummerCere = stats:: weighted.mean(`misc%SummerCere`, `misc%weights`, na.rm = TRUE),
Winterbarley = weighted.mean ( `misc%Winterbarley` , `misc%weights` , na.rm = TRUE ),
Winterbarley = stats:: weighted.mean(`misc%Winterbarley`, `misc%weights`, na.rm = TRUE),
WinterWheat = weighted.mean ( `misc%WinterWheat` , `misc%weights` , na.rm = TRUE ),
WinterWheat = stats:: weighted.mean(`misc%WinterWheat`, `misc%weights`, na.rm = TRUE),
MaizCorn = weighted.mean ( `misc%MaizCorn` , `misc%weights` , na.rm = TRUE ),
MaizCorn = stats:: weighted.mean(`misc%MaizCorn`, `misc%weights`, na.rm = TRUE),
MaizSil = weighted.mean ( `misc%MaizSil` , `misc%weights` , na.rm = TRUE ),
MaizSil = stats:: weighted.mean(`misc%MaizSil`, `misc%weights`, na.rm = TRUE),
# `Annual Work Units` = median(`global%Aks`, `misc%weights`, na.rm = TRUE),
# `Annual Work Units` = median(`global%Aks`, `misc%weights`, na.rm = TRUE),
`Farm Net Value Added [EUR]` = weighted.mean ( `misc%net cashflow` , `misc%weights` , na.rm = TRUE ),
`Farm Net Value Added [EUR]` = stats:: weighted.mean(`misc%net cashflow`, `misc%weights`, na.rm = TRUE),
`Median FNVA [EUR]` = median ( `misc%net cashflow` , na.rm = TRUE ),
`Median FNVA [EUR]` = stats:: median(`misc%net cashflow`, na.rm = TRUE),
`Annual Work Units` = weighted.mean ( `global%Aks` , `misc%weights` , na.rm = TRUE ),
`Annual Work Units` = stats:: weighted.mean(`global%Aks`, `misc%weights`, na.rm = TRUE),
`FNVA per AWU` = `Farm Net Value Added [EUR]` / `Annual Work Units`,
`FNVA per AWU` = `Farm Net Value Added [EUR]` / `Annual Work Units`,
N_use = weighted.mean ( `misc%N_use` , `misc%weights` , na.rm = TRUE ),
N_use = stats:: weighted.mean(`misc%N_use`, `misc%weights`, na.rm = TRUE),
n = sum(`misc%nFarms`)
n = sum(`misc%nFarms`)
)
)
descstats <- descstats %>%
descstats <- descstats %>%
... @@ -1018,29 +1016,29 @@ fd_desc <- function(farm_data, type = c("arable", "dairy"), csv = FALSE, dir = N
... @@ -1018,29 +1016,29 @@ fd_desc <- function(farm_data, type = c("arable", "dairy"), csv = FALSE, dir = N
`Annual Work Units`, `kg N per ha`, `Farm Net Value Added [EUR]`, n,
`Annual Work Units`, `kg N per ha`, `Farm Net Value Added [EUR]`, n,
`Median FNVA [EUR]`, `FNVA per AWU`
`Median FNVA [EUR]`, `FNVA per AWU`
) %>%
) %>%
filter ( n >= 15 )
dplyr:: filter(n >= 15)
}
}
if (type == "dairy") {
if (type == "dairy") {
descstats <- farm_data %>%
descstats <- farm_data %>%
group_by(NUTS0) %>%
group_by(NUTS0) %>%
summarise(
summarise(
nCows_mean = weighted.mean ( `global%nCows` , `misc%weights` , na.rm = TRUE ),
nCows_mean = stats:: weighted.mean(`global%nCows`, `misc%weights`, na.rm = TRUE),
nArabLand_mean = weighted.mean ( `global%nArabLand` , `misc%weights` , na.rm = TRUE ),
nArabLand_mean = stats:: weighted.mean(`global%nArabLand`, `misc%weights`, na.rm = TRUE),
nGrasLand_mean = weighted.mean ( `global%nGrasLand` , `misc%weights` , na.rm = TRUE ),
nGrasLand_mean = stats:: weighted.mean(`global%nGrasLand`, `misc%weights`, na.rm = TRUE),
milkYield_mean = weighted.mean ( `global%milkYield` , `misc%weights` , na.rm = TRUE ),
milkYield_mean = stats:: weighted.mean(`global%milkYield`, `misc%weights`, na.rm = TRUE),
`Share of Grassland [%]` = weighted.mean ( `global%ShareGrassLand` , `misc%weights` , na.rm = TRUE ) * 100 ,
`Share of Grassland [%]` = stats:: weighted.mean(`global%ShareGrassLand`, `misc%weights`, na.rm = TRUE) * 100,
# `Annual Work Units` = median(`global%Aks`, `misc%weights`, na.rm = TRUE),
# `Annual Work Units` = median(`global%Aks`, `misc%weights`, na.rm = TRUE),
`Farm Net Value Added [EUR]` = weighted.mean ( `misc%net_value_added` , `misc%weights` , na.rm = TRUE ),
`Farm Net Value Added [EUR]` = stats:: weighted.mean(`misc%net_value_added`, `misc%weights`, na.rm = TRUE),
`Median FNVA [EUR]` = median ( `misc%net_value_added` , na.rm = TRUE ),
`Median FNVA [EUR]` = stats:: median(`misc%net_value_added`, na.rm = TRUE),
`Annual Work Units` = weighted.mean ( `global%Aks` , `misc%weights` , na.rm = TRUE ),
`Annual Work Units` = stats:: weighted.mean(`global%Aks`, `misc%weights`, na.rm = TRUE),
`FNVA per AWU` = `Farm Net Value Added [EUR]` / `Annual Work Units`,
`FNVA per AWU` = `Farm Net Value Added [EUR]` / `Annual Work Units`,
`Livestock density` = nCows_mean / (nArabLand_mean + nGrasLand_mean),
`Livestock density` = nCows_mean / (nArabLand_mean + nGrasLand_mean),
n = sum(`misc%nFarms`)
n = sum(`misc%nFarms`)
) %>%
) %>%
filter ( n >= 15 )
dplyr:: filter(n >= 15)
}
}
if (csv == TRUE) {
if (csv == TRUE) {
descstats %>% write.csv ( file.path ( dir , paste0 ( type , "_descstats.csv" )), row.names = FALSE )
descstats %>% utils:: write.csv(file.path(dir, paste0(type, "_descstats.csv")), row.names = FALSE)
}
}
return(descstats)
return(descstats)
}
}
... @@ -1054,7 +1052,7 @@ fd_desc <- function(farm_data, type = c("arable", "dairy"), csv = FALSE, dir = N
... @@ -1054,7 +1052,7 @@ fd_desc <- function(farm_data, type = c("arable", "dairy"), csv = FALSE, dir = N
is.nan.data.frame <- function(x) do.call(cbind, lapply(x, is.nan))
is.nan.data.frame <- function(x) do.call(cbind, lapply(x, is.nan))
# Remove aggregated farms with less than 15 farms for reporting
# Remove aggregated farms with less than 15 farms for reporting
## remove_aggregated_farms ----
## rm_lown ----
#' `rm_lown()` removes aggregated farms with less than 15 farms for reporting
#' `rm_lown()` removes aggregated farms with less than 15 farms for reporting
#' @param data A dataframe with the data to plot
#' @param data A dataframe with the data to plot
#' @param farm_data A dataframe with the farm data
#' @param farm_data A dataframe with the farm data
... ...