From 3e4497f44653a57e3b9ed54831353be41df93c01 Mon Sep 17 00:00:00 2001 From: Valentine Rahier Date: Mon, 5 Oct 2026 11:47:07 +0200 Subject: [PATCH 1/4] refactor: refactoring statistics --- DESCRIPTION | 1 - NAMESPACE | 1 - R/generic_stats.R | 387 +++++++++++------- tests/testthat/_inputs/make_stats_reference.R | 13 + tests/testthat/_inputs/stats_reference.rds | Bin 0 -> 13670 bytes tests/testthat/helper-stats_cases.R | 98 +++++ tests/testthat/test-stats_reference.R | 14 + 7 files changed, 362 insertions(+), 152 deletions(-) create mode 100644 tests/testthat/_inputs/make_stats_reference.R create mode 100644 tests/testthat/_inputs/stats_reference.rds create mode 100644 tests/testthat/helper-stats_cases.R create mode 100644 tests/testthat/test-stats_reference.R diff --git a/DESCRIPTION b/DESCRIPTION index 4286ee97..caf46115 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -42,7 +42,6 @@ Imports: ggrepel, gridExtra, lifecycle, - plyr, reshape2, rlang, tibble, diff --git a/NAMESPACE b/NAMESPACE index ff254ac1..13aa8b71 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -65,7 +65,6 @@ importFrom(graphics,plot.new) importFrom(graphics,title) importFrom(parallel,parLapply) importFrom(parallel,stopCluster) -importFrom(plyr,join_all) importFrom(reshape2,melt) importFrom(rlang,":=") importFrom(rlang,.data) diff --git a/R/generic_stats.R b/R/generic_stats.R index a1154bff..0e4f33b7 100644 --- a/R/generic_stats.R +++ b/R/generic_stats.R @@ -32,7 +32,6 @@ statistics_situations <- function( all_plants = TRUE, verbose = TRUE ) { - . <- NULL dot_args <- list(...) # Name the groups if not named: @@ -40,52 +39,245 @@ statistics_situations <- function( names(dot_args) <- paste0("Version_", seq_along(dot_args)) } - # Restructure data into a list of one single element if all_situations - if (all_situations) { - list_data <- cat_situations(dot_args, obs) - dot_args <- list_data[[1]] - obs <- list_data[[2]] + stat <- check_stat_names(stat) + + # One row per observed / simulated pair, for all groups and situations: + pairs <- stats_pairs(dot_args, obs, verbose = verbose) + + if (nrow(pairs) == 0) { + stats <- dplyr::tibble() } else { - list_data <- add_situation_col(dot_args, obs) - dot_args <- list_data[[1]] - obs <- list_data[[2]] - # obs_sd <- list_data[[3]] + if (all_situations) { + pairs$situation <- "all_situations" + } + by <- c("group", "situation", "variable") + if (!all_plants) { + by <- c(by, "Plant") + } + stats <- compute_stats(pairs, stat, by) + } + class(stats) <- c("statistics", class(stats)) + + return(stats) +} + +#' Observed / simulated pairs for all groups and situations +#' +#' @param dot_args A named list (each element= group, i.e. model version) of +#' named lists (each element= situation) of simulations `data.frame`s +#' @param obs A list (each element= situation) of observations `data.frame`s +#' (named by situation) +#' @param verbose Boolean. Print information during execution. +#' +#' @return A data.frame with columns group, situation, Plant, variable, +#' Observed and Simulated, with one row per observation and group. Situations +#' without observations are dropped. +#' +#' @keywords internal +stats_pairs <- function(dot_args, obs, verbose = TRUE) { + dot_args <- lapply(dot_args, unclass) + situations <- unique(unlist(lapply(dot_args, names))) + + pairs <- lapply(situations, function(sit) { + obs_sit <- obs[[sit]] + if (is.null(obs_sit) || nrow(obs_sit) == 0) { + if (verbose) { + cli::cli_alert_warning("No observations found for situation {.val {sit}}") + } + return(NULL) + } + + # All groups at once, format_cropr() keeps the version column: + sim_sit <- lapply(dot_args, function(x) x[[sit]]) + sim_sit <- dplyr::bind_rows( + sim_sit[!vapply(sim_sit, is.null, logical(1))], + .id = "version" + ) + + pairs_sit <- situation_pairs(sim_sit, obs_sit, verbose = verbose) + if (is.null(pairs_sit)) { + return(NULL) + } + pairs_sit$situation <- rep(sit, nrow(pairs_sit)) + pairs_sit + }) + + pairs <- dplyr::bind_rows(pairs) + if (nrow(pairs) == 0) { + return(pairs) } + pairs <- dplyr::rename(pairs, group = "version") + dplyr::relocate(pairs, "group", "situation") +} - # Compute stats (assign directly into dot_args): - for (versions in seq_along(dot_args)) { - class(dot_args[[versions]]) <- NULL - # Remove the class to avoid messing up with it afterward - for (situation in rev(names(dot_args[[versions]]))) { - # NB: rev() is important here because if the result is NULL, - # the situation is popped out of the list, so we want to decrement the - # list in case it is popped (and not increment with the wrong index) - dot_args[[versions]][[situation]] <- - statistics( - sim = dot_args[[versions]][[situation]], - obs = obs[[situation]], - all_situations = all_situations, - all_plants = all_plants, - verbose = verbose, - stat = stat +#' Observed / simulated pairs for one situation +#' +#' @param sim A simulation data.frame, possibly with a `version` column +#' @param obs An observation data.frame (variable names must match) +#' @param verbose Boolean. Print information during execution. +#' +#' @return A data.frame with columns (version), Plant, variable, Observed and +#' Simulated, or `NULL` if there are no common variables between `sim` and +#' `obs`. +#' +#' @keywords internal +situation_pairs <- function(sim, obs, verbose = TRUE) { + # Testing if the obs and sim have the same plants names: + if ("Plant" %in% colnames(obs) && "Plant" %in% colnames(sim)) { + common_crops <- unique(sim$Plant) %in% unique(obs$Plant) + + if (any(!common_crops)) { + cli::cli_alert_warning( + paste0( + "Observed and simulated crops are different. Obs Plant: ", + "{.value {unique(obs$Plant)}}, + Sim Plant: {.value {unique(sim$Plant)}}" ) + ) } } - stats <- - lapply(dot_args, dplyr::bind_rows, .id = "situation") %>% - dplyr::bind_rows(.id = "group") %>% - { - if (length(stat) == 1 && stat == "all") { - . - } else { - stat <- c("group", "situation", "variable", stat) - dplyr::select(., !!stat) - } + formated_df <- format_cropr(sim, obs, type = "scatter") + + # In case obs is given but no common variables between obs and sim: + if (is.null(formated_df) || is.null(formated_df$Observed)) { + if (verbose) { + cli::cli_alert_warning("No observations found for required variables") } - class(stats) <- c("statistics", class(stats)) + return(NULL) + } - return(stats) + formated_df <- dplyr::filter( + formated_df, + !is.na(.data$Observed) & !is.na(.data$Simulated) + ) + + # Sole crops are formatted without the Plant column: + if (!"Plant" %in% colnames(formated_df)) { + plant <- unique(c(obs$Plant, sim$Plant)) + if (length(plant) != 1) { + plant <- NA_character_ + } + formated_df$Plant <- rep(plant, nrow(formated_df)) + } + + formated_df$variable <- as.character(formated_df$variable) + keep <- c("version", "Plant", "variable", "Observed", "Simulated") + formated_df[, intersect(keep, colnames(formated_df)), drop = FALSE] +} + +#' Compute the statistics on observed / simulated pairs +#' +#' @param pairs Output of [stats_pairs()] or [situation_pairs()] +#' @param stat A character vector of statistics, already checked by +#' [check_stat_names()] +#' @param by The columns of `pairs` used to group the statistics +#' +#' @return A data.frame with the `by` columns and one column per statistic, +#' with the groups and situations in their order of appearance in `pairs`, and +#' the description of the statistics as the `description` attribute. +#' +#' @keywords internal +compute_stats <- function(pairs, stat, by) { + args <- list(obs = rlang::sym("Observed"), sim = rlang::sym("Simulated")) + calls <- lapply(stat, function(cur_stat) { + rlang::call2(cur_stat, !!!args[intersect(names(args), names(formals(cur_stat)))]) + }) + names(calls) <- stat + + # Keep the order of appearance of the groups and situations instead of + # sorting them (the variables and plants are sorted): + ordered <- intersect(c("group", "situation"), by) + for (col in ordered) { + pairs[[col]] <- factor(pairs[[col]], levels = unique(pairs[[col]])) + } + + stats <- pairs %>% + dplyr::group_by(dplyr::across(dplyr::all_of(by))) %>% + dplyr::summarise(!!!calls, .groups = "drop") %>% + as.data.frame() + + for (col in ordered) { + stats[[col]] <- as.character(stats[[col]]) + } + # Some statistics return named values (e.g. Inter, Slope): + stats[stat] <- lapply(stats[stat], unname) + attr(stats, "description") <- dplyr::select(stats_description(), all_of(stat)) + stats +} + +#' Description of the available statistics +#' +#' @return A one row data.frame with the description of each statistic, named +#' by statistic. +#' +#' @keywords internal +stats_description <- function() { + data.frame( + n_obs = "Number of observations", + mean_obs = "Mean of the observations", + mean_sim = "Mean of the simulations", + r_means = "Ratio between mean simulated values and mean observed values (%)", + sd_obs = "Standard deviation of the observations", + sd_sim = "Standard deviation of the simulation", + CV_obs = "Coefficient of variation of the observations", + CV_sim = "Coefficient of variation of the simulation", + R2 = "coefficient of determination for obs~sim", + SS_res = "Residual sum of squares", + Inter = "Intercept of regression line", + Slope = "Slope of regression line", + RMSE = "Root Mean Squared Error", + RMSEs = "Systematic Root Mean Squared Error", + RMSEu = "Unsystematic Root Mean Squared Error", + nRMSE = "Normalized Root Mean Squared Error, CV(RMSE)", + rRMSE = "Relative Root Mean Squared Error", + rRMSEs = "Relative Systematic Root Mean Squared Error", + rRMSEu = "Relative Unsystematic Root Mean Squared Error", + pMSEs = "Proportion of Systematic Mean Squared Error in Mean Squared Error", + pMSEu = "Proportion of Unsystematic Mean Squared Error in Mean Squared Error", + Bias2 = "Bias squared (1st term of Kobayashi and Salam (2000) MSE decomposition)", + SDSD = "Difference between sd_obs and sd_sim squared (2nd term of Kobayashi and Salam (2000) MSE decomposition)", + LCS = "Correlation between observed and simulated values (3rd term of Kobayashi and Salam (2000) MSE decomposition)", + rbias2 = "Relative bias squared", + rSDSD = "Relative difference between sd_obs and sd_sim squared", + rLCS = "Relative correlation between observed and simulated values", + MAE = "Mean Absolute Error", + FVU = "Fraction of variance unexplained", + MSE = "Mean squared Error", + EF = "Model efficiency", + Bias = "Bias", + ABS = "Mean Absolute Bias", + MAPE = "Mean Absolute Percentage Error", + RME = "Relative mean error (%)", + tSTUD = "T student test of the mean difference", + tLimit = "T student threshold", + Decision = "Decision of the t student test of the mean difference" + ) +} + +#' Check the names of the required statistics +#' +#' @param stat A character vector of required statistics, or "all" for all. +#' +#' @return The names of the statistics to compute, without the unknown ones +#' (with a warning). +#' +#' @keywords internal +check_stat_names <- function(stat) { + stat_names <- names(stats_description()) + if (length(stat) == 1 && stat == "all") { + return(stat_names) + } + if (!all(stat %in% stat_names)) { + warning(paste( + "Argument stats includes statistics not defined in CroPlot:", + paste(setdiff(stat, stat_names), collapse = ","), + "\nPlease chose between:", + paste(stat_names, collapse = ", ") + )) + stat <- intersect(stat, stat_names) + } + stat } #' Generic simulated/observed statistics for one situation @@ -116,7 +308,6 @@ statistics_situations <- function( #' @importFrom reshape2 melt #' @importFrom parallel parLapply stopCluster #' @importFrom dplyr ungroup group_by summarise "%>%" filter -#' @importFrom plyr join_all #' @importFrom rlang ":=" #' @examples #' \dontrun{ @@ -145,8 +336,6 @@ statistics <- function( verbose = TRUE, stat = "all" ) { - . <- NULL # To avoid CRAN check note - is_obs <- !is.null(obs) && nrow(obs) > 0 if (!is_obs) { @@ -156,120 +345,18 @@ statistics <- function( return(NULL) } - # Testing if the obs and sim have the same plants names: - if (is_obs && "Plant" %in% colnames(obs) && "Plant" %in% colnames(sim)) { - common_crops <- unique(sim$Plant) %in% unique(obs$Plant) - - if (any(!common_crops)) { - cli::cli_alert_warning( - paste0( - "Observed and simulated crops are different. Obs Plant: ", - "{.value {unique(obs$Plant)}}, - Sim Plant: {.value {unique(sim$Plant)}}" - ) - ) - } - } - - # Format the data: - formated_df <- format_cropr(sim, obs, type = "scatter") + stat <- check_stat_names(stat) - # In case obs is given but no common variables between obs and sim: - if (is.null(formated_df) || is.null(formated_df$Observed)) { - if (verbose) { - cli::cli_alert_warning("No observations found for required variables") - } + pairs <- situation_pairs(sim, obs, verbose = verbose) + if (is.null(pairs)) { return(NULL) } - # Define list of stats to compute - all_stats <- - data.frame( - n_obs = "Number of observations", - mean_obs = "Mean of the observations", - mean_sim = "Mean of the simulations", - r_means = "Ratio between mean simulated values and mean observed values (%)", - sd_obs = "Standard deviation of the observations", - sd_sim = "Standard deviation of the simulation", - CV_obs = "Coefficient of variation of the observations", - CV_sim = "Coefficient of variation of the simulation", - R2 = "coefficient of determination for obs~sim", - SS_res = "Residual sum of squares", - Inter = "Intercept of regression line", - Slope = "Slope of regression line", - RMSE = "Root Mean Squared Error", - RMSEs = "Systematic Root Mean Squared Error", - RMSEu = "Unsystematic Root Mean Squared Error", - nRMSE = "Normalized Root Mean Squared Error, CV(RMSE)", - rRMSE = "Relative Root Mean Squared Error", - rRMSEs = "Relative Systematic Root Mean Squared Error", - rRMSEu = "Relative Unsystematic Root Mean Squared Error", - pMSEs = "Proportion of Systematic Mean Squared Error in Mean Squared Error", - pMSEu = "Proportion of Unsystematic Mean Squared Error in Mean Squared Error", - Bias2 = "Bias squared (1st term of Kobayashi and Salam (2000) MSE decomposition)", - SDSD = "Difference between sd_obs and sd_sim squared (2nd term of Kobayashi and Salam (2000) MSE decomposition)", - LCS = "Correlation between observed and simulated values (3rd term of Kobayashi and Salam (2000) MSE decomposition)", - rbias2 = "Relative bias squared", - rSDSD = "Relative difference between sd_obs and sd_sim squared", - rLCS = "Relative correlation between observed and simulated values", - MAE = "Mean Absolute Error", - FVU = "Fraction of variance unexplained", - MSE = "Mean squared Error", - EF = "Model efficiency", - Bias = "Bias", - ABS = "Mean Absolute Bias", - MAPE = "Mean Absolute Percentage Error", - RME = "Relative mean error (%)", - tSTUD = "T student test of the mean difference", - tLimit = "T student threshold", - Decision = "Decision of the t student test of the mean difference" - ) - - stat_names <- names(all_stats) - if (length(stat) == 1 && stat == "all") { - stat <- stat_names + by <- "variable" + if (!all_plants) { + by <- c(by, "Plant") } - if (!all(stat %in% stat_names)) { - warning(paste( - "Argument stats includes statistics not defined in CroPlot:", - paste(setdiff(stat, stat_names), collapse = ","), - "\nPlease chose between:", - paste(stat_names, collapse = ", ") - )) - stat <- intersect(stat, stat_names) - } - - # Filter and group data - formated_df <- formated_df %>% - dplyr::filter(!is.na(.data$Observed) & !is.na(.data$Simulated)) %>% - { - if (all_plants) { - dplyr::group_by(., .data$variable) - } else { - dplyr::group_by(., .data$variable, .data$Plant) - } - } - - # Compute the selected list of stats - potential_arglist <- list( - obs = "Observed", - sim = "Simulated" - ) - x <- lapply(stat, function(cur_stat) { - arglist <- potential_arglist[intersect( - names(potential_arglist), - names(formals(cur_stat)) - )] - arglist_quoted <- do.call( - call, - c("list", lapply(arglist, as.name)), - quote = TRUE - ) - formated_df %>% - dplyr::summarise(!!cur_stat := do.call(cur_stat, !!arglist_quoted)) - }) - x <- plyr::join_all(x, by = "variable") - attr(x, "description") <- dplyr::select(all_stats, all_of(stat)) + x <- compute_stats(pairs, stat, by) return(x) } diff --git a/tests/testthat/_inputs/make_stats_reference.R b/tests/testthat/_inputs/make_stats_reference.R new file mode 100644 index 00000000..cbd7fa67 --- /dev/null +++ b/tests/testthat/_inputs/make_stats_reference.R @@ -0,0 +1,13 @@ +# Make the reference statistics used in test-stats_reference.R +# +# Run from the package root, on the version of the code taken as reference: +# Rscript tests/testthat/_inputs/make_stats_reference.R + +devtools::load_all(".", quiet = TRUE) +library(testthat) +source("tests/testthat/helper-stats_cases.R") + +cases <- stats_cases("tests/testthat/_inputs/sim_obs.RData") +reference <- lapply(cases, run_stats_case) + +saveRDS(reference, "tests/testthat/_inputs/stats_reference.rds", version = 2) diff --git a/tests/testthat/_inputs/stats_reference.rds b/tests/testthat/_inputs/stats_reference.rds new file mode 100644 index 0000000000000000000000000000000000000000..00e45a46c1edf21589165ced58ee91de35db3ced GIT binary patch literal 13670 zcmZXaWmFtZ*rpRgkU$`~yM^HH?rs5sPH=(~+=k%p?ry=|1_emMTiHwsLQPdf7Hck467>R-=cwCaDWZNZ$`hiP;dv#?v>=GcWchf~(83*gl$ z2ex*Yefm^QAS6wUCKFarT=Y*({c~3)-%Sj1NC6?xQ1E7uyNzU!^=2&B8oXus%i4tc zrQC?}cW`Y|Qd~h%LVfM*l=)y+jq*)iEqfDZ9f6mGh3%Q89sdn(hzUVAst5YBW2BHq z4_;+Vzc4W>KI|ZO;|TgNv|*>1w|96DT$_cZB&VTBy~Jkgr-&|es%2xXmp!~*c#pJM z+wpR9t&S6U;I||-0unT}|Mso1{NCl?k?;!hUCf!(`4RpBy)$D+pzU;Q7K5*X(^{wU z@j&(lP%*(+!uTZFd``KNHK9(Dk%QC1uC9$jFY0pb#JmXeP_cIZthrIkz(NXo6EUCB zIYioxhwgoi&S52SN4Oq%y1Jnz>ZRy^ewU^a+oAhgthqal+R|W@!QHuBq%P&xJYHoT`(?)0V|RU={lS=K1<^gs z63%Ny6w_+XHCpOIqxY2=H>8`$0)Nibj4|s`^?A43m}NS?|D~wgoY;ok*n7T<3AznO zHN}bTP`#a5LCuPo!gu0R=(%FA3;Fe3xMdrH+O(Mp>jCwDTCQ#>XF2jJ`rs;UaTj<^ zK;@PE?}ceHN3OT>2?#3Q{0n&jZM^)TqI@U3cy$ESO$|T$=-yjWox=O>MXk_k^a;(B z<<=o_wN?T@eUjN#2&C!xxnYF|p4%MCn~y&ec2(Hz zhV%IzHzP^N8U774c40>8dADiaZS0rKLFDwy5u;hKCGWDS%Cqis&j0bq6YD;VExjXg z3;*1-noX)7vHi^o_PNy+GbPLFh09#z}Ow@q!R$O?9?acQDbL_g9e zXY z5oKR6mq@K~Dfq!D?JdH$3ojZ#9W8a5wU9-y*eF#om$x z=t}4l0y+cQO@a@ZPMM-ekiVBTVmDw97;4xiE{fZxJ;CQYLXoA;Syf!er1K7Yn@LQFx%qlF8%n4PL28sODQeI>D5 zm~6>=e`s@C!m8-BG-hE8-m|i^>*WzFMz(a~5XLiMuyB$QHX*8?W-5RT@F1Zu(^{#> zj{ZWjJ^MLeVGcIt!@MGk#erH^JDx}i=U+7)w7cr0>!z>reh!eCIPk@{N2cHGiu`87 zKRr9iXs^c3mYfmyHFZG zmnL*$-4uc+AZ_;6O6ET3qcSqpC6CG|`el9E$HPwCAnl(Hq37pa;{Ve9GPQDeWNIhW zKvnGhIwm1HIN(?(oS$J!QV~_jc#m%Tih`~t>|wCI{VUAf2J$N%oeT@_+818|ew(ht zS|RS#{;VLgEub>1@`I7!Gxn3Vwy*-x%;ymm8wa?eO&fI&cPkR2Ky&Y&ooHq6-VYuv z9$b1@yFLTaxXDz99m%yxwOlzheOLRVc-Nmv67w+Zt*mV=1f01@@+G`OT^W9WSIoda z?M$qq4-%&pc4bWp7W*MJm=aCCR24~}%7B1}Bjkvk{9!9`UGQhmZh4%!!C8blL~o=~DRvJiTK)ztRo z&pw=W4?)C(vI)_?9D7UL%js!)5R77#Ss%$&nd&>=g>RIPbVwUvNVnU|vjfBK_c<5y zjB`O$iyYT+*ZYg*skz)a1qt=bm&6yQ;3LVFZ;{YQGSMC7=iy;vOW~%P#z!;!FAEfb zxLGecncGG1{aZgw#P@DbUM)^FN46ziudkdP=9H!IF#{o7M$chH_|F-!LU}Y5-mkP? zSN8a{(ixSM_6_qrYfHnj>uXDvmc|CP&PSW_1>>Wy^goM}pX_aRW+*vflRV0%FNYqv zo9o=3*uO$zE-$AENzr?EcS{bpC%YR|yR7&8*gk$1@n<{PVB+y=4m8%Uj_I45Tt@{& zP89jzt%o^gr4R$jyZ#c1(a7u;vJT`iq#j`E9gRA9{zB=t$(O7D7>0uKtBRt za+CX$gHX73$HZ)$;W`0=k{z|yT7zG@;PVK(0_=3$i`0AqfVGTon$UP#>$U7*!>fe2Lskiesu!*eQ;N)kH?exk# z9Gz&$9j{xGw)P(Eu4i8w_^sJw3nOIv+&j;1UjLny?;%yB@65s|{NsGOR(cxH0O~mY|)z*rbiYv;S!|_3dSmjwyAYSA0w;)b>A zmB+aDEv$g$?l_i|41B@WjmWF+^GAD_Z)&U`sB}mAV4PCc zyDwftFgEsypRC&0w~r}rr`DlVq#*Y<;P z#$}h$^4C-LXl>)W_)a|oeouPDHn4LDopu>{7o1UA00#4QF5{wW+^91DQE5h8d9Me$ z=biS7?y`bJl8gJvSwea4uA*~H^{d`qN@F6xqT7aQ=;?)v+;P{<(rgn_Ra1?@f5xQ1 zm1LY}**uQ-Edg(eu^Hy%Ezf#2T8XN{RH_&ppU)4gQ23~7mO=?yQY7S0o}mFT-Ufzi zqBcg?>gBaP8D6F>PEJ7*(3x@>!`8x>3g%e}wqOwG~Ufq~!?NqDL`wI+yqftwi9idQ6Yb)Y*#}M`MF6su?T-sjtIe*7) z2>R|}zquTeWx4qt!Ux_a)V}L2UyUO(v~HD1PDHjirbqtj@*MwD42FZrpGea=-X8Qc zVpocrb;0?kBA>6MPGvKArJl2lQ+Z7Fy?XVP6`5$a;i+-@DX!`>wE$zd3etm*;oVD* z{ED|FFGlvn|oeFXy4c`tvNJFHx_{BMtkstpPVW$F5fU-TU^5X{q7NZIA_N{8LG+u>FKqjqlg3fdl?>zJtTc8JB#x%->Iync4~;fc|M zq2^CL`PM(IZ*jUacF-UGNabu(>u-2=c9K3kWXi{4S08=UXpdL~nX34$S5n?u_|J>B zhqAlY#$xKTqUA3;dgJMTU+={~J_vil1ZFx|ycWaLsk@MX2TA_?C_-8cOyv(1Y$)_| zy(GmZ-sZ1rX(xE%dq$aD0?7cYF~f1+p2-1jzqt^r`?CDZX|gmUg)65BD46HAwBT?A zJRi@P6D2gCJ8U^%IzxOj%>Wc zE&NgxEO>!7ua_iFc&@Uagtwx`5!vykx1 z%zIVp8ExeZ5p?0ob{whuEjU4gN98EI)j;=7$l$E^=u(6VkZPBr-JTveh7LGts<5S> zXCGSXTr!_M?E^e{CSq%ETRB5Wo_CULqKPh_Q9A2DS1JGQ9g$$cUJ;_*Ld!Y?GJ3fY zJ}C}J_XwOUYTUF}h8&p@YFBe06_cI8C2dXwt#AFts1wbM6LjmeK$V83)YQqBl4@EY zK6y#oFc}H$?Q~wsQ9&|S2iyjXTnp6e>TVG*WWa z>SA;(%4%xf`j$oPV3y$xZg60f5tN0^N8%suXs z0w{$y*T#1Qd)Wf1)CI)Xg-=dol-l!>0$%-zyNG%)%E^5Qq{CnCNh24}e=%vNg8gz=)R3LVl^_R+&?TiHZGqXiM_tcyrCQoki>PJFSPl zwB!N=0u*9zht6d<^k^DuoXrSr*(29*93ggi8nuEQyltQ>#zP3Z*ZjcXwWQ0}xfWc=v|fvNLY0i@o);oq^be+R72z!* z`))20@BQIf;rvN7WlxdNxk6Q&{HCm?7ScMA`Hv{W`Vx*|b45@K$kSxCddm)nK)XDE zufS2Xg1et5q{THWsUuT%H{SH-WmnUg6r)V#RXi%ZO2RjztYDFI)5PwC6SPEqcshhq zya`}^CV!&`{@7Nv&OFduG`c@pxAL3wV!>ph%RTj%h15`kd0i^bzxK9CP+leR?iMQNY?&Go2> z`$rpvnKUT{fJ^kQ$LMVgFAH%m%ix^m_rnGPjeKB6;fx3BYZekfI?z|FFw#7`f}QZM zJ`_!%S}>X|^l~tJ!!&HV{w9=Eq&SAD_0eY7dy^CTsCCjie1|fX5_=PR9sDVrLym?k zbF?g0_IW9KvJ0xZvFe5;+#F{2aTL|@>F@$5PKcQ|<+FAj?|sSU{c)7YPE7t00?f#~ zB20hcX6*D;#?~!3+W^H^2TNyP+uHv+&8rPcSSb=FR-c)utD(sbj+S{LQuLp4&!|u* zy6RC{1SEiiMv@ofdVPM{|}MO>#mnZ9l$wGvlEK z^)>vh!WQFmYrI|+r7!h*wK;&4+8oKX{laUZMUd~>zOk6F4Tjr50;Oay|CbIgNUi{L zZKwG21?s_Mr@kpV7p-eJ0SZZOBjhe@m&sQ3L3wM-s8Jr83G}cw5c|sSOIt=fxZu=g zu!p=E#sp9)Pa&%a8+KZ3LQuap`k}u&ooEr3N;oJkr@4Tn=#Jj|A)-aGK_uaOxIjPtT#$JW*rF`vpOA!i*&_wbTa3KxS4Q2R zct5C-Yoqwl6?JyD&XYTIQ@(jn2+7A%(X^9|l(kj)k0H9NeQOX=pZU_CR(M6ip0x7= zRwG#2_FYM{NRa3ofIEG-sUn0w-QI|SYN5Bi|GdXb1mth?L3gsjFXih5b<)+;)L+Lx z;*3P{8&xMdwg9AkL&|axJi5dNUel738Z56ZtcpG(3!RV=oxt`^RmzdJtRkehSgvB# zd!M4Yw2gF3S#eVm)qy2c7zyZsTDJZ%y)G4Cjk}&m};4F-ymW-9RF+v z3{aMi8~uJcs*+gRZ0f)2ro+uVo$>N-*oTy+Jt8J$E>qkNiB4!o-Tr3{cFAiW6+K4c zCTrEh5I)Z(W}uWw*=S4deXa+xaey(Fa<&h+ahtM$v_AszQHmCT$=ZDR_?`^Pu=e08GPt!`Z_*hUMX8jVt8BHvR`?sGTQnqW#gQSL1CABz=l~Fu9ILZzkN9 zR*H(Vm*v3LYL^EmZ^A+DWA>#F5{*%@?Ra`BuD4zeM$Nt-)2U|4X>tGCoxXjK{j$BR zXVdj%g<$Sb<}{}te{cbj?B1D?eULpj($a@@SRTppXKST{OcAQCxfv1*S8Z^9clG%i zqpRv@mRp*LI7QsRuAbG$sCNyYg0oW97UV)XmPe4EG)6suaRJqrCWD9oSRw?7Sx%Yl z;C*G9_;7&+43M!AIB;ZxzAg@SQ!{Yn#(Jqu^7K;0-aZQ#QKt%?oJ*zBOcVLA`kz!Z&I?B z+e=(}yufVcljXX=vV7cT1)~^W%I0523LqB{9hUPLcj1zd5cMin2SIr-ik+m!e33Vow5eUZPc8Jei=;UOz|LbUE?3g?w1UcY%F7z*qbUBDt{cp5(DMn$y1LPK~IR zIX@bACwqVt(-v2$Rt@pRMw~rzY&5QR+4pmfeAalphLmOnlQOznhUB$+`#A8}qW08l zYoI*U#v@=|rP|;5DUfVmI3-3LHhAu6P~MU?2NzL!DV<>2YMd%s{xaH0^PopuE_ajJ zr$@LHbxH(iMU}JEY1`b&*C)&VxuU9G^4^Hh#_ieC7q2g zv@}iXML_i3Rme-l)|M@L={G<991hL-93CpK5j($%(D1g*NiJ6PNG_S8dE;#PzHXcvXI;bD*1D3UziOQ}gr-g1Ce1YP{asV1XY z!g93WKc*~ezx;4Ee32~u<*&n6ws1HCyj{4P^*PByYQ9&o&Uf1{l_*p1-f+S<_L^+( z3Gx3T@9&p@%vW+2kypekvcU8s-(7(MWZUO^%}cD^SGvtpu?h;ZN^82jk21WNEB0{F ziLOMAGU5tR4%7{^yN<7hqmgek`jr{^oUJEr3XO^w`TW9tt!oiX`9@4{(!_tja3X@a zqB%#3d`|x+MgJ$!y@B0-K=TI5{{ht-F#iV>Z-Dk6kiCHo#T$^k!Nh++^j=23o%{Hi zJdZ@eQO>gKOLU+sN|p?D!*|JRVV!+RL-V+<>440ADvJk)Jw`IVQJIOWxO(qB#?2*8 z#fhu!q0z}#$o}D8y>~;)ap7;m7e$#N+vjDLiPyD-O&>dnuFE@E&MJ^J=QYX;_FXdM zET{7Eb(;_jNCT9<%-THy7Pl~ftM<;$Xv}F!_l*Zk131qcVf);{XPXb=jMelZ#+j`x zok%J@7fEWyD?R0|y20K9O?MSOKgN$EFAXjh<>ff^2k@`%oA58RrSBHDe0-0zu#FjM z2T@NdFLGU*5*G+vQA$lR;)!kyby6r{<{{KRguU++ccbSYzS$Or`K#OrnT=hK=Ke}K z^TV4S`~ocQt=i$Tx@Vg{4-UTwNdMAF+3ZxJ24d~SFm>`3atPF-u z+j!sGLx3LBQcDR7$`9;|RSMc7eT?IOI1(_OTw{;b@b*Lz{QCWcnYs&M*_z9KGWoXL z@8ApBIrAdPE({0a2yCrlGG%6Q#yeEnxO_j$2+}Fhy8M@Pt8ccsTS@YiML6p zon_ZLnxc{{=_^)7?vaYh2iF3Oj)!FYaa ztXpS0Ke;XuY3Bv4yA=*C`Q8VG3F@5OkG~vMfZ5FZ5NifR68SNZ-M;g=@e#3$8D|!+ zg<)Fk>>?_S$b(30GecwsP}VgBH*UoixyH2mya^(eCa7mM4)`)dZVNP!=Rn zED9Wx8@VqMkoL(zbp~;Fv{o#087K&5t7APCZi6iJIg24XJ}gRwyXG4KPs|`);7QL1 zep#=IJvv7g_zf1`v)iA=BIdV}7DsszJL5|Q8QD~;(T^O~xF*dZw4(Aj6TZ6-WU3^@ z4kd_(QDwXj%d4yV6e4BN$c?BFTjX65JzBOB#QS~Z;)Ozb%GMUR56KlpKF3jAmt(^8 z)~&al6gz48MO&GaS0vv={?_RI5DM{E*^gp}xJRFAMr3!bt#@!Q#SQDTfVAm*=6NC`C-b#AB!}Eiv&08 zh|_p53ajQ3;(JH3eS9c_Pjz+qmgymS#FUth0J$}JRIopPE|RYRmJG)Mmf zEf?rl%;)m`JEhFvphao>%>)+1cJBy!P=GJ1xUJaKbu7A$L%Umz(vNtI2hG)L3kDBr z|DEBL`g)+n=tugOOTRQQ005rvO3h zx1e6rDJdMtRc-jT>fPA_V_V_fhd|NoM&epRA9hNlkkp8Sl16Y?kXp8~{Nn>>f^XnbDBY=~v;T9IJh25ryn zID4eTBEyBkfYMy5N}5;@Nb+J>`t*@aB@&oBwY0NE)yJXpx}e-mgt8sx)wq4o&y%Mr zZ>QJYWMOg`fEJ!ods2I|`bDb;1Ygn&@Gx;-z@kLB00~KZVOB9QdboD_3~amRyYJZW z#Lq4|6c1$lSqFpYY_tSQ+=37hrD;%&EvAbZl?t7cQ zRKDa;ZQ(CB@z>LP-kf}7N)s{(|ASFfhXunAmRDETzT{-%Vo(Q;{)eO26jUs)=;5)o z71xG7gQqT&bT(sM5zbnxWnEplCqQlVOdU6=Zi}39<1b_1SAl!8SSTh@0?4jYbN`Aq5%HuaY_;f@qr~~6KfKAa4t`XaMj}kdAQ8_{tkFO~ z_=2M+Wyy)YwbpfefYiO7jHw&I%p~J3x6xW+PUbH5&m>Xj?iq7uS+$J%H}l_1!GSnK zU)j08{zt+nh_pc&mw%#{&wXaxxW#ZZfu?og9MWl>`F1|4^auE?E8vm48e?f4uRxZ{ zN%KKGyKW32R@fAq;fxJ!#+5)^R`{^#FdeBE^l8GOD=>v*VA@gER_m5(jLDRe#fRs9 z-Z9gBNM%uC*+aOQ*RNp_h+(SjI<(QpUko`5bi;Ev!DrGBi%97B4*!hqw34Hs&mCBGXLdt1U0r zxJQlr;4T{=DK~?JIqCBUqB&+5&9V^T@gowzd`JUK0wKB0Y35PVT!fJZ;$@t6oDL(n z!jTp%x%w;Hdoj(?rhP5qk^RYWK>b7iO4_~8I(xL4W4zn!>jYleZqYJOATJ|@=VW`i z8o$Jl1)Mv{uPE>K(O12get^$O>|q=w012RLvAIv!3`yBVvd}|SCV7kutGVX)Dh-Lb z4qxTCKLDAirjR*Hzy3z!4#>`1A>a78tG$5ptu`ylT`V_rtK?*_SI7hy?6C$kJG?Mn zxc?-j=O$_7<>b~UShpU&Bi9&+=pKF?y$k!1ZM)Kv<3NmcznEKRBwsS{1nx^m=6PsjalWhQvTsed%LCpHEsgk-i5x(&;j zWC=ZspW%*j@C`Tyg`U2_X#2||WkuGDBwaz5m7nB_ERxMI$YcWTT~}!n*#Mp(pOm`H z3=3Sb(WaFSx(h8ah9vBE!-vdn2nP2G!1IGXortwl?!%Em#QmcIW=bBcTr|hA2#=Op z>%0kCm_S^)ExVdZK;vT?Yemx2HP(a`FESjsbHdpC!vtznMLgjK@3&04rVscnh`+4| zH;cXAi!R>(FG>qMUx)vCuKH2S-kgt_xje_C`vVXmLK+4q-VXg*vi^ws`;>w)r|i0? z1U?k#svupI{CONpQ0;s1WQ!IRX&h!o_0F7>(7*;(_OxI(DEQUk%vCLL)8(o$qj$dX z3q=8jQ%*NR9jUYig1{PGHeD_W!(~DIFUdpga*h5+tCDY)ygtnG8QUnFwq*d0YFd0- z`%9NZO=Ob6=9Y65AG`j$S)YkG#FdS&U1j+OR2UuhDV&LNI-ZCtX;t2nUDoiGQJ>i8 zI^3|<>GuEO&$-rxyKk$BluQn4Cy}TI=3h!Z1Vu{>ip=X7pK1ba(1GI&>&^&~pYL&R z&=ASJ&%zI<(-u9|eBG;kQ$|RR{LYJ~N^RNC~q@kd>h=%emquBM|4I?lx zIj7sjzKEa-veS}b!uJWrh{y822A`0{Xsq3Pxt8CPAEh!wD6gqrGG!!kAG9J(yq|yD zsPr81!3rLNoZmQt1e`x~GB3*#B zi$=;xYkE2Iw2}7Ir=h_uJ6G}MBQ}|zQr^=7NF#j){FJg>c0tz@(n${5@)CDfjN9uJ zDtQkR9TG%en~l9=p!(VA#T164hjx1>Us}VeUKK2exDL zr3TgF9qnea7RQmg_^r1;mG8OjUjI#wPllglawaz0`zrZ>S3~iXpFu_>j%U-ihi*A& zAos1GIw^(Ol$-x<)KRe`Ud7F$=^xam&RVR53#D*-*4yWE`9Bp^MJf$8{PxcUTS;<^ zt8yr50weNLi35vL_Cm%ME>iR4hBgdyJ563^e!!6PyDXoqx3A-lUlA!hJ#<5x5r%>y zWb*t=b4RXF(E}gd*TMUBR(_S!xw}D`FV)vc#(oCr6+>0KVYoI_+APH-d5XwmJWNjs&#jj}l(c^Dp3jKTN-1*y}xY|3(QnC^P2r@P~Ge zz?lR@* z6JU@-Kvsm_(igmeAnQ}Bp+4e?+tX#(8r|mqiVxvOyh0OLog%mw1DEX(q^k@buBVK5 z82iXP=9+e7)=;>ind-J~>LkT~QgQtbY|AzZch6FOvSD8YW3A+T%Z@hy-=OCzZF5XA z@RM2g40fPvUc~0YSrA(!@$XQwHTyGqW<2D@#B*Vz z_^}Q!Ry@X)zvw@tr*?tn*(ffWZRVV(gV*50SXkj`}f65$1pGFOfjlva8^=8`UJ5Ril~t@t!%*-uoJoIR!lJ&e2w-f&?V5R4ZkC zb`i`u%Rzpm^2(6^-iy zyK<&O$w9iz9$tyZqWs9R=ek$P*Bde~|GDI!1ODi415Jh<5d~;1efd#JWCh7_G3lYf z-g9_8Ml;ed{a?oZ?7bhpMWFTt17!Jd1hKdTtbIPp8eq%sgEv!`Uu)-jhrCnC}S$$m1Aa&UO= zOX{LypE${2U={{(w~39e5lgvOG6e`CkK<)_KAGFPqIJH8K(+Na#9$>}?q{1su<)=( zbJ+uLYEmZAM>&0an%Gy8jn~ujlj#FL1l2ZnWC7?wm4!vY+_X2xpQVYtd%9ZCw8@?v zhQIT&<5&4t?i9PV>C3hWX_nrwz3&&h{jesegMH9}3En9RTG-1T`wF03Yg3D(bTi^{ zc~o;-4@ZMXUpB`}d+QG-l;jz+r{4*G_s7eTxWxY3;^_I4Rgxi7j~=XUJe}-VK@iL~ z(93sdifd7EDuO+CNC5k^9n^~}lCydaNBWCL-U7Z1?$E>PzD)^tspl5UgMiML6MP>d z{cNNAtTbW^vvB9KmH~L&poenE3R>YOf7s4f>LsiBxtj#eC@WtXjPbI)D&KKhvCL`{ z^raZQ7RLz{N~bn-z91lmQ4iy^UBmY%_*!>mt2YqX;G{UV!qZlJC78~dspX={91AK@ z-Bw~$Z=Jvx4`*&-H>dqFOU-b=4zfFu&9MU{Ek{6S|%7x^daEcM6o(m=o9YZ15?4a1m=? zGvmR2PiLd;mPOK}VM3r>-&@t>lcnORbjED;v?J9`NL|hCJcRfk9^eM9W zVBcbix(|l1TkT2r=_sC<|MKCOA2>m^af3zuX31yg7JhG(`0Wq0RvflV(_<_;y8UjO z&`D{bNaxY(h84pS=AOE@+6bCFi>wBFM?^3>ZkqS{^cj!@S}o3_eWJ%}5Ov+#K$ z(b7v%)c4ru!tq$Icgm2!>Zp^z){3988-%RuD@uf=l z^eO*kmgRK*m>-+~E4)=8y^ExANJ5dcR0A6ArsVAxf z?w_H+ArD<4(jVgZ%}~m$=~En|=Oo;7&GRJwDksI8vU|&0w173PvK81V?^c+0)dIUl zBVYkQ0a+!biCB{yWMi&L@CZibdNH@O77vstBK*OM-UFW}clT3Z@;AIT)h9 z+U81tkX+%akLI5g=*G?h%%8lL;)J+=MS=g{5S;C2j3sbv2%?;S5ZpeW_=Flg=tR-L)@f)WK z=X9m#BB?U=SXaIP_Uzm(W7J_WN>=sJ43Yr{x zJQ)hvo`!JUo&O0zUW{WCT4I?z!qY9mjmb#OAk|K;Ennj0r!opH*a!AJSNl?`!mP&t z+yeANzH`DlGBTZUd}ciCdc*wubBV2>0vC4+wi!%t5smVU9@2>Jim#GlskbFY5#~YG*o>7@q z%o13K<^t2rt&HNm-R}xNvH&!M%)EI^uXnXqoG{B$J{D(qdbB~ro;kAEaQ#$vBd3inSM7whzZ*CG_?VkX#b^UARe#MM!88G6g#Og zP%>1p;NbUOM6EI6Ey$H(_>e8iXy+Fs_05I!O;s5T;TL66(c7g?ieb7W-)xBEVT#7U z;rzh{@q$II5vthPpIR)3GvV~$L#ao zQYJetos5WJr1+bRnQAw$PW=GyED$Io9FxH=Y)do)t9B~I(zO3CiYeaP-vh9Q;|X&f zfqqAL=Iw0Z@GnhQd`meYZZBcDY<|Zg0v!Bw>dk+Uqg<-yb(JuBl=V`QI0;H!HqxR@^rE z>|5bQ%)BW#N`ydAYA9XG^uw=oO|!QKJ1PH}6z75yA-}xnHF8XE<9PvZHB!l4IVym$ zI8W9&%)AZlmfFHsOfl3Ni{E-{fqIyZZiMRgF{4qVAF;qwF{Efck>W2Y&Rb&zg%75- zXP|rvelu@E-A=?*0$z-!g14bKUr`7Zy-Kbs3U9tpCdg^3iOGrf2D~Z=CkV#8)_ZuT zYr^995-#&91aumGN1)W`BSolu%r&hfu7au7e&;^$|y`xWJihst zNZ9#65|N%P+%?Rv>CH-*Bm4K%*(>yK{l{WGmpkX)UD}gB!}B|@B6lAgIrdgOenV!u z)Ir~stFq`8Clag=ha0c|Q_lrkT}fsBkC>7(Tki_&*)k%OVAs)W1 literal 0 HcmV?d00001 diff --git a/tests/testthat/helper-stats_cases.R b/tests/testthat/helper-stats_cases.R new file mode 100644 index 00000000..0d5014ee --- /dev/null +++ b/tests/testthat/helper-stats_cases.R @@ -0,0 +1,98 @@ +# Cases used to check that the statistics stay the same when the way they are +# computed changes. The reference outputs are made by +# `_inputs/make_stats_reference.R` and stored in `_inputs/stats_reference.rds`. + +#' Build the simulations / observations used for the statistics reference +#' +#' @param inputs Path to `sim_obs.RData` +#' +#' @return A named list of cases, each being a list of arguments for +#' `statistics_situations()` +stats_cases <- function(inputs = test_path("_inputs", "sim_obs.RData")) { + env <- new.env() + load(inputs, envir = env) + sim <- env$sim + obs <- env$obs + sim_rot <- env$sim_rot + + # Second version of the intercrop simulations, slightly different: + sim_v2 <- sim + for (s in names(sim_v2)) { + sim_v2[[s]]$lai_n <- sim_v2[[s]]$lai_n * 1.1 + sim_v2[[s]]$masec_n <- sim_v2[[s]]$masec_n * 0.9 + 0.05 + } + + # Synthetic observations for the rotation simulations, with edge cases: + set.seed(42) + obs_rot <- lapply(names(sim_rot), function(s) { + sim_s <- sim_rot[[s]] + dates <- sort(sample(sim_s$Date, 12)) + o <- sim_s[sim_s$Date %in% dates, c("Date", "lai_n", "masec_n", "HR_1")] + n <- nrow(o) + noise <- function(x) x * stats::runif(n, 0.7, 1.3) + stats::rnorm(n, 0, 0.01) + o$lai_n <- noise(o$lai_n) + o$lai_n[o$lai_n < 0.05] <- 0 # observed zeros (MAPE, RME) + o$masec_n <- noise(o$masec_n) + o$HR_1 <- noise(o$HR_1) + o$HR_1[c(2, 5)] <- NA # missing observations + o$Qles <- NA_real_ # variable observed only once + o$Qles[3] <- sim_s$Qles[sim_s$Date == o$Date[3]] + 1 + o$resmes <- NA_real_ # constant observations + o$resmes[1:4] <- 100 + o$ET <- noise(sim_s$et[sim_s$Date %in% dates]) # different casing + o$not_simulated <- 1 # variable not in the simulations + o$Plant <- unique(sim_s$Plant) + o + }) + names(obs_rot) <- names(sim_rot) + + sim_rot_v2 <- sim_rot + for (s in names(sim_rot_v2)) { + sim_rot_v2[[s]]$masec_n <- sim_rot_v2[[s]]$masec_n * 1.2 + } + + sim_sole <- sim[c("SC_Pea_2005-2006_N0", "SC_Wheat_2005-2006_N0")] + attr(sim_sole, "class") <- "cropr_simulation" + + obs_missing <- obs + obs_missing[["SC_Wheat_2005-2006_N0"]] <- NULL + + case <- function(dots, obs, ...) c(dots, list(obs = obs, ...)) + + list( + mixture_all = case(list(sim), obs), + mixture_sit = case(list(sim), obs, all_situations = FALSE), + mixture_versions_all = case(list(v1 = sim, v2 = sim_v2), obs), + mixture_versions_sit = case( + list(v1 = sim, v2 = sim_v2), obs, + all_situations = FALSE + ), + mixture_missing_obs_all = case(list(sim), obs_missing), + mixture_missing_obs_sit = case( + list(sim), obs_missing, + all_situations = FALSE + ), + mixture_stat_subset = case( + list(sim), obs, + stat = c("n_obs", "RMSE", "Decision") + ), + sole_all = case(list(sim_sole), obs), + rotation_all = case(list(sim_rot), obs_rot), + rotation_sit = case(list(sim_rot), obs_rot, all_situations = FALSE), + rotation_versions_sit = case( + list(a = sim_rot, b = sim_rot_v2), obs_rot, + all_situations = FALSE + ) + ) +} + +#' Compute the statistics of a case with a given statistics function +run_stats_case <- function(case, fun = statistics_situations) { + out <- NULL + utils::capture.output( + out <- suppressWarnings(suppressMessages( + do.call(fun, c(case, verbose = FALSE)) + )) + ) + out +} diff --git a/tests/testthat/test-stats_reference.R b/tests/testthat/test-stats_reference.R new file mode 100644 index 00000000..05e321cf --- /dev/null +++ b/tests/testthat/test-stats_reference.R @@ -0,0 +1,14 @@ +# Check that the statistics are the same as the reference ones, made by +# `_inputs/make_stats_reference.R` on the previous version of the code. + +reference <- readRDS(test_path("_inputs", "stats_reference.rds")) +cases <- stats_cases() + +for (case_name in names(reference)) { + test_that(paste("statistics are unchanged:", case_name), { + expect_equal( + run_stats_case(cases[[case_name]]), + reference[[case_name]] + ) + }) +} From 5f73b0b816d4fea81a4335f4a60e79a0aeeb20fb Mon Sep 17 00:00:00 2001 From: Valentine Rahier Date: Mon, 5 Oct 2026 17:10:02 +0200 Subject: [PATCH 2/4] remove debug tests --- tests/testthat/_inputs/make_stats_reference.R | 13 --- tests/testthat/helper-stats_cases.R | 98 ------------------- tests/testthat/test-stats_reference.R | 14 --- 3 files changed, 125 deletions(-) delete mode 100644 tests/testthat/_inputs/make_stats_reference.R delete mode 100644 tests/testthat/helper-stats_cases.R delete mode 100644 tests/testthat/test-stats_reference.R diff --git a/tests/testthat/_inputs/make_stats_reference.R b/tests/testthat/_inputs/make_stats_reference.R deleted file mode 100644 index cbd7fa67..00000000 --- a/tests/testthat/_inputs/make_stats_reference.R +++ /dev/null @@ -1,13 +0,0 @@ -# Make the reference statistics used in test-stats_reference.R -# -# Run from the package root, on the version of the code taken as reference: -# Rscript tests/testthat/_inputs/make_stats_reference.R - -devtools::load_all(".", quiet = TRUE) -library(testthat) -source("tests/testthat/helper-stats_cases.R") - -cases <- stats_cases("tests/testthat/_inputs/sim_obs.RData") -reference <- lapply(cases, run_stats_case) - -saveRDS(reference, "tests/testthat/_inputs/stats_reference.rds", version = 2) diff --git a/tests/testthat/helper-stats_cases.R b/tests/testthat/helper-stats_cases.R deleted file mode 100644 index 0d5014ee..00000000 --- a/tests/testthat/helper-stats_cases.R +++ /dev/null @@ -1,98 +0,0 @@ -# Cases used to check that the statistics stay the same when the way they are -# computed changes. The reference outputs are made by -# `_inputs/make_stats_reference.R` and stored in `_inputs/stats_reference.rds`. - -#' Build the simulations / observations used for the statistics reference -#' -#' @param inputs Path to `sim_obs.RData` -#' -#' @return A named list of cases, each being a list of arguments for -#' `statistics_situations()` -stats_cases <- function(inputs = test_path("_inputs", "sim_obs.RData")) { - env <- new.env() - load(inputs, envir = env) - sim <- env$sim - obs <- env$obs - sim_rot <- env$sim_rot - - # Second version of the intercrop simulations, slightly different: - sim_v2 <- sim - for (s in names(sim_v2)) { - sim_v2[[s]]$lai_n <- sim_v2[[s]]$lai_n * 1.1 - sim_v2[[s]]$masec_n <- sim_v2[[s]]$masec_n * 0.9 + 0.05 - } - - # Synthetic observations for the rotation simulations, with edge cases: - set.seed(42) - obs_rot <- lapply(names(sim_rot), function(s) { - sim_s <- sim_rot[[s]] - dates <- sort(sample(sim_s$Date, 12)) - o <- sim_s[sim_s$Date %in% dates, c("Date", "lai_n", "masec_n", "HR_1")] - n <- nrow(o) - noise <- function(x) x * stats::runif(n, 0.7, 1.3) + stats::rnorm(n, 0, 0.01) - o$lai_n <- noise(o$lai_n) - o$lai_n[o$lai_n < 0.05] <- 0 # observed zeros (MAPE, RME) - o$masec_n <- noise(o$masec_n) - o$HR_1 <- noise(o$HR_1) - o$HR_1[c(2, 5)] <- NA # missing observations - o$Qles <- NA_real_ # variable observed only once - o$Qles[3] <- sim_s$Qles[sim_s$Date == o$Date[3]] + 1 - o$resmes <- NA_real_ # constant observations - o$resmes[1:4] <- 100 - o$ET <- noise(sim_s$et[sim_s$Date %in% dates]) # different casing - o$not_simulated <- 1 # variable not in the simulations - o$Plant <- unique(sim_s$Plant) - o - }) - names(obs_rot) <- names(sim_rot) - - sim_rot_v2 <- sim_rot - for (s in names(sim_rot_v2)) { - sim_rot_v2[[s]]$masec_n <- sim_rot_v2[[s]]$masec_n * 1.2 - } - - sim_sole <- sim[c("SC_Pea_2005-2006_N0", "SC_Wheat_2005-2006_N0")] - attr(sim_sole, "class") <- "cropr_simulation" - - obs_missing <- obs - obs_missing[["SC_Wheat_2005-2006_N0"]] <- NULL - - case <- function(dots, obs, ...) c(dots, list(obs = obs, ...)) - - list( - mixture_all = case(list(sim), obs), - mixture_sit = case(list(sim), obs, all_situations = FALSE), - mixture_versions_all = case(list(v1 = sim, v2 = sim_v2), obs), - mixture_versions_sit = case( - list(v1 = sim, v2 = sim_v2), obs, - all_situations = FALSE - ), - mixture_missing_obs_all = case(list(sim), obs_missing), - mixture_missing_obs_sit = case( - list(sim), obs_missing, - all_situations = FALSE - ), - mixture_stat_subset = case( - list(sim), obs, - stat = c("n_obs", "RMSE", "Decision") - ), - sole_all = case(list(sim_sole), obs), - rotation_all = case(list(sim_rot), obs_rot), - rotation_sit = case(list(sim_rot), obs_rot, all_situations = FALSE), - rotation_versions_sit = case( - list(a = sim_rot, b = sim_rot_v2), obs_rot, - all_situations = FALSE - ) - ) -} - -#' Compute the statistics of a case with a given statistics function -run_stats_case <- function(case, fun = statistics_situations) { - out <- NULL - utils::capture.output( - out <- suppressWarnings(suppressMessages( - do.call(fun, c(case, verbose = FALSE)) - )) - ) - out -} diff --git a/tests/testthat/test-stats_reference.R b/tests/testthat/test-stats_reference.R deleted file mode 100644 index 05e321cf..00000000 --- a/tests/testthat/test-stats_reference.R +++ /dev/null @@ -1,14 +0,0 @@ -# Check that the statistics are the same as the reference ones, made by -# `_inputs/make_stats_reference.R` on the previous version of the code. - -reference <- readRDS(test_path("_inputs", "stats_reference.rds")) -cases <- stats_cases() - -for (case_name in names(reference)) { - test_that(paste("statistics are unchanged:", case_name), { - expect_equal( - run_stats_case(cases[[case_name]]), - reference[[case_name]] - ) - }) -} From 46b325562dcba3ee3829ed595fdb7bb30e2d152c Mon Sep 17 00:00:00 2001 From: Valentine Rahier Date: Mon, 5 Oct 2026 17:11:13 +0200 Subject: [PATCH 3/4] remove debug file --- tests/testthat/_inputs/stats_reference.rds | Bin 13670 -> 0 bytes 1 file changed, 0 insertions(+), 0 deletions(-) delete mode 100644 tests/testthat/_inputs/stats_reference.rds diff --git a/tests/testthat/_inputs/stats_reference.rds b/tests/testthat/_inputs/stats_reference.rds deleted file mode 100644 index 00e45a46c1edf21589165ced58ee91de35db3ced..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 13670 zcmZXaWmFtZ*rpRgkU$`~yM^HH?rs5sPH=(~+=k%p?ry=|1_emMTiHwsLQPdf7Hck467>R-=cwCaDWZNZ$`hiP;dv#?v>=GcWchf~(83*gl$ z2ex*Yefm^QAS6wUCKFarT=Y*({c~3)-%Sj1NC6?xQ1E7uyNzU!^=2&B8oXus%i4tc zrQC?}cW`Y|Qd~h%LVfM*l=)y+jq*)iEqfDZ9f6mGh3%Q89sdn(hzUVAst5YBW2BHq z4_;+Vzc4W>KI|ZO;|TgNv|*>1w|96DT$_cZB&VTBy~Jkgr-&|es%2xXmp!~*c#pJM z+wpR9t&S6U;I||-0unT}|Mso1{NCl?k?;!hUCf!(`4RpBy)$D+pzU;Q7K5*X(^{wU z@j&(lP%*(+!uTZFd``KNHK9(Dk%QC1uC9$jFY0pb#JmXeP_cIZthrIkz(NXo6EUCB zIYioxhwgoi&S52SN4Oq%y1Jnz>ZRy^ewU^a+oAhgthqal+R|W@!QHuBq%P&xJYHoT`(?)0V|RU={lS=K1<^gs z63%Ny6w_+XHCpOIqxY2=H>8`$0)Nibj4|s`^?A43m}NS?|D~wgoY;ok*n7T<3AznO zHN}bTP`#a5LCuPo!gu0R=(%FA3;Fe3xMdrH+O(Mp>jCwDTCQ#>XF2jJ`rs;UaTj<^ zK;@PE?}ceHN3OT>2?#3Q{0n&jZM^)TqI@U3cy$ESO$|T$=-yjWox=O>MXk_k^a;(B z<<=o_wN?T@eUjN#2&C!xxnYF|p4%MCn~y&ec2(Hz zhV%IzHzP^N8U774c40>8dADiaZS0rKLFDwy5u;hKCGWDS%Cqis&j0bq6YD;VExjXg z3;*1-noX)7vHi^o_PNy+GbPLFh09#z}Ow@q!R$O?9?acQDbL_g9e zXY z5oKR6mq@K~Dfq!D?JdH$3ojZ#9W8a5wU9-y*eF#om$x z=t}4l0y+cQO@a@ZPMM-ekiVBTVmDw97;4xiE{fZxJ;CQYLXoA;Syf!er1K7Yn@LQFx%qlF8%n4PL28sODQeI>D5 zm~6>=e`s@C!m8-BG-hE8-m|i^>*WzFMz(a~5XLiMuyB$QHX*8?W-5RT@F1Zu(^{#> zj{ZWjJ^MLeVGcIt!@MGk#erH^JDx}i=U+7)w7cr0>!z>reh!eCIPk@{N2cHGiu`87 zKRr9iXs^c3mYfmyHFZG zmnL*$-4uc+AZ_;6O6ET3qcSqpC6CG|`el9E$HPwCAnl(Hq37pa;{Ve9GPQDeWNIhW zKvnGhIwm1HIN(?(oS$J!QV~_jc#m%Tih`~t>|wCI{VUAf2J$N%oeT@_+818|ew(ht zS|RS#{;VLgEub>1@`I7!Gxn3Vwy*-x%;ymm8wa?eO&fI&cPkR2Ky&Y&ooHq6-VYuv z9$b1@yFLTaxXDz99m%yxwOlzheOLRVc-Nmv67w+Zt*mV=1f01@@+G`OT^W9WSIoda z?M$qq4-%&pc4bWp7W*MJm=aCCR24~}%7B1}Bjkvk{9!9`UGQhmZh4%!!C8blL~o=~DRvJiTK)ztRo z&pw=W4?)C(vI)_?9D7UL%js!)5R77#Ss%$&nd&>=g>RIPbVwUvNVnU|vjfBK_c<5y zjB`O$iyYT+*ZYg*skz)a1qt=bm&6yQ;3LVFZ;{YQGSMC7=iy;vOW~%P#z!;!FAEfb zxLGecncGG1{aZgw#P@DbUM)^FN46ziudkdP=9H!IF#{o7M$chH_|F-!LU}Y5-mkP? zSN8a{(ixSM_6_qrYfHnj>uXDvmc|CP&PSW_1>>Wy^goM}pX_aRW+*vflRV0%FNYqv zo9o=3*uO$zE-$AENzr?EcS{bpC%YR|yR7&8*gk$1@n<{PVB+y=4m8%Uj_I45Tt@{& zP89jzt%o^gr4R$jyZ#c1(a7u;vJT`iq#j`E9gRA9{zB=t$(O7D7>0uKtBRt za+CX$gHX73$HZ)$;W`0=k{z|yT7zG@;PVK(0_=3$i`0AqfVGTon$UP#>$U7*!>fe2Lskiesu!*eQ;N)kH?exk# z9Gz&$9j{xGw)P(Eu4i8w_^sJw3nOIv+&j;1UjLny?;%yB@65s|{NsGOR(cxH0O~mY|)z*rbiYv;S!|_3dSmjwyAYSA0w;)b>A zmB+aDEv$g$?l_i|41B@WjmWF+^GAD_Z)&U`sB}mAV4PCc zyDwftFgEsypRC&0w~r}rr`DlVq#*Y<;P z#$}h$^4C-LXl>)W_)a|oeouPDHn4LDopu>{7o1UA00#4QF5{wW+^91DQE5h8d9Me$ z=biS7?y`bJl8gJvSwea4uA*~H^{d`qN@F6xqT7aQ=;?)v+;P{<(rgn_Ra1?@f5xQ1 zm1LY}**uQ-Edg(eu^Hy%Ezf#2T8XN{RH_&ppU)4gQ23~7mO=?yQY7S0o}mFT-Ufzi zqBcg?>gBaP8D6F>PEJ7*(3x@>!`8x>3g%e}wqOwG~Ufq~!?NqDL`wI+yqftwi9idQ6Yb)Y*#}M`MF6su?T-sjtIe*7) z2>R|}zquTeWx4qt!Ux_a)V}L2UyUO(v~HD1PDHjirbqtj@*MwD42FZrpGea=-X8Qc zVpocrb;0?kBA>6MPGvKArJl2lQ+Z7Fy?XVP6`5$a;i+-@DX!`>wE$zd3etm*;oVD* z{ED|FFGlvn|oeFXy4c`tvNJFHx_{BMtkstpPVW$F5fU-TU^5X{q7NZIA_N{8LG+u>FKqjqlg3fdl?>zJtTc8JB#x%->Iync4~;fc|M zq2^CL`PM(IZ*jUacF-UGNabu(>u-2=c9K3kWXi{4S08=UXpdL~nX34$S5n?u_|J>B zhqAlY#$xKTqUA3;dgJMTU+={~J_vil1ZFx|ycWaLsk@MX2TA_?C_-8cOyv(1Y$)_| zy(GmZ-sZ1rX(xE%dq$aD0?7cYF~f1+p2-1jzqt^r`?CDZX|gmUg)65BD46HAwBT?A zJRi@P6D2gCJ8U^%IzxOj%>Wc zE&NgxEO>!7ua_iFc&@Uagtwx`5!vykx1 z%zIVp8ExeZ5p?0ob{whuEjU4gN98EI)j;=7$l$E^=u(6VkZPBr-JTveh7LGts<5S> zXCGSXTr!_M?E^e{CSq%ETRB5Wo_CULqKPh_Q9A2DS1JGQ9g$$cUJ;_*Ld!Y?GJ3fY zJ}C}J_XwOUYTUF}h8&p@YFBe06_cI8C2dXwt#AFts1wbM6LjmeK$V83)YQqBl4@EY zK6y#oFc}H$?Q~wsQ9&|S2iyjXTnp6e>TVG*WWa z>SA;(%4%xf`j$oPV3y$xZg60f5tN0^N8%suXs z0w{$y*T#1Qd)Wf1)CI)Xg-=dol-l!>0$%-zyNG%)%E^5Qq{CnCNh24}e=%vNg8gz=)R3LVl^_R+&?TiHZGqXiM_tcyrCQoki>PJFSPl zwB!N=0u*9zht6d<^k^DuoXrSr*(29*93ggi8nuEQyltQ>#zP3Z*ZjcXwWQ0}xfWc=v|fvNLY0i@o);oq^be+R72z!* z`))20@BQIf;rvN7WlxdNxk6Q&{HCm?7ScMA`Hv{W`Vx*|b45@K$kSxCddm)nK)XDE zufS2Xg1et5q{THWsUuT%H{SH-WmnUg6r)V#RXi%ZO2RjztYDFI)5PwC6SPEqcshhq zya`}^CV!&`{@7Nv&OFduG`c@pxAL3wV!>ph%RTj%h15`kd0i^bzxK9CP+leR?iMQNY?&Go2> z`$rpvnKUT{fJ^kQ$LMVgFAH%m%ix^m_rnGPjeKB6;fx3BYZekfI?z|FFw#7`f}QZM zJ`_!%S}>X|^l~tJ!!&HV{w9=Eq&SAD_0eY7dy^CTsCCjie1|fX5_=PR9sDVrLym?k zbF?g0_IW9KvJ0xZvFe5;+#F{2aTL|@>F@$5PKcQ|<+FAj?|sSU{c)7YPE7t00?f#~ zB20hcX6*D;#?~!3+W^H^2TNyP+uHv+&8rPcSSb=FR-c)utD(sbj+S{LQuLp4&!|u* zy6RC{1SEiiMv@ofdVPM{|}MO>#mnZ9l$wGvlEK z^)>vh!WQFmYrI|+r7!h*wK;&4+8oKX{laUZMUd~>zOk6F4Tjr50;Oay|CbIgNUi{L zZKwG21?s_Mr@kpV7p-eJ0SZZOBjhe@m&sQ3L3wM-s8Jr83G}cw5c|sSOIt=fxZu=g zu!p=E#sp9)Pa&%a8+KZ3LQuap`k}u&ooEr3N;oJkr@4Tn=#Jj|A)-aGK_uaOxIjPtT#$JW*rF`vpOA!i*&_wbTa3KxS4Q2R zct5C-Yoqwl6?JyD&XYTIQ@(jn2+7A%(X^9|l(kj)k0H9NeQOX=pZU_CR(M6ip0x7= zRwG#2_FYM{NRa3ofIEG-sUn0w-QI|SYN5Bi|GdXb1mth?L3gsjFXih5b<)+;)L+Lx z;*3P{8&xMdwg9AkL&|axJi5dNUel738Z56ZtcpG(3!RV=oxt`^RmzdJtRkehSgvB# zd!M4Yw2gF3S#eVm)qy2c7zyZsTDJZ%y)G4Cjk}&m};4F-ymW-9RF+v z3{aMi8~uJcs*+gRZ0f)2ro+uVo$>N-*oTy+Jt8J$E>qkNiB4!o-Tr3{cFAiW6+K4c zCTrEh5I)Z(W}uWw*=S4deXa+xaey(Fa<&h+ahtM$v_AszQHmCT$=ZDR_?`^Pu=e08GPt!`Z_*hUMX8jVt8BHvR`?sGTQnqW#gQSL1CABz=l~Fu9ILZzkN9 zR*H(Vm*v3LYL^EmZ^A+DWA>#F5{*%@?Ra`BuD4zeM$Nt-)2U|4X>tGCoxXjK{j$BR zXVdj%g<$Sb<}{}te{cbj?B1D?eULpj($a@@SRTppXKST{OcAQCxfv1*S8Z^9clG%i zqpRv@mRp*LI7QsRuAbG$sCNyYg0oW97UV)XmPe4EG)6suaRJqrCWD9oSRw?7Sx%Yl z;C*G9_;7&+43M!AIB;ZxzAg@SQ!{Yn#(Jqu^7K;0-aZQ#QKt%?oJ*zBOcVLA`kz!Z&I?B z+e=(}yufVcljXX=vV7cT1)~^W%I0523LqB{9hUPLcj1zd5cMin2SIr-ik+m!e33Vow5eUZPc8Jei=;UOz|LbUE?3g?w1UcY%F7z*qbUBDt{cp5(DMn$y1LPK~IR zIX@bACwqVt(-v2$Rt@pRMw~rzY&5QR+4pmfeAalphLmOnlQOznhUB$+`#A8}qW08l zYoI*U#v@=|rP|;5DUfVmI3-3LHhAu6P~MU?2NzL!DV<>2YMd%s{xaH0^PopuE_ajJ zr$@LHbxH(iMU}JEY1`b&*C)&VxuU9G^4^Hh#_ieC7q2g zv@}iXML_i3Rme-l)|M@L={G<991hL-93CpK5j($%(D1g*NiJ6PNG_S8dE;#PzHXcvXI;bD*1D3UziOQ}gr-g1Ce1YP{asV1XY z!g93WKc*~ezx;4Ee32~u<*&n6ws1HCyj{4P^*PByYQ9&o&Uf1{l_*p1-f+S<_L^+( z3Gx3T@9&p@%vW+2kypekvcU8s-(7(MWZUO^%}cD^SGvtpu?h;ZN^82jk21WNEB0{F ziLOMAGU5tR4%7{^yN<7hqmgek`jr{^oUJEr3XO^w`TW9tt!oiX`9@4{(!_tja3X@a zqB%#3d`|x+MgJ$!y@B0-K=TI5{{ht-F#iV>Z-Dk6kiCHo#T$^k!Nh++^j=23o%{Hi zJdZ@eQO>gKOLU+sN|p?D!*|JRVV!+RL-V+<>440ADvJk)Jw`IVQJIOWxO(qB#?2*8 z#fhu!q0z}#$o}D8y>~;)ap7;m7e$#N+vjDLiPyD-O&>dnuFE@E&MJ^J=QYX;_FXdM zET{7Eb(;_jNCT9<%-THy7Pl~ftM<;$Xv}F!_l*Zk131qcVf);{XPXb=jMelZ#+j`x zok%J@7fEWyD?R0|y20K9O?MSOKgN$EFAXjh<>ff^2k@`%oA58RrSBHDe0-0zu#FjM z2T@NdFLGU*5*G+vQA$lR;)!kyby6r{<{{KRguU++ccbSYzS$Or`K#OrnT=hK=Ke}K z^TV4S`~ocQt=i$Tx@Vg{4-UTwNdMAF+3ZxJ24d~SFm>`3atPF-u z+j!sGLx3LBQcDR7$`9;|RSMc7eT?IOI1(_OTw{;b@b*Lz{QCWcnYs&M*_z9KGWoXL z@8ApBIrAdPE({0a2yCrlGG%6Q#yeEnxO_j$2+}Fhy8M@Pt8ccsTS@YiML6p zon_ZLnxc{{=_^)7?vaYh2iF3Oj)!FYaa ztXpS0Ke;XuY3Bv4yA=*C`Q8VG3F@5OkG~vMfZ5FZ5NifR68SNZ-M;g=@e#3$8D|!+ zg<)Fk>>?_S$b(30GecwsP}VgBH*UoixyH2mya^(eCa7mM4)`)dZVNP!=Rn zED9Wx8@VqMkoL(zbp~;Fv{o#087K&5t7APCZi6iJIg24XJ}gRwyXG4KPs|`);7QL1 zep#=IJvv7g_zf1`v)iA=BIdV}7DsszJL5|Q8QD~;(T^O~xF*dZw4(Aj6TZ6-WU3^@ z4kd_(QDwXj%d4yV6e4BN$c?BFTjX65JzBOB#QS~Z;)Ozb%GMUR56KlpKF3jAmt(^8 z)~&al6gz48MO&GaS0vv={?_RI5DM{E*^gp}xJRFAMr3!bt#@!Q#SQDTfVAm*=6NC`C-b#AB!}Eiv&08 zh|_p53ajQ3;(JH3eS9c_Pjz+qmgymS#FUth0J$}JRIopPE|RYRmJG)Mmf zEf?rl%;)m`JEhFvphao>%>)+1cJBy!P=GJ1xUJaKbu7A$L%Umz(vNtI2hG)L3kDBr z|DEBL`g)+n=tugOOTRQQ005rvO3h zx1e6rDJdMtRc-jT>fPA_V_V_fhd|NoM&epRA9hNlkkp8Sl16Y?kXp8~{Nn>>f^XnbDBY=~v;T9IJh25ryn zID4eTBEyBkfYMy5N}5;@Nb+J>`t*@aB@&oBwY0NE)yJXpx}e-mgt8sx)wq4o&y%Mr zZ>QJYWMOg`fEJ!ods2I|`bDb;1Ygn&@Gx;-z@kLB00~KZVOB9QdboD_3~amRyYJZW z#Lq4|6c1$lSqFpYY_tSQ+=37hrD;%&EvAbZl?t7cQ zRKDa;ZQ(CB@z>LP-kf}7N)s{(|ASFfhXunAmRDETzT{-%Vo(Q;{)eO26jUs)=;5)o z71xG7gQqT&bT(sM5zbnxWnEplCqQlVOdU6=Zi}39<1b_1SAl!8SSTh@0?4jYbN`Aq5%HuaY_;f@qr~~6KfKAa4t`XaMj}kdAQ8_{tkFO~ z_=2M+Wyy)YwbpfefYiO7jHw&I%p~J3x6xW+PUbH5&m>Xj?iq7uS+$J%H}l_1!GSnK zU)j08{zt+nh_pc&mw%#{&wXaxxW#ZZfu?og9MWl>`F1|4^auE?E8vm48e?f4uRxZ{ zN%KKGyKW32R@fAq;fxJ!#+5)^R`{^#FdeBE^l8GOD=>v*VA@gER_m5(jLDRe#fRs9 z-Z9gBNM%uC*+aOQ*RNp_h+(SjI<(QpUko`5bi;Ev!DrGBi%97B4*!hqw34Hs&mCBGXLdt1U0r zxJQlr;4T{=DK~?JIqCBUqB&+5&9V^T@gowzd`JUK0wKB0Y35PVT!fJZ;$@t6oDL(n z!jTp%x%w;Hdoj(?rhP5qk^RYWK>b7iO4_~8I(xL4W4zn!>jYleZqYJOATJ|@=VW`i z8o$Jl1)Mv{uPE>K(O12get^$O>|q=w012RLvAIv!3`yBVvd}|SCV7kutGVX)Dh-Lb z4qxTCKLDAirjR*Hzy3z!4#>`1A>a78tG$5ptu`ylT`V_rtK?*_SI7hy?6C$kJG?Mn zxc?-j=O$_7<>b~UShpU&Bi9&+=pKF?y$k!1ZM)Kv<3NmcznEKRBwsS{1nx^m=6PsjalWhQvTsed%LCpHEsgk-i5x(&;j zWC=ZspW%*j@C`Tyg`U2_X#2||WkuGDBwaz5m7nB_ERxMI$YcWTT~}!n*#Mp(pOm`H z3=3Sb(WaFSx(h8ah9vBE!-vdn2nP2G!1IGXortwl?!%Em#QmcIW=bBcTr|hA2#=Op z>%0kCm_S^)ExVdZK;vT?Yemx2HP(a`FESjsbHdpC!vtznMLgjK@3&04rVscnh`+4| zH;cXAi!R>(FG>qMUx)vCuKH2S-kgt_xje_C`vVXmLK+4q-VXg*vi^ws`;>w)r|i0? z1U?k#svupI{CONpQ0;s1WQ!IRX&h!o_0F7>(7*;(_OxI(DEQUk%vCLL)8(o$qj$dX z3q=8jQ%*NR9jUYig1{PGHeD_W!(~DIFUdpga*h5+tCDY)ygtnG8QUnFwq*d0YFd0- z`%9NZO=Ob6=9Y65AG`j$S)YkG#FdS&U1j+OR2UuhDV&LNI-ZCtX;t2nUDoiGQJ>i8 zI^3|<>GuEO&$-rxyKk$BluQn4Cy}TI=3h!Z1Vu{>ip=X7pK1ba(1GI&>&^&~pYL&R z&=ASJ&%zI<(-u9|eBG;kQ$|RR{LYJ~N^RNC~q@kd>h=%emquBM|4I?lx zIj7sjzKEa-veS}b!uJWrh{y822A`0{Xsq3Pxt8CPAEh!wD6gqrGG!!kAG9J(yq|yD zsPr81!3rLNoZmQt1e`x~GB3*#B zi$=;xYkE2Iw2}7Ir=h_uJ6G}MBQ}|zQr^=7NF#j){FJg>c0tz@(n${5@)CDfjN9uJ zDtQkR9TG%en~l9=p!(VA#T164hjx1>Us}VeUKK2exDL zr3TgF9qnea7RQmg_^r1;mG8OjUjI#wPllglawaz0`zrZ>S3~iXpFu_>j%U-ihi*A& zAos1GIw^(Ol$-x<)KRe`Ud7F$=^xam&RVR53#D*-*4yWE`9Bp^MJf$8{PxcUTS;<^ zt8yr50weNLi35vL_Cm%ME>iR4hBgdyJ563^e!!6PyDXoqx3A-lUlA!hJ#<5x5r%>y zWb*t=b4RXF(E}gd*TMUBR(_S!xw}D`FV)vc#(oCr6+>0KVYoI_+APH-d5XwmJWNjs&#jj}l(c^Dp3jKTN-1*y}xY|3(QnC^P2r@P~Ge zz?lR@* z6JU@-Kvsm_(igmeAnQ}Bp+4e?+tX#(8r|mqiVxvOyh0OLog%mw1DEX(q^k@buBVK5 z82iXP=9+e7)=;>ind-J~>LkT~QgQtbY|AzZch6FOvSD8YW3A+T%Z@hy-=OCzZF5XA z@RM2g40fPvUc~0YSrA(!@$XQwHTyGqW<2D@#B*Vz z_^}Q!Ry@X)zvw@tr*?tn*(ffWZRVV(gV*50SXkj`}f65$1pGFOfjlva8^=8`UJ5Ril~t@t!%*-uoJoIR!lJ&e2w-f&?V5R4ZkC zb`i`u%Rzpm^2(6^-iy zyK<&O$w9iz9$tyZqWs9R=ek$P*Bde~|GDI!1ODi415Jh<5d~;1efd#JWCh7_G3lYf z-g9_8Ml;ed{a?oZ?7bhpMWFTt17!Jd1hKdTtbIPp8eq%sgEv!`Uu)-jhrCnC}S$$m1Aa&UO= zOX{LypE${2U={{(w~39e5lgvOG6e`CkK<)_KAGFPqIJH8K(+Na#9$>}?q{1su<)=( zbJ+uLYEmZAM>&0an%Gy8jn~ujlj#FL1l2ZnWC7?wm4!vY+_X2xpQVYtd%9ZCw8@?v zhQIT&<5&4t?i9PV>C3hWX_nrwz3&&h{jesegMH9}3En9RTG-1T`wF03Yg3D(bTi^{ zc~o;-4@ZMXUpB`}d+QG-l;jz+r{4*G_s7eTxWxY3;^_I4Rgxi7j~=XUJe}-VK@iL~ z(93sdifd7EDuO+CNC5k^9n^~}lCydaNBWCL-U7Z1?$E>PzD)^tspl5UgMiML6MP>d z{cNNAtTbW^vvB9KmH~L&poenE3R>YOf7s4f>LsiBxtj#eC@WtXjPbI)D&KKhvCL`{ z^raZQ7RLz{N~bn-z91lmQ4iy^UBmY%_*!>mt2YqX;G{UV!qZlJC78~dspX={91AK@ z-Bw~$Z=Jvx4`*&-H>dqFOU-b=4zfFu&9MU{Ek{6S|%7x^daEcM6o(m=o9YZ15?4a1m=? zGvmR2PiLd;mPOK}VM3r>-&@t>lcnORbjED;v?J9`NL|hCJcRfk9^eM9W zVBcbix(|l1TkT2r=_sC<|MKCOA2>m^af3zuX31yg7JhG(`0Wq0RvflV(_<_;y8UjO z&`D{bNaxY(h84pS=AOE@+6bCFi>wBFM?^3>ZkqS{^cj!@S}o3_eWJ%}5Ov+#K$ z(b7v%)c4ru!tq$Icgm2!>Zp^z){3988-%RuD@uf=l z^eO*kmgRK*m>-+~E4)=8y^ExANJ5dcR0A6ArsVAxf z?w_H+ArD<4(jVgZ%}~m$=~En|=Oo;7&GRJwDksI8vU|&0w173PvK81V?^c+0)dIUl zBVYkQ0a+!biCB{yWMi&L@CZibdNH@O77vstBK*OM-UFW}clT3Z@;AIT)h9 z+U81tkX+%akLI5g=*G?h%%8lL;)J+=MS=g{5S;C2j3sbv2%?;S5ZpeW_=Flg=tR-L)@f)WK z=X9m#BB?U=SXaIP_Uzm(W7J_WN>=sJ43Yr{x zJQ)hvo`!JUo&O0zUW{WCT4I?z!qY9mjmb#OAk|K;Ennj0r!opH*a!AJSNl?`!mP&t z+yeANzH`DlGBTZUd}ciCdc*wubBV2>0vC4+wi!%t5smVU9@2>Jim#GlskbFY5#~YG*o>7@q z%o13K<^t2rt&HNm-R}xNvH&!M%)EI^uXnXqoG{B$J{D(qdbB~ro;kAEaQ#$vBd3inSM7whzZ*CG_?VkX#b^UARe#MM!88G6g#Og zP%>1p;NbUOM6EI6Ey$H(_>e8iXy+Fs_05I!O;s5T;TL66(c7g?ieb7W-)xBEVT#7U z;rzh{@q$II5vthPpIR)3GvV~$L#ao zQYJetos5WJr1+bRnQAw$PW=GyED$Io9FxH=Y)do)t9B~I(zO3CiYeaP-vh9Q;|X&f zfqqAL=Iw0Z@GnhQd`meYZZBcDY<|Zg0v!Bw>dk+Uqg<-yb(JuBl=V`QI0;H!HqxR@^rE z>|5bQ%)BW#N`ydAYA9XG^uw=oO|!QKJ1PH}6z75yA-}xnHF8XE<9PvZHB!l4IVym$ zI8W9&%)AZlmfFHsOfl3Ni{E-{fqIyZZiMRgF{4qVAF;qwF{Efck>W2Y&Rb&zg%75- zXP|rvelu@E-A=?*0$z-!g14bKUr`7Zy-Kbs3U9tpCdg^3iOGrf2D~Z=CkV#8)_ZuT zYr^995-#&91aumGN1)W`BSolu%r&hfu7au7e&;^$|y`xWJihst zNZ9#65|N%P+%?Rv>CH-*Bm4K%*(>yK{l{WGmpkX)UD}gB!}B|@B6lAgIrdgOenV!u z)Ir~stFq`8Clag=ha0c|Q_lrkT}fsBkC>7(Tki_&*)k%OVAs)W1 From 5b0ac80b9d1a928b4cc5f0efab05f2e6a013b33d Mon Sep 17 00:00:00 2001 From: Valentine Rahier Date: Tue, 6 Oct 2026 09:23:59 +0200 Subject: [PATCH 4/4] update doc --- DESCRIPTION | 2 +- man/check_stat_names.Rd | 19 +++++++++++++++++++ man/compute_stats.Rd | 25 +++++++++++++++++++++++++ man/situation_pairs.Rd | 24 ++++++++++++++++++++++++ man/stats_description.Rd | 16 ++++++++++++++++ man/stats_pairs.Rd | 26 ++++++++++++++++++++++++++ 6 files changed, 111 insertions(+), 1 deletion(-) create mode 100644 man/check_stat_names.Rd create mode 100644 man/compute_stats.Rd create mode 100644 man/situation_pairs.Rd create mode 100644 man/stats_description.Rd create mode 100644 man/stats_pairs.Rd diff --git a/DESCRIPTION b/DESCRIPTION index caf46115..714b4d0a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -58,4 +58,4 @@ Encoding: UTF-8 Language: en-US LazyData: true Roxygen: list(markdown = TRUE) -RoxygenNote: 7.3.3 +Config/roxygen2/version: 8.0.0 diff --git a/man/check_stat_names.Rd b/man/check_stat_names.Rd new file mode 100644 index 00000000..4bfd7644 --- /dev/null +++ b/man/check_stat_names.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/generic_stats.R +\name{check_stat_names} +\alias{check_stat_names} +\title{Check the names of the required statistics} +\usage{ +check_stat_names(stat) +} +\arguments{ +\item{stat}{A character vector of required statistics, or "all" for all.} +} +\value{ +The names of the statistics to compute, without the unknown ones +(with a warning). +} +\description{ +Check the names of the required statistics +} +\keyword{internal} diff --git a/man/compute_stats.Rd b/man/compute_stats.Rd new file mode 100644 index 00000000..51bf871a --- /dev/null +++ b/man/compute_stats.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/generic_stats.R +\name{compute_stats} +\alias{compute_stats} +\title{Compute the statistics on observed / simulated pairs} +\usage{ +compute_stats(pairs, stat, by) +} +\arguments{ +\item{pairs}{Output of \code{\link[=stats_pairs]{stats_pairs()}} or \code{\link[=situation_pairs]{situation_pairs()}}} + +\item{stat}{A character vector of statistics, already checked by +\code{\link[=check_stat_names]{check_stat_names()}}} + +\item{by}{The columns of \code{pairs} used to group the statistics} +} +\value{ +A data.frame with the \code{by} columns and one column per statistic, +with the groups and situations in their order of appearance in \code{pairs}, and +the description of the statistics as the \code{description} attribute. +} +\description{ +Compute the statistics on observed / simulated pairs +} +\keyword{internal} diff --git a/man/situation_pairs.Rd b/man/situation_pairs.Rd new file mode 100644 index 00000000..a031d62c --- /dev/null +++ b/man/situation_pairs.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/generic_stats.R +\name{situation_pairs} +\alias{situation_pairs} +\title{Observed / simulated pairs for one situation} +\usage{ +situation_pairs(sim, obs, verbose = TRUE) +} +\arguments{ +\item{sim}{A simulation data.frame, possibly with a \code{version} column} + +\item{obs}{An observation data.frame (variable names must match)} + +\item{verbose}{Boolean. Print information during execution.} +} +\value{ +A data.frame with columns (version), Plant, variable, Observed and +Simulated, or \code{NULL} if there are no common variables between \code{sim} and +\code{obs}. +} +\description{ +Observed / simulated pairs for one situation +} +\keyword{internal} diff --git a/man/stats_description.Rd b/man/stats_description.Rd new file mode 100644 index 00000000..2603ca59 --- /dev/null +++ b/man/stats_description.Rd @@ -0,0 +1,16 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/generic_stats.R +\name{stats_description} +\alias{stats_description} +\title{Description of the available statistics} +\usage{ +stats_description() +} +\value{ +A one row data.frame with the description of each statistic, named +by statistic. +} +\description{ +Description of the available statistics +} +\keyword{internal} diff --git a/man/stats_pairs.Rd b/man/stats_pairs.Rd new file mode 100644 index 00000000..de4a2e4a --- /dev/null +++ b/man/stats_pairs.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/generic_stats.R +\name{stats_pairs} +\alias{stats_pairs} +\title{Observed / simulated pairs for all groups and situations} +\usage{ +stats_pairs(dot_args, obs, verbose = TRUE) +} +\arguments{ +\item{dot_args}{A named list (each element= group, i.e. model version) of +named lists (each element= situation) of simulations \code{data.frame}s} + +\item{obs}{A list (each element= situation) of observations \code{data.frame}s +(named by situation)} + +\item{verbose}{Boolean. Print information during execution.} +} +\value{ +A data.frame with columns group, situation, Plant, variable, +Observed and Simulated, with one row per observation and group. Situations +without observations are dropped. +} +\description{ +Observed / simulated pairs for all groups and situations +} +\keyword{internal}