From 1b5b47788bfeb378474976a59d9ad7751078ba85 Mon Sep 17 00:00:00 2001 From: Sven Verweij <37927107+SvenVw@users.noreply.github.com> Date: Fri, 3 May 2024 11:12:57 +0200 Subject: [PATCH 1/9] Add p_type_manure and p_p_wcl to dataset --- R/dataset.R | 2 +- data-raw/fertilizers.R | 7 +++++++ data/fertilizers.rda | Bin 2616 -> 2788 bytes 3 files changed, 8 insertions(+), 1 deletion(-) diff --git a/R/dataset.R b/R/dataset.R index 456484c..f59a895 100644 --- a/R/dataset.R +++ b/R/dataset.R @@ -49,7 +49,7 @@ createApusDataset <- function(farms = NULL, cultivations, fertilizers, fields_ma fertilizers[, p_stored := 0] fertilizers[, p_price := 1] - fertilizers <- fertilizers[, c('p_stored', 'p_price', 'p_n_rt', 'p_n_wc', 'p_p_rt', 'p_k_rt')] + fertilizers <- fertilizers[, c('p_stored', 'p_price', 'p_n_rt', 'p_n_wc', 'p_p_rt', 'p_k_rt', 'p_type_manure', 'p_p_wcl')] self$fertilizers <- torch::torch_tensor(as.matrix(fertilizers), device = device) }, diff --git a/data-raw/fertilizers.R b/data-raw/fertilizers.R index a5cec45..1bbeb3a 100644 --- a/data-raw/fertilizers.R +++ b/data-raw/fertilizers.R @@ -13,5 +13,12 @@ token <- '' fertilizers <- fread(paste0('https://raw.githubusercontent.com/AgroCares/pandex/main/data-raw/b_fp/b_fp_srm.csv?token=', token)) setnames(fertilizers, colnames(fertilizers), tolower(colnames(fertilizers))) +fertilizers[, p_type_manure := fifelse(p_type_manure, 1, 0)] +fertilizers[, p_p_wcl := 1] +fertilizers[p_type_compost == TRUE, p_p_wcl := 0.25] +fertilizers[p_name_nl == 'Champost', p_p_wcl := 0.75] +fertilizers[p_name_nl == 'Rundvee vaste mest', p_p_wcl := 0.75] + + # Export table ------------------------------------------------------------ usethis::use_data(fertilizers, overwrite = TRUE, version = 3, compress = 'xz') diff --git a/data/fertilizers.rda b/data/fertilizers.rda index adfedbf4ef59825a39c70f7caec260e2c7b1ed51..5b860b78a34e0aad1552e6d54fd65b92062fb960 100644 GIT binary patch literal 2788 zcmVvQ&2UKVgRpfkl* zy7}J8y%(LSVlrVEGvG*o*df4odNVNmpdGuLNU1?48G!Jc;e%)kv=`%3a``I=RggL* zKaO)9W91PS{3$&hfwb8hnGR~Ldvct_hD@R*K#{c5wk^c*U-dvJ#^kENhNK7%7dQWF-1CFGbhGeBw zAfijY;MoEN`vsX!E{^JFQ&DwiBkh!p{^@iQZiGAUO`YXBFlY!~6)P|gog@ProFO=q zTz7fx*^J7>jYMyhm$f@Ww3Kzj=-I!nz8e$v@+vhv!)>}DMlXTm^;*%9G z;gKG-?e-b$53fCzj60R3Nr_IYiLMYp*|IXoY*@i_oCA;J$v*ec^_J!p9M0irycA7{ z!1;H%H>x)QO4Jbf*eLQ;{oxKPe>f&WWzm-IADCn)*?r_nx%xu=%)h<~Oq?j}ay*f&x6>|L^TZ02)H{r^Z}ENFlCr;S8!+UW+=D!r z2<#CoV~Z{-qedwk`E&(Pjh&auhu$yA^5hsoY`u>-bgj*avWG7_XM!bsDI=7d{E1Yd z7ML{V?5sozs#vZ|IG-_UHufWXU;f1x{!6b2?uC_<{V-?#%L&`J%K7ADAoq6}sUftj@r~%WW zb`rCrzE;AFLD>H?x^hjWh$(>%Qc_b{SA~fLDo&pL^_pE#GwG9dv3MRuD*S-r!p0aM zVN)nF@xzQ{dYZa?jwwV%-3RS*i6f5I zT2&rd2o8Hux_{zzV{u^M^8rh&A0*IQ$TVPTx02FFz3(lXV8n~?Le7Zdhnj;v=i~i@ z=FS+J#-@hjyR669y7!7_Os*p9^cZ#UmmA<<_@S#c8d3>sz_Z7HjxEQJg@DArwQ_x^ zsMoX~pCKr%#=9G6BC{mQautPL;!6PvT}(uKY#7X_9cx9Jsm@|tPgu{0!C`H8xziFc zt<;ZQq>3p!iBSkCGqY@gFl;ep_w=g6wO=9#%dqQa$uq7%OR;-L)te>Fv)9=%F3w2y zi72GXD(F*nGJ&52UHuX&3@msl&+(SONvhawvPJ{`hEZOP{;maCN8O#4cu|5cs{~;5 z%RFCqK_FD5DLVfJXuR||V%L%Nhf$MIV{#6`2HJk5Kd@urS2{~ZJp{X9;TTlv$lRAZ z)mgPjEGTnbH65$-maBh0H6(_`8O^tN+&RasP3YADsN6-$9c=`Dl(z-5?(@^ndnnPo z(1DRkslZ_K$B>FyTm^OLGGz?L%P7%|?_vWx)p8UZnc8Mep^%QPQv>i$p3bD4gjKo> z*3|m2U7rQKlw-`5r?xQ2jQ|JFMk_o^G1~siYVrm&>1B%6i;r)&VYi=h3%sRpS*ja| ze=(oD8{VXhX2Z5s1wSRQj@?6=j!%O_c6V{v8QrVp8&V-_0SudWf>4aZ{V@_$K0#nm zu)V)$O1OKC(4Zrp*wlxQR56r_yR-y>Z6gRxWc}}awrs^+10yEP& zVj6`kQ2VmRaazqq=K>~TQ|C1kc*IEDjmxzelm?J;`A;{=9AF;fDnxPNP=u2#u0R1H z#XNEV9v+3Lw!5^Iqkj3PV_ESoJ>It?H#opa!%^o2yT`S2%xfY{I2I)2Oppor`QyF4Fcagvl#^o8M!xInr5%j4sJ#CaC2T z>~E1pD|+MurTYU>{Xz3DYII88X2*MlJ|5*r>n}P$C4$Xe0Q+u8>(*fKL|pgydn+HR znAj8b$AWQ6el}^_w?(t&o8+Sj95B(t70XjDK|qO*=y7^M#Ez%70&p^5D;dRWbakt= zC-dv_gb2&(R4|$5-Qu{dm9KOS{WN>x34S%sVcec8A|EoF?p=ZS26nv>E>2c4iwnnn z-8f@WVO3xUH+(9mDG>H3=9fRh<0<^Q?}=XxcUPens|qeRFtM1VS#!v0jZ|H7joBco zwJT#oVtK=QoYB#zTY!ifE@o&Eb7|^D{-5|(HAqJi+^Q)t1Y`fvElXlNeFMWm3W6uS z-9+_3@zI|VR( zNxsL*ztz{%&?-`oVJr$+hZxc@ie4{O#r%MCddP@;HZ7JU)Q*`b^Fv_>xZpM%q& zBf46PI>PePymyh3v(2vg}^GJ#BeF59vJ!#Bgs?uT7HBtikaSYaSa zmk`8b;T}bV{{lQROrT?` zX_(L?GBE#O_ZIqimcrWc!FlCEbsP0|{c?+7FLHq&39>9{!*0&k8Ww+BjB<9{D<1r2 zy2d(mM{rb923A9w0lG(XyagMTle-&p1BFN=LPcx28Ku}eLy4r9PQKQT003~7D<+)Q z9HO5puje5CpCs?AH^TrP7*hG7kk8p@yNzG9R>O29;rtUzQv}&Qk}q!zNbB5l#(jB;kg$}28T7*EX!%_(S)d>a0NO)$bYE;O3rz)mqXBqn%KFu>GlyMOa+Jq z;l>%P&xN4KdPC?{5wgF{jp+$ghx^JYYQK_+a$bmyT%3!&M=?F$`DdhVru22 qVr-7y{uxMbh5!Kc6zDww0lyXHcK`rTqSi1zFb#_W000000a;oO+(g;{ literal 2616 zcmV-83di;RH+ooF0004LBHlIv03iV!0000G&sfahH>L^uT>vQ&2UKVgRpfklJ zl5LXH8q(0&dr0P~9R`|E3#NW1eZ?wIbVLH_eX$h#UIyy~J4epxcryqlIa%KDVUq6$ z+vINsBZqF}aJcG6XC#kHq$X?{>W7t6`x%&1?8Q{F&Q>r~A(N*n4*386W>2wx7tF7h zMw@c$;shW))3eg_H4N!k+X^;S$wMEWJ8?f0r<*dUq9%QtL5^zYe@+O5aCLj4r)1|%2acoy-lu=tmz3o($f@*coSH^^F)>7PbiZY4qnx%;nmQ8Xl&^);E|7Nsk(oV z{1-|g6hdvWI?NOmXYdg8{cFTq@JCj=_sGd2eFcK$AElrU&G!0r6XEiwXghI-ed%bo zlVD9p3b{`#3mo(I(7gW%VvXhe&egt1^#M7NiKlG?CW%gWXyiBpYc4TQ5bTWDVr649 z-VFDwrIt4Cl!U(X0{;y!m3XDQ4Rj0S52<=pTB9VL7Od7KQ$XS zAS8WBAo`uN&g+v*xohM&MIF+52rV>^)L6%p13_d;cr-*90Z3lOg1HcQxNQBzNhs%< z*|OQ0-)sGB;?N-6SLnQM42J1)X@Ro4`AUbN8CaQP3Xv8l7lv2?RzCjG&WSsa`Qr+s z9hKXqfx3wDX{r2*OJ4clWVEHbj(5OI$*ZQW7dRO{_O(<2VZE^Lsv{@y*uZE_W2@d= zt`RDrSOO9Z;S7W*z2BEj#LrC(O%yfgIdJC z&mbqv=_&#I)L93-i$xGyJ-YQ=LA_x7qZFwc#)ym9=%X%t0kI>gr9U1HZIp}EW5vI$ zAWmsv-mL&2dSbqg{d_mok@e0Hr-q-Dl|~e64#aw~=B~@W#eHJ(qiSykzF%TRh@Ol| zjZMN{E)6yZ;~TXZ_&}%2f!g{-3-3F^Ezzf~@>U?2nhfkSaWv2U5c?@{9n#6Dd<6Ek zaf!OJwh)um{9Bv&lx}B)X=|YKq>bKLH_T<+&Fgu@;@{|c`n$32ICYGgBSCs>1US;K z$*nQW5I31+*(zXvw{DS!dg+e|-&ufVszFKJ@SlDh&Lm3-l1J8MusFpOkq>2!ChiKw zb>c39qz9?8ZYzD!T}0y8bXCdw&@DQHE5a@F{P2^yO`2zD+T|@9$nq^vCo~|rV4fi0 zr0F5!|qA^nq zPdSSiXZZ*~H&*in`?Z|VAc7a-j^Em@Mn0qhb#1T5iJ{2K|NQU{=AE$a77VK=#>CRU zATnf-6Wdesz1wZjH=ozcHQc)@q2O};Oq$K3d(21q*4~h2EXKUG_}<4}lpDS5Adv*s z$o{b3N*8hc!8Y~o1q2kk@MKZ&^T*J$gu=lXE{9~Mky-We#l(^x^Cw^sU#s-|rMDMi z+UB9hOU@X$ikHRt)7!q5>mM!@4aa^CfOlbYiggi2a}V@}gP;o`+^9(msz*>$&b;tW z&C(L6OT4GN&;hkHgj4==hBz$>?h4DBiS@T_){Kg|bDd-UOqjVgS0Plm**Z>kbWRUV z3F}?J0}s&o!PqwvjLiY57>Y-y&qAc^+DI^2;-F;CK`Ef76pF3U_!A82J4`;rj7U8H zwgFh#7ajpxd|Xc2b5>YBNYl|4H2n9vV6?)jvkFifnQM%6kqiFoJ;s5Zl^e3%+70I> z5@&^GMt%1GkC47x{V6huvm&?NDr`!0GgRB+Dy(yjftiOQ23 z)sqP$M{Ou%ej-rLUnj25UT9#(39PO}bdkWQ=_c&JSuDH?=Zg;=<%Mbz`H=8r97VQa z*qt)m`Ou4-<-GIS+2&=mh=T@@D~&7B`+=~;gs0(wr_jk#0rEep;kDA=QH>~?*@UcC zL_l?;gXyxX?|kk!tX?@-ZJQD_&@r^&P;?VQ_-bfPZy(jG?`!5zX)NVa8Iky}r?3!R zO3}Qtx}=8ATwSK;>|_<%(5`hZ3p8J)Q3c-ANZIy{ilMa#BOTFNDrIBtW` zqp>jVYy7p~8K;mu;W{Ue?Zv)vL~!&he9Q58Jxa3Oy64gyd$ObZ+ek~a04p~Yi`2YM1en|yFR{!PJeT$7#D8_no*)ET8-@dXwC`@&eHo6D?q5W zPygAjBgtgI7m2XNW7hW+g%O;eVQq0B2Xbj9Bx2oRbIVRVnm4AM|6juxk~6}TB#R*eGk%b@-?l5_M;S~ z5Lx{qz;v From aac33fb2e097538f8041b181a6a83b2769b44f93 Mon Sep 17 00:00:00 2001 From: Sven Verweij <37927107+SvenVw@users.noreply.github.com> Date: Fri, 3 May 2024 13:17:56 +0200 Subject: [PATCH 2/9] Add module 5: penalties for exceeding legal limit --- DESCRIPTION | 1 + NEWS.md | 2 +- R/apus.R | 4 +- R/dataset.R | 12 +++-- R/model.R | 81 ++++++++++++++++++++++++++++--- man/createApusDataset.Rd | 11 ++++- man/fertilizers.Rd | 2 +- tests/testthat/test-001-dataset.R | 10 ++-- tests/testthat/test-002-model.R | 12 +++-- 9 files changed, 113 insertions(+), 22 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 684ebca..f6e56ec 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -33,6 +33,7 @@ Imports: R6, torch Suggests: + devtools, testthat (>= 3.0.0) Config/testthat/edition: 3 Depends: diff --git a/NEWS.md b/NEWS.md index 667bc2b..745bb5c 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,5 +2,5 @@ ## Added * Adds `apus` object with the functions `addField`, `trainModel` and `optimizeFertilizerChoice` -* Adds for the cost function module 1 and 2 +* Adds for the cost function module 1,4 and 5 * Adds default table for `cultivations`, `fertilizers`, `parameters` and `fines` diff --git a/R/apus.R b/R/apus.R index 3a23644..8df9553 100644 --- a/R/apus.R +++ b/R/apus.R @@ -168,6 +168,7 @@ Apus <- R6::R6Class( dataset.train <- createApusDataset(farms = NULL, cultivation = self$cultivation, fertilizers = self$fertilizers, + fines = self$fines, fields_max = self$fields_max, device = device) @@ -177,6 +178,7 @@ Apus <- R6::R6Class( dataset.valid <- createApusDataset(farms = farms.valid, cultivation = self$cultivation, fertilizers = self$fertilizers, + fines = self$fines, fields_max = self$fields_max, device = device) @@ -217,7 +219,7 @@ Apus <- R6::R6Class( fields[is.na(fields)] <- 0 } - dataset <- createApusDataset(farms = fields, cultivations = self$cultivations, fertilizers = self$fertilizers, fields_max = self$fields_max, device = self$device) + dataset <- createApusDataset(farms = fields, cultivations = self$cultivations, fertilizers = self$fertilizers, fines = self$fines, fields_max = self$fields_max, device = self$device) dl <- torch::dataloader(dataset, batch_size = 1) diff --git a/R/dataset.R b/R/dataset.R index f59a895..4c3525b 100644 --- a/R/dataset.R +++ b/R/dataset.R @@ -6,6 +6,7 @@ #' @param farms (data.table) #' @param cultivations (data.table) #' @param fertilizers (data.table) +#' @param fines (data.table) #' @param fields_max (integer) #' @param device (character) #' @@ -15,7 +16,7 @@ #' @import torch #' #'@export -createApusDataset <- function(farms = NULL, cultivations, fertilizers, fields_max, device) { +createApusDataset <- function(farms = NULL, cultivations, fertilizers, fines, fields_max, device) { transformfieldsToTensor = createSyntheticfields = code = fields_count = self = NULL size = value_max = value_min = p_price = p_stored = b_id_farm = b_id_field = NULL @@ -27,7 +28,7 @@ createApusDataset <- function(farms = NULL, cultivations, fertilizers, fields_ma apus_dataset <- torch::dataset( name = "apus_dataset", - initialize = function(farms = NULL, cultivations, fertilizers, fields_max, device) { + initialize = function(farms = NULL, cultivations, fertilizers, fines, fields_max, device) { # Check arguments ----------------------------------------------------- # TODO @@ -45,6 +46,9 @@ createApusDataset <- function(farms = NULL, cultivations, fertilizers, fields_ma self$farms_count <- 100 } + fines <- dcast(fines, . ~ norm, value.var = 'fine')[, 2:4] + self$fines <- torch::torch_tensor(as.matrix(fines), device = device) + # Set temporary fertilizers[, p_stored := 0] fertilizers[, p_price := 1] @@ -63,7 +67,7 @@ createApusDataset <- function(farms = NULL, cultivations, fertilizers, fields_ma } t.fields <- transformFieldsToTensor(farms, self$device) - return(list(fields = t.fields, fertilizers = self$fertilizers)) + return(list(fields = t.fields, fertilizers = self$fertilizers, fines = self$fines)) }, .length = function() { @@ -73,7 +77,7 @@ createApusDataset <- function(farms = NULL, cultivations, fertilizers, fields_ma # Create torch dataset for apus ------------------------------------------- - dataset <- apus_dataset(farms = farms, cultivations = cultivations, fertilizers = fertilizers, fields_max = fields_max, device = device) + dataset <- apus_dataset(farms = farms, cultivations = cultivations, fertilizers = fertilizers, fines = fines, fields_max = fields_max, device = device) return(dataset) } diff --git a/R/model.R b/R/model.R index 6f24a92..63180a8 100644 --- a/R/model.R +++ b/R/model.R @@ -106,14 +106,14 @@ createApusModel <- function(dataset.train, dataset.valid, width = 12, layers = 1 cli::cli_progress_bar(paste0('Training model [', epoch, '/', epochs, ']'), total = dl.train$.length()) - # For testing + # For developing # b <- dl.train$.iter() # b <- b$.next() # Forward pass optimizer$zero_grad() doses <- model(b$fields, b$fertilizers) - cost <- calculateCost(doses, b$fields, b$fertilizers) + cost <- calculateCost(doses, b$fields, b$fertilizers, b$fines) # Backward pass cost$backward() @@ -133,13 +133,16 @@ createApusModel <- function(dataset.train, dataset.valid, width = 12, layers = 1 cli::cli_progress_bar(paste0('Validating model [', epoch, '/', epochs, ']'), total = dl.valid$.length()) - # For testing + # For developing # b <- dl.valid$.iter() # b <- b$.next() + fields <- b$fields + fertilizers <- b$fertilizers + fines <- b$fines # Forward pass doses <- model(b$fields, b$fertilizers) - cost <- calculateCost(doses, b$fields, b$fertilizers) + cost <- calculateCost(doses, b$fields, b$fertilizers, b$fines) losses.validation <- c(losses.validation, cost$item()) @@ -157,7 +160,7 @@ createApusModel <- function(dataset.train, dataset.valid, width = 12, layers = 1 return(model) } -calculateCost <- function(doses, fields, fertilizers, reduce_batches = TRUE) { +calculateCost <- function(doses, fields, fertilizers, fines, reduce_batches = TRUE) { # Check arguments --------------------------------------------------------- @@ -172,8 +175,12 @@ calculateCost <- function(doses, fields, fertilizers, reduce_batches = TRUE) { module4 <- calculateRevenueModule4(doses, fields, fertilizers) + # Module 5: Penalty for exceeding legal limit ----------------------------- + module5 <- calculatePenaltyModule5(doses, fields, fertilizers, fines) + + # Combine the modules ----------------------------------------------------- - cost <- torch::torch_zeros(dim(module1)) + module1 - module4 + cost <- torch::torch_zeros(dim(module1)) + module1 - module4 + module5 # Convert to € / ha ------------------------------------------------------- @@ -274,3 +281,65 @@ calculateRevenueModule4 <- function(doses, fields, fertilizers) { return(module4) } +# Module 5: Penalties in case of exceeding legal limits ----------------------- +calculatePenaltyModule5 <- function(doses, fields, fertilizers, fines) { + + # Calculate d_n_norm_man per field + fertilizers.p_n_rt <- fertilizers[,,3] + fertilizers.p_type_manure <- fertilizers[,,7] + fertilizers.p_n_manure <- fertilizers.p_n_rt * fertilizers.p_type_manure + fertilizers.p_n_manure <- torch::torch_unsqueeze(fertilizers.p_n_manure, 2) + fertilizers.p_n_manure <- torch::torch_repeat_interleave(fertilizers.p_n_manure, repeats = dim(doses)[2], dim =2) + fields.fertilizers.dose.n_manure <- doses * fertilizers.p_n_manure + fields.dose.n_manure <- torch::torch_sum(fields.fertilizers.dose.n_manure, dim = 3) + farms.dose.n_manure <- torch::torch_sum(fields.dose.n_manure, dim = 2) + + fields.d_n_norm_man <- fields[,,6] + fields.b_area <- fields[,,1] + fine.d_n_norm_man <- fines[,1,2] + farms.d_n_norm_man <- torch::torch_sum(fields.b_area * fields.d_n_norm_man, dim = 2L) + farms.exceeding.d_n_norm_man <- torch::torch_relu(farms.dose.n_manure - farms.d_n_norm_man) + farms.penalty.d_n_norm_man <- farms.exceeding.d_n_norm_man * fine.d_n_norm_man + + # Calculate d_n_norm per field + fertilizers.p_n_rt <- fertilizers[,,3] + fertilizers.p_n_wc <- fertilizers[,,4] # TODO Replace with p_n_wcl + fertilizers.p_n_workable <- fertilizers.p_n_rt * fertilizers.p_n_wc + fertilizers.p_n_workable <- torch::torch_unsqueeze(fertilizers.p_n_workable, 2) + fertilizers.p_n_workable <- torch::torch_repeat_interleave(fertilizers.p_n_workable, repeats = dim(doses)[2], dim =2) + fields.fertilizers.dose.n_workable <- doses * fertilizers.p_n_workable + fields.dose.n_workable <- torch::torch_sum(fields.fertilizers.dose.n_workable, dim = 3) + farms.dose.n_workable <- torch::torch_sum( fields.dose.n_workable , dim = 2) + + fields.d_n_norm <- fields[,,5] + fields.b_area <- fields[,,1] + fine.d_n_norm <- fines[,1,1] + farms.d_n_norm <- torch::torch_sum(fields.b_area * fields.d_n_norm, dim = 2L) + farms.exceeding.d_n_norm <- torch::torch_relu(farms.dose.n_workable - farms.d_n_norm) + farms.penalty.d_n_norm <- farms.exceeding.d_n_norm * fine.d_n_norm + + # Calculate d_p_norm per field + fertilizers.p_p_rt <- fertilizers[,,5] + fertilizers.p_p_wcl <- fertilizers[,,8] + fertilizers.p_p_legal <- fertilizers.p_p_rt * fertilizers.p_p_wcl + fertilizers.p_p_legal <- torch::torch_unsqueeze(fertilizers.p_p_legal, 2) + fertilizers.p_p_legal <- torch::torch_repeat_interleave(fertilizers.p_p_legal, repeats = dim(doses)[2], dim =2) + fields.fertilizers.dose.p_legal <- doses * fertilizers.p_p_legal + fields.dose.p_legal <- torch::torch_sum(fields.fertilizers.dose.p_legal, dim = 3) + farms.dose.p_legal <- torch::torch_sum( fields.dose.p_legal, dim = 2) + + fields.d_p_norm <- fields[,,7] + fields.b_area <- fields[,,1] + fine.d_p_norm <- fines[,1,3] + farms.d_p_norm <- torch::torch_sum(fields.b_area * fields.d_p_norm, dim = 2L) + farms.exceeding.d_p_norm <- torch::torch_relu(farms.dose.p_legal - farms.d_p_norm) + farms.penalty.d_p_norm <- farms.exceeding.d_p_norm * fine.d_p_norm + + + # Combine the penalties + module5 <- farms.penalty.d_n_norm_man + farms.penalty.d_n_norm + farms.penalty.d_p_norm + + return(module5) +} + + diff --git a/man/createApusDataset.Rd b/man/createApusDataset.Rd index 2a7b67f..29915b2 100644 --- a/man/createApusDataset.Rd +++ b/man/createApusDataset.Rd @@ -4,7 +4,14 @@ \alias{createApusDataset} \title{A torch dataset for apus} \usage{ -createApusDataset(farms = NULL, cultivations, fertilizers, fields_max, device) +createApusDataset( + farms = NULL, + cultivations, + fertilizers, + fines, + fields_max, + device +) } \arguments{ \item{farms}{(data.table)} @@ -13,6 +20,8 @@ createApusDataset(farms = NULL, cultivations, fertilizers, fields_max, device) \item{fertilizers}{(data.table)} +\item{fines}{(data.table)} + \item{fields_max}{(integer)} \item{device}{(character)} diff --git a/man/fertilizers.Rd b/man/fertilizers.Rd index a5475ee..938d509 100644 --- a/man/fertilizers.Rd +++ b/man/fertilizers.Rd @@ -5,7 +5,7 @@ \alias{fertilizers} \title{Fertilizers table} \format{ -An object of class \code{data.table} (inherits from \code{data.frame}) with 47 rows and 45 columns. +An object of class \code{data.table} (inherits from \code{data.frame}) with 47 rows and 46 columns. } \usage{ fertilizers diff --git a/tests/testthat/test-001-dataset.R b/tests/testthat/test-001-dataset.R index 5a5c3d2..fac499b 100644 --- a/tests/testthat/test-001-dataset.R +++ b/tests/testthat/test-001-dataset.R @@ -1,10 +1,10 @@ test_that("Create training dataset", { fields_max <- 5 - dataset <- apus::createApusDataset(farms = NULL, cultivations = apus::cultivations, fertilizers = apus::fertilizers, fields_max = fields_max, device = 'cpu') + dataset <- apus::createApusDataset(farms = NULL, cultivations = apus::cultivations, fertilizers = apus::fertilizers, fines = apus::fines, fields_max = fields_max, device = 'cpu') expect_contains(class(dataset), 'apus_dataset') expect_equal(dataset$.length(), dataset$farms_count) expect_contains(class(dataset$.getitem(1)$fields), 'torch_tensor') - expect_setequal(names(dataset$.getitem(1)), c('fields', 'fertilizers')) + expect_setequal(names(dataset$.getitem(1)), c('fields', 'fertilizers', 'fines')) expect_equal(dim(dataset$.getitem(1)$fields), c(dataset$fields_max, 9)) expect_false(identical(dataset$.getitem(1), dataset$.getitem(2))) }) @@ -17,11 +17,11 @@ test_that("Create validation/test dataset", { expect_contains(class(farms), 'data.table') expect_equal(nrow(farms), farms_count * fields_max) - dataset.valid <- apus::createApusDataset(farms = farms, cultivations = apus::cultivations, fertilizers = apus::fertilizers, fields_max = fields_max, device = 'cpu') + dataset.valid <- apus::createApusDataset(farms = farms, cultivations = apus::cultivations, fertilizers = apus::fertilizers, fines = apus::fines, fields_max = fields_max, device = 'cpu') expect_contains(class(dataset.valid), 'apus_dataset') expect_equal(dataset.valid$.length(), dataset.valid$farms_count) expect_contains(class(dataset.valid$.getitem(1)$fields), 'torch_tensor') - expect_setequal(names(dataset.valid$.getitem(3)), c('fields', 'fertilizers')) + expect_setequal(names(dataset.valid$.getitem(3)), c('fields', 'fertilizers', 'fines')) expect_equal(dim(dataset.valid$.getitem(1)$fields), c(fields_max, 9)) dl <- torch::dataloader(dataset.valid, batch_size = farms_count) @@ -30,7 +30,7 @@ test_that("Create validation/test dataset", { expect_contains(class(batch$fields), 'torch_tensor') expect_equal(dim(batch$fields), c(farms_count, fields_max, 9)) - expect_equal(dim(batch$fertilizers), c(farms_count, nrow(apus::fertilizers), 6)) + expect_equal(dim(batch$fertilizers), c(farms_count, nrow(apus::fertilizers), 8)) }) diff --git a/tests/testthat/test-002-model.R b/tests/testthat/test-002-model.R index cc0ec33..138d596 100644 --- a/tests/testthat/test-002-model.R +++ b/tests/testthat/test-002-model.R @@ -3,9 +3,9 @@ farms_count <- 10 fields_max <- 5 -dataset.train <- apus::createApusDataset(farms = NULL, cultivations = apus::cultivations, fertilizers = apus::fertilizers, fields_max = fields_max, device = 'cpu') +dataset.train <- apus::createApusDataset(farms = NULL, cultivations = apus::cultivations, fertilizers = apus::fertilizers, fines = apus::fines, fields_max = fields_max, device = 'cpu') farms.valid <- apus:::createSyntheticFarms(farms_count = farms_count, fields_max = fields_max) -dataset.valid<- apus::createApusDataset(farms = farms.valid, cultivations = apus::cultivations, fertilizers = apus::fertilizers, fields_max = fields_max, device = 'cpu') +dataset.valid <- apus::createApusDataset(farms = farms.valid, cultivations = apus::cultivations, fertilizers = apus::fertilizers, fines = apus::fines, fields_max = fields_max, device = 'cpu') model <- apus::createApusModel(dataset.train, dataset.valid, device = 'cpu', epochs = 2) dl <- torch::dataloader(dataset.train, batch_size = farms_count) @@ -14,6 +14,7 @@ batch <- dl$.iter() batch <- batch$.next() fields <- batch$fields fertilizers <- batch$fertilizers +fines <- batch$fines doses <- model(fields, fertilizers) test_that("Create model and run a forward pass", { @@ -42,9 +43,14 @@ test_that("Calculate revenue for module 4: Revenue of harvested crops", { expect_length(as.numeric(module4), farms_count) }) +module5 <- calculatePenaltyModule5(doses, fields, fertilizers, fines) +test_that("Calculate penalties for module 5: Penalties for exceeding legal limits", { + expect_contains(class(module5), 'torch_tensor') + expect_length(as.numeric(module5), farms_count) +}) -cost <- calculateCost(doses, fields, fertilizers) +cost <- calculateCost(doses, fields, fertilizers, fines) test_that("Calculate overall cost", { expect_contains(class(cost), 'torch_tensor') From 24dab1cba3e3d261e2f2895cfa5accfdbf50ecd5 Mon Sep 17 00:00:00 2001 From: Sven Verweij <37927107+SvenVw@users.noreply.github.com> Date: Fri, 3 May 2024 13:21:42 +0200 Subject: [PATCH 3/9] Update roadmap --- README.md | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/README.md b/README.md index fc39c73..379aae3 100644 --- a/README.md +++ b/README.md @@ -73,13 +73,17 @@ For the v1 version of `apus` we plan to develop to following features: * [ ] Import and export trained models * [ ] Include a trained base model +* [x] Add function to train model * [ ] Enable fine-tuning of (base) models -* [ ] Include cost function for module 2: Cost of storing fertilizers -* [ ] Include cost function for module 3: Cost of applying fertilizers -* [ ] Include cost function for module 5: Penalties in case of exceeding legal limits -* [ ] Include cost function for module 6: Cost of greenhouse gas emissions -* [ ] Include realistic cultivation response curves from module 4 -* [ ] Add other nutrients and organic matter to module 4 +* [x] Include cost function for module 1: Purchase of fertilizers +* [ ] Include cost function for module 2: Disposal of manure +* [ ] Include cost function for module 3: Cost of storing fertilizers +* [ ] Include cost function for module 4: Cost of applying fertilizers +* [x] Include cost function for module 5: Revenue of harvest +* [x] Include cost function for module 6: Penalties in case of exceeding legal limits +* [ ] Include cost function for module 7: Cost of greenhouse gas emissions +* [ ] Include realistic cultivation response curves from module 5 +* [ ] Add other nutrients than NPK to module 5 * [ ] Add custom fertilizers * [ ] Add custom cultivations * [ ] Add details of the optimization to the result From 80e4cc11990a9b3efc52bab0a466ec8f9a247d93 Mon Sep 17 00:00:00 2001 From: Sven Verweij <37927107+SvenVw@users.noreply.github.com> Date: Fri, 3 May 2024 13:29:53 +0200 Subject: [PATCH 4/9] Fix module numbering --- R/model.R | 28 ++++++++++++++-------------- tests/testthat/test-002-model.R | 16 ++++++++-------- 2 files changed, 22 insertions(+), 22 deletions(-) diff --git a/R/model.R b/R/model.R index 63180a8..c001e5c 100644 --- a/R/model.R +++ b/R/model.R @@ -171,16 +171,16 @@ calculateCost <- function(doses, fields, fertilizers, fines, reduce_batches = TR module1 <- calculateCostModule1(doses, fields, fertilizers) - # Module 4: Revenue from harvested crops ---------------------------------- - module4 <- calculateRevenueModule4(doses, fields, fertilizers) + # Module 5: Revenue from harvested crops ---------------------------------- + module5 <- calculateRevenueModule5(doses, fields, fertilizers) - # Module 5: Penalty for exceeding legal limit ----------------------------- - module5 <- calculatePenaltyModule5(doses, fields, fertilizers, fines) + # Module 6: Penalty for exceeding legal limit ----------------------------- + module6 <- calculatePenaltyModule6(doses, fields, fertilizers, fines) # Combine the modules ----------------------------------------------------- - cost <- torch::torch_zeros(dim(module1)) + module1 - module4 + module5 + cost <- torch::torch_zeros(dim(module1)) + module1 - module5 + module6 # Convert to € / ha ------------------------------------------------------- @@ -218,8 +218,8 @@ calculateCostModule1 <- function(doses, fields, fertilizers) { return(module1) } -# Module 4: Revenue from harvested crops ------------------------------------ -calculateRevenueModule4 <- function(doses, fields, fertilizers) { +# Module 5: Revenue from harvested crops ------------------------------------ +calculateRevenueModule5 <- function(doses, fields, fertilizers) { # Calculate N dose per fields fertilizers.p_n_rt <- fertilizers[,,3] @@ -275,14 +275,14 @@ calculateRevenueModule4 <- function(doses, fields, fertilizers) { fields.b_area <- fields[,,1] fields.b_lu_yield <- fields[,,8] fields.b_lu_price <- fields[,,9] - module4 <- fields.b_area * fields.b_lu_yield * fields.b_lu_price * fields.d_realized - module4 <- torch::torch_sum(module4, dim = 2L) + module5 <- fields.b_area * fields.b_lu_yield * fields.b_lu_price * fields.d_realized + module5 <- torch::torch_sum(module5, dim = 2L) - return(module4) + return(module5) } -# Module 5: Penalties in case of exceeding legal limits ----------------------- -calculatePenaltyModule5 <- function(doses, fields, fertilizers, fines) { +# Module 6: Penalties in case of exceeding legal limits ----------------------- +calculatePenaltyModule6 <- function(doses, fields, fertilizers, fines) { # Calculate d_n_norm_man per field fertilizers.p_n_rt <- fertilizers[,,3] @@ -337,9 +337,9 @@ calculatePenaltyModule5 <- function(doses, fields, fertilizers, fines) { # Combine the penalties - module5 <- farms.penalty.d_n_norm_man + farms.penalty.d_n_norm + farms.penalty.d_p_norm + module6 <- farms.penalty.d_n_norm_man + farms.penalty.d_n_norm + farms.penalty.d_p_norm - return(module5) + return(module6) } diff --git a/tests/testthat/test-002-model.R b/tests/testthat/test-002-model.R index 138d596..4f92774 100644 --- a/tests/testthat/test-002-model.R +++ b/tests/testthat/test-002-model.R @@ -36,18 +36,18 @@ test_that("Calculate cost for module 1: Purchase of fertilizers", { expect_length(as.numeric(module1), farms_count) }) -module4 <- calculateRevenueModule4(doses, fields, fertilizers) +module5 <- calculateRevenueModule5(doses, fields, fertilizers) -test_that("Calculate revenue for module 4: Revenue of harvested crops", { - expect_contains(class(module4), 'torch_tensor') - expect_length(as.numeric(module4), farms_count) +test_that("Calculate revenue for module 5: Revenue of harvested crops", { + expect_contains(class(module5), 'torch_tensor') + expect_length(as.numeric(module5), farms_count) }) -module5 <- calculatePenaltyModule5(doses, fields, fertilizers, fines) +module6 <- calculatePenaltyModule6(doses, fields, fertilizers, fines) -test_that("Calculate penalties for module 5: Penalties for exceeding legal limits", { - expect_contains(class(module5), 'torch_tensor') - expect_length(as.numeric(module5), farms_count) +test_that("Calculate penalties for module 6: Penalties for exceeding legal limits", { + expect_contains(class(module6), 'torch_tensor') + expect_length(as.numeric(module6), farms_count) }) cost <- calculateCost(doses, fields, fertilizers, fines) From 79ecbaf448f0f187a8bf9ca781abaddf889a4138 Mon Sep 17 00:00:00 2001 From: Sven Verweij <37927107+SvenVw@users.noreply.github.com> Date: Fri, 3 May 2024 13:34:11 +0200 Subject: [PATCH 5/9] Fix module numbering in changelog --- NEWS.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/NEWS.md b/NEWS.md index 745bb5c..ef905da 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,5 +2,5 @@ ## Added * Adds `apus` object with the functions `addField`, `trainModel` and `optimizeFertilizerChoice` -* Adds for the cost function module 1,4 and 5 +* Adds for the cost function module 1,5 and 6 * Adds default table for `cultivations`, `fertilizers`, `parameters` and `fines` From a27c34b7aad691a40d15e56474bbc44ee40e46ed Mon Sep 17 00:00:00 2001 From: Sven Verweij <37927107+SvenVw@users.noreply.github.com> Date: Fri, 3 May 2024 13:35:16 +0200 Subject: [PATCH 6/9] Remove code that was leftover --- R/model.R | 3 --- 1 file changed, 3 deletions(-) diff --git a/R/model.R b/R/model.R index c001e5c..c128aee 100644 --- a/R/model.R +++ b/R/model.R @@ -136,9 +136,6 @@ createApusModel <- function(dataset.train, dataset.valid, width = 12, layers = 1 # For developing # b <- dl.valid$.iter() # b <- b$.next() - fields <- b$fields - fertilizers <- b$fertilizers - fines <- b$fines # Forward pass doses <- model(b$fields, b$fertilizers) From f48a4a9ec17ab994a1ca44315050926000bfbcfd Mon Sep 17 00:00:00 2001 From: Sven Verweij <37927107+SvenVw@users.noreply.github.com> Date: Fri, 3 May 2024 17:01:58 +0200 Subject: [PATCH 7/9] Add function to apus model to update fertilizer properties --- R/apus.R | 42 +++++++++++++++++++++++++++++++++ R/dataset.R | 6 +---- data-raw/fertilizers.R | 16 +++++++++++++ data/fertilizers.rda | Bin 2788 -> 2904 bytes man/Apus.Rd | 29 +++++++++++++++++++++++ man/fertilizers.Rd | 2 +- tests/testthat/test-003-apus.R | 17 +++++++++++++ 7 files changed, 106 insertions(+), 6 deletions(-) diff --git a/R/apus.R b/R/apus.R index 8df9553..9828ce0 100644 --- a/R/apus.R +++ b/R/apus.R @@ -133,6 +133,48 @@ Apus <- R6::R6Class( return(TRUE) }, + #' @description + #' Update a fertilizer + #' + #' @param p_id (character) ID of the fertilizer + #' @param p_price (number) + #' @param p_stored (number) + #' @param p_storage_available (number) + #' + #' @export + updateFertilizer = function(p_id, p_price = NA_real_, p_stored = NA_real_, p_storage_available = NA_real_) { + + # Check arguments --------------------------------------------------------- + #TODO + + # update the fertilizers table with data for that fertilizer -------------- + fertilizers.new <- self$fertilizers + p_id.new <- p_id + + # Update price + if(! is.na(p_price)) { + p_price.new <- p_price + fertilizers.new[p_id == p_id.new, p_price := p_price.new] + } + + # Update stored amount of fertilizer + if(! is.na(p_stored)) { + p_stored.new <- p_stored + fertilizers.new[p_id == p_id.new, p_stored := p_stored.new] + } + + # Update available storages for fertilizer + if(! is.na(p_storage_available)) { + p_storage_available.new <- p_storage_available + fertilizers.new[p_id == p_id.new, p_storage_available := p_storage_available.new] + } + + # Return back updated fertilizer + self$fertilizers <- fertilizers.new + + return(TRUE) + }, + #' @description #' Train a model to #' diff --git a/R/dataset.R b/R/dataset.R index 4c3525b..a0685ae 100644 --- a/R/dataset.R +++ b/R/dataset.R @@ -49,13 +49,9 @@ createApusDataset <- function(farms = NULL, cultivations, fertilizers, fines, fi fines <- dcast(fines, . ~ norm, value.var = 'fine')[, 2:4] self$fines <- torch::torch_tensor(as.matrix(fines), device = device) - # Set temporary - fertilizers[, p_stored := 0] - fertilizers[, p_price := 1] - fertilizers <- fertilizers[, c('p_stored', 'p_price', 'p_n_rt', 'p_n_wc', 'p_p_rt', 'p_k_rt', 'p_type_manure', 'p_p_wcl')] - self$fertilizers <- torch::torch_tensor(as.matrix(fertilizers), device = device) + }, .getitem = function(index) { diff --git a/data-raw/fertilizers.R b/data-raw/fertilizers.R index 1bbeb3a..18594dd 100644 --- a/data-raw/fertilizers.R +++ b/data-raw/fertilizers.R @@ -13,12 +13,28 @@ token <- '' fertilizers <- fread(paste0('https://raw.githubusercontent.com/AgroCares/pandex/main/data-raw/b_fp/b_fp_srm.csv?token=', token)) setnames(fertilizers, colnames(fertilizers), tolower(colnames(fertilizers))) + +# Assign an id ------------------------------------------------------------ +fertilizers[, p_id := 1:.N] + + +# Assign derivative parameters -------------------------------------------- +fertilizers[, p_stored := 0] +fertilizers[, p_price := 1] + fertilizers[, p_type_manure := fifelse(p_type_manure, 1, 0)] fertilizers[, p_p_wcl := 1] fertilizers[p_type_compost == TRUE, p_p_wcl := 0.25] fertilizers[p_name_nl == 'Champost', p_p_wcl := 0.75] fertilizers[p_name_nl == 'Rundvee vaste mest', p_p_wcl := 0.75] +fertilizers[, p_storage_cost := 10000] +fertilizers[, p_storage_capacity := 1000000] +fertilizers[, p_storage_available := 0] +fertilizers[p_type_artificial == TRUE, p_storage_capacity := 1000] +fertilizers[p_type_artificial == TRUE, p_storage_cost := 100] +fertilizers[p_type_artificial == TRUE, p_storage_available := 1] # Export table ------------------------------------------------------------ usethis::use_data(fertilizers, overwrite = TRUE, version = 3, compress = 'xz') + diff --git a/data/fertilizers.rda b/data/fertilizers.rda index 5b860b78a34e0aad1552e6d54fd65b92062fb960..61a56cdd8295a182118dd908ecc4eb74d24626cd 100644 GIT binary patch delta 2857 zcmV+^3)b}H71$P#83aZ93mlOhH-Cjy7voYY+STk-*LB%VIBTQc)f(bjw`EFpE?$3< zNv5yw8BqFJBK)S(zbe&+=^P+~gXKoY6NFo`zut;Xb-?4}!*x%b8sKkac z?tqe-wc)S{6EXl?#IVqG0N*|w%pyK+kEc+)Fq7L(f{*!0D(&?wD)@e*Mt_!r2!NPT z9eR{a*T}ge`%edcF}$1`3FJaR15az0^ksCKyo(m&#KN6Z2?}D~X3e=k;PJOoX8ho4 zk>1L9e?FOzQ<#nX=&M5(7xZY3M47e#8P;!C7OjLK9~{kmRr5c8rU|I`!WD&Gm(~th zI=hra=eHY2gb@gDT-rP+L{t$udN<`%1fil zHE`I_r;KVB_Qf6vWic{7A0@s2Q1|%M;T)l3H;@ZIJnhNm)g2_Lr+K7Vr+n?*6w(W{B3 z&pqCiOpO(C);t6DARk~Ut|y-yn%YMF&)>@nmw^+4WRygl0Ds90{0Yq(T?Ue(8FuV=3Qd`opd+rz$4U!~G67p`LVXng^~G441MCM| zM3`(e3u`<7n0jP}Vfv`R|Jl_Dm3m@20XS|!_oaRE3s*lt^ zbLCabIU7MY%{6m=T4$4l)fE;SENn{?WFAG1Yk3Knpno$g$+X|g3+!n=AR-|%dBse8 zg*l2-$C&WDL!$siDkh1p%sK>%|HE3Q8Uf^w7E58`PE_dg^Bz;7kPv!6hD>04?N?elD+1E)x+3w@=sd zX4Q#yQOGU{^Pg>3j=2np>wnLn>B?L$4LXBU5fJ@%b;|}6zl@SJ z;w5Yg_4F9jP5ls8{*P#=>W}4Pk1F3cMpg7b`(E2Cvr+M2_=*lsw)Say5GAFM64#>Cd^B%8{DmquPrlI9sPKG`H_^41^LzUhn)G_?ruVMjqqBwebU!q3~o zSAP;Xj&y%=st#EoA*hGJJgR{fJ*HW0O-4P@lMvXs8pqypZlc0*MG0FJENOlE{3cQ0yZ_Sc1BF*?^VR3NUPu# zD#?+?Sk>ib9MrC=Gt`O~`A#oieFm61&8!S)29noQhTOokGrmhB1b@*rUIc*v zjde1Ka2_{4WglZd`kFoVyiGLcR-G{75+bZ$1gviAu4f}k46h4lXMM*%8UUP?&o>&v!YdrXOxvnZ4g?ut7gDJi=+Pn>pnkscc+vyrQYjhs^P|+R%ME?ErBd8V95oMwIBgL}YNu}h zDb`KH(X@JWTF)S#jDHg94yyRzQFvmWAF01kF%+SVI4Ni5_^*R(UHAGWhqAn%g6^6Z zgWM_AYJeDCX9OX>NGVddFXdnfW!CuYxf2t`L1y9%_1IK(aRo#o;GJzMWYd3r#=(8; zHZ}y>!|dLAdpJfZuWvqR8i@);(OoG4aKhJN-u8H*(Jw{a#DDQmF8B5I(-yeo8F?}a z*7V7)ipC>y@hr;pj+k)K!eZ+D^<&$3gg?DYhl=M(-y~Wk>dT$r?~aD#gS=D1J}tlv zX%Pj&>7o&`=>ZZY=SGJkOcqdw?QwI9oje0-j*Cf?Z)XEOE9_Xe8>vGSVC0lj!$b_# z!$rb=d?=h#^nb{eWXSdp*}n>#$ivfge>WJa`lxe~@8Hzl58Yf=Sy(91nu6xpEj2dH z`OR`-4~tHJJt5MZIdAzh77`%(LWwVY%(HD1`=(BvlIi0J6p36nB!?8a=NQwBBp;Wl z1vJEEnpH97+PE3S)`O1s^%M|q!M_S z)qdnsDSdr%ibn2x+S_uz6T(6o(6al+M-*UIXFYKLv|-{qCE0jGX&uykCYURIsUG&A zTVK`Tv46F6(ZPwPpW4RS;?Lk);lWzMfRU&tOEO`gOl>BU%`Pui<=DteHhBlKsxSuW z3Q-E_{E0&!d6D(S@8US delta 2740 zcmV;l3QP6a7UUI>83a4z3a61BH-8JX7vocM`6~!jkUAwlj&mJjr~Atfb>05(J$%kgReN3z6y0ORuez&^-&(YbQhUhoK9kUrsv^6 zZx7+d|KjD5{|kZMT#|A0VGnRfOfi;vPiJcbj-;7}WTjLfqD#Ku*#ZUo1%H`NE{^JF zQ&DwiBkh!p{^@iQZiGAUO`YXBFlY!~6)P|gog@ProFO=qTz7fx*^J7>jYMyhm$f@Ww3Kzj=-I!nz8h>IO3ft#9>DF60Rg-kvzv7b>FX53Mwe9v9><_O!mW(@< zrAdiStBI}~geOgHN@XOMj}>AmnRF^lB5s zsV;BMicRa3$fLK@E?e`&3Y644jInR=ecF<;zib;YF)y*#9!R za!sX(DS-}BQd3!1g^2_zPM-bsnq5&d>63P`cpgP6{D9)Z#(x+eVN)nF@xzQ{dYZa? zjwwV%-3RS*i6f5IT2&rd2o8Hux_{zz zV{u^M^8rh&A0*IQ$TVPTx02FFz3(lXV8n~?Le7Zdhnj;v=i~i@=FS+J#-@hjyR669 zy7!7_Os*p9^nVz2@Ru9lVECb{H5yV0YrwO|e~vB3kA;B5zqN9GsHoSpAD zXd<&D%5oKjUE)gt3SCS@du$lYs2yuXnyJoWTu)ffh{0iPce&FNF|E{(U8IUBJBd*U zDKoQdfiP?_W%u-|!?j-`2+OeRX2~+q{=GjQ*|> zW6YJOwlK(z00+-TD?Cdv+WyOG@&+{NWs25|kAH8sVYi=h3%sRpS*ja|e=(oD8{VXh zX2Z5s1wSRQj@?6=j!%O_c6V{v8QrVp8&V-_0SudWf>4aZ{V@_$K0#nmu)V)$O1OKC z(4Zrp*wlxQR56r_yR-y>`zScxVo4|KwW$1+emT|NM6B61&`uLYpMasQ55seNi8Lw7YRf6VqL9($i5Te}x$Ec>uqM|N2s%-s|>yux`-tH!44FF*n_(>Y=qg?}ti z`?AJyTFpi00w!Wp=QR^}#7NwY%e5Jl29R?3PdCXNU>@TtL~-Fzgp(|;Kmj4eJaPaY z9)+m3yR?;~e)*?kS@AAC-nSz+IKWB6QRfA_$F+0JYcB#GL*4gT_;P?75LhZJSlj$6 zd$jf9ZEWq^D?46n!lgaasIyp|i+^lUF4Fcagvl#^o8M!xInr5%j4sJ#CaC2T>~E1p zD|+MurTYU>{Xz3DYII88X2*MlJ|5*r>n}P$C4$Xe0Q+u8>(*fKL|pgydn+HRnAj8b z$AWQ6el}^_w?(t&o8+Sj95B(t70XjDK|qO*=y7^M#Ez%70&p^5D;dRWbbocLv?ufH z@`MP>>Qpe9=H24Bt(C8I4gEBG;t75=&SBi1DG~a*f#_sP7ya_*OMYM-tqsDKP|N|IsZ=Vmy5V!$AsyC%xT8 zIz&u=(JYxFuCC5D*C{V%ul%Wm58zlZDCV{86T*m9G+X-O5p85}Ju&3>fxkq!GPZ_s zz#CW`Ia3NQopUD&7Ul*w8ZI(hm_F{*icZF73KtMtl3G#`Huif;xqo)tu>t}+1u%U{ zzQ@YH)z{O|DpHSOEDBkN7}79`UN2R}{D7&%G~xD8qIhB!eG$spp_})#MlSiEgVUfR zx>}1m!t(zo&zGOnOn$Gmu=%C2`JtRT_yjWo% zN|zACW8$>vais1?^r~x)m6}_^qOWK61WvJ(QA2#Q&&&0fSdvPq4(fB$m;VAhGEAUj zs%e+Poi(oHufgcI7ENR1T&es|ie_M=lcH1i+ z{ARkwI&?>HR8j_3Lz)4)M{~Rd8ANNF+i)ef( z@j$$B^0kJPk}A33xfe?Yhc(wM%W3V=gs7o#1v)>-f2jdV&UvwyL(qtt*txao_7NmZ z1&9UV#u=>7g`oW|ApiV7s+q|AJ4ucGv0{USM^W`_3m>`LB)oIG#s&+{FrUTB5K>cO uYUQM2Y$cA~{uxMbh5!Kc6zDww0lyXHcK`rTqSi1zFb#_W000000a;pPpfWiC diff --git a/man/Apus.Rd b/man/Apus.Rd index b49b802..a46d9f1 100644 --- a/man/Apus.Rd +++ b/man/Apus.Rd @@ -35,6 +35,7 @@ A farm needs to have fields, fertilizer etc \itemize{ \item \href{#method-Apus-new}{\code{Apus$new()}} \item \href{#method-Apus-addField}{\code{Apus$addField()}} +\item \href{#method-Apus-updateFertilizer}{\code{Apus$updateFertilizer()}} \item \href{#method-Apus-trainModel}{\code{Apus$trainModel()}} \item \href{#method-Apus-optimizeFertilizerChoice}{\code{Apus$optimizeFertilizerChoice()}} \item \href{#method-Apus-clone}{\code{Apus$clone()}} @@ -107,6 +108,34 @@ Add a field to the apus object } } \if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Apus-updateFertilizer}{}}} +\subsection{Method \code{updateFertilizer()}}{ +Update a fertilizer +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Apus$updateFertilizer( + p_id, + p_price = NA_real_, + p_stored = NA_real_, + p_storage_available = NA_real_ +)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{p_id}}{(character) ID of the fertilizer} + +\item{\code{p_price}}{(number)} + +\item{\code{p_stored}}{(number)} + +\item{\code{p_storage_available}}{(number)} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Apus-trainModel}{}}} \subsection{Method \code{trainModel()}}{ diff --git a/man/fertilizers.Rd b/man/fertilizers.Rd index 938d509..5c92a0e 100644 --- a/man/fertilizers.Rd +++ b/man/fertilizers.Rd @@ -5,7 +5,7 @@ \alias{fertilizers} \title{Fertilizers table} \format{ -An object of class \code{data.table} (inherits from \code{data.frame}) with 47 rows and 46 columns. +An object of class \code{data.table} (inherits from \code{data.frame}) with 47 rows and 52 columns. } \usage{ fertilizers diff --git a/tests/testthat/test-003-apus.R b/tests/testthat/test-003-apus.R index cb59da2..6e53ef6 100644 --- a/tests/testthat/test-003-apus.R +++ b/tests/testthat/test-003-apus.R @@ -132,6 +132,23 @@ test_that("Third field is added", { }) +# Update a fertilizer ----------------------------------------------------- + +apus$updateFertilizer( + p_id = 17, + p_price = -5, + p_stored = 15000, + p_storage_available = 1 +) + +test_that("Fertilizer is updated", { + expect_contains(class(apus$fertilizers), 'data.table') + expect_equal(nrow(apus$fertilizers), nrow(apus::fertilizers)) + expect_equal(apus$fertilizers[p_id == 17]$p_price, -5) + expect_equal(apus$fertilizers[p_id == 17]$p_stored, 15000) + expect_equal(apus$fertilizers[p_id == 17]$p_storage_available, 1) +}) + # Train a model ----------------------------------------------------------- apus$trainModel() From 7ea0e24450f7c614221c2f563023fffdbbee4cf2 Mon Sep 17 00:00:00 2001 From: Sven Verweij <37927107+SvenVw@users.noreply.github.com> Date: Fri, 3 May 2024 17:04:32 +0200 Subject: [PATCH 8/9] Add function to readme about updating fertilizer properties --- README.md | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/README.md b/README.md index 379aae3..56301ca 100644 --- a/README.md +++ b/README.md @@ -57,6 +57,17 @@ apus$addField( ) ``` +To update a fertilizer with specific values for your situation use the `updateFertilizer` function + +``` +apus$updateFertilizer( + p_id = 17, + p_price = -5, + p_stored = 15000, + p_storage_available = 1 +) +``` + To get a fertilizer advice you need a model first. A model can be trained with with the function `trainModel()` `apus$trainModel()` @@ -84,6 +95,7 @@ For the v1 version of `apus` we plan to develop to following features: * [ ] Include cost function for module 7: Cost of greenhouse gas emissions * [ ] Include realistic cultivation response curves from module 5 * [ ] Add other nutrients than NPK to module 5 +* [x] Add function to update fertilizer properties * [ ] Add custom fertilizers * [ ] Add custom cultivations * [ ] Add details of the optimization to the result From e462383724504cfdcf20fe6f871f532d4852adc9 Mon Sep 17 00:00:00 2001 From: Sven Verweij <37927107+SvenVw@users.noreply.github.com> Date: Fri, 3 May 2024 17:19:17 +0200 Subject: [PATCH 9/9] Add module 3 cost of storing fertilizers --- R/dataset.R | 3 +-- R/model.R | 29 ++++++++++++++++++++++++++++- tests/testthat/test-001-dataset.R | 2 +- tests/testthat/test-002-model.R | 7 +++++++ 4 files changed, 37 insertions(+), 4 deletions(-) diff --git a/R/dataset.R b/R/dataset.R index a0685ae..3fb4b49 100644 --- a/R/dataset.R +++ b/R/dataset.R @@ -49,9 +49,8 @@ createApusDataset <- function(farms = NULL, cultivations, fertilizers, fines, fi fines <- dcast(fines, . ~ norm, value.var = 'fine')[, 2:4] self$fines <- torch::torch_tensor(as.matrix(fines), device = device) - fertilizers <- fertilizers[, c('p_stored', 'p_price', 'p_n_rt', 'p_n_wc', 'p_p_rt', 'p_k_rt', 'p_type_manure', 'p_p_wcl')] + fertilizers <- fertilizers[, c('p_stored', 'p_price', 'p_n_rt', 'p_n_wc', 'p_p_rt', 'p_k_rt', 'p_type_manure', 'p_p_wcl', 'p_storage_cost', 'p_storage_capacity', 'p_storage_available')] self$fertilizers <- torch::torch_tensor(as.matrix(fertilizers), device = device) - }, .getitem = function(index) { diff --git a/R/model.R b/R/model.R index c128aee..4a76532 100644 --- a/R/model.R +++ b/R/model.R @@ -168,6 +168,10 @@ calculateCost <- function(doses, fields, fertilizers, fines, reduce_batches = TR module1 <- calculateCostModule1(doses, fields, fertilizers) + # Module 3: Cost of storing fertilizers ----------------------------------- + module3 <- calculateCostModule3(doses, fields, fertilizers) + + # Module 5: Revenue from harvested crops ---------------------------------- module5 <- calculateRevenueModule5(doses, fields, fertilizers) @@ -177,7 +181,7 @@ calculateCost <- function(doses, fields, fertilizers, fines, reduce_batches = TR # Combine the modules ----------------------------------------------------- - cost <- torch::torch_zeros(dim(module1)) + module1 - module5 + module6 + cost <- torch::torch_zeros(dim(module1)) + module1 + module3 - module5 + module6 # Convert to € / ha ------------------------------------------------------- @@ -215,6 +219,29 @@ calculateCostModule1 <- function(doses, fields, fertilizers) { return(module1) } +# Module 3: Cost of storing fertilizers ------------------------------------- +calculateCostModule3 <- function(doses, fields, fertilizers) { + + # Sum dose per fertilizer ------------------------------------------------- + fields.b_area <- torch::torch_unsqueeze(fields[,,1], -1) + fields.dose <- fields.b_area * doses + fertilizers.dose <- torch::torch_sum(doses, dim = 2L) + + + # Calculate requires storage places for fertilizer ------------------------ + fertilizers.storage_capacity <- fertilizers[,,10] + fertilizers.storage_cost <- fertilizers[,,9] + fertilizers.storage_available <- fertilizers[,,11] + fertilizers.storages <- torch::torch_ceil(fertilizers.dose / fertilizers.storage_capacity) + fertilizers.cost <- (fertilizers.storages - fertilizers.storage_available) * fertilizers.storage_cost + + + # Sum cost for farm ------------------------------------------------------- + module3 <- torch::torch_sum(fertilizers.cost, dim = 2L) + + return(module3) +} + # Module 5: Revenue from harvested crops ------------------------------------ calculateRevenueModule5 <- function(doses, fields, fertilizers) { diff --git a/tests/testthat/test-001-dataset.R b/tests/testthat/test-001-dataset.R index fac499b..96069b6 100644 --- a/tests/testthat/test-001-dataset.R +++ b/tests/testthat/test-001-dataset.R @@ -30,7 +30,7 @@ test_that("Create validation/test dataset", { expect_contains(class(batch$fields), 'torch_tensor') expect_equal(dim(batch$fields), c(farms_count, fields_max, 9)) - expect_equal(dim(batch$fertilizers), c(farms_count, nrow(apus::fertilizers), 8)) + expect_equal(dim(batch$fertilizers), c(farms_count, nrow(apus::fertilizers), 11)) }) diff --git a/tests/testthat/test-002-model.R b/tests/testthat/test-002-model.R index 4f92774..261a13e 100644 --- a/tests/testthat/test-002-model.R +++ b/tests/testthat/test-002-model.R @@ -36,6 +36,13 @@ test_that("Calculate cost for module 1: Purchase of fertilizers", { expect_length(as.numeric(module1), farms_count) }) +module3 <- calculateCostModule3(doses, fields, fertilizers) + +test_that("Calculate cost for module 3: Cost of storing fertilizers", { + expect_contains(class(module3), 'torch_tensor') + expect_length(as.numeric(module3), farms_count) +}) + module5 <- calculateRevenueModule5(doses, fields, fertilizers) test_that("Calculate revenue for module 5: Revenue of harvested crops", {