Merge pull request #45 from AgroCares/corrections_AB

Corrections ab

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: BBWPC
 Type: Package
 Title: Calculator for BedrijfsBodemWaterPlan (BBWP)
-Version: 0.9.1
+Version: 0.10.0
 Authors@R: c(
     person("Gerard", "Ros", email = "[email protected]", role = c("aut","cre")),
     person("Sven", "Verweij", email = "[email protected]", role = c("aut")),

NAMESPACE

@@ -20,8 +20,10 @@ export(er_field_scores)
 export(er_meas_rank)
 export(er_meas_score)
 export(er_medal)
+export(er_opi)
 export(wf)
 import(OBIC)
+import(checkmate)
 import(data.table)
 import(stats)
 importFrom(data.table,":=")

NEWS.md

@@ -1,3 +1,23 @@
+# BBWPC v0.10.0
+## Fixed
+* test csv files removed from package directory and dev directory
+* threshold of scores for medals are set to zero for indicators climate and water (only on peat soils)
+* the absolute total score is used for medal check instead of the integrative total score 
+* no "terras" measures are recommended for fields where B_SLOPE_DEGREE is less than 2\% (fix in `bbwp_meas_rank`)
+
+## Added
+* function `er_opi` to estimate the contribution of single fields to the farm score
+* exception for measure G20 is added to `er_meas_rank`, `er_meas_score` and `er_crop_rotation`.
+
+## Changed
+* the field score is set equal to the farm score for Ecoregeling method
+* input arguments `B_CT_??` are removed from `er_crop_rotation`,`er_field_score`
+* input argument `E_ER_TOT` is removed from `er_farm_score`
+* adjust targets for landscape in the final scoring in `er_medal` and `er_opi`; there is no minimum needed.
+* the indicator score is set to the contribution of single fields to the farm score. The function `er_field_score` givers therefore the actual score per hectare, and not the relative score given target.
+* measures table is updated (some levels (field vs farm) have been altered)
+
+
 # BBWPC v0.9.1
 ## Added
 * Added table with BBWPC variable from pandex to standardise parameter checks

R/bbwp_meas_rank.R

@@ -153,6 +153,9 @@ bbwp_meas_rank <- function(B_SOILTYPE_AGR, B_GWL_CLASS,  A_P_SG, B_SLOPE_DEGREE,
     dt[grepl('veen', B_SOILTYPE_AGR) & peat == FALSE , c(cols) := 0]
     dt[grepl('loess', B_SOILTYPE_AGR) & loess == FALSE , c(cols) := 0]
 
+    # adapt the score for slope dependent
+    dt[B_SLOPE_DEGREE <= 2 & bbwp_id == 'G21',c(cols) := 0]
+
     # add impact score for measure per opportunity index
     dt[, D_MEAS_NGW := D_OPI_NGW * effect_ngw]
     dt[, D_MEAS_NSW := D_OPI_NSW * effect_nsw]

R/bbwp_meas_scores.R

@@ -35,7 +35,7 @@ bbwp_meas_score <- function(B_SOILTYPE_AGR, B_GWL_CLASS,  A_P_SG, B_SLOPE_DEGREE
   D_MEAS_PSW = D_MEAS_NGW = D_MEAS_PSW = effect_wb = NULL
   nc1 = nc2 = nc3 = nc4 = nc5 = nc6 = nc7 = nc8 = nc9 = nc10 = nc11 = nc12 = NULL
   fsector = fdairy = dairy = farable = arable = ftree_nursery = tree_nursery = fbulbs = bulbs = NULL
-  oid = NULL
+  oid = bbwp_id = NULL
   code = value_min = value_max =  choices = NULL
 
   # Load bbwp_parms
@@ -155,6 +155,9 @@ bbwp_meas_score <- function(B_SOILTYPE_AGR, B_GWL_CLASS,  A_P_SG, B_SLOPE_DEGREE
       dt[grepl('veen', B_SOILTYPE_AGR) & peat == FALSE , c(cols) := 0]
       dt[grepl('loess', B_SOILTYPE_AGR) & loess == FALSE , c(cols) := 0]
 
+      # adapt the score for slope dependent
+      dt[B_SLOPE_DEGREE <= 2 & bbwp_id == 'G21',c(cols) := 0]
+
   # add impact score for measure per opportunity index
   dt[, D_MEAS_NGW := D_OPI_NGW * effect_ngw]
   dt[, D_MEAS_NSW := D_OPI_NSW * effect_nsw]

R/er_croprotation.R

@@ -9,11 +9,6 @@
 #' @param B_LU_PRODUCTIVE_ER (boolean) does the crop fall within the ER category "productive"
 #' @param B_LU_CULTIVATED_ER (boolean) does the crop fall within the ER category "cultivated"
 #' @param B_AER_CBS (character) The agricultural economic region in the Netherlands (CBS, 2016)
-#' @param B_CT_SOIL (numeric) the target value for soil quality conform Ecoregeling scoring  (score / ha)
-#' @param B_CT_WATER (numeric) the target value for water quality conform Ecoregeling scoring (score / ha)
-#' @param B_CT_CLIMATE (numeric) the target value for climate conform Ecoregeling scoring (score / ha)
-#' @param B_CT_BIO (numeric) the target value for biodiversity conform Ecoregeling scoring (score / ha)
-#' @param B_CT_LANDSCAPE (numeric) the target value for landscape quality conform Ecoregeling scoring (score / ha)
 #' @param B_AREA (numeric) the area of the field (m2) 
 #' @param sector (string) a vector with the farm type given the agricultural sector (options: 'dairy', 'arable', 'tree_nursery', 'bulbs')
 #' @param measures (list) The measures planned / done per fields
@@ -26,7 +21,6 @@
 er_croprotation <- function(B_SOILTYPE_AGR, B_AER_CBS,B_AREA,
                             B_LU_BBWP,B_LU_BRP, 
                             B_LU_ARABLE_ER, B_LU_PRODUCTIVE_ER,B_LU_CULTIVATED_ER,
-                            B_CT_SOIL, B_CT_WATER,B_CT_CLIMATE,B_CT_BIO,B_CT_LANDSCAPE,
                             measures, sector){
 
   # add visual bindings
@@ -59,18 +53,13 @@ er_croprotation <- function(B_SOILTYPE_AGR, B_AER_CBS,B_AREA,
   checkmate::assert_logical(B_LU_ARABLE_ER,len = arg.length)
   checkmate::assert_logical(B_LU_PRODUCTIVE_ER,len = arg.length)
   checkmate::assert_logical(B_LU_CULTIVATED_ER,len = arg.length)
-  checkmate::assert_numeric(B_CT_SOIL, lower = 0, min.len = 1)
-  checkmate::assert_numeric(B_CT_WATER, lower = 0, min.len = 1)
-  checkmate::assert_numeric(B_CT_CLIMATE, lower = 0, min.len = 1)
-  checkmate::assert_numeric(B_CT_BIO, lower = 0, min.len = 1)
-  checkmate::assert_numeric(B_CT_LANDSCAPE, lower = 0, min.len = 1)
-
+
   # check and update the measure table
   dt.meas.farm <- bbwp_check_meas(dt = measures, eco = TRUE, score = TRUE)
   dt.meas.field <- bbwp_check_meas(dt = NULL, eco = TRUE, score = FALSE)
   dt.meas.eco <- as.data.table(BBWPC::er_measures)
 
-  # subset both measurement tables
+  # subset both measurement tables # Add EB18 here Gerard
   dt.meas.field <- dt.meas.field[grepl('EB1$|EB2$|EB3$|EB8|EB9',eco_id) & level == 'field',]
   dt.meas.farm <- dt.meas.farm[level == 'farm']
 
@@ -101,12 +90,7 @@ er_croprotation <- function(B_SOILTYPE_AGR, B_AER_CBS,B_AREA,
                    B_LU_ARABLE_ER = B_LU_ARABLE_ER, 
                    B_LU_PRODUCTIVE_ER = B_LU_PRODUCTIVE_ER,
                    B_LU_CULTIVATED_ER = B_LU_CULTIVATED_ER,
-                   B_AREA = B_AREA,
-                   B_CT_SOIL = B_CT_SOIL, 
-                   B_CT_WATER = B_CT_WATER,
-                   B_CT_CLIMATE = B_CT_CLIMATE,
-                   B_CT_BIO = B_CT_BIO,
-                   B_CT_LANDSCAPE = B_CT_LANDSCAPE)
+                   B_AREA = B_AREA)
 
   # add regional correction value for price
   dt <- merge(dt,dt.er.reward[,.(statcode,reward_cf = er_cf)], 
@@ -126,7 +110,8 @@ er_croprotation <- function(B_SOILTYPE_AGR, B_AER_CBS,B_AREA,
                     dt.meas.eco, 
                     by = c('B_LU_BRP','eco_id'),
                     all.x = TRUE)
-  dt.field[is.na(eco_app),eco_app := 0]
+  dt.field[is.na(eco_app) & !grepl('EG20',eco_id),eco_app := 0]
+  dt.field[is.na(eco_app) & grepl('EG20',eco_id), eco_app := 1]
 
     # columns with the Ecoregelingen ranks and reward
     cols <- c('er_soil','er_water','er_biodiversity','er_climate','er_landscape','er_euro_ha', 'er_euro_farm')
@@ -151,7 +136,7 @@ er_croprotation <- function(B_SOILTYPE_AGR, B_AER_CBS,B_AREA,
     # set the score to zero when not applicable for a given ER combined category
     dt.field[eco_app == 0, c(cols) := 0]
 
-    # set measures not applicable on arable, cultivated or productive land
+    # set measures not applicable on arable, cultivated or productive land (only for measures that are crop rotation based)
     dt.field[B_LU_ARABLE_ER  == TRUE & b_lu_arable_er  == 0, c(cols) := 0]
     dt.field[B_LU_PRODUCTIVE_ER == TRUE & b_lu_productive_er == 0, c(cols) := 0]
     dt.field[B_LU_CULTIVATED_ER  == TRUE & b_lu_cultivated_er == 0, c(cols) := 0]
@@ -252,6 +237,10 @@ er_croprotation <- function(B_SOILTYPE_AGR, B_AER_CBS,B_AREA,
       # adapt the score when measure is not applicable
       dt.meas.farm[fsector == 0, c(cols) := 0]
 
+      # farm measures do not have a field_id
+      scols <- colnames(dt.meas.farm)[grepl('^er_|bbwp_id|bbwp_conflict',colnames(dt.meas.farm))]
+      dt.meas.farm <- unique(dt.meas.farm[,mget(scols)])
+
       # multiply by (political) urgency
       dt3 <- melt(dt.meas.farm, 
                   id.vars = c('bbwp_id','bbwp_conflict'),
@@ -271,6 +260,9 @@ er_croprotation <- function(B_SOILTYPE_AGR, B_AER_CBS,B_AREA,
       dt4[, oid := frank(-total, ties.method = 'first',na.last = 'keep'),by = c('bbwp_conflict')]
       dt4[oid > 1, c(cols) := 0]
 
+      # measure index crop diversificaiton (score dependent on cultivated area)
+      dt4[grepl('B189|B190|B191',bbwp_id), c(cols) := lapply(.SD, function (x) x * dt.farm$area_cultivated / dt.farm$area_farm),.SDcols = cols]
+
       # add correction reward
       cfr <- weighted.mean(x = dt$reward_cf, w = dt$B_AREA)
 

R/er_farm_score.R

@@ -2,7 +2,6 @@
 #'
 #' Estimate the potential to contribute to agronomic and environmental challenges in a region for a farm
 #'
-#' @param S_ER_TOT (numeric) the Ecoregeling score for the integrative opportunity index for each field
 #' @param S_ER_SOIL (numeric) the Ecoregeling scoring index for soil quality for each field
 #' @param S_ER_WATER (numeric) the Ecoregeling scoring index for water quality for each field
 #' @param S_ER_CLIMATE (numeric) the Ecoregeling scoring index for climate for each field
@@ -15,25 +14,25 @@
 #'
 #' @export
 # calculate the opportunities for a set of fields
-er_farm_score <- function(S_ER_TOT,S_ER_SOIL,S_ER_WATER,S_ER_CLIMATE,S_ER_BIODIVERSITY,S_ER_LANDSCAPE, 
+er_farm_score <- function(S_ER_SOIL,S_ER_WATER,S_ER_CLIMATE,S_ER_BIODIVERSITY,S_ER_LANDSCAPE, 
                           S_ER_REWARD, B_AREA){
 
-  code = value_min = value_max = NULL
+  # add visual bindings
+  code = value_min = value_max = S_ER_TOT = NULL
 
   # Load bbwp_parms
   bbwp_parms <- BBWPC::bbwp_parms
 
   # check length of the inputs
-  arg.length <- max(length(S_ER_TOT),length(S_ER_SOIL),length(S_ER_WATER),length(S_ER_CLIMATE),
+  arg.length <- max(length(S_ER_SOIL),length(S_ER_WATER),length(S_ER_CLIMATE),
                     length(S_ER_BIODIVERSITY),length(S_ER_LANDSCAPE),length(B_AREA))
 
   # check inputs
-  checkmate::assert_numeric(S_ER_TOT, lower = 0, upper = 100, len = arg.length)
-  checkmate::assert_numeric(S_ER_SOIL, lower = 0, upper = 100, len = arg.length)
-  checkmate::assert_numeric(S_ER_WATER, lower = 0, upper = 100, len = arg.length)
-  checkmate::assert_numeric(S_ER_CLIMATE, lower = 0, upper = 100, len = arg.length)
-  checkmate::assert_numeric(S_ER_BIODIVERSITY, lower = 0, upper = 100, len = arg.length)
-  checkmate::assert_numeric(S_ER_LANDSCAPE, lower = 0, upper = 100, len = arg.length)
+  checkmate::assert_numeric(S_ER_SOIL, lower = 0, upper = 1000, len = arg.length)
+  checkmate::assert_numeric(S_ER_WATER, lower = 0, upper = 1000, len = arg.length)
+  checkmate::assert_numeric(S_ER_CLIMATE, lower = 0, upper = 1000, len = arg.length)
+  checkmate::assert_numeric(S_ER_BIODIVERSITY, lower = 0, upper = 1000, len = arg.length)
+  checkmate::assert_numeric(S_ER_LANDSCAPE, lower = 0, upper = 1000, len = arg.length)
   checkmate::assert_numeric(B_AREA, lower = bbwp_parms[code == "B_AREA", value_min], upper = bbwp_parms[code == "B_AREA", value_max], len = arg.length)
   checkmate::assert_numeric(S_ER_REWARD, lower = 0, upper = 10000, len = arg.length)
 
@@ -44,19 +43,22 @@ er_farm_score <- function(S_ER_TOT,S_ER_SOIL,S_ER_WATER,S_ER_CLIMATE,S_ER_BIODIV
                    S_ER_CLIMATE = S_ER_CLIMATE,
                    S_ER_BIODIVERSITY = S_ER_BIODIVERSITY,
                    S_ER_LANDSCAPE = S_ER_LANDSCAPE,
-                   S_ER_TOT = S_ER_TOT,
                    S_ER_REWARD = S_ER_REWARD,
                    B_AREA = B_AREA
   )
 
-  # columns with the score of the opportunity indexes
+  # add total score
+  dt[, S_ER_TOT := S_ER_SOIL + S_ER_WATER + S_ER_CLIMATE + S_ER_BIODIVERSITY + S_ER_LANDSCAPE]
+
+  # keep relevant columns 
   cols <- c('S_ER_SOIL','S_ER_WATER','S_ER_CLIMATE','S_ER_BIODIVERSITY','S_ER_LANDSCAPE','S_ER_TOT','S_ER_REWARD')
+  dt <- dt[, mget(c('id',cols))]
 
-  # calculate area weigthed sum of the field indices
+  # calculate area weighted sum of the field indices
   dt <- dt[,lapply(.SD, stats::weighted.mean, w = B_AREA), .SDcols = cols]
 
   # Round the values
-  dt<- dt[, lapply(.SD, round, digits = 0)]
+  dt <- dt[, lapply(.SD, round, digits = 1)]
 
   # return output
   return(dt)