... @@ -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
... ...