Merge pull request #24 from AgroCares/add_solveconflict

Add solveconflict

DESCRIPTION

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

NEWS.md

@@ -1,6 +1,14 @@
 # Changelog BBWPC
 
-### 0.5.0
+## 0.5.1
+### Changed
+- internal table `bbwp_measures` with column bbwp_conflict
+- avoid additive scoring for conflicting measures in `bbwp_meas_score` and `bbp_meas_rank`
+- avoid additive scoring for conflicting measures in `er_meas_score`
+- add `er_medal` as farm output for `ecoregeling` 
+- tests are updated
+
+## 0.5.0
 ### Added
 - internal table `er_aer_reward`, prepared in dev
 - check and automatic update `B_GWL_CLASS` via function `bbwp_format_aer`, included in all relevant bbwp and er functions, issue #18

R/bbwp_meas_rank.R

@@ -36,7 +36,7 @@ bbwp_meas_rank <- function(B_SOILTYPE_AGR, B_GWL_CLASS,  A_P_SG, B_SLOPE_DEGREE,
   clay = sand= peat = loess = D_MEAS_TOT = effect_costs = id = D_MEAS_PSW = NULL
   crop_cat1 = crop_cat2 = crop_cat3 = crop_cat4 = crop_cat5 = crop_cat6 = crop_cat7 = crop_cat8 = crop_cat9 = NULL
   fsector = fdairy = dairy = farable = arable = ftree_nursery = tree_nursery = fbulbs = bulbs = NULL
-  bbwp_id = NULL
+  bbwp_id = oid = NULL
 
   # check length of the inputs
   arg.length <- max(length(D_OPI_NGW), length(D_OPI_NSW), length(D_OPI_PSW), length(D_OPI_NUE),
@@ -165,29 +165,35 @@ bbwp_meas_rank <- function(B_SOILTYPE_AGR, B_GWL_CLASS,  A_P_SG, B_SLOPE_DEGREE,
   # Calculate total measure score
   dt[, D_MEAS_TOT := (D_MEAS_NGW + D_MEAS_NSW + D_MEAS_PSW + D_MEAS_NUE + D_MEAS_WB ) /  5 - effect_costs * 0.01]
 
+  # set impact of conflict measures to the highest score of those that are selected
+
+  # add sort-id conflicting measures based on total integrative impact
+  dt[, oid := frank(-D_MEAS_TOT, ties.method = 'first',na.last = 'keep'), by = c('id','bbwp_conflict')]
+
+
   # define an empty list
   list.meas <- list()
 
   # select for each field the top5 measures per objective
   for (i in 1:arg.length) {
 
     # Get the overall top measures
-    top_bbwp_tot <- dt[id == i & D_MEAS_TOT > 0, ][order(-D_MEAS_TOT)][1:5,bbwp_id]
+    top_bbwp_tot <- dt[id == i & D_MEAS_TOT > 0, ][order(oid,-D_MEAS_TOT)][1:5,bbwp_id]
 
     # Get the top measures for nitrate losses groundwater
-    top_bbwp_ngw <- dt[id == i & D_MEAS_NGW > 0, ][order(-D_MEAS_NGW)][1:5,bbwp_id]
+    top_bbwp_ngw <- dt[id == i & D_MEAS_NGW > 0, ][order(oid,-D_MEAS_NGW)][1:5,bbwp_id]
 
     # Get the top measures for nitrogen loss surface water
-    top_bbwp_nsw <- dt[id == i & D_MEAS_NSW > 0, ][order(-D_MEAS_NSW)][1:5,bbwp_id]
+    top_bbwp_nsw <- dt[id == i & D_MEAS_NSW > 0, ][order(oid,-D_MEAS_NSW)][1:5,bbwp_id]
 
     # Get the top measures for phosphorus loss surface water
-    top_bbwp_psw <- dt[id == i & D_MEAS_PSW > 0, ][order(-D_MEAS_PSW)][1:5,bbwp_id]
+    top_bbwp_psw <- dt[id == i & D_MEAS_PSW > 0, ][order(oid,-D_MEAS_PSW)][1:5,bbwp_id]
 
     # Get the top measures for water retention and availability
-    top_bbwp_wb <- dt[id == i & D_MEAS_WB > 0, ][order(-D_MEAS_WB)][1:5,bbwp_id]
+    top_bbwp_wb <- dt[id == i & D_MEAS_WB > 0, ][order(oid,-D_MEAS_WB)][1:5,bbwp_id]
 
     # Get the top measures for nutrient use efficiency
-    top_bbwp_nue <- dt[id == i & D_MEAS_NUE > 0, ][order(-D_MEAS_NUE)][1:5,bbwp_id]
+    top_bbwp_nue <- dt[id == i & D_MEAS_NUE > 0, ][order(oid,-D_MEAS_NUE)][1:5,bbwp_id]
 
     # add them to list
     list.meas[[i]] <- data.table(id = i,

R/bbwp_meas_scores.R

@@ -36,6 +36,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
   crop_cat1 = crop_cat2 = crop_cat3 = crop_cat4 = crop_cat5 = crop_cat6 = crop_cat7 = crop_cat8 = crop_cat9 = NULL
   fsector = fdairy = dairy = farable = arable = ftree_nursery = tree_nursery = fbulbs = bulbs = NULL
+  oid = NULL
 
   # check length of the inputs
   arg.length <- max(length(D_OPI_NGW), length(D_OPI_NSW), length(D_OPI_PSW), length(D_OPI_NUE),
@@ -81,7 +82,7 @@ bbwp_meas_score <- function(B_SOILTYPE_AGR, B_GWL_CLASS,  A_P_SG, B_SLOPE_DEGREE
                    D_OPI_WB = D_OPI_WB,
                    D_MEAS_NGW = NA_real_,
                    D_MEAS_NSW = NA_real_,
-                   D_MEAS_PSE = NA_real_,
+                   D_MEAS_PSW = NA_real_,
                    D_MEAS_NUE = NA_real_,
                    D_MEAS_WB = NA_real_,
                    D_MEAS_TOT = NA_real_
@@ -155,7 +156,6 @@ 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]
 
-
   # 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]
@@ -169,6 +169,14 @@ bbwp_meas_score <- function(B_SOILTYPE_AGR, B_GWL_CLASS,  A_P_SG, B_SLOPE_DEGREE
   # Calculate total measure score
   dt[, D_MEAS_TOT := (D_MEAS_NGW + D_MEAS_NSW + D_MEAS_PSW + D_MEAS_NUE + D_MEAS_WB ) /  5]
 
+  # set impact of conflict measures to the highest score of those that are selected
+
+    # sort conflicting measures based on total integrative impact
+    dt[, oid := frank(-D_MEAS_TOT, ties.method = 'first',na.last = 'keep'), by = c('id','bbwp_conflict')]
+
+    # remove the measures that are duplicated
+    dt <- dt[oid==1 | is.na(oid)]
+
   # calculate the total impact of measures on the five opportunity indexes (in units of effectiveness, from -2 to +2 per measure)
   dt.meas <- dt[ ,lapply(.SD, sum), .SDcols = scols, by = 'id']
 

R/er_main.R

@@ -112,6 +112,9 @@ ecoregeling <- function(B_SOILTYPE_AGR, B_LU_BRP, B_LU_BBWP,B_GWL_CLASS, B_SLOPE
     # Add field id
     setnames(dt.fields,'id','field_id')
 
+    # add fake medal for the moment
+    dt.farm$er_medal <- 'silver'
+
     # set output object
     out <- list(farm = as.list(dt.farm),fields = dt.fields)
 

R/er_meas_scores.R

@@ -21,6 +21,7 @@ er_meas_score <- function(B_SOILTYPE_AGR, B_LU_BRP,B_LU_BBWP,B_AER_CBS, measures
   crop_cat1 = crop_cat2 = crop_cat3 = crop_cat4 = crop_cat5 = crop_cat6 = crop_cat7 = crop_cat8 = crop_cat9 = NULL
   soiltype = peat = clay = sand = silt = loess = NULL
   patterns = indicator = erscore = urgency = reward = value = NULL
+  total = biodiversity = climate = landscape = soil = water = oid = NULL
 
   # reformat B_AER_CBS
   B_AER_CBS <- bbwp_format_aer(B_AER_CBS)
@@ -99,7 +100,7 @@ er_meas_score <- function(B_SOILTYPE_AGR, B_LU_BRP,B_LU_BBWP,B_AER_CBS, measures
     dt[grepl('zand|dal', B_SOILTYPE_AGR) & sand == FALSE , c(cols) := 0]
     dt[grepl('veen', B_SOILTYPE_AGR) & peat == FALSE , c(cols) := 0]
     dt[grepl('loess', B_SOILTYPE_AGR) & loess == FALSE , c(cols) := 0]
-
+    
   # multiply by (political) urgency
 
     # first add soil type for political and environmental urgency
@@ -110,7 +111,7 @@ er_meas_score <- function(B_SOILTYPE_AGR, B_LU_BRP,B_LU_BBWP,B_AER_CBS, measures
 
     # melt dt
     dt <- melt(dt,
-               id.vars = c('id','bbwp_id','soiltype'),
+               id.vars = c('id','bbwp_id','soiltype','bbwp_conflict'),
                measure = patterns(erscore = "^er_"),
                variable.name = 'indicator',
                value.name = 'value')
@@ -119,12 +120,20 @@ er_meas_score <- function(B_SOILTYPE_AGR, B_LU_BRP,B_LU_BBWP,B_AER_CBS, measures
     # merge with urgency table
     dt <- merge(dt,dt.er.urgency, by= c('soiltype','indicator'),all.x = TRUE)
 
-  # calculate the weighed average ER score (points/ ha) for the whole farm due to measures taken
-  dt.field <- dt[indicator != 'profit',list(erscore = sum(value * urgency)),by = c('id', 'indicator')]
-
-  # dcast the output
-  dt.field <- dcast(dt.field,id~indicator,value.var = "erscore")
+  # adapt the score based on urgency
+  dt[indicator != 'profit', value := value * urgency]
+
+  # dcast to add totals, to be used to update scores when measures are conflicting
 
+    cols <- c('biodiversity', 'climate', 'landscape', 'soil','water','total')
+    dt2 <- dcast(dt, id + soiltype + bbwp_id + bbwp_conflict ~ indicator, value.var = 'value')
+    dt2[, total := biodiversity + climate + landscape + soil + water]
+    dt2[, oid := frank(-total, ties.method = 'first',na.last = 'keep'), by = c('id','bbwp_conflict')]
+    dt2[oid > 1, c(cols) := 0]
+
+  # calculate the weighed average ER score (points/ ha) for the whole farm due to measures taken
+  dt.field <- dt2[,lapply(.SD,sum), .SDcols = cols, by = 'id']
+
   # calculate total reward per field (euro / ha)
   dt.reward <- dt[indicator == 'profit',list(reward = sum(value)),by = 'id']
 
@@ -133,8 +142,8 @@ er_meas_score <- function(B_SOILTYPE_AGR, B_LU_BRP,B_LU_BBWP,B_AER_CBS, measures
 
   # setnames
   setnames(dt.field,
-           c('biodiversity', 'climate', 'landscape', 'soil','water'),
-           c('D_MEAS_BIO', 'D_MEAS_CLIM', 'D_MEAS_LAND', 'D_MEAS_SOIL', 'D_MEAS_WAT'))
+           c('biodiversity', 'climate', 'landscape', 'soil','water','total'),
+           c('D_MEAS_BIO', 'D_MEAS_CLIM', 'D_MEAS_LAND', 'D_MEAS_SOIL', 'D_MEAS_WAT','D_MEAS_TOT'))
 
   # order to ensure field order
   setorder(dt.field, id)

tests/testthat/test-bbwp.R

@@ -224,14 +224,14 @@ test <- bbwp(B_SOILTYPE_AGR = c('dekzand', 'loess', 'rivierklei'),
   test_that("check bbwp", {
     expect_equal(
       object = test$fields$s_bbwp_tot,
-      expected = c(81,17,55),
+      expected = c(100,17,8),
       tolerance = 0.01)
   })
 
   test_that("check bbwp", {
     expect_equal(
       object = as.numeric(unlist(test$farm)),
-      expected = c(53,73,56,56,50,96),
+      expected = c(62,92,55,55,72,95),
       tolerance = 0.01)
   })
 

tests/testthat/test-bbwp_check_meas.R

@@ -8,7 +8,7 @@ test <- bbwp_check_meas(dt = NULL,eco = FALSE, score = FALSE)
 test_that("check bbwp_check_meas", {
   expect_equal(
     object = dim(test),
-    expected = c(139,48),
+    expected = c(139,49),
     tolerance = 0.01)
 })
 
@@ -19,7 +19,7 @@ test <- bbwp_check_meas(dt = NULL,eco = TRUE, score = FALSE)
 test_that("check bbwp_check_meas", {
   expect_equal(
     object = dim(test),
-    expected = c(67,48),
+    expected = c(67,49),
     tolerance = 0.01)
 })
 
@@ -29,7 +29,7 @@ test <- bbwp_check_meas(dt = NULL,eco = TRUE, score = TRUE)
 test_that("check bbwp_check_meas", {
   expect_equal(
     object = dim(test),
-    expected = c(0,49),
+    expected = c(0,50),
     tolerance = 0.01)
 })
 
@@ -47,7 +47,7 @@ test <- bbwp_check_meas(dt = measures,eco = TRUE, score = TRUE)
 test_that("check bbwp_check_meas", {
   expect_equal(
     object = dim(test),
-    expected = c(14,49),
+    expected = c(14,50),
     tolerance = 0.01)
 })
 
@@ -57,7 +57,7 @@ test <- bbwp_check_meas(dt = measures,eco = TRUE, score = FALSE)
 test_that("check bbwp_check_meas", {
   expect_equal(
     object = dim(test),
-    expected = c(68,48),
+    expected = c(68,49),
     tolerance = 0.01)
 })
 

tests/testthat/test-bbwp_field_scores.R

@@ -1,22 +1,22 @@
 
-  # # default inputs for testing
-  # B_SOILTYPE_AGR = c('dekzand', 'loess', 'rivierklei') 
+  ## default inputs for testing
+  # B_SOILTYPE_AGR = c('dekzand', 'loess', 'rivierklei')
   # B_GWL_CLASS = c('-', 'GtI', 'GtV')
   # A_P_SG = c(0.4, 0.8, 1)
   # B_SLOPE_DEGREE = c(1.5,4,1.5)
   # B_LU_BRP = c(265, 1932, 266)
   # B_LU_BBWP = c(1,4,1)
   # M_DRAIN = c(TRUE, FALSE, TRUE)
   # D_SA_W = c(0, 0.5, 1)
-  # D_RISK_NGW = c(0, 0.5 ,1) 
+  # D_RISK_NGW = c(0, 0.5 ,1)
   # D_RISK_NSW = c(0, 0.5, 1)
   # D_RISK_PSW = c(0, 0.5, 1)
   # D_RISK_NUE = c(0, 0.5, 1)
   # D_RISK_WB= c(0, 0.5, 1)
-  # B_GWP = c(TRUE, FALSE, TRUE) 
+  # B_GWP = c(TRUE, FALSE, TRUE)
   # B_AREA_DROUGHT = c(TRUE, FALSE, TRUE)
   # B_CT_PSW = c(0, 25, 50)
-  # B_CT_NSW = c(0, 50, 100) 
+  # B_CT_NSW = c(0, 50, 100)
   # B_CT_PSW_MAX = 0.5
   # B_CT_NSW_MAX = 5.0
   # measures = NULL
@@ -102,12 +102,12 @@ test_that("check bbwp_field_scores", {
   expect_equal(
     object = test,
     expected = data.table(
-      S_BBWP_NGW = c(99,53,27),
-      S_BBWP_NSW = c(100,0,88),
-      S_BBWP_PSW = c(100,0,75),
-      S_BBWP_NUE = c(99,53,31),
-      S_BBWP_WB = c(100,53,41),
-      S_BBWP_TOT = c(100,16,45)
+      S_BBWP_NGW = c(100,53,2),
+      S_BBWP_NSW = c(100,0,0),
+      S_BBWP_PSW = c(100,0,0),
+      S_BBWP_NUE = c(100,53,3),
+      S_BBWP_WB = c(100,53,2),
+      S_BBWP_TOT = c(100,16,1)
     ),
     tolerance = 0.01)
 })

tests/testthat/test-bbwp_meas_rank.R

@@ -53,7 +53,7 @@ test_that("check bbwp_meas_rank", {
 test_that("check bbwp_meas_rank", {
   expect_equal(
     object = test$top_bbwp_tot[c(1,2,7,12,15)],
-    expected = c(NA,"G21","G20","G66","G54"),
+    expected = c(NA,"G21","G20","G66","G17"),
     tolerance = 0.01)
 })
 
@@ -102,7 +102,7 @@ test_that("check bbwp_meas_rank", {
 test_that("check bbwp_meas_rank", {
   expect_equal(
     object = test$top_bbwp_tot[c(1,2,5,9,16)],
-    expected = c("G68","G27","B132","BWP7","G66"),
+    expected = c("G68","G27","B131","BWP7","G66"),
     tolerance = 0.01)
 })
 

tests/testthat/test-er.R

@@ -1,20 +1,21 @@
 require(testthat)
 
   # # default input for testing
-  B_SOILTYPE_AGR = c('dekzand', 'loess', 'rivierklei')
-  B_GWL_CLASS = c('GtIII', 'GtI', 'GtV')
-  A_P_SG = c(0.4, 0.8, 1)
-  B_SLOPE_DEGREE = c(1.5,4,1.5)
-  B_AER_CBS = c('LG05','LG14','LG02')
-  B_LU_BRP = c(265, 1932, 266)
-  B_LU_BBWP = c(1,4,1)
-  M_DRAIN = c(TRUE, FALSE, TRUE)
-  D_SA_W = c(0, 0.5, 1)
-  D_AREA = c(100,80,2.5)
-  measures = NULL
-  farmscore = 100
-  sector = c('dairy', 'arable')
-  output = 'scores'
+  # B_SOILTYPE_AGR = c('dekzand', 'loess', 'rivierklei')
+  # B_GWL_CLASS = c('GtIII', 'GtI', 'GtV')
+  # B_AER_CBS = c('LG05','LG14','LG02')
+  # A_P_SG = c(0.4, 0.8, 1)
+  # B_SLOPE_DEGREE = c(1.5,4,1.5)
+  # B_AER_CBS = c('LG05','LG14','LG02')
+  # B_LU_BRP = c(265, 1932, 266)
+  # B_LU_BBWP = c(1,4,1)
+  # M_DRAIN = c(TRUE, FALSE, TRUE)
+  # D_SA_W = c(0, 0.5, 1)
+  # D_AREA = c(100,80,2.5)
+  # measures = NULL
+  # farmscore = 100
+  # sector = c('dairy', 'arable')
+  # output = 'scores'
 
 # run example 1 without any measures taken
 test <- ecoregeling(B_SOILTYPE_AGR = c('dekzand', 'loess', 'rivierklei'),
@@ -56,8 +57,8 @@ test <- ecoregeling(B_SOILTYPE_AGR = c('dekzand', 'loess', 'rivierklei'),
 
   test_that("check ecoregeling", {
     expect_equal(
-      object = as.numeric(unlist(test$farm)),
-      expected = c(6,9,6,11,6,0,460),
+      object = as.character(unlist(test$farm)),
+      expected = c(6,9,6,11,6,0,460,'silver'),
       tolerance = 0.01)
   })
 
@@ -92,14 +93,14 @@ test <- ecoregeling(B_SOILTYPE_AGR = c('dekzand', 'loess', 'rivierklei'),
   test_that("check ecoregeling", {
     expect_equal(
       object = test$fields$s_er_tot,
-      expected = c(20,6,43),
+      expected = c(36,6,40),
       tolerance = 0.01)
   })
 
   test_that("check ecoregeling", {
     expect_equal(
-      object = as.numeric(unlist(test$farm)),
-      expected = c(14,14,15,29,13,8,682),
+      object = as.character(unlist(test$farm)),
+      expected = c(23,23,27,51,16,15,802,'silver'),
       tolerance = 0.01)
   })
 
@@ -132,4 +133,5 @@ test <- ecoregeling(B_SOILTYPE_AGR = c('dekzand', 'loess', 'rivierklei'),
       object = test$measures[[1]]$top_er_tot,
       expected = c('B156','B133','G50'))
   })
+