From 31271d33e8a8a091d40f3e9eda150beb8d44db4f Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Fri, 10 Nov 2023 12:23:23 +0100 Subject: [PATCH 01/49] Add new function, `interval_coverage_deviation_quantile()` - I know the name is terrible --- NAMESPACE | 1 + R/metrics-quantile.R | 86 +++++++++++++++++++++ man/interval_coverage_deviation_quantile.Rd | 70 +++++++++++++++++ 3 files changed, 157 insertions(+) create mode 100644 man/interval_coverage_deviation_quantile.Rd diff --git a/NAMESPACE b/NAMESPACE index fab2e17d3..32259fd85 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -32,6 +32,7 @@ export(crps_sample) export(dispersion) export(dss_sample) export(get_duplicate_forecasts) +export(interval_coverage_deviation_quantile) export(interval_coverage_quantile) export(interval_coverage_sample) export(interval_score) diff --git a/R/metrics-quantile.R b/R/metrics-quantile.R index f3598690e..4df7cdcaf 100644 --- a/R/metrics-quantile.R +++ b/R/metrics-quantile.R @@ -218,6 +218,92 @@ interval_coverage_quantile <- function(observed, predicted, quantile, range = 50 } +#' @title Interval Coverage Deviation (For Quantile-Based Forecasts) +#' @description Check the agreement between desired and actual interval coverage +#' of a forecast. +#' +#' The function is similar to [interval_coverage_quantile()], +#' but looks at all provided prediction intervals instead of only one. It +#' compares nominal coverage (i.e. the desired coverage) with the actual +#' observed coverage. +#' +#' A central symmetric prediction interval is defined by a lower and an +#' upper bound formed by a pair of predictive quantiles. For example, a 50% +#' prediction interval is formed by the 0.25 and 0.75 quantiles of the +#' predictive distribution. Ideally, a forecaster should aim to cover about +#' 50% of all observed values with their 50% prediction intervals, 90% of all +#' observed values with their 90% prediction intervals, and so on. +#' +#' For every prediction interval, the deviation is computed as the difference +#' between the observed coverage and the nominal coverage +#' For a single observed value and a single prediction interval, +#' coverage is always either 0 or 1. This is not the case for a single observed +#' value and multiple prediction intervals, but it still doesn't make that much +#' sense to compare nominal (desired) coverage and actual coverage for a single +#' observation. In that sense coverage deviation only really starts to make +#' sense as a metric when averaged across multiple observations). +#' +#' Positive values of coverage deviation are an indication for underconfidence, +#' i.e. the forecaster could likely have issued a narrower forecast. Negative +#' values are an indication for overconfidence, i.e. the forecasts were too +#' narrow. +#' +#' \deqn{ +#' \textrm{coverage deviation} = +#' \mathbf{1}(\textrm{observed value falls within interval} - +#' \textrm{nominal coverage}) +#' }{ +#' coverage deviation = +#' 1(observed value falls within interval) - nominal coverage +#' } +#' The coverage deviation is then averaged across all prediction intervals. +#' The median is ignored when computing coverage deviation. +#' @inheritParams wis +#' @return A numeric vector of length n with the coverage deviation for each +#' forecast (comprising one or multiple prediction intervals). +#' @export +#' @examples +#' observed <- c(1, -15, 22) +#' predicted <- rbind( +#' c(-1, 0, 1, 2, 3), +#' c(-2, 1, 2, 2, 4), +#' c(-2, 0, 3, 3, 4) +#' ) +#' quantile <- c(0.1, 0.25, 0.5, 0.75, 0.9) +#' interval_coverage_deviation_quantile(observed, predicted, quantile) +interval_coverage_deviation_quantile <- function(observed, predicted, quantile) { + assert_input_quantile(observed, predicted, quantile) + + # transform available quantiles into central interval ranges + boundary <- ifelse(quantile <= 0.5, "lower", "upper") + available_ranges <- ifelse( + boundary == "lower", + (1 - 2 * quantile) * 100, + (2 * quantile - 1) * 100 + ) + available_ranges <- unique(available_ranges) + necessary_quantiles <- unique(c( + (100 - available_ranges) / 2, + 100 - (100 - available_ranges) / 2) / 100 + ) + if (!all(necessary_quantiles %in% quantile)) { + warning( + "To compute coverage deviation, all quantiles must belong to central ", + "symmetric prediction intervals. Returnting `NA`.") + return(NA) + } + + reformatted <- quantile_to_interval(observed, predicted, quantile)[range != 0] + reformatted[, coverage := ifelse( + observed >= lower & observed <= upper, TRUE, FALSE + )] + reformatted[, coverage_deviation := coverage - range / 100] + out <- reformatted[, .(coverage_deviation = mean(coverage_deviation)), + by = c("forecast_id")] + return(out$coverage_deviation) +} + + #' @title Determines Bias of Quantile Forecasts #' #' @description diff --git a/man/interval_coverage_deviation_quantile.Rd b/man/interval_coverage_deviation_quantile.Rd new file mode 100644 index 000000000..a1398d468 --- /dev/null +++ b/man/interval_coverage_deviation_quantile.Rd @@ -0,0 +1,70 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/metrics-quantile.R +\name{interval_coverage_deviation_quantile} +\alias{interval_coverage_deviation_quantile} +\title{Interval Coverage Deviation (For Quantile-Based Forecasts)} +\usage{ +interval_coverage_deviation_quantile(observed, predicted, quantile) +} +\arguments{ +\item{observed}{A vector with observed values of size n} + +\item{predicted}{vector of size n with the predicted values} + +\item{quantile}{vector with quantile levels of size N} +} +\value{ +A numeric vector of length n with the coverage deviation for each +forecast (comprising one or multiple prediction intervals). +} +\description{ +Check the agreement between desired and actual interval coverage +of a forecast. + +The function is similar to \code{\link[=interval_coverage_quantile]{interval_coverage_quantile()}}, +but looks at all provided prediction intervals instead of only one. It +compares nominal coverage (i.e. the desired coverage) with the actual +observed coverage. + +A central symmetric prediction interval is defined by a lower and an +upper bound formed by a pair of predictive quantiles. For example, a 50\% +prediction interval is formed by the 0.25 and 0.75 quantiles of the +predictive distribution. Ideally, a forecaster should aim to cover about +50\% of all observed values with their 50\% prediction intervals, 90\% of all +observed values with their 90\% prediction intervals, and so on. + +For every prediction interval, the deviation is computed as the difference +between the observed coverage and the nominal coverage +For a single observed value and a single prediction interval, +coverage is always either 0 or 1. This is not the case for a single observed +value and multiple prediction intervals, but it still doesn't make that much +sense to compare nominal (desired) coverage and actual coverage for a single +observation. In that sense coverage deviation only really starts to make +sense as a metric when averaged across multiple observations). + +Positive values of coverage deviation are an indication for underconfidence, +i.e. the forecaster could likely have issued a narrower forecast. Negative +values are an indication for overconfidence, i.e. the forecasts were too +narrow. + +\deqn{ +\textrm{coverage deviation} = +\mathbf{1}(\textrm{observed value falls within interval} - +\textrm{nominal coverage}) +}{ +coverage deviation = +1(observed value falls within interval) - nominal coverage +} +The coverage deviation is then averaged across all prediction intervals. +The median is ignored when computing coverage deviation. +} +\examples{ +observed <- c(1, -15, 22) +predicted <- rbind( + c(-1, 0, 1, 2, 3), + c(-2, 1, 2, 2, 4), + c(-2, 0, 3, 3, 4) +) +quantile <- c(0.1, 0.25, 0.5, 0.75, 0.9) +interval_coverage_deviation_quantile(observed, predicted, quantile) +} From 9c9f286b29da7b826946a6dfbd2596d6f2b5cefd Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Fri, 10 Nov 2023 13:21:02 +0100 Subject: [PATCH 02/49] Create a new helper function to compute ranges of central prediction intervals from quantiles --- R/metrics-quantile.R | 16 +++++++--------- R/utils_data_handling.R | 28 +++++++++++++++++++++++----- man/get_range_from_quantile.Rd | 25 +++++++++++++++++++++++++ 3 files changed, 55 insertions(+), 14 deletions(-) create mode 100644 man/get_range_from_quantile.Rd diff --git a/R/metrics-quantile.R b/R/metrics-quantile.R index 4df7cdcaf..0fee05438 100644 --- a/R/metrics-quantile.R +++ b/R/metrics-quantile.R @@ -275,21 +275,19 @@ interval_coverage_deviation_quantile <- function(observed, predicted, quantile) assert_input_quantile(observed, predicted, quantile) # transform available quantiles into central interval ranges - boundary <- ifelse(quantile <= 0.5, "lower", "upper") - available_ranges <- ifelse( - boundary == "lower", - (1 - 2 * quantile) * 100, - (2 * quantile - 1) * 100 - ) - available_ranges <- unique(available_ranges) + available_ranges <- unique(get_range_from_quantile(quantile)) + + # check if all necessary quantiles are available necessary_quantiles <- unique(c( (100 - available_ranges) / 2, 100 - (100 - available_ranges) / 2) / 100 ) if (!all(necessary_quantiles %in% quantile)) { + missing <- necessary_quantiles[!necessary_quantiles %in% quantile] warning( - "To compute coverage deviation, all quantiles must belong to central ", - "symmetric prediction intervals. Returnting `NA`.") + "To compute coverage deviation, all quantiles must form central ", + "symmetric prediction intervals. Missing quantiles: ", + toString(missing), ". Returning `NA`.") return(NA) } diff --git a/R/utils_data_handling.R b/R/utils_data_handling.R index cb9470e87..f1dc27201 100644 --- a/R/utils_data_handling.R +++ b/R/utils_data_handling.R @@ -216,11 +216,7 @@ quantile_to_interval.data.frame <- function(dt, } dt[, boundary := ifelse(quantile <= 0.5, "lower", "upper")] - dt[, range := ifelse( - boundary == "lower", - round((1 - 2 * quantile) * 100, 10), - round((2 * quantile - 1) * 100, 10) - )] + dt[, range := get_range_from_quantile(quantile)] # add median quantile median <- dt[quantile == 0.5, ] @@ -311,3 +307,25 @@ sample_to_range_long <- function(data, return(data[]) } + +#' Get Range Belonging to a Quantile +#' @description Every quantile can be thought of either as the lower or the +#' upper bound of a symmetric central prediction interval. This helper function +#' returns the range of the central prediction interval to which the quantile +#' belongs. +#' +#' Due to numeric instability that sometimes occurred in the past, ranges are +#' rounded to 10 decimal places. This is not a problem for the vast majority of +#' use cases, but it is something to be aware of. +#' @param quantile a numeric vector of quantile levels of size N +#' @return a numeric vector of interval ranges of size N +#' @keywords internal +get_range_from_quantile <- function(quantile) { + boundary <- ifelse(quantile <= 0.5, "lower", "upper") + range <- ifelse( + boundary == "lower", + round((1 - 2 * quantile) * 100, digits = 10), + round((2 * quantile - 1) * 100, digits = 10) + ) + return(range) +} diff --git a/man/get_range_from_quantile.Rd b/man/get_range_from_quantile.Rd new file mode 100644 index 000000000..eca15af36 --- /dev/null +++ b/man/get_range_from_quantile.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils_data_handling.R +\name{get_range_from_quantile} +\alias{get_range_from_quantile} +\title{Get Range Belonging to a Quantile} +\usage{ +get_range_from_quantile(quantile) +} +\arguments{ +\item{quantile}{a numeric vector of quantile levels of size N} +} +\value{ +a numeric vector of interval ranges of size N +} +\description{ +Every quantile can be thought of either as the lower or the +upper bound of a symmetric central prediction interval. This helper function +returns the range of the central prediction interval to which the quantile +belongs. + +Due to numeric instability that sometimes occurred in the past, ranges are +rounded to 10 decimal places. This is not a problem for the vast majority of +use cases, but it is something to be aware of. +} +\keyword{internal} From b883dd8e91f1ad6db781ae32aadd67fbd1d8b248 Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Fri, 10 Nov 2023 13:21:22 +0100 Subject: [PATCH 03/49] Update `metrics_quantile` --- data/metrics_quantile.rda | Bin 6730 -> 15100 bytes inst/create-list-available-forecasts.R | 3 ++- man/metrics_quantile.Rd | 2 +- 3 files changed, 3 insertions(+), 2 deletions(-) diff --git a/data/metrics_quantile.rda b/data/metrics_quantile.rda index 2f2607933179842f7fcdb9c19e8ef140fe59117d..e8be29ea39e171f8a6ff0c021e5171c107222e1e 100644 GIT binary patch literal 15100 zcmV(KT-?)Ll6ihA|yWxZDbIiP#AU9nJov>Y*>&EID2 zx7)czSQU+|JD5pc+MPG7m1EKGbGSa;fC9$0H(icU?|f7Q-*jBNjb<_rbN~PYl>h($ z0Gk5X8UllRx=3gNxu_o}tER52MFlDmNd}&VgOz*kci%-f)iQze;vP!3+#(M9ud;AS zBp@c3fEq>s69$Q(G#Mt))I5_D#F$MdlxCC0riPdasguYiGH7JcGgHz}42`H$Z8Xu6 zF;5}sGy~Ko)YH_{1k)43o`$BFfh33kLrnlCngqa&0ihZc{XspFX*`&T?FNL&lnpaT z+Cxl0$Z4jBsMFLm4^u&-%4vdWrqm6n4K!(!)X)Zi&;V!yWd;c#riq|sPdzGnn+i9n z>PNH`$n^$|8X9^}DD+3DVj466G-zZ18VvvjfMfs-Gynhq0009(00000sj5hcPg79! zPe}BbWSTupN2p;uNs;P3MnKt37>pr;VKYEO5N4nn27u7hKxw8Lh58;yeih|l>h$Kzin2<`Nd`o=i~bbCQ3KWg)B|+~Z+YDRvH`Qd457HgchIdW2g#u% z0{!}G185_LA@y+j(hn3w(u10y(TX>gB2In<2nNb8OJ07ZJMkqHx5(RI^iZ`nAYneL z;Hieq4T$}fVQP|VN|2Cbfg(v~=WJ6BN0myyE+bga0`(Cqk-QjZm?;Fc=J0DHbW|0iy`1dx@X#}9~ z2P!xRAFT1W$#jB%ctp+W=eZAjL)u{JI=ii)N#>&Y$BU=uSDBwLr|K)086j*~t2MQ_ z>xIJKSb)sJ)WvgF)OYU49fr?j0wsRl-5K_M0=aW%5gie2SGl<8OJ@zcW|(FYW7GCe zL5Wg?fE#^)FQ+W3<*Q=PRU7EVS81U7^A0fiX7$>p36D{hKvyoelXEHui+U=Suy%BG z^l{@JO#F!F%^3j*kTV3V57>ET2#4}(=}LDKm%CFXc&HA~o6~;(b#dar7LEH9dNgVy z!zIF67@iy6SX?p$oD#wHCVkG<5v3TzA%z5E4jv3e$cj0mDkBZI8Q*}298%C|<+vyd z6(CqTX^tHSo3E#@<1g+hhc2u!+3q#Od^`fUasGLW!I zBG3#CI?Ft1+R1~y8j=QjbH>C-z>tA4l?V}p{ROj(!!5G3tkPZhz_R)Yfpr7XK;PrF1js;eho2gNIUrpRvxxp4BOnG?=jPcB05i95E-hKy zuvCHqgCXk~+0$TT&4iA>?3DZu&f7t7nc@sBOGHYQ0tqA_OtH-pL9jXHAp%Jtdnq1U z1qRgG$yx8l%}rCD2QgxxcrXx91TB2Vg9wD995`4gUYbbIX810Q zM)n+k5jK`D8?m84Bs8&*iW!aol0~Kx1rV0<)~ZOPmMxW@nATk3<_2c2wYo?j%OsLR zz~q$1l@DKY;`zS6&eUyxH^bO^IDfxg6M;557B*hhQbt30%PT(;<#Kp;43RDEg)H00$#xGu89xeV_Ve;6oBx8APgFkctKoZ zgR2g*!60Ubt43@MZm|z;C6X$LAJ&1L5MygtPg)j*p&@F4U~8ArV7-(AF0B{RDsCT80SdIz~_(ohs zn0N@`BZdw<62-oX?$)^3uN1~c$sKX9O5=uYM0qEgyyfU4lm~vj70fxv^-;|aSUrP; zk7XS9?>~L)O~`hE`VZLl&u(ttP;VdNkUOQ>o!A`n{a3s@!{a*j{L#oY{~+7GxIdyl zx?Q+->wLB;ZB41!F4=g;91hKH7T`3&wn5#7z&GpV2C(6yhOt%Ppmm*NrkRvrMMN_Q{LA5? z0f`hsIsmy!Fl}BpeU7G-zff^R7a33i0w_ZTi-?0}FkGIhEQ+&LaikUwtpt9|7U{eN z!Hp&R&l}SNnJ#l1?(Oaqc)iR0hbiw9`@3{G*P46h{fGQGo-kZz%O&zH0@)h1!738y%-_q` zHgsn*mw^s(LRca&Kn(bu$7;H~*qaVOwC{o^B2Lu(tNj+Qng};UJb_x&<|&$BI%mO8 z0~;+WMPSGtKv0T!L797(9Mj-n%Z5RT$`qb`_!NOSz$=Rp=et3~{f~WUxL)){{L%Ed zo;3o@8L&}wx`=X4;qnaPBR7KQ5P@JYT?aH7cj1CUBDyCcm%C~ty-#V<@B3&byDxuC z@VYCVywIJ#J|{8{9kH^tOPY64hFbZTZs6~7(n>O&co_6$hfUI8>A@acT{<>l!q_An zZg?2T4MPpCbqKl*OEWobO8izi4hS}_-yA}XM>}(8V*YszoSCxqc&gRKcJ_!%`qm0i z!6Z;&vCm{UAnx5^(1D5#AZ zp?aN3DWWt|iQGLfoEACNZrQ1U`E0pdSz^9W8S$56gB-T>>BEh%X&MUf(A8;U%_lUk zB&rs_L%t6WHW)OeuAD^?j*X4_KSE0N?oX=hx3l7c<)c}n!2@J`oQU|jjT3o0aa<$M zdr#D5j%ed8S~%{h!_BsaKnsKNSPQKun3;q`O)7X-h(6P)@7;nRY11yK4H15iWA;{h zh)n`c?v+^pg61Gx+XL@3)GEZqs6r0NS&DdGe2OMvLkj@6A0-b6WevPz#__5|IJoJ)KY#D*=y-kmUt)ig3P4KXC50ZA0(iVl(s*q!WNmk&z&n4}gO=@;v# zEt6$B2Ki0-WpZ7^n0X+Hdk{F|(TKib7C~7AKs0a26aWpup3$wu+(U1LR}fr^SJMxs z70$roK!9Zkou~&mT7?N@wzQKJ+a7?neD}6|SAj^k6+#}6-2l7i0~4{SvAOwk@^jCY zmSIP93RhenaXk-f<$K@bTI+p=fjE#ehm;G$6H!zcd|!dwKmlx12yimPj942IY$GK+ z^Us224iP|LKw(I<3Yf%mHH6GwKv<6}o{p`hVMvzo%r6Fv6(QrD5goGH6vLnuqrP3* z?iFAb%M%Fi_aPjO8fSgeG z|Kks&=yr~}<{zKl=jvt9mG*hXuzIySiai%bLw{2i>B`6&=@X0`V@*m-YaqA)0oOph zeQqC*NdLk=IQoT z>!1NN&>)<`KrLJcZ-&#LUS9E9^LMF$nnDsuBO!!_25{hXzID-Y98l9SuY!INgO=hV zyxZ3cgA5gwmQgK{>Q# zN2%C~4H_UQ8x#!Tuq??nTe0j$^cH?3>=@tnSo14P}lB}fmN7@cJ;$5&< zNU8}5$)U~=iwQwgG6PWr>vMAjgbtK6^uIsw?teDJR7Q9bgR3~dxnCDqE1x1$!gB;T zf!qh6;9%oN%gS?bsWF|i1$ZsLe^@LQh-iYh=%o2@v@!$^u7h#hvv>I>VKn7(oWD`n z50MK%f*>czr9Umz$}u^bonJbLLY1_ zCl6LJ&tTes76wS`n{Qyvs12=AMwzA*o15fHn!JV1B6z;3VHBnbNQ13m7TC39#C}e^ zUA)p+0=_MWj$nA-Ci0Jh(lD$cbTG#ncLG8AXSzINIRLc;%OIHtV!_gbq8u6=PKExN z$JD$6xe9c|3WSigG(mhYuyIniL30ymAV@u=9@85QN#6S!hI-^b_D436DGtAIA0XU|c2>vG z{r8+$C4|ulurk$TYYdRg3`jvXpt}%nhWtZ}AQ?hy_eulsk-Je**6q7vg3_UF@83p+ zhr%!Kmi5^_1+JZ-o(Ba7%5iKmD$aTA9C4~-UZO9mAeb;61PwIL#Cr*wftk!wp7+Dc z@-$u-VMtUNeikG{zQFjCehXq3b!)%TD(Wd4O4z!|(IOs9hrrW8;HHI5Q94jaonQ^z zLBV?0kUv~A$)jUB7J_#&F07cM6!gY`MKR9pT&Fe#2s!4&!NBxMQVhR+zueWVLde;E zM+Ylj1A2Ba=^98~C8t}XLCb1$*eGx=Xc~)?n6;aoQifu;p=F_R7z&VC-yY z?6L_6a=H1Zj#?QKqAB4nBKhg?5gaix7ZthGI0{UC-5~+aj!8n!{hlT*_M}mw~tCszd4JVOthJ8uV4Jbk)A*UHGT~BcI1_pS@57hlX zaqfI*KsnctleG%i zfxpc|)s3Wx9`J~9OwyAkWXSxF56JGjta{+G1(q2E#?tw%Thw;kSXm?3%v*Dyfe zmG5r6P%&vRdK2=@;xqK+22{8h$p2GNCfj@bQ?p}IF6^Jjp#bpyQP{?LvQL5jJ+b)X=rDQ^6?h$c>!V28$fXK28iyEpYQb&gIgF&KfzJ>xEs!zxK zUs%p{y5_5~dhmdIRC2th?m6At`GLX1(|+X9$jbXt5yp7MD3o&MxM9Yj+-W9Hd!NYI z^JHarG2Y2ez|YBoOuD(tTVGP$uZ!67yZ+Za%oJ`>wF2ZaTOH%DH))Z`dl-x<%R8E( zFa@9Ao-s$8$9Ia5g#nu?&TriBCLnNn8a6cNW$wfjY7;_*_RC_3aML**D#!w&RcH$Str zh3|*FW!(1d;@kcfEAFo!Z+Ls}P} zPeLPE2PWxW?j|pflht|pY*ve{$)VP+IEQV=F2Th;W3=`>EC&!;M%anP0x$DkdC@XO zl?UuE)mhe}ju{qXn}8qjhr-8%!iFjt8%>Ru5iih9hg(vU8hZ;+G=_(1vLfCq2N}5Mv-8|mJH3H zII9>k7g@yTt=U(z3=&85IK+&}OAZ!gQidKRZNgTWES!iSfX0}<_XK+M^2)8%%CzFC;1q0? z-1e7O2{jc>iIH0h;}m3aTI`D^z>kQ(U3?|(7gVj=!?TF+G4fFpD_D_@?n!APc(yUp z+T7%@G7L-x7i=P+4{Yb0C7vf_*GavlmgK7_9FkA65h{fRQu~4K2e=(jGLm+=WJ`*l zoFG9yB<^m^UU)BQ-dj34Ac|-S z`@rCvB*o;FvnjxymrP?7*cBlHq{yg>d!IV&>~XN8GA`Ua`1+hg^yBoCT|uK$jFz#5 zILfjqr#_NC!alk+EmOnMx>(L+mw5V~5V78|4_fV%lV^!|sy=o^;+WjRXL2Z;&5MF? zb~rO45|Zy3)oN@~BF2+eG8tD^8k7hI_6XN7IGXb9buQVQ9wTehxsU(gO(?Lu&K#`=f9i-)A*eXlt=O|2CJT!QQ3=|wNf^OzOD+=^c~D`5!EAW9wU&AF{a1k6i!+CJ;9K0>cmSXV?ba=N}x zwyMBmgvBMZ;i99&N*ql7yI*|4%yK$j&B}+p=_s;E$KFJBlzNu;a2F9#Ht!^g*jiAX zR@D2nMhg}#r;RNu=7RscKVJ>j*mki?tLS5fs~P)g$B3_zH+`U}qtABHT_UtP%f=^PI_~LfODR@`ejN?(H2H>c`q>-dp*6-OAeCunnfNnMo(%OB_@VL ziyJZV^S&75GTzba=039HR0}4URFAW+m3WOmsrLiiJB5NtfK&u$WI%}#_fyu*B6XWP z+cN+%DH{k2kPhZ5nV2?(90ZtEat^UWB)&2b-(+~8MHPxzTRx8h=JlD^3$1d+;R~`% z4K&a(T_gx1G!X4vqjlZxp*0@Sdqq}#$qC%@=hliA9H$)&MGRBh@bzL*Y%IuImN!dB zhsn!=;jSl|-SRc!7dOn}Ng(?HHpiiu?>45}Qwn~%a?Jd60-{JMXdSpn$b+OYN~FEx zihe>NzQDRCL!qLr<-K`wDCy8KSTaTe(F!fHn@n?C8(EQwn=LiAs#7eOs*5bvpqM6N z*_LS5GR(^jR>X+{611kQw1~9U)>75BmTMKVQEHT=rj|;ywJNewQd(BEt5TAb5Y6+u zdCg6%t!bhZ)+qxyBuS>O-z;aH zzn{DK_VL%3jP1OQiI!P5w$>z7h@_Hgsj0bSdT3M2>xZ3e@8Ly}My*U$RVl7!W6ZFl zB7=UQ-nNkemg}=oLo0-|iV;w8iYHP9L=w;yFuI$diBM`HZ9z=Yv>6dhA{8VNFP}a( zhBt0Ow2**YNdQm%%Grt(VH@qJ6CIY7O=ya?D>G9mnzw_-o}-++h2*hFNmv##z`8R< z6*3?&1iZuewk?vXiOhexf<8X)@Neq9Q#fsp}nLB5#0CjJM*yC%Kk+T+U=isddoy-EQ&e$d24@ z4N??^P*7Hv6uFPRGliJIfe3o|B%9F{&Y)~WVT2Gv1rWeckQ@RaQ8SP)3JZ!p1-`4~ z=jFK+QBCFmrp>;WTHp{zw1O%1;)WU^L{SmWD5zW^j|nET8*R6*v4|uBK}^^pDJwRL zNwCtZK@mw)4JzxfL=solx`idLU^D_s_SFnK6C{IFA+#X0sshM3nswK7ek%zTFv*L6b&xzz!}Hg zoq~2Kf!|q6k}j$QkvJpg{ul3Gpz}Ys>t`KjneY4_Cu4IHZT(N9o(cwlDe681IO541a(5liPBS)s+nMOR)yjVgUt3JFOFx^< zi=kCl@7lFy{m!1BS)! z4yOm1%yTpFe}pLWPdxKYJrz|y!1=!SwDjK>`@LuH_Z2Bv;qb z(d|4f{%?&Z^7fZ^bK8%xDpaU&;Xj}|ZL1c8sT(Kx`d7U1EJJb3l$)+z$ zlBYrM;dGrghZA027={6wFS5NZvrVMK=v?CIuyAm2ehgeqJ|?376WBDyA%R@e7$KQ|HE&+X;FNAP^F)OY%;!1JUg45KYsYtq16sdt`&ts_y*g|FDF~p#10bNd3v3cZ9mEHw`&d4Z z*lYVPk1y+KsvfFHO|r6+mDdNM!_^GW~QTI*ID7Bn@cZOPZ@X7wD*v{hT{4l zC{3kMP^u!K%|JuhO(G-#P;sza0g@19Lxf;LLLj8&zsp5ZIcWPx^t~Em&nw9FH@Fy@SA^L1rufIk{@ zo>_-%kk@-F&|f7(Um|8E0)yxf08y?T6kY65P~N~phl&bFsf4iwC`1uO?O>(E5D}FY zh=_wqFe5=h!eXGNvx2wdypyqht7Z3s!>*;d;9gPGxGp({Y6|j)EHf1f&{e9{8gyn7 z#Y<|ms&Nz}Vua|g3pgEC>b!%9<+zSph~=1vn==M`JV<4^=a+NtT4&QfyOsMFh0>d( z_XAixqlD<;_%3?)9v9qrUvU0;?!0fhah~b0avcEoUN_x%-*q_C)I;si`Hv%{=nyo4 z_TYPgC_A#ChmrGj&v~k$Y!yQ5ii6G6OE?Btemiyngb(_=40R=AtjgjY zAu5|5YuM^y$5R&EkYlU0j$ND7AEgF3b)k-T1xC1LG1e-_MAT!WOpI{C40T$!%WRop zoeZ$l23YBa`3>qDaOT4W(Xlq}tHDU8S7fsTD?)lodc`Qi)4WZgU5T069aC$b<`umM%`u9NZ!}F_R(<{ zrW}ylS<{>I>kq|mFg?)w8CZuAeWd(G^NIp}|Fhb=WT+P4JJ74#%9K4Rdie*)iMJS*~140OXfLl_C zGS1x0XF0avvvLN?W@;Nwa~pEo6@yl6DS>NkwzR^|7IS7RY}1^^Zdrc zxy~>v4XLq4ZA{7;sf|p9P*J1`QN^*VDU+No9L=b6oWqWD4eU|JTq%u(V{F}7;Ph@Y zXJfu_=Qv@TYHm5Wz%ooNHm-ApqUFIBlS!mgYHAga2G@RZj@HFyD;rj3QCk$-YO13f zHg=iiS+h4*5^QQV8kvCATPZ@V4S& z%V`M-HEpOX6Pz|>rqUXQDB4Y{9BXw4jZ-DHJUPtOnMJK=JMm1W$cCY-6H6?rGO-es znzb5|ODU^ls*PDHibSkiC97)1H8hMZR@Jr^vlA_&R<$ZqRw9*EHK|c5R@+v}veH>p zn^jh{Oxe5bW^Ey?w$0%yU~e|XV-7|dvtw@gg|Rbi$PH#z$Ac~zVn&-&X|`-Frdb(i zHKvnMWs5@EwAnRnj~iwN@UgYQSmlZ?(9Y}9SCv8A@!nAq}JnX;P$OJ{YlTgEtr4YuiQ%+1=S3Xc|%LJ$cQ zkc1RVn?r@X2E=L*F^5n!=hIg&Ru>$bMnhc?D-H5radMikjkcbsie{2zYTHEHH8#|&8&Rx=t%(|eO}p)c4Oz4! zG1}W6Z|1p=$wu35_?t1_GdCb4+_u{Xgx0fTqRq9fv6-!4S_oKzrI{mSAP3H~N~;@C zKL!ePtNDNL4PvFi6d@G?66mQy3{nPcv}VNTFx=J{;MiJeve_~=CegEEXwycevI}D^ zD-uMkg|b3xB9w%=t|@7)rnX8_l%*+UGi*|u7DnF7ZNk`zv|BdO7({XkW@}KZBVrJP zBC2W_Uo9kA7_DeaO~S$2+Zn>!cTJ8hkv5jbOEZeLcP^7^)ORIGEhMvHmP=BpS!_0| zT2-w!&8nMLrm8l@Hh$LbM#0}I)?0UNZLv+d(Yj-G#%$>aSaowGZOlVCZH=+}DqA_D z2IE^PNQxzpjfPkRVyHAkMJP0Owq|Nbc8-M2k4M`%WwFw2&c_*ujm+=IGmd9zgQr`C zrs^B9Y};uYL>sL&t&X-6W2_K#@tXGYIiX5J;3Li!@s^r19Eq)itvaV(xr5 zHu-i)g5t2_`C)-?g_?#T6mS?7)uSO14XePlg)c%X8yPy~V>J%ppv#l%Ow^SjKvDsm zBnXYawmGzN`gNnxFHhwnXcJiF)uc!=pdf2!X$nWi?T>HG^M~l{HjvpXPY2y;vwPL? zw_{Nfc#XT_iW2ii&_;of&Yr*nbs~Ui;vqvs5xjNB=ly4K(|E4n{r}rOm(~3*3FdX> zcfS$Y>0O0p(bygl)=`NOBJJ!^04N|(bEfOT4vY?M94(_1ctnBgZb>C&FA5AODA|Z6 zDa1sj%iE&yKAkxwpeIHcos29wJlnAzZ6*oW)a21|j4oi0)a4p73kCWxyfDVf76^#s z;~%dZW0IF9Ol*Mn4}F1QLotO75dp?4=MD970{iGkattQ?Zi*IejR1-TT9qs@%4Nxh zPPu^yDTwd|iv{R7ez68vj6h@qJV7hyX}_071`%UC&aQ7tE<^Y z+s(q3*}1E6$g^h|CfV1t8zH|%4KaT}3ztgJ^8wZrx)_iU#xaW25IGCWK{8&eDZSwB z;i9d>iL22KfLH`kedG}+2)axFL3hmO*Btl?bS9_^cqzx4g26(Q)_P6Bq%gGZ`ulUu#){s(+hT$>ue5+PLKEEulu zdw%TV`5%ucYb25pNvs*ri}(3()OUKmzd$%NIo*UcT1CXN1B{mq41Cm93`KxD{za8W z*m7H=!EeZ2kVt|tBBX&+p5{~88K9M1WXvx$G?z>~%V7cAwjEnh&T!C@iVJ)hnVirf z#E>K_$Z{U7A+ZF3VW`LyLxDT7E;=tz3cMl{LdZrjnY3`CBCknUHKVW=IM8UXhnmp{ zN^eC-=Lo0^u8H5vZ9%=q)Gl`Q*Kv9Lj!w=eEO2Dm1nQqKvP{$<#fSTk5LfBO~^zs4f)moa>zN(6(JngL!Xx2MA zG=wt=l6yN>wVy_4Zt*jNdW%W4U96`|XtlADLJ*i_M1%cdrtu<79PlzkswW8DUWmj| zYWgtFP7a0OH}L8V@2Pk;R0Z?*d|3K`qWU~UdBdGFFk=LOM+h`HgNCVWLJW+7YcSUT zCgttH8Xo1!Of=p-RizYltY*W=cAcQn4aip81U6L09!Hb9`7+3uaAvMH06GEC2J|OW zX2aBhdE;69M;S7Wi1!4o(RVSDj6UZLgn!60P{Ji&>yu6-1aDjMs07Y5dzPB$hC zdM636y@-+@P85uSLA7-%c;dbSZtvSbyorVc*z@FbCr&4wMJCogm5cswJiEGS`_ zGcrg>q!3r3#P95Z+3rRa(I* zH<(EC<0;0XdO;bt#N-)8yQR!Djy8<1j{Vg)I`f7_`;);uqQfmHurAn8%*s|sL+MT# z_u3F7B3TiX5WvGFCTymYg!>4UeCP-N`{S|T>F0qX0!BpFf#rPfwfHAvk4grW&TK&EA+B%J-oh1^WN<96 zm(H+uH1L~RdBN7dqHvEAqKWaKDn352Jt!&5x}n(x0X&GJjkV5>qnjj|1x4CA_q#^% z0B}HTKy^^jv3~itK-^wZA=vWD68M;2DaN}vRkb+YF6}!>RiAva%)Fhk7dx`w2(b>4 z%-IKFrUu=%iFdVgcwL|qERgPutn*nlX3?W9)EP06x~w@yz&hxe2O=cLCo(8xK|(17 zhDMqas%bSbVNzhAGC~XzCAv8SJ@p|_A)cfwfO?%XtZ{GO+V{S`@1x^ezlL0zEl}@C zBtgt`2c-!fw$9gDJI7Co+&msm|M*ccdx_fZ?exLC6kR#S4;A~oxfLiADZZitQi?kH zV*y3VwHPv~Sq?fikO~_-q!GoEH-P6}Z$<7ST55vV+SRk)JuCvWnyh8=ekWVTF@-ub z7Z6NVS0;)s+Ak`jt#rEyh2ZH|q>{1}VQLv_a*t+gY#J2KY3_H&QYGRA=nqRM=ZuL9 z%BXuBj;PL#MC@ zHDRZ!lsnyu>yGk}<3X&*Ntpxgfq=rsfOv&~$$UpPZN3gKzjMvIHaJh3#f}G}(E4{+nsYO4YhF|BJh{R!OT*$W34^s{W}z5}pqFiA>)y6(GOn5q)F5vIWW_nd3c zH@$0ggam^)QPNTnFgTc+0Lnmf2G3m*1?F(hv5Wi6#&qf?z6Ki5q7Pk$)}m}#K`${y zBY7i!)(Zg7IpC(ivO#r_NdR0HL9W5qS#&`gF}hy|r`OJJ&PYZRK6D-@4l(LBTOvo%$jspua z10gJZ)FFTk^ae{JIxHNv<}R|evRcUIIN;Pjkz0JQHp(P zG+RJuBpzx6;;?(LER1F3C?Z2J(F3o?*^T}Mq8RW7q*4hBiF!!XO0)^^>1+`Q5g1AL z8SQ=)1>t6qrq(5r=`vhd%A`PUOco_30eI5VC5apcWIj-Bl3-)Kx)6GJ3@~jE{MP%w4&1Xhmlun(k1T#1q@xW}L2lF)-XkgXfcEgb zKWz;Hl0CU$lscDBOF5&eI3FcZWBb>^z}tjLyVIX6(WcBY3_tlo2dJdS(_~XvfFiypuhdez{n; zU-M%?d_)7A2w?o%q-fOf5cT3O&SpX>)-*BU5Xxq@j?F$7zKy7Gs9ZEVZY2u2(F_BO zH61x4XdNgWqd@7x1PBIa1SrULIJ-|Ts>C}T_d-_zsNTMeM}2oNX&->#XzlNQ>;xZv zgFSS(G2zfEg?Kz*v;cfDU98SpT5hO z>g-0xU8}*vJ9(XUg@1qjes;N9VSIV=BQw;r{8(SAELc}NF)wuMM65oYGhYoZn!0|2 zH#c(Ie2VC*7Slbq4P}>k+9y4@ru994z5joE!tr^YkG<)7pZ)NEE{FB#dta~dV%n_@ zVO(^F?eTQ+`{Ld2GL$$=f>2&cVVnGBDK?D#%1QYRf%@QGlaJUSNL&7sq#y&K z*g5x|vg~IlEgkR2cB{P9l1U_zNhFeET-UGRZ9CZBf#Qayw`hMiP~q#xLXt@?i7h7E zZM2`bxO*KQkDTdxW?OVQzk1fUMI@3*%>Lc*@ME@tzp}~l7s2UYs!205HuCdh>upVp zHZ!D+j%XbRg9nVw$NEf6;J|NAAzJEQGo0r+(EI-42q3DHlJ9Ow66gJgp7Jv14tCeN z9o?feb6}mw$?A0u&Edwy(NhvymAyDznVvH?f4!XvnGDR2C;j7bb6$gW8qWfR*3}h0 zBrYuWQg{BbWKHr3GbQmN^FCyXNpWMx{8`^hJnT8|E5v(MIn~kI+J1`2neSGY(bdkw zyR0@bIX1L(bohR*Ho|Z9_J5n-+ew41@%?|hag`cgTP5<;&cAERhM8=c6Bt7?J?KJt z5P|#ws9=qH{Rz)g=qZ8V6gM12KTl`5x#ExKxd42iCSdLLWzL^t2v7WBc$&0~)eM1Z zh{6Smt4l`KWF&$hC|FUTL=8s}Q8L(u6Ce^Lk_AMR(^QtC)(KRQg{35I6`am)v284q zbaiJrX0pc)a3D%VoN6Kz2{O=9LYomJB526uNru8{=?DxGj0GYg4h9pEq=X8$Zp3xF zUAJb=X6&kDnoXUpMJ1&ut7Ju{9NRh^VNtQuU1gAOg4X$HwS;7BBN=e!OSXK^iTgbc ew{C)lWkLd`?jQo!!{-3iLONcMpG&P literal 6730 zcmV-Q8nxv@T4*^jL0KkKStp_Q;{aPpfB*mg|NsC0|NsC0|NQ^||Nr@i|Nr~{|Nj5~ zG2|Oqxfj>VBmCQ1sGz6GKKI(@g=RKmnsoG-5OWGyuqHq3Hm@ z8Z-ug(@jJwJyX$6(z(#=6O$<#m zG#NB#XwYQSOc8|B6GluSN>eF>n5U+YVj43@10ZPAL690502%-^0D6D`$N&HafDHkl z000000000D0x2qFn^by7rYY((O+k}Jm?lO~LNw4aF*MT?Mg%fo1kr?fModjK4Ff>J zWW-=hO)v?B(GZGZ55a_r0}$;w($Wz)v`B&}|8e3=hA6 zl$OenA3A^YYL}h z6AMfnf}$vhs-d>J=H8riX{Q(de_UpWQN74)Q6)yDLFOCYXU}yX*UbRV9d>4_6fCEr zav){|jNnJlk`ZVbJo2`ZIR@374u3P6s#fq+Udpgw)K>T&T=3lHbHOzvBp!+Zd7S4z z8bGpU6Rd0v8P`;hQ^mqii0QU91!E{~$V;&h8-CbMKGz~x$$%`YTxGt^u;sRiL9$lo zKK9_;w0Lc>)p{)K@@&p@)bl zq?mQ+V^&UO31JCP4p3?DEYY5im*Ux@%b=>19Ugm*({XDXDBR!&1#lmWV z>5yyFA0-K|oXyA%b_CWyY{|QWTyt}(qL-TOSSCj^F5Sy)=DUu!`&oC~ciYU|AT<#L z?p(&0@T_Ts^N?U5v5f4D8VpS{hhh(vA_z_{NUykZO=47}LPwB@!SV&jmFcDGXTmZx z^y%9Am^~@Ckc_VL-RP^%5?~penUqL_REU5ifUyxnJ|>rovCG%~JU{R4Gx)MO&JZCK z*QId#^aHSo%lHu$d0ARTpr(M5Sbd3IAwm#+`Vi-g?#K)QM8c6LosD_3z3p)G*>#63 z>0V;^P`TBeW3Lad5+OVW145pjlDp-{UX4GFxa!>j44~?8)c97S_XHLd0AT?52Hwh= zGlw|40*SnC86Xl4tT_*$H&YEF?Pb@r)UUjKDd88u`emePKh8&-y_z~FaP@~dFBtR^ z#e6c0D1%q-@h>RN;hxan`kiA!sA0y$-ZsIPRWcq#!L(LQm#WL$jF_6;OHVm|BM47G zJ<_g5zGe*-Go2SF6vh2bY#a8(AiX=;d(o(uldsc%HxDj;+`fER+e;|pqtnPjJ?zbs zccH*u+_p>`4$qd?X+cay%E^HS>IJ+-jwWk>rOnf=rZ+1FF4F<<~)qY)!=68dgiBY$MW0#8;Qsfjlhih~#LJG$w z0Io)+@dHA*Fes2n1b{juPOnE7XJ2O)=@t&mO+F)&*4zwpN?n+uU4T1VJqE}I!ECA< zNEZW1;x?XRf)XhpDb^SiX}j9jxbe=@(DdJhR=1_gP4Jw}W0%kKAwhlSDE0!^zfMV2 z(7XiW;x@3eTwig^|4WT2B6?L}!6o{;ww= zSBmp$sbvcB*&%#D7mz{8?({Tp68#@$A8po>2lpiOulCZ)@$-&hJ(0*%CIK5mYbJ$* zRgmHgFObrpg2T8cR5`73|y{>Gy z#>+~|vKbv5!yd2O)1@zxG8p*NDX=?KOPNW_gELz8y&|QDG%U2xNr~L6zBwe@;z-pP zHO8$4p}CC=}sMF?lmVXo{u+Rom(1!Db&yK#?a@YKUQQ@SFnB;D_`frrgET zVcUn-X6Uvb z8YFs#En$E#_}{uXFhwxIUq><5%@p(TB;RZHjE1H;g8zlY$LaJb%os9ISjI#tKnSvc zXh^Np)ERqmlX)GcxVLx`t?=Ll#H)a+*Cmc58JO2sodlk&?l;v#=|~Cp;jcUV_mp@u z8X)G?moIL<%GgO^ExiEpd{f3`Y*D&KSmrx8s=`IGRp{X3qL|XI?Q4y(hVXc;d63tl zq-AvSx3hcrE4tf}Vd&_JpTG|aHV8B{z(5Q=xn+-2f55M&)pkQO|*IjHpL>Lb}B*&<@M^{+Z)3pz4a z;&WSZ4!<%b?Bv_cwe4HX7`DjZKM-d}3j_-Y6TzsHMLSE11W zinCv?v~9~3U8m9jV?s(TP5eyj^50Kc7Mmx)1uCEl)$@2E*jrk3(t*IkKv|_oC_<mMZSWE|K4MG;kRDsS#B)73Uj84BmVu@%t zXDlHVpE5+mXQn~fs7A9HP^#P_FpT^$Z60`20Xd#(r;N6A9wLsB6i zB|zs+0{i@XxX4C8yfnGA>g-ohjT||=NeFj`xS`Zd3hb}YkUT`}Iy|l&2u%2S&d{LY z#u3Gkvcz~=au&tPTwizPc}o z%F@Pq&AP!1(NNd{DuE+dx@8)$HDfjCsi*-2z{m5fTT-g!EqLv{ zZ>`{LV&q8z0nh;ie9v{rvEvC*9?Eu63|;n02(022POh8VrI-j0vjC~=P>M+q0MkKC zfa5?fp;cD#cm<$IFI81gWG>)4xN^V}UEST|R)9nTk^vA3NCZODeV}PoTC*lF#KNEx zWI*Df6TyIp;GiTyLnj#nl>@>RSnqWH1^gJDA(0hhsC<3u1BTc%7pTyZJv8;yds@Z~Xo3QBVFZd*1iUMD#uHd*1iHd5?Qd(bUsTG}BEq z(Ak@9xy<0J$@F}6;kEO8ZhM$m9Ug+0Kk5{&bRYif=ASqI?WAhD>~B%~_r5G2wKt(V zqd#Kag%0{p*cQ^MTu+}qeJWI_(iE)EA-utDN^{iGB$Q3INQJ^FEy0JZ8dl}sXu(|46uB+;eKGs$$(Q=O4+IvlI40m%%i ze1a}<7GK+JRw3e$V#9UIkW8v<0v^aAVj@QHb)kI6*#qhZRX;%)&{3R1Q4O&R1Qc64 z!cR~^av4N71Qc41**yfwJd$?_e0tR9C_hVnysoxf#L-J1ly@XMpEtsJQ@bIVtUIK9 zVVLeEg(#6A-J|Er(B5zeyV3^$kROUgPKFMVAT%d3j`eX@LP1bAi9k3Kftm}5A~}rC z2=c_BnrVmvW>|=fO4))2LV+1Z2$=vBs6C;6`w2WpTxd2k&Dg=O8E(m5|AwV>OAxhANAX1cxgacEA<$;-zl4TSYxWjK+ zYBbfX(@kK(n5G1z1e8R|$dNe}N|~8!Lt?-Y_XMhmszFr>5d>xm0EuWQh@b>lRP7Q1 z8cMVwMGDdaD-sb^F)ay0Bnkj%DscUe4=)4SbiIhZ;?V)$Kl2G0ypg7)%>S-_{ zL4W~yc(gLr_6fgcOn@6%qtg)DtsAMNtwfMMRM*gh4`qL8Vd@v_uU8(=xhX zr4rO74GjuZR0_=nB^5vvutbW6?gR#q6wp#qP!a@Tq=6(MXjwo)Ss8?&VU!_5VpUa; zlAq)NzL~o_O>+gPxtp_Li?zXDjKt z4G?#+zkv<(g(#?LA|#9eIufHm6jBgE6palOg(F%L3XVa;LI{}x2$mQYNJ8jgR#1D; z2C#EoW_n_aKLChuVNl3LAw+_R1_=eEP@;(-BuR=2NMT z_aikuQ*M2zr~EdNp^*it3ITN^hsy97(^aGzs)}PvGSD;N(LlpPIz$o(WYi@{mlKX( zy%=beF#dFINLwsGBQ!BX3k3YQ;T9Q4#kOqLF&LiKVSFr|=jxA-8)crH*=Dkwqp!xo zxItWhoO5Auz7!0LP!$4ICPr9zYk`Unz(KfK5GGxk_0HFcEQ6WkHz>k4_~8nJ^)IMJ_hCnYgIx>6>3hil`J9wnDmZvyu#cW ztF~(-7795Llq7&A8LgAmC=`}OPiL&5P$|Wlj>{xo*7B5GuyO&JAPI=M&}E)UB$5)= zxJcTP`$Z-*_AXKJxta8HmYPC*vY|%8LJg6SC6#J!1yy5dNe*pz?qkSx=F<{Ei)mbr zn_SlLyL@9wb!}TxNJ0}K#D8RK02!k-En^U&>535uB53fypv3d32r5tjb?y30z0wGF zd&GFY-+ToM<+>AKcB1e?Y3b_jnj7l?OE%E^k|Kl^2ZAUsMC2vEUQE0B^T0wa+#9|UHwr2Nu?w$p~*S4d)>m>Z{EbvC`*@`KM zm}HU+3eY!;YNS;M7_e7y7p~#7ShY1>xt}J%sUV&wmj)?huR%Vsi^-G%c4kG!Mdm>) z$kNa!3(LjEF>K_`WBE0fReF1oGcu8YT5lZCUA#o1(n+Ypeix$67>Xe!(%*p!<7i^a z+3ZlzNwpTBgNh^E-#EZzWuxy1&b8Xuqr2IL;?Ud7!n8}XJ)O#zB5@4Cm6`$AV{h} zuP~!0Ct1+s;;V$Q3sD1e(UxowW3kEVw^2?}*dNi)?%&q*S)C5Y@Nl~NZHf`h%VTE~N8#(?1x z@wnp&5FR29CJi0Da7jo=FXGW+!edorZ4v(n1Lx&LjVzK<>xaOkC0*&G=z|n5{iXHk96Eq@B0)#>l3W6~JqI&;d z>-&E4Z~6cC)|r_u#hkW8oAB82`YsOdEPBwlVHw&k@~HFTy8(_iiW>JkM+hP`E@I26 z-k+Xg{2ud#WW9dxccmYt%C;9_R_)?!pb_C6Kmb$2!ME8_tGr6K_$}s zFk_NNz_GXwhS1d2Vj|cNK`_vy2{dm)5J@2!D`enHESEsd&lmuS&ko$>1NWrt_LpUi zFLy^iu2~v(u=M+F_tF2q8kZjCCzH+HRR0{>_4ZQl#tx5Hr2(8^#_q(6FU~aV!@V)16=qu*>{^z^cPl-@2ae-doWEggT| zdQR5Jrd4}E*sD+rz!vXF7o=eOUQv;8%)Rsgg8oj5y`bhi37NL9j% gBU&zft(vd8!C=r(^+S&&C%^G`BvXY60(u{QFkCG$1ONa4 diff --git a/inst/create-list-available-forecasts.R b/inst/create-list-available-forecasts.R index 21a2c8682..e69745e2a 100644 --- a/inst/create-list-available-forecasts.R +++ b/inst/create-list-available-forecasts.R @@ -29,6 +29,7 @@ metrics_quantile <- list( "dispersion" = dispersion, "bias" = bias_quantile, "coverage_50" = \(...) {run_safely(..., range = 50, fun = interval_coverage_quantile)}, - "coverage_90" = \(...) {run_safely(..., range = 90, fun = interval_coverage_quantile)} + "coverage_90" = \(...) {run_safely(..., range = 90, fun = interval_coverage_quantile)}, + "coverage_deviation" = \(...) {interval_coverage_deviation_quantile(...)} ) usethis::use_data(metrics_quantile, overwrite = TRUE) diff --git a/man/metrics_quantile.Rd b/man/metrics_quantile.Rd index 9fda39f03..edf32a8ff 100644 --- a/man/metrics_quantile.Rd +++ b/man/metrics_quantile.Rd @@ -5,7 +5,7 @@ \alias{metrics_quantile} \title{Default metrics for quantile-based forecasts.} \format{ -An object of class \code{list} of length 7. +An object of class \code{list} of length 8. } \usage{ metrics_quantile From 7b629192caf917ca02254c0c7f8c75741df6df29 Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Fri, 10 Nov 2023 13:30:45 +0100 Subject: [PATCH 04/49] Small update to `metrics_quantile` + fixing a typo --- R/metrics-quantile.R | 2 +- data/metrics_quantile.rda | Bin 15100 -> 12404 bytes inst/create-list-available-forecasts.R | 2 +- 3 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/metrics-quantile.R b/R/metrics-quantile.R index 0fee05438..186d057cc 100644 --- a/R/metrics-quantile.R +++ b/R/metrics-quantile.R @@ -205,7 +205,7 @@ interval_coverage_quantile <- function(observed, predicted, quantile, range = 50 if (!all(necessary_quantiles %in% quantile)) { warning( "To compute the coverage for a range of ", range, "%, the quantiles ", - necessary_quantiles, " are required. Returnting `NA`.") + necessary_quantiles, " are required. Returning `NA`.") return(NA) } r <- range diff --git a/data/metrics_quantile.rda b/data/metrics_quantile.rda index e8be29ea39e171f8a6ff0c021e5171c107222e1e..2d9413756a7778a95643a11ae205d5b927d3574d 100644 GIT binary patch literal 12404 zcmV-)FpJMZT4*^jL0KkKS)kq?y#Un9|NsC0|NsC0|NsC0|NsC0|NsC0|M!3Y_y7O@ z{{R2~|Nr1Q-ZTU5x#*95;Kdw$-rqod?byYDL#lT+O-ER9nAg))xpwJ|H3hLLtx8hZ z$GY%Gz^Z!+2|DE7`610Op=JUA1L;&1NJJ8-`e+hVfOoJ}plL_YPTF0YU=39TP(8P7 z0qw!i06jhA0wd&HE8k%xkpL!0#()Aa0x>6}OrE1gRPZLzPtXzQn?&_Zg-^;n35Jm# znA9?!Y8q3_DYB;ZPa0{d>W7U?lX|9~sy$ClN2EO`>W@k38L8=#JZMu-QR-y!f>96v z6Gk8i2-+rrpwTfIGB8x$Oe%QNC+LakH>Q-@Kzg2|MnKcl$R4ImJxvUrqtpNZ27#kM z007bI002Et6w}nuX^J8tPeV^pJef5cQHkVeMnR#VX_F%$^$d*xqeg%RfuI9Hpa1{> z007Vc0B8Vc000000#8*`Q4JFTFiZdh(*OXN002x(OaK4?0W@FRA zkUdR3AU#8BXlMXr0NRgG27mxPLA3w?13&-FxyUD3pnA8FhO0u8B`u`F^a2(IZ)L?P*GfV(Wr^4qrT<` zKIV-`MME>&K%K1U=Vk;qH?d}pUQeb<(%C+p_ONJcZ5c0`gLw@}3wi zpjrU(7EyTo{+FXeOU~8&xs6WlKq63H1dwpygyg3doo6q!K9%W&ii72em*VEJmLcIF z=Qwy8&omQ|^EkSchnvnyC{Ya67cLm_>?VeWvOxeYCJbK|%W}^J>Y(RzKm~_Sp{Fq8 z+HvYDb$b1H0WKcPwbF395{QT4|4eCuZJ_y<9nNJx0$ zLK)N)GHMhZsG<%(45QqY0yx0>VGNb39%TjR4L}+-)y15<&YreQ=XYPu@$J*Glk0Vj zW7pCYL%;DTdy~ThF)W;1F z3g^T*(ZivN@*fk3^4@j_mOS=iFCm-0tTQt}-03 zQO)GAGJHgx^P!o}&c4XFXBg2k!j>o$*rteX2DJm>@ECbEE^84XEea5&3?`^9Fmpwx z3!BBb8YiuT0QsnS_nEe7NJHnOz?qYmspqxJx@F0SK6Ft}S&7LSXsF8)cQ|3HqE5Cj zymVy*Sc0TzEM%s^F?*tHSJyDrL>VS@*Euv0;}U}wwGeYb3+-x>kQ&`Y$fOkl{%{Qv zB}<0{0kqzydKm*nn)%BD_4^}8is*;ltwT&9uO>G*`0%imx zvYcqSFS*aUt=*JI==VM!lTrp*X91Zo%&-T602$O6h?JBb_(FrjN;^Z-` zV}dcCL^TjC267ZI&oYJ^72K_eY(UqT0yRN;1wQcale^@A$M)hioA9fs(4&TfY$J+{ zRBMq>;c^!JYK?j@k+3zXPFfow9OKJgV(FvLN1%^IAIguyk8yj*_tF0cz`hmn9~ttQ z?JgQM zCRe>&N8^$rR!%^8$um)kiBW$eDqn>N{`C)L^&+7e>iuHnv$xVnI@&rEf58Hgu{ zzK5+#q4bui6ILGIpq)Z3MD)!Fd0rylX_V}3@hO0@Ttw(Re91VHsvvho@-9B&YuxW! zWL$fXB#e1l*+=98Hb=FbdN6vWb zt!j>5WD5?zJAY44an*c?hi@EvZzHJuIUK>!l0J@16Le+WyLoHU7;E)%4idsru_~(# zIBbE`gLA2^UXFak2AH~QJ0n+gAe*?07ZXu)Zd<21VmC1CXl^%}t}_jh6{$Lx*#;V2 z6=iRB9lGi8WrqU}pn7BsZcwo3fWkCV9@U|0-N&$-dtHQY!I#^I2zHLG!& zohN9bmc+38y+|#F{CaxTTYSX`$*}M<=F6d;O&uFEZ*b+WB{|j$aOy_7l3rUfWQ_4B zn(32QFRjY-nhcLmMUH0J+HxQLy@Z5>lSG>Upt`T1c*Cpr8vad!DW6(d2t%wu`Fvkx zQ0<{LMr`V-wikJLhkvXVtm#9o4rcJ^Jpu7?;qx~`0PF{JeDpj)i?xI~9-yhZB@<$Z z2IhPy+OYGIas|;n1Tbxu9CMZ{nBdbxl2#DpI z##3V3*$0LJXxzl$k6#LSQd$+HRPQ|r#6)&E+MMjus)n8PTm^9&9PHmiB^+X$!5ILN z7(|efNf90RrYAFyYBSRGc6Oem=HSC;A_QQlO7i<%lJVYs?&>Nsv*?mPZXOm$*f*I2ba z8{Dnwz&I4asAXXOifFhrxI7F+K~1fQx*FX~C0{DekbolQqNw#o1!=f+`qi67#dqWh zZ-Y&q^$cfL9d4aYbEUSy;+$RmB_J9XDlS4(y~x@MYHbV1>ocl#_$#S$n zOSG8F)<;g=w-RZU|Xyj7;k0nwbXW z8-hF$IkNd0wFQU@yao<=iw??MVCAxSS;}@=uU@;=$#}KSs=Ij3P?U&}rh5fO0WhWm z#XOOPwT84g|mCGyL=P1|!;vC9?953i0a%4sz6+xZhB8TAa07ufVZ>?;_G zBks|C|7yUfRqnJ!LgkWAaojnUsfR#uN-_gHYZduQTs6IdB2`8+>IqaUA^8*+ve-TT|3xfk`uof+6L;jY@W3RM%5wd22DjspO6w_~T%qhvl&E}=b7j~&XP zJO{k`M`GW~^imad^I<_m886`)1aTsv!2@PLh;>LL0cTEJ+ALVJKa7ZBo&bi^gzpCHp)X z3Mbt065l&v0r^9Rb+4T((cs_nCzKWUnMo(3?O(8bv4Iw;`oXe2dIX5bG6}N;*nxMw zLxKU-i>o#}bbhWn0W-)Q2^u4OqWr+tn%{^Ds_QJJaw`Fd*i7u90b4MJBt)-iC?8XW z0sW-afuDMa_@UyJoBGrQEe2Zb_Tz>dG%kt7vq3wAZSgyvWp{29&z>7mcl^DJ#5N&H z$VTCey30+)P8;hq36cAXDWZ;xO1P8}3Y0$Qik69L<#VV8_s#OY_p8rzdFwp7K7{i4 zb8=cr!<&AHaoyOfn$&NJ0f?8cJ)v!MO46siub(yhD(#a)+15grTSg!p7PvK5`lA&NC9erSp~(>8HxD>k2_O>{4$}(2T|u%HALMph$@G`_x@&A0NzqT9k9a; zkenc0TZ5X&3V4;`JhZ%q9DyS?+f|^5S0o9}#lQl!x)Ek!krAG{Pz7;|LPs35SCulZ zRRsgZ0GO#b#I#RON+6R=T4OPemuB!Qwomf;RBx)q9a5D|zwPqq>>2HrTm(ajQg>FM z#Ad>mDbi|MsEBe^IpO+98`Fk&UrL!}X7&^{gSV{|d4eYJ9~9$v0Id%7h`K^Vr+OMG z#R;ZHSo5Ztu#sD+vDTQ<(}cN{5mXk8jQ}84E9xtZ(ib(H5qn0{?iyr2I^;TC;msfV z=YQXAP6p~d?c;E;9cWD0U;SB~8*4J*3WFh&Mr0M3psyKQp~X!<4uVeGLjEqvuX^8O zb^PI^&H8u3y(Bf?sRk&T)AITJk*Za zo~?dN+-v&oW{TR|y=?`VSE$6|swZ1`%gQ3&F10Z+STwCn_nOh}v!lK_sBLlj<^8&e zGIaK|mb&JsF7}Y5=Pm53{)!}NNnrd5K^_X5If|6Z1u05lV~~SW6_o><9m?lXRN}tQ zXSC|i?awNF>0n~HhDQuJOX-iEQ6;Ur6^#(>jomj@Lj)aaTs7dipK*%1X26&vBwkUtz^jE_`P=99gGL zt+w#e;K`+mW(boiC7Z`HI_Y96UFa}55}Rh!^Rq#Wn zlJHna5n6`fBjNHTy~wY^!=*gzD0^@;C#6a~oxtj)4Q-5?3;O;=+luY- z(OwzTtwmkPiH3cH%F_Knd~?dZ-=>n)Nw_2~i!@cd8W6 zqM^#&F_4FL`)ue}IktBiudqW-i#2>_>ry$c%ydKkKBh4^Xja9YbS|#XXCGnw1UVy` z9C{C2;oZ-pnK7jE>N6j+ZF1}=38dG!S_Vn^;cU^;N1Bf@8bor@!bN3;(5IelXWW48 z@a%MVZaHKokzV-0{X%o^>SZ-2FR4$q`l*Xu!trIkq zDDHPZS+|b<1o4jlwX0LNmm%x#b~5f)&i8xMI#veHVud1ob*TNUPazB;D$hJ8$tMR* zM9X6Y_cpL18qH9)Go&ACh3Z!Jfgvq$T`U2D{ZI%rcS70{IqpnE~^56TaU*o)2WNshh)9J2w~zbCn09^HBBSv36-(P8^=U#?oV`N}%$V%!Y<>43leL z_kejK6o{Ci${1%}%o9>39eNeDA3TnWfu8u!seiPtj~>VF5a*$O$Ku3<>UkRs_j0hf zqijKnhWtaak!yIl-|oAyCkI8ZAe!l!BxsNd62*0arV8`Pbs;ElR5L#kLIn$ z-)?Mp=%0p}A;z6``RU%awg&g1Kv z;zWl@;|u2tgwqZVm&y4Q^LrTOw@D+);{`(Ay~G-Vpz{u*rrA$yWiE1K^^F}TjBcu+ zb27d1%-=qVar2ui69m@LP^)5seN_a*@3u6@!^YxdvqR)$J6I@dD)&0{fdmW@B}^bM zjdlqEpCE0usoi!g9T>tQtqK<4Y@PX_K^b#(O~Z>*7%FDb7ltm4CL|5`$k|l6@qDN#G!+fHhFPOnXQUh2`Pl z2giF3DsoHYI(*w5uq>T%D@sb^A_R#b5{%0=f-N+t6w_qdk*%c5Y9`w%i&-|Zl%(1= zn{3ipnoVORMXbvV(xTB>B`}DQWTY}^F_DoJGDadsG?rCs&Q}yz%`+6qG?P#i1!tw` zW5qR!fw1kYciU|(RvRixHq|6WAg#S(9P8FQ@!N}YVjCQaz{C|wRJ4>*kXUHYbPgIf zCf6CN;y94Sf};^djtf=4p|!R|P{BauwITs7_jaHkx8}HjKnGGHP*R3wAUna3CnRJq zR#TcoMM9h-a{ReAl{E%O8tb++8%+d2o|fx01_s&DM~7HqtJ0CBT6i3^cKMOXa(cXe z#_K&tjMod+UW(=D71-1hq7T64cTVOH)c~%_INd!WI zsG_XHD||9)--d%#Qrh>O94N#DIC#GeaH=sF##~qRTswrA$&y1iLEIIiS+7r#Z#n-*RI74(YO3Xy zUfA_x_}b8zr~Bx;UA(?M&f>2-d;T9w&+%UBS+5SYe&XbDV@HRmu&dR{lSwxYO%85v zYiEgRugP=rb@kl)D=KR`+RDD}+bP?9HPodoosLe}wYax+y}iA)#l^%F2l#tEk6!yo z!=HWU;6Unk_l@}?62rF#x5FXF$8793cyiQjwEx$gM> zrt6jeT(9Tg?!7po>@bbVqmBQu^*y`Y;I}rXqIhPaS|XNt=vnGH{I@EIT9&dBiM+olteV5aHR}E`7 zQ5V7benC)lAOquNA2S`8kf4E6D3X~nVd;z{fhZFAJq=Pj2-Ty?M{(a#oyn0SQ{{I@ zNs{UFS7YWcFNaY1N&D2v*wo3s_uRM5@Gb!pD2@?HI`P6FWe9m#`jdJ^fZeBmOnh_R z4-pjzh>sBvA#r~D)#!wb(l1c_8O&a@{t6+ZgpWZF!Gw|*h2%f3L^OC|;{`hZ#f3ER zT?eQc@YjYBenV4D_R-s-*&o!55UUShHo>htQZ)_@W7M0}QKNct&G5!7YBQ2xkH&0b z)PpQ$HA(4PlLC528C{(r^#Ez0Ac^_tg0KIgr=u#30(h0_E+RT56$JXoUSd!{v@QS& z24e)^0DGA#qv5@)e|UPUWGA3OH}%i&)Fr=LHNQO5fTouK+8bmaIt)O%3`1~G)r`i$ zSF4m>qcVwzm=}SFv#PCWQJV>2h#D}&6_}u)y+L{w!5vkmMdGkjNPKPb=q>n9hWvzC z!!5E%NeFY9$PfV7)mYk$isCK$g^jG@tg?teY-DLsjEM-wC78={v6TYGoSZo8yHCn) zO>`5Ix~q~HVFnv=O5^<>F(qOnB#!jKI0F)Z-vNZF77$hj5%&o_HY|jNtLVMV3Lx;; zRdZ3YMk>mvu_J1CuWDA&b64{&aTJ3MvmC-9l8VMrh>4P@QUWCchGHa`2)=AxVu}`( z!2rxx1Op^c3P4IkBQR0OR+K`KK%_*N6lN5#BNZtSjKD?60HgyD02u`=mjF!6QCd+- z1t>*m6`)i*4WEGfaXBncBhfo_5rh{ax3LG$SW+J07(PL2-DNLdQ z1j2}>=xu2=`NRt3lmdt(%8Cn15F6uGC=Du<292$wRbxiA8(ILXX#mN2h}0?}Koo#b zs0Ak4+N9GqF>D25)SGO9RT=>l&^>G*{2#sIee4P7AYVTyg7QL?9A{(b;HMDUO-acQ zppd0GIAMG~A;f^G2mwv4rNU8DXawgfpr-Pwh&*7BX<7l8QG}Hc2@nYom{dxovrR^$ zZMK6(#%!$$Q2+#WDu#p>VSrbrF&U~^XAQx@6;@+O14W31AebtG8c{HW0Wwqy6$(VJ zLmeAZC}gfg1k6z(Qy57=*-?@f4TXua8kja)YgvrdB!tG2mL)V3FlmvZw$ud7#L`8! zv`AG$1vDUSDH4OcfQ2G06Dtr60EGg?r3;MeLxoV0EgUlupc<)}fH%UL$!aYYY?R4r zH6&uA6&5Nj2xN?AFvB*)S}4`AZK;DKp%yVsf@%{76A&)nM%EsFQ&_oR)&>m-j*NLSNQ)ocxNN|-vU?fve zsu>`}IRdI}48W_Ql~h7u8Gvw+bfgXG_FW1Dy1_gYf#p~6J3jlchdNZ`2vQ{oxgZ=V zgg_<(r2+$~6$n8YNrpgWU_lh6DkV#1wV4TIjHc4fD3X;ViMB*UiaYiOLa5P5!25$0SYKUzz_P$fxWXRxe)=d5V;_XBpRI%xDbm3CXytRP-%q& zL^_2u1R^9r5im%u01)6xlq&`6WpQB&W>qUlP=NyaZ%>P|LTgx{2aw4jm{{;Fz|)gz zp%ud|&^~nuW4+V(%tF25;*LYD$XEJ?!I;3Y#%qhR$4p3&1!RD7Nq`IqK!PBF@FzDs zE}$E5WljXrL@IxzWLm(%l^(r=Kt~?44boYVVV%YT?X6WTH~28{xcBM2f>=nntF*!jkH)DtM5d6~?ZOy&fFJVfFV;18g$vkN`t z;JLEMfY|1TNzGODxHp@BcRBxnH+?L^TLdCXY@3k+BouS88jmRa@3-G`T%oc*Bl15( z#mndL7h%dfPEZIzBcnYCGzih_CcD86s2R4JanYh1Vnp^eq>~}Zcw++dPD%nF(t(sn z_Mvc^p8}v{mVlR>*HuiP0@sgIRJ=7CWyZ~z0q}7e7zAJ8!r;dmwFrTa)(_vtxMM)a z94a7rM~?cc8At{AVk^c|w;l6h9k<0AKr#>jX#$ed0}YE`h3fE}b%_{Y3T`=5;x2NZ#z zNG+&5TBVRUND1`%-`Fo)_W|-qqL@rs1%P;VY4+YYTJMi>NF{*XD_mtJ;d9d+-RE#4 zj)!^wPh-{0WALY_9lKOB&eXo6#LAx2OIGuj=`N{ho=~429XglYCGEw%Yh;YN^sec< z+#|kL?a72$6D~UB&f8#Gp95aBF(^sTdd-{TQV;42zpM8N=A&S%iqrqJ%IjFQw?!Dqx;WQe9XsMrv%|2}|HDvH)xk-C% zrfG*EHGvS42Tm3BR|SMAL=X@z2@g$(8n77D-A8dKSc_;?I$~L=)Qw=9gp-S#9Xt-v zG#fe4)z(*^WD@CBu`hp^|5zQ*2>>sx`P&OW}?z-p1uFz~I#! z$J5>oP(eSnx94HwMHANIBhYj`FgMjidI(p#=bMYa1?Gg&{GDx{MDA2OW%``UbpcT8 z+-0|r)0i}yQ2o_J*n}hkM+j5L^`B+96%yPTY1CqYn>q{#Bm_4k=h&;y5}Gb`=VP&f zh?z1#i{FXXJe>$Y#Atd06Il$MyNf{OpT?AUf zsuz_6iBP6Q3>m~?2ChyCjNN6v-8;7uBZ#F%+l`BFQP|RBByWr&jdC<4c4fw5_kVvL z3P34-jvd!@Rxv29=HkNO@Jp24@rUKca6ITi9KXdREq7f@8m2>iUGOV(aHTgXXTI1c zR)cv5YA3{nTs3s%!kV0%-Fsm#JzXMWm@OAk1QMCy?_Ec0a+=YRZ&+Of4be5+qj}=F z;WsRZrc8yzFx0A+MX|}RC@5>#-Q7tOxBbJj#m^rw=nYO2uxaeu#X;VV$Sws+A}MP* zPD&x5Ow>?1z|=Bu2upuK{rHzLv_#ns>sB<+hbAFZ#}Lz#p1qA?>JnTMEsn-=&F2|S zw7~FsrO-NnZ4feCiY4^gAv&$#y^xGlP*p>Qsm1p{1+xaF{81CCX^Ko&IML<|#t2?{ zIhGE5+0AN~@`I~>;krA(fWFK{L${<(7$(XmI;f9^0-?E_u2rF_E}F zu{bhhR5R9E*{)2eaHOS*92LB%($sRNG&E>4gNfMAB~fY!aA4$&i6BBqe6I%kQ#pxR z8j5#xYUie8xx=dskn+|KvWuilw1%c!q@h!^?l3m}AoF}ZO%Ga^>T;zAZRqip+77wM zhiV8&wcSNskT+J5Xd}6`y#V6L+3|Nji%OoJ2G2KM*3-Xgri%hiQICi=BEZ;4K!uJA zXW;JSdz?B0gn2nL;Q`b&NRWvrA_>`m3ToSqR^yA8O^urWqH5w=_+VjqRWJ#y&I~Rw zUZPCdsB0Rn3l^zY{a=hLQs^ZBkU|2&JDYpS-`xQfk&sw*5IXpC2lH5qm)~xEc%qe@ z4z$&X=}9ist!KwP66K@VW92`t{j-JD|huw4$zT0GJ*k?9EcC$lcffxl6ooghZ6vXWrF66Ho@z+!+H3qPQ#&s ze*7F6JE+Jg34_Xy4J)K31DZpYdD|E!`!LMiK#BfNs-BZ0g=P+f`(*Ksh6vN8vLmLTdA zg!Zs+AjA&>1Qe9AN;ar$nrkHuNC#8BK!He{AxB~v5SbR07G*`GL<$w86jG1@K}-k} zCK80kn>+CT*SYxr7wPyMzlV3??aBvpBvYQ>%=I*A4^bMQ{514qA!`-8vq`=e%}dI9 znECjdclWOR56joXL=g?g`o@K4Y_`~4@CGDp8Tlf#f)6X9b>7{+NB+O&{Y@G%#pCWU z<9Ew>DDvEvD5cZ{*R}jJJG!N=0oIu%(nuYdqK%IqED}HHR+jyrdKNC&vNhIwx*eGNnsNk6L3if*V?+2uZV)S zBUEFY`|LT~%ac6(1gTmJYPT&bMo)b>IuZGr-2S5t*>)z=n^rJVJmHl za1~$6l9$&X@p(nUBgx43FVI$$?dv^Hlqep0Dk7?jPkddc0q8AS=J_}Ab_^7@3mNEp z6E_IR`^7HXibtzIL-1eaME-1qi%S~0FLV1ai(B1qe>3mFcXIDG7Q5V3$T3-on897DV$)_SMhg=&uypw z-}HFguju>!|7-R1bM*O%^QGnbSxyFit6Qn!)ZG7ex@qm)OkG#%_jfu7BrmCt<*@@r zYa;tYJv|ShfexDLdOit-tmJtdokdMTi!surd`Ln`4ng^^x(~n^A*O$iE1rM@N5^NC z>j7#=#pq=@@h!I7ZMNHOw%c_jn(1;j`LUbMj7DbOJ=`uv?O}AY@>H3>L`u?pm z_5Wn&K0&tIZ!zp+wKKOf@HGyP)o)ft=IaaiwuCP;aU)@L=pMI^>dkl;+;W}%9|O*y zwo*a*~Wy%~}t;}4UEl2H~p8L=|ubYJ)Uv0(jXz{YTZ%S4|#k^W0 zsp4xikzsixexzsN)4Q_^+RJ`H^=i;{wxY!wA~c-KhfvIlM>RDi?y%W&2($4 zK7FN!uYv4hehu!AKRLT-Z#5jIr996?;QRPICBJ!4=A#9i&i6FI-SmV5AriYv7@}41 z^VdBx`bfW9@_KUq#Qta=tMv0v{r?C7@~HEVQ_tr87u4^w(CD{7vyG5iBO;qsr&_Ye zO=cP+Em-Cnb%Bx=U}PnYnzGfIWnqnwMpK&9V^L`}VPH_@47rT3+HFDwkc&X1K?o9{ zl0qR7^0->VXwv44q^j84Z3foHml4>9VGKiX5F*54#!8yE4a05~vEstlmkbMw=(UZL mbj5J_p8vu6A1~Ya!l3Jc3i`Pf9bZHL;_gVN3KA3>!`Gmg#}{P) literal 15100 zcmV(KT-?)Ll6ihA|yWxZDbIiP#AU9nJov>Y*>&EID2 zx7)czSQU+|JD5pc+MPG7m1EKGbGSa;fC9$0H(icU?|f7Q-*jBNjb<_rbN~PYl>h($ z0Gk5X8UllRx=3gNxu_o}tER52MFlDmNd}&VgOz*kci%-f)iQze;vP!3+#(M9ud;AS zBp@c3fEq>s69$Q(G#Mt))I5_D#F$MdlxCC0riPdasguYiGH7JcGgHz}42`H$Z8Xu6 zF;5}sGy~Ko)YH_{1k)43o`$BFfh33kLrnlCngqa&0ihZc{XspFX*`&T?FNL&lnpaT z+Cxl0$Z4jBsMFLm4^u&-%4vdWrqm6n4K!(!)X)Zi&;V!yWd;c#riq|sPdzGnn+i9n z>PNH`$n^$|8X9^}DD+3DVj466G-zZ18VvvjfMfs-Gynhq0009(00000sj5hcPg79! zPe}BbWSTupN2p;uNs;P3MnKt37>pr;VKYEO5N4nn27u7hKxw8Lh58;yeih|l>h$Kzin2<`Nd`o=i~bbCQ3KWg)B|+~Z+YDRvH`Qd457HgchIdW2g#u% z0{!}G185_LA@y+j(hn3w(u10y(TX>gB2In<2nNb8OJ07ZJMkqHx5(RI^iZ`nAYneL z;Hieq4T$}fVQP|VN|2Cbfg(v~=WJ6BN0myyE+bga0`(Cqk-QjZm?;Fc=J0DHbW|0iy`1dx@X#}9~ z2P!xRAFT1W$#jB%ctp+W=eZAjL)u{JI=ii)N#>&Y$BU=uSDBwLr|K)086j*~t2MQ_ z>xIJKSb)sJ)WvgF)OYU49fr?j0wsRl-5K_M0=aW%5gie2SGl<8OJ@zcW|(FYW7GCe zL5Wg?fE#^)FQ+W3<*Q=PRU7EVS81U7^A0fiX7$>p36D{hKvyoelXEHui+U=Suy%BG z^l{@JO#F!F%^3j*kTV3V57>ET2#4}(=}LDKm%CFXc&HA~o6~;(b#dar7LEH9dNgVy z!zIF67@iy6SX?p$oD#wHCVkG<5v3TzA%z5E4jv3e$cj0mDkBZI8Q*}298%C|<+vyd z6(CqTX^tHSo3E#@<1g+hhc2u!+3q#Od^`fUasGLW!I zBG3#CI?Ft1+R1~y8j=QjbH>C-z>tA4l?V}p{ROj(!!5G3tkPZhz_R)Yfpr7XK;PrF1js;eho2gNIUrpRvxxp4BOnG?=jPcB05i95E-hKy zuvCHqgCXk~+0$TT&4iA>?3DZu&f7t7nc@sBOGHYQ0tqA_OtH-pL9jXHAp%Jtdnq1U z1qRgG$yx8l%}rCD2QgxxcrXx91TB2Vg9wD995`4gUYbbIX810Q zM)n+k5jK`D8?m84Bs8&*iW!aol0~Kx1rV0<)~ZOPmMxW@nATk3<_2c2wYo?j%OsLR zz~q$1l@DKY;`zS6&eUyxH^bO^IDfxg6M;557B*hhQbt30%PT(;<#Kp;43RDEg)H00$#xGu89xeV_Ve;6oBx8APgFkctKoZ zgR2g*!60Ubt43@MZm|z;C6X$LAJ&1L5MygtPg)j*p&@F4U~8ArV7-(AF0B{RDsCT80SdIz~_(ohs zn0N@`BZdw<62-oX?$)^3uN1~c$sKX9O5=uYM0qEgyyfU4lm~vj70fxv^-;|aSUrP; zk7XS9?>~L)O~`hE`VZLl&u(ttP;VdNkUOQ>o!A`n{a3s@!{a*j{L#oY{~+7GxIdyl zx?Q+->wLB;ZB41!F4=g;91hKH7T`3&wn5#7z&GpV2C(6yhOt%Ppmm*NrkRvrMMN_Q{LA5? z0f`hsIsmy!Fl}BpeU7G-zff^R7a33i0w_ZTi-?0}FkGIhEQ+&LaikUwtpt9|7U{eN z!Hp&R&l}SNnJ#l1?(Oaqc)iR0hbiw9`@3{G*P46h{fGQGo-kZz%O&zH0@)h1!738y%-_q` zHgsn*mw^s(LRca&Kn(bu$7;H~*qaVOwC{o^B2Lu(tNj+Qng};UJb_x&<|&$BI%mO8 z0~;+WMPSGtKv0T!L797(9Mj-n%Z5RT$`qb`_!NOSz$=Rp=et3~{f~WUxL)){{L%Ed zo;3o@8L&}wx`=X4;qnaPBR7KQ5P@JYT?aH7cj1CUBDyCcm%C~ty-#V<@B3&byDxuC z@VYCVywIJ#J|{8{9kH^tOPY64hFbZTZs6~7(n>O&co_6$hfUI8>A@acT{<>l!q_An zZg?2T4MPpCbqKl*OEWobO8izi4hS}_-yA}XM>}(8V*YszoSCxqc&gRKcJ_!%`qm0i z!6Z;&vCm{UAnx5^(1D5#AZ zp?aN3DWWt|iQGLfoEACNZrQ1U`E0pdSz^9W8S$56gB-T>>BEh%X&MUf(A8;U%_lUk zB&rs_L%t6WHW)OeuAD^?j*X4_KSE0N?oX=hx3l7c<)c}n!2@J`oQU|jjT3o0aa<$M zdr#D5j%ed8S~%{h!_BsaKnsKNSPQKun3;q`O)7X-h(6P)@7;nRY11yK4H15iWA;{h zh)n`c?v+^pg61Gx+XL@3)GEZqs6r0NS&DdGe2OMvLkj@6A0-b6WevPz#__5|IJoJ)KY#D*=y-kmUt)ig3P4KXC50ZA0(iVl(s*q!WNmk&z&n4}gO=@;v# zEt6$B2Ki0-WpZ7^n0X+Hdk{F|(TKib7C~7AKs0a26aWpup3$wu+(U1LR}fr^SJMxs z70$roK!9Zkou~&mT7?N@wzQKJ+a7?neD}6|SAj^k6+#}6-2l7i0~4{SvAOwk@^jCY zmSIP93RhenaXk-f<$K@bTI+p=fjE#ehm;G$6H!zcd|!dwKmlx12yimPj942IY$GK+ z^Us224iP|LKw(I<3Yf%mHH6GwKv<6}o{p`hVMvzo%r6Fv6(QrD5goGH6vLnuqrP3* z?iFAb%M%Fi_aPjO8fSgeG z|Kks&=yr~}<{zKl=jvt9mG*hXuzIySiai%bLw{2i>B`6&=@X0`V@*m-YaqA)0oOph zeQqC*NdLk=IQoT z>!1NN&>)<`KrLJcZ-&#LUS9E9^LMF$nnDsuBO!!_25{hXzID-Y98l9SuY!INgO=hV zyxZ3cgA5gwmQgK{>Q# zN2%C~4H_UQ8x#!Tuq??nTe0j$^cH?3>=@tnSo14P}lB}fmN7@cJ;$5&< zNU8}5$)U~=iwQwgG6PWr>vMAjgbtK6^uIsw?teDJR7Q9bgR3~dxnCDqE1x1$!gB;T zf!qh6;9%oN%gS?bsWF|i1$ZsLe^@LQh-iYh=%o2@v@!$^u7h#hvv>I>VKn7(oWD`n z50MK%f*>czr9Umz$}u^bonJbLLY1_ zCl6LJ&tTes76wS`n{Qyvs12=AMwzA*o15fHn!JV1B6z;3VHBnbNQ13m7TC39#C}e^ zUA)p+0=_MWj$nA-Ci0Jh(lD$cbTG#ncLG8AXSzINIRLc;%OIHtV!_gbq8u6=PKExN z$JD$6xe9c|3WSigG(mhYuyIniL30ymAV@u=9@85QN#6S!hI-^b_D436DGtAIA0XU|c2>vG z{r8+$C4|ulurk$TYYdRg3`jvXpt}%nhWtZ}AQ?hy_eulsk-Je**6q7vg3_UF@83p+ zhr%!Kmi5^_1+JZ-o(Ba7%5iKmD$aTA9C4~-UZO9mAeb;61PwIL#Cr*wftk!wp7+Dc z@-$u-VMtUNeikG{zQFjCehXq3b!)%TD(Wd4O4z!|(IOs9hrrW8;HHI5Q94jaonQ^z zLBV?0kUv~A$)jUB7J_#&F07cM6!gY`MKR9pT&Fe#2s!4&!NBxMQVhR+zueWVLde;E zM+Ylj1A2Ba=^98~C8t}XLCb1$*eGx=Xc~)?n6;aoQifu;p=F_R7z&VC-yY z?6L_6a=H1Zj#?QKqAB4nBKhg?5gaix7ZthGI0{UC-5~+aj!8n!{hlT*_M}mw~tCszd4JVOthJ8uV4Jbk)A*UHGT~BcI1_pS@57hlX zaqfI*KsnctleG%i zfxpc|)s3Wx9`J~9OwyAkWXSxF56JGjta{+G1(q2E#?tw%Thw;kSXm?3%v*Dyfe zmG5r6P%&vRdK2=@;xqK+22{8h$p2GNCfj@bQ?p}IF6^Jjp#bpyQP{?LvQL5jJ+b)X=rDQ^6?h$c>!V28$fXK28iyEpYQb&gIgF&KfzJ>xEs!zxK zUs%p{y5_5~dhmdIRC2th?m6At`GLX1(|+X9$jbXt5yp7MD3o&MxM9Yj+-W9Hd!NYI z^JHarG2Y2ez|YBoOuD(tTVGP$uZ!67yZ+Za%oJ`>wF2ZaTOH%DH))Z`dl-x<%R8E( zFa@9Ao-s$8$9Ia5g#nu?&TriBCLnNn8a6cNW$wfjY7;_*_RC_3aML**D#!w&RcH$Str zh3|*FW!(1d;@kcfEAFo!Z+Ls}P} zPeLPE2PWxW?j|pflht|pY*ve{$)VP+IEQV=F2Th;W3=`>EC&!;M%anP0x$DkdC@XO zl?UuE)mhe}ju{qXn}8qjhr-8%!iFjt8%>Ru5iih9hg(vU8hZ;+G=_(1vLfCq2N}5Mv-8|mJH3H zII9>k7g@yTt=U(z3=&85IK+&}OAZ!gQidKRZNgTWES!iSfX0}<_XK+M^2)8%%CzFC;1q0? z-1e7O2{jc>iIH0h;}m3aTI`D^z>kQ(U3?|(7gVj=!?TF+G4fFpD_D_@?n!APc(yUp z+T7%@G7L-x7i=P+4{Yb0C7vf_*GavlmgK7_9FkA65h{fRQu~4K2e=(jGLm+=WJ`*l zoFG9yB<^m^UU)BQ-dj34Ac|-S z`@rCvB*o;FvnjxymrP?7*cBlHq{yg>d!IV&>~XN8GA`Ua`1+hg^yBoCT|uK$jFz#5 zILfjqr#_NC!alk+EmOnMx>(L+mw5V~5V78|4_fV%lV^!|sy=o^;+WjRXL2Z;&5MF? zb~rO45|Zy3)oN@~BF2+eG8tD^8k7hI_6XN7IGXb9buQVQ9wTehxsU(gO(?Lu&K#`=f9i-)A*eXlt=O|2CJT!QQ3=|wNf^OzOD+=^c~D`5!EAW9wU&AF{a1k6i!+CJ;9K0>cmSXV?ba=N}x zwyMBmgvBMZ;i99&N*ql7yI*|4%yK$j&B}+p=_s;E$KFJBlzNu;a2F9#Ht!^g*jiAX zR@D2nMhg}#r;RNu=7RscKVJ>j*mki?tLS5fs~P)g$B3_zH+`U}qtABHT_UtP%f=^PI_~LfODR@`ejN?(H2H>c`q>-dp*6-OAeCunnfNnMo(%OB_@VL ziyJZV^S&75GTzba=039HR0}4URFAW+m3WOmsrLiiJB5NtfK&u$WI%}#_fyu*B6XWP z+cN+%DH{k2kPhZ5nV2?(90ZtEat^UWB)&2b-(+~8MHPxzTRx8h=JlD^3$1d+;R~`% z4K&a(T_gx1G!X4vqjlZxp*0@Sdqq}#$qC%@=hliA9H$)&MGRBh@bzL*Y%IuImN!dB zhsn!=;jSl|-SRc!7dOn}Ng(?HHpiiu?>45}Qwn~%a?Jd60-{JMXdSpn$b+OYN~FEx zihe>NzQDRCL!qLr<-K`wDCy8KSTaTe(F!fHn@n?C8(EQwn=LiAs#7eOs*5bvpqM6N z*_LS5GR(^jR>X+{611kQw1~9U)>75BmTMKVQEHT=rj|;ywJNewQd(BEt5TAb5Y6+u zdCg6%t!bhZ)+qxyBuS>O-z;aH zzn{DK_VL%3jP1OQiI!P5w$>z7h@_Hgsj0bSdT3M2>xZ3e@8Ly}My*U$RVl7!W6ZFl zB7=UQ-nNkemg}=oLo0-|iV;w8iYHP9L=w;yFuI$diBM`HZ9z=Yv>6dhA{8VNFP}a( zhBt0Ow2**YNdQm%%Grt(VH@qJ6CIY7O=ya?D>G9mnzw_-o}-++h2*hFNmv##z`8R< z6*3?&1iZuewk?vXiOhexf<8X)@Neq9Q#fsp}nLB5#0CjJM*yC%Kk+T+U=isddoy-EQ&e$d24@ z4N??^P*7Hv6uFPRGliJIfe3o|B%9F{&Y)~WVT2Gv1rWeckQ@RaQ8SP)3JZ!p1-`4~ z=jFK+QBCFmrp>;WTHp{zw1O%1;)WU^L{SmWD5zW^j|nET8*R6*v4|uBK}^^pDJwRL zNwCtZK@mw)4JzxfL=solx`idLU^D_s_SFnK6C{IFA+#X0sshM3nswK7ek%zTFv*L6b&xzz!}Hg zoq~2Kf!|q6k}j$QkvJpg{ul3Gpz}Ys>t`KjneY4_Cu4IHZT(N9o(cwlDe681IO541a(5liPBS)s+nMOR)yjVgUt3JFOFx^< zi=kCl@7lFy{m!1BS)! z4yOm1%yTpFe}pLWPdxKYJrz|y!1=!SwDjK>`@LuH_Z2Bv;qb z(d|4f{%?&Z^7fZ^bK8%xDpaU&;Xj}|ZL1c8sT(Kx`d7U1EJJb3l$)+z$ zlBYrM;dGrghZA027={6wFS5NZvrVMK=v?CIuyAm2ehgeqJ|?376WBDyA%R@e7$KQ|HE&+X;FNAP^F)OY%;!1JUg45KYsYtq16sdt`&ts_y*g|FDF~p#10bNd3v3cZ9mEHw`&d4Z z*lYVPk1y+KsvfFHO|r6+mDdNM!_^GW~QTI*ID7Bn@cZOPZ@X7wD*v{hT{4l zC{3kMP^u!K%|JuhO(G-#P;sza0g@19Lxf;LLLj8&zsp5ZIcWPx^t~Em&nw9FH@Fy@SA^L1rufIk{@ zo>_-%kk@-F&|f7(Um|8E0)yxf08y?T6kY65P~N~phl&bFsf4iwC`1uO?O>(E5D}FY zh=_wqFe5=h!eXGNvx2wdypyqht7Z3s!>*;d;9gPGxGp({Y6|j)EHf1f&{e9{8gyn7 z#Y<|ms&Nz}Vua|g3pgEC>b!%9<+zSph~=1vn==M`JV<4^=a+NtT4&QfyOsMFh0>d( z_XAixqlD<;_%3?)9v9qrUvU0;?!0fhah~b0avcEoUN_x%-*q_C)I;si`Hv%{=nyo4 z_TYPgC_A#ChmrGj&v~k$Y!yQ5ii6G6OE?Btemiyngb(_=40R=AtjgjY zAu5|5YuM^y$5R&EkYlU0j$ND7AEgF3b)k-T1xC1LG1e-_MAT!WOpI{C40T$!%WRop zoeZ$l23YBa`3>qDaOT4W(Xlq}tHDU8S7fsTD?)lodc`Qi)4WZgU5T069aC$b<`umM%`u9NZ!}F_R(<{ zrW}ylS<{>I>kq|mFg?)w8CZuAeWd(G^NIp}|Fhb=WT+P4JJ74#%9K4Rdie*)iMJS*~140OXfLl_C zGS1x0XF0avvvLN?W@;Nwa~pEo6@yl6DS>NkwzR^|7IS7RY}1^^Zdrc zxy~>v4XLq4ZA{7;sf|p9P*J1`QN^*VDU+No9L=b6oWqWD4eU|JTq%u(V{F}7;Ph@Y zXJfu_=Qv@TYHm5Wz%ooNHm-ApqUFIBlS!mgYHAga2G@RZj@HFyD;rj3QCk$-YO13f zHg=iiS+h4*5^QQV8kvCATPZ@V4S& z%V`M-HEpOX6Pz|>rqUXQDB4Y{9BXw4jZ-DHJUPtOnMJK=JMm1W$cCY-6H6?rGO-es znzb5|ODU^ls*PDHibSkiC97)1H8hMZR@Jr^vlA_&R<$ZqRw9*EHK|c5R@+v}veH>p zn^jh{Oxe5bW^Ey?w$0%yU~e|XV-7|dvtw@gg|Rbi$PH#z$Ac~zVn&-&X|`-Frdb(i zHKvnMWs5@EwAnRnj~iwN@UgYQSmlZ?(9Y}9SCv8A@!nAq}JnX;P$OJ{YlTgEtr4YuiQ%+1=S3Xc|%LJ$cQ zkc1RVn?r@X2E=L*F^5n!=hIg&Ru>$bMnhc?D-H5radMikjkcbsie{2zYTHEHH8#|&8&Rx=t%(|eO}p)c4Oz4! zG1}W6Z|1p=$wu35_?t1_GdCb4+_u{Xgx0fTqRq9fv6-!4S_oKzrI{mSAP3H~N~;@C zKL!ePtNDNL4PvFi6d@G?66mQy3{nPcv}VNTFx=J{;MiJeve_~=CegEEXwycevI}D^ zD-uMkg|b3xB9w%=t|@7)rnX8_l%*+UGi*|u7DnF7ZNk`zv|BdO7({XkW@}KZBVrJP zBC2W_Uo9kA7_DeaO~S$2+Zn>!cTJ8hkv5jbOEZeLcP^7^)ORIGEhMvHmP=BpS!_0| zT2-w!&8nMLrm8l@Hh$LbM#0}I)?0UNZLv+d(Yj-G#%$>aSaowGZOlVCZH=+}DqA_D z2IE^PNQxzpjfPkRVyHAkMJP0Owq|Nbc8-M2k4M`%WwFw2&c_*ujm+=IGmd9zgQr`C zrs^B9Y};uYL>sL&t&X-6W2_K#@tXGYIiX5J;3Li!@s^r19Eq)itvaV(xr5 zHu-i)g5t2_`C)-?g_?#T6mS?7)uSO14XePlg)c%X8yPy~V>J%ppv#l%Ow^SjKvDsm zBnXYawmGzN`gNnxFHhwnXcJiF)uc!=pdf2!X$nWi?T>HG^M~l{HjvpXPY2y;vwPL? zw_{Nfc#XT_iW2ii&_;of&Yr*nbs~Ui;vqvs5xjNB=ly4K(|E4n{r}rOm(~3*3FdX> zcfS$Y>0O0p(bygl)=`NOBJJ!^04N|(bEfOT4vY?M94(_1ctnBgZb>C&FA5AODA|Z6 zDa1sj%iE&yKAkxwpeIHcos29wJlnAzZ6*oW)a21|j4oi0)a4p73kCWxyfDVf76^#s z;~%dZW0IF9Ol*Mn4}F1QLotO75dp?4=MD970{iGkattQ?Zi*IejR1-TT9qs@%4Nxh zPPu^yDTwd|iv{R7ez68vj6h@qJV7hyX}_071`%UC&aQ7tE<^Y z+s(q3*}1E6$g^h|CfV1t8zH|%4KaT}3ztgJ^8wZrx)_iU#xaW25IGCWK{8&eDZSwB z;i9d>iL22KfLH`kedG}+2)axFL3hmO*Btl?bS9_^cqzx4g26(Q)_P6Bq%gGZ`ulUu#){s(+hT$>ue5+PLKEEulu zdw%TV`5%ucYb25pNvs*ri}(3()OUKmzd$%NIo*UcT1CXN1B{mq41Cm93`KxD{za8W z*m7H=!EeZ2kVt|tBBX&+p5{~88K9M1WXvx$G?z>~%V7cAwjEnh&T!C@iVJ)hnVirf z#E>K_$Z{U7A+ZF3VW`LyLxDT7E;=tz3cMl{LdZrjnY3`CBCknUHKVW=IM8UXhnmp{ zN^eC-=Lo0^u8H5vZ9%=q)Gl`Q*Kv9Lj!w=eEO2Dm1nQqKvP{$<#fSTk5LfBO~^zs4f)moa>zN(6(JngL!Xx2MA zG=wt=l6yN>wVy_4Zt*jNdW%W4U96`|XtlADLJ*i_M1%cdrtu<79PlzkswW8DUWmj| zYWgtFP7a0OH}L8V@2Pk;R0Z?*d|3K`qWU~UdBdGFFk=LOM+h`HgNCVWLJW+7YcSUT zCgttH8Xo1!Of=p-RizYltY*W=cAcQn4aip81U6L09!Hb9`7+3uaAvMH06GEC2J|OW zX2aBhdE;69M;S7Wi1!4o(RVSDj6UZLgn!60P{Ji&>yu6-1aDjMs07Y5dzPB$hC zdM636y@-+@P85uSLA7-%c;dbSZtvSbyorVc*z@FbCr&4wMJCogm5cswJiEGS`_ zGcrg>q!3r3#P95Z+3rRa(I* zH<(EC<0;0XdO;bt#N-)8yQR!Djy8<1j{Vg)I`f7_`;);uqQfmHurAn8%*s|sL+MT# z_u3F7B3TiX5WvGFCTymYg!>4UeCP-N`{S|T>F0qX0!BpFf#rPfwfHAvk4grW&TK&EA+B%J-oh1^WN<96 zm(H+uH1L~RdBN7dqHvEAqKWaKDn352Jt!&5x}n(x0X&GJjkV5>qnjj|1x4CA_q#^% z0B}HTKy^^jv3~itK-^wZA=vWD68M;2DaN}vRkb+YF6}!>RiAva%)Fhk7dx`w2(b>4 z%-IKFrUu=%iFdVgcwL|qERgPutn*nlX3?W9)EP06x~w@yz&hxe2O=cLCo(8xK|(17 zhDMqas%bSbVNzhAGC~XzCAv8SJ@p|_A)cfwfO?%XtZ{GO+V{S`@1x^ezlL0zEl}@C zBtgt`2c-!fw$9gDJI7Co+&msm|M*ccdx_fZ?exLC6kR#S4;A~oxfLiADZZitQi?kH zV*y3VwHPv~Sq?fikO~_-q!GoEH-P6}Z$<7ST55vV+SRk)JuCvWnyh8=ekWVTF@-ub z7Z6NVS0;)s+Ak`jt#rEyh2ZH|q>{1}VQLv_a*t+gY#J2KY3_H&QYGRA=nqRM=ZuL9 z%BXuBj;PL#MC@ zHDRZ!lsnyu>yGk}<3X&*Ntpxgfq=rsfOv&~$$UpPZN3gKzjMvIHaJh3#f}G}(E4{+nsYO4YhF|BJh{R!OT*$W34^s{W}z5}pqFiA>)y6(GOn5q)F5vIWW_nd3c zH@$0ggam^)QPNTnFgTc+0Lnmf2G3m*1?F(hv5Wi6#&qf?z6Ki5q7Pk$)}m}#K`${y zBY7i!)(Zg7IpC(ivO#r_NdR0HL9W5qS#&`gF}hy|r`OJJ&PYZRK6D-@4l(LBTOvo%$jspua z10gJZ)FFTk^ae{JIxHNv<}R|evRcUIIN;Pjkz0JQHp(P zG+RJuBpzx6;;?(LER1F3C?Z2J(F3o?*^T}Mq8RW7q*4hBiF!!XO0)^^>1+`Q5g1AL z8SQ=)1>t6qrq(5r=`vhd%A`PUOco_30eI5VC5apcWIj-Bl3-)Kx)6GJ3@~jE{MP%w4&1Xhmlun(k1T#1q@xW}L2lF)-XkgXfcEgb zKWz;Hl0CU$lscDBOF5&eI3FcZWBb>^z}tjLyVIX6(WcBY3_tlo2dJdS(_~XvfFiypuhdez{n; zU-M%?d_)7A2w?o%q-fOf5cT3O&SpX>)-*BU5Xxq@j?F$7zKy7Gs9ZEVZY2u2(F_BO zH61x4XdNgWqd@7x1PBIa1SrULIJ-|Ts>C}T_d-_zsNTMeM}2oNX&->#XzlNQ>;xZv zgFSS(G2zfEg?Kz*v;cfDU98SpT5hO z>g-0xU8}*vJ9(XUg@1qjes;N9VSIV=BQw;r{8(SAELc}NF)wuMM65oYGhYoZn!0|2 zH#c(Ie2VC*7Slbq4P}>k+9y4@ru994z5joE!tr^YkG<)7pZ)NEE{FB#dta~dV%n_@ zVO(^F?eTQ+`{Ld2GL$$=f>2&cVVnGBDK?D#%1QYRf%@QGlaJUSNL&7sq#y&K z*g5x|vg~IlEgkR2cB{P9l1U_zNhFeET-UGRZ9CZBf#Qayw`hMiP~q#xLXt@?i7h7E zZM2`bxO*KQkDTdxW?OVQzk1fUMI@3*%>Lc*@ME@tzp}~l7s2UYs!205HuCdh>upVp zHZ!D+j%XbRg9nVw$NEf6;J|NAAzJEQGo0r+(EI-42q3DHlJ9Ow66gJgp7Jv14tCeN z9o?feb6}mw$?A0u&Edwy(NhvymAyDznVvH?f4!XvnGDR2C;j7bb6$gW8qWfR*3}h0 zBrYuWQg{BbWKHr3GbQmN^FCyXNpWMx{8`^hJnT8|E5v(MIn~kI+J1`2neSGY(bdkw zyR0@bIX1L(bohR*Ho|Z9_J5n-+ew41@%?|hag`cgTP5<;&cAERhM8=c6Bt7?J?KJt z5P|#ws9=qH{Rz)g=qZ8V6gM12KTl`5x#ExKxd42iCSdLLWzL^t2v7WBc$&0~)eM1Z zh{6Smt4l`KWF&$hC|FUTL=8s}Q8L(u6Ce^Lk_AMR(^QtC)(KRQg{35I6`am)v284q zbaiJrX0pc)a3D%VoN6Kz2{O=9LYomJB526uNru8{=?DxGj0GYg4h9pEq=X8$Zp3xF zUAJb=X6&kDnoXUpMJ1&ut7Ju{9NRh^VNtQuU1gAOg4X$HwS;7BBN=e!OSXK^iTgbc ew{C)lWkLd`?jQo!!{-3iLONcMpG&P diff --git a/inst/create-list-available-forecasts.R b/inst/create-list-available-forecasts.R index e69745e2a..2778a22c4 100644 --- a/inst/create-list-available-forecasts.R +++ b/inst/create-list-available-forecasts.R @@ -30,6 +30,6 @@ metrics_quantile <- list( "bias" = bias_quantile, "coverage_50" = \(...) {run_safely(..., range = 50, fun = interval_coverage_quantile)}, "coverage_90" = \(...) {run_safely(..., range = 90, fun = interval_coverage_quantile)}, - "coverage_deviation" = \(...) {interval_coverage_deviation_quantile(...)} + "coverage_deviation" = interval_coverage_deviation_quantile ) usethis::use_data(metrics_quantile, overwrite = TRUE) From c6747640f19598af8880a71fdf92f51435becc07 Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Fri, 10 Nov 2023 15:20:33 +0100 Subject: [PATCH 05/49] update `ae_median_quantile()` and documentation associated to `wis()` and other functions with the same arguments --- R/metrics-quantile.R | 59 ++++++++++----------- man/ae_median_quantile.Rd | 30 +++++------ man/interval_coverage.Rd | 9 +++- man/interval_coverage_deviation_quantile.Rd | 9 +++- man/wis.Rd | 13 +++-- 5 files changed, 66 insertions(+), 54 deletions(-) diff --git a/R/metrics-quantile.R b/R/metrics-quantile.R index 186d057cc..ecd356d7e 100644 --- a/R/metrics-quantile.R +++ b/R/metrics-quantile.R @@ -80,14 +80,20 @@ #' `overprediction`, `underprediction`, and `dispersion.` #' #' @inheritParams interval_score -#' @param predicted vector of size n with the predicted values +#' @param observed numeric vector of size n with the observed values +#' @param predicted numeric nxN matrix of predictive +#' quantiles, n (number of rows) being the number of forecasts (corresponding +#' to the number of observed values) and N +#' (number of columns) the number of quantiles per forecast. +#' If `observed` is just a single number, then predicted can just be a +#' vector of size N. #' @param quantile vector with quantile levels of size N #' @param count_median_twice if TRUE, count the median twice in the score #' @param na.rm if TRUE, ignore NA values when computing the score #' @importFrom stats weighted.mean #' @return -#' `wis()`: a numeric vector with WIS values (one per observation), or a list -#' with separate entries if `separate_results` is `TRUE`. +#' `wis()`: a numeric vector with WIS values of size n (one per observation), +#' or a list with separate entries if `separate_results` is `TRUE`. #' @export wis <- function(observed, predicted, @@ -616,48 +622,39 @@ wis_one_to_one <- function(observed, #' @title Absolute Error of the Median (Quantile-based Version) -#' #' @description -#' Absolute error of the median calculated as -#' +#' Compute the absolute error of the median calculated as #' \deqn{ -#' \textrm{abs}(\textrm{observed} - \textrm{prediction}) +#' \textrm{abs}(\textrm{observed} - \textrm{median prediction}) #' }{ #' abs(observed - median_prediction) #' } -#' -#' The function was created for internal use within [score()], but can also -#' used as a standalone function. -#' -#' @param predicted numeric vector with predictions, corresponding to the -#' quantiles in a second vector, `quantiles`. -#' @param quantiles numeric vector that denotes the quantile for the values -#' in `predicted`. Only those predictions where `quantiles == 0.5` will -#' be kept. If `quantiles` is `NULL`, then all `predicted` and -#' `observed` will be used (this is then the same as [abs_error()]) -#' @return vector with the scoring values +#' The median prediction is the predicted value for which quantile == 0.5, +#' the function therefore requires 0.5 to be among the quantile levels in +#' `quantile`. +#' @inheritParams wis +#' @return numeric vector of length N with the absolute error of the median #' @seealso [ae_median_sample()], [abs_error()] #' @importFrom stats median -#' @inheritParams ae_median_sample #' @examples #' observed <- rnorm(30, mean = 1:30) #' predicted_values <- rnorm(30, mean = 1:30) #' ae_median_quantile(observed, predicted_values, quantiles = 0.5) #' @export #' @keywords metric - -ae_median_quantile <- function(observed, predicted, quantiles = NULL) { - if (!is.null(quantiles)) { - if (!any(quantiles == 0.5) && !anyNA(quantiles)) { - return(NA_real_) - warning( - "in order to compute the absolute error of the median, `0.5` must be ", - "among the quantiles given. Maybe you want to use `abs_error()`?" - ) - } - observed <- observed[quantiles == 0.5] - predicted <- predicted[quantiles == 0.5] +ae_median_quantile <- function(observed, predicted, quantile) { + assert_input_quantile(observed, predicted, quantile) + if (!any(quantiles == 0.5)) { + warning( + "in order to compute the absolute error of the median, `0.5` must be ", + "among the quantiles given. Returning `NA`." + ) + return(NA_real_) + } + if (is.null(dim(predicted))) { + predicted <- matrix(predicted, nrow = 1) } + predicted <- predicted[, quantile == 0.5] abs_error_median <- abs(observed - predicted) return(abs_error_median) } diff --git a/man/ae_median_quantile.Rd b/man/ae_median_quantile.Rd index 841850235..e85400121 100644 --- a/man/ae_median_quantile.Rd +++ b/man/ae_median_quantile.Rd @@ -4,33 +4,33 @@ \alias{ae_median_quantile} \title{Absolute Error of the Median (Quantile-based Version)} \usage{ -ae_median_quantile(observed, predicted, quantiles = NULL) +ae_median_quantile(observed, predicted, quantile) } \arguments{ -\item{observed}{A vector with observed values of size n} +\item{observed}{numeric vector of size n with the observed values} -\item{predicted}{numeric vector with predictions, corresponding to the -quantiles in a second vector, \code{quantiles}.} +\item{predicted}{numeric nxN matrix of predictive +quantiles, n (number of rows) being the number of forecasts (corresponding +to the number of observed values) and N +(number of columns) the number of quantiles per forecast. +If \code{observed} is just a single number, then predicted can just be a +vector of size N.} -\item{quantiles}{numeric vector that denotes the quantile for the values -in \code{predicted}. Only those predictions where \code{quantiles == 0.5} will -be kept. If \code{quantiles} is \code{NULL}, then all \code{predicted} and -\code{observed} will be used (this is then the same as \code{\link[=abs_error]{abs_error()}})} +\item{quantile}{vector with quantile levels of size N} } \value{ -vector with the scoring values +numeric vector of length N with the absolute error of the median } \description{ -Absolute error of the median calculated as - +Compute the absolute error of the median calculated as \deqn{ - \textrm{abs}(\textrm{observed} - \textrm{prediction}) + \textrm{abs}(\textrm{observed} - \textrm{median prediction}) }{ abs(observed - median_prediction) } - -The function was created for internal use within \code{\link[=score]{score()}}, but can also -used as a standalone function. +The median prediction is the predicted value for which quantile == 0.5, +the function therefore requires 0.5 to be among the quantile levels in +\code{quantile}. } \examples{ observed <- rnorm(30, mean = 1:30) diff --git a/man/interval_coverage.Rd b/man/interval_coverage.Rd index 8fbfc67d1..74256cc77 100644 --- a/man/interval_coverage.Rd +++ b/man/interval_coverage.Rd @@ -11,9 +11,14 @@ interval_coverage_quantile(observed, predicted, quantile, range = 50) interval_coverage_sample(observed, predicted, range = 50) } \arguments{ -\item{observed}{A vector with observed values of size n} +\item{observed}{numeric vector of size n with the observed values} -\item{predicted}{vector of size n with the predicted values} +\item{predicted}{numeric nxN matrix of predictive +quantiles, n (number of rows) being the number of forecasts (corresponding +to the number of observed values) and N +(number of columns) the number of quantiles per forecast. +If \code{observed} is just a single number, then predicted can just be a +vector of size N.} \item{quantile}{vector with quantile levels of size N} diff --git a/man/interval_coverage_deviation_quantile.Rd b/man/interval_coverage_deviation_quantile.Rd index a1398d468..9a6029ec7 100644 --- a/man/interval_coverage_deviation_quantile.Rd +++ b/man/interval_coverage_deviation_quantile.Rd @@ -7,9 +7,14 @@ interval_coverage_deviation_quantile(observed, predicted, quantile) } \arguments{ -\item{observed}{A vector with observed values of size n} +\item{observed}{numeric vector of size n with the observed values} -\item{predicted}{vector of size n with the predicted values} +\item{predicted}{numeric nxN matrix of predictive +quantiles, n (number of rows) being the number of forecasts (corresponding +to the number of observed values) and N +(number of columns) the number of quantiles per forecast. +If \code{observed} is just a single number, then predicted can just be a +vector of size N.} \item{quantile}{vector with quantile levels of size N} } diff --git a/man/wis.Rd b/man/wis.Rd index a76b3c35f..057e9d04a 100644 --- a/man/wis.Rd +++ b/man/wis.Rd @@ -24,9 +24,14 @@ overprediction(observed, predicted, quantile) underprediction(observed, predicted, quantile) } \arguments{ -\item{observed}{A vector with observed values of size n} +\item{observed}{numeric vector of size n with the observed values} -\item{predicted}{vector of size n with the predicted values} +\item{predicted}{numeric nxN matrix of predictive +quantiles, n (number of rows) being the number of forecasts (corresponding +to the number of observed values) and N +(number of columns) the number of quantiles per forecast. +If \code{observed} is just a single number, then predicted can just be a +vector of size N.} \item{quantile}{vector with quantile levels of size N} @@ -46,8 +51,8 @@ Default: \code{TRUE}.} \item{na.rm}{if TRUE, ignore NA values when computing the score} } \value{ -\code{wis()}: a numeric vector with WIS values (one per observation), or a list -with separate entries if \code{separate_results} is \code{TRUE}. +\code{wis()}: a numeric vector with WIS values of size n (one per observation), +or a list with separate entries if \code{separate_results} is \code{TRUE}. \code{dispersion()}: a numeric vector with dispersion values (one per observation) From 27d4a78e9009b6b9c3d1b4ad6e83173662ec29dc Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Fri, 10 Nov 2023 15:27:33 +0100 Subject: [PATCH 06/49] add input checks to `ae_median_sample()` and `se_mean_sample()` --- R/metrics-sample.R | 12 ++++++------ man/abs_error.Rd | 10 +++++++--- man/se_mean_sample.Rd | 5 +++-- 3 files changed, 16 insertions(+), 11 deletions(-) diff --git a/R/metrics-sample.R b/R/metrics-sample.R index 73026bfcf..96a3ee0ce 100644 --- a/R/metrics-sample.R +++ b/R/metrics-sample.R @@ -102,12 +102,11 @@ bias_sample <- function(observed, predicted) { #' @keywords metric ae_median_sample <- function(observed, predicted) { + assert_input_sample(observed, predicted) median_predictions <- apply( - as.matrix(predicted), MARGIN = 1, FUN = median # this is rowwise + as.matrix(predicted), MARGIN = 1, FUN = median # this is row-wise ) - ae_median <- abs(observed - median_predictions) - return(ae_median) } @@ -118,11 +117,11 @@ ae_median_sample <- function(observed, predicted) { #' Squared error of the mean calculated as #' #' \deqn{ -#' \textrm{mean}(\textrm{observed} - \textrm{prediction})^2 +#' \textrm{mean}(\textrm{observed} - \textrm{mean prediction})^2 #' }{ -#' mean(observed - mean_prediction)^2 +#' mean(observed - mean prediction)^2 #' } -#' +#' The mean prediction is calculated as the mean of the predictive samples. #' @param observed A vector with observed values of size n #' @param predicted nxN matrix of predictive samples, n (number of rows) being #' the number of data points and N (number of columns) the number of Monte @@ -137,6 +136,7 @@ ae_median_sample <- function(observed, predicted) { #' @keywords metric se_mean_sample <- function(observed, predicted) { + assert_input_sample(observed, predicted) mean_predictions <- rowMeans(as.matrix(predicted)) se_mean <- (observed - mean_predictions)^2 diff --git a/man/abs_error.Rd b/man/abs_error.Rd index 099937bfd..197703193 100644 --- a/man/abs_error.Rd +++ b/man/abs_error.Rd @@ -7,10 +7,14 @@ abs_error(observed, predicted) } \arguments{ -\item{observed}{A vector with observed values of size n} +\item{observed}{numeric vector of size n with the observed values} -\item{predicted}{numeric vector with predictions, corresponding to the -quantiles in a second vector, \code{quantiles}.} +\item{predicted}{numeric nxN matrix of predictive +quantiles, n (number of rows) being the number of forecasts (corresponding +to the number of observed values) and N +(number of columns) the number of quantiles per forecast. +If \code{observed} is just a single number, then predicted can just be a +vector of size N.} } \value{ vector with the absolute error diff --git a/man/se_mean_sample.Rd b/man/se_mean_sample.Rd index d7c7d332f..08a6d5d16 100644 --- a/man/se_mean_sample.Rd +++ b/man/se_mean_sample.Rd @@ -20,10 +20,11 @@ vector with the scoring values Squared error of the mean calculated as \deqn{ - \textrm{mean}(\textrm{observed} - \textrm{prediction})^2 + \textrm{mean}(\textrm{observed} - \textrm{mean prediction})^2 }{ - mean(observed - mean_prediction)^2 + mean(observed - mean prediction)^2 } +The mean prediction is calculated as the mean of the predictive samples. } \examples{ observed <- rnorm(30, mean = 1:30) From e2618cdeaa43347114f6fdbdfbab9abb8ba85ec7 Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Fri, 10 Nov 2023 15:54:55 +0100 Subject: [PATCH 07/49] Update documentation for `metrics_quantile` and remove # no lint from other data documentation (seems it was ignored anyway) --- R/data.R | 21 +++++++++++++-------- man/example_binary.Rd | 2 +- man/example_continuous.Rd | 2 +- man/example_point.Rd | 2 +- man/example_quantile.Rd | 2 +- man/example_quantile_forecasts_only.Rd | 2 +- man/example_truth_only.Rd | 2 +- man/metrics_quantile.Rd | 9 +++++++-- 8 files changed, 26 insertions(+), 16 deletions(-) diff --git a/R/data.R b/R/data.R index 48548ffed..c57e044d8 100644 --- a/R/data.R +++ b/R/data.R @@ -19,7 +19,7 @@ #' \item{model}{name of the model that generated the forecasts} #' \item{horizon}{forecast horizon in weeks} #' } -#' @source \url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/} # nolint +#' @source \url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/} "example_quantile" @@ -44,7 +44,7 @@ #' \item{model}{name of the model that generated the forecasts} #' \item{horizon}{forecast horizon in weeks} #' } -#' @source \url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/} # nolint +#' @source \url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/} "example_point" @@ -69,7 +69,7 @@ #' \item{predicted}{predicted value} #' \item{sample_id}{id for the corresponding sample} #' } -#' @source \url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/} # nolint +#' @source \url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/} "example_continuous" @@ -124,7 +124,7 @@ #' \item{horizon}{forecast horizon in weeks} #' \item{predicted}{predicted value} #' } -#' @source \url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/} # nolint +#' @source \url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/} "example_binary" @@ -147,7 +147,7 @@ #' \item{model}{name of the model that generated the forecasts} #' \item{horizon}{forecast horizon in weeks} #' } -#' @source \url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/} # nolint +#' @source \url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/} "example_quantile_forecasts_only" @@ -167,7 +167,7 @@ #' \item{observed}{observed values} #' \item{location_name}{name of the country for which a prediction was made} #' } -#' @source \url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/} # nolint +#' @source \url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/} "example_truth_only" #' Summary information for selected metrics @@ -216,8 +216,13 @@ #' #' A named list with functions: #' - "wis" = [wis()] +#' - "overprediction" = [overprediction()] +#' - "underprediction" = [underprediction()] +#' - "dispersion" = [dispersion()] #' - "bias" = [bias_quantile()] -#' - "coverage_50" = \(...) {run_safely(..., range = 50, fun = interval_coverage_quantile)} #nolint -#' - "coverage_90" = \(...) {run_safely(..., range = 90, fun = interval_coverage_quantile)} #nolint +#' - "coverage_50" = \(...) {run_safely(..., range = 50, fun = [interval_coverage_quantile][interval_coverage_quantile()])} +#' - "coverage_90" = \(...) {run_safely(..., range = 90, fun = [interval_coverage_quantile][interval_coverage_quantile()])} +#' - "coverage_deviation" = [interval_coverage_deviation_quantile()], +#' - "ae_median" = [ae_median_quantile()] #' @keywords info "metrics_quantile" diff --git a/man/example_binary.Rd b/man/example_binary.Rd index e7042d6b2..47797b8cd 100644 --- a/man/example_binary.Rd +++ b/man/example_binary.Rd @@ -19,7 +19,7 @@ A data frame with 346 rows and 10 columns: } } \source{ -\url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/} # nolint +\url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/} } \usage{ example_binary diff --git a/man/example_continuous.Rd b/man/example_continuous.Rd index d1fba390e..354ebc5d6 100644 --- a/man/example_continuous.Rd +++ b/man/example_continuous.Rd @@ -20,7 +20,7 @@ A data frame with 13,429 rows and 10 columns: } } \source{ -\url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/} # nolint +\url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/} } \usage{ example_continuous diff --git a/man/example_point.Rd b/man/example_point.Rd index 62af0e44f..1eb734b76 100644 --- a/man/example_point.Rd +++ b/man/example_point.Rd @@ -19,7 +19,7 @@ A data frame with } } \source{ -\url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/} # nolint +\url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/} } \usage{ example_point diff --git a/man/example_quantile.Rd b/man/example_quantile.Rd index 00250e6d0..2582907e9 100644 --- a/man/example_quantile.Rd +++ b/man/example_quantile.Rd @@ -20,7 +20,7 @@ A data frame with } } \source{ -\url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/} # nolint +\url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/} } \usage{ example_quantile diff --git a/man/example_quantile_forecasts_only.Rd b/man/example_quantile_forecasts_only.Rd index 3fcaf2722..d789ed1e0 100644 --- a/man/example_quantile_forecasts_only.Rd +++ b/man/example_quantile_forecasts_only.Rd @@ -18,7 +18,7 @@ A data frame with 7,581 rows and 9 columns: } } \source{ -\url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/} # nolint +\url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/} } \usage{ example_quantile_forecasts_only diff --git a/man/example_truth_only.Rd b/man/example_truth_only.Rd index 46453ba97..f8ae05afa 100644 --- a/man/example_truth_only.Rd +++ b/man/example_truth_only.Rd @@ -15,7 +15,7 @@ A data frame with 140 rows and 5 columns: } } \source{ -\url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/} # nolint +\url{https://github.com/covid19-forecast-hub-europe/covid19-forecast-hub-europe/commit/a42867b1ea152c57e25b04f9faa26cfd4bfd8fa6/} } \usage{ example_truth_only diff --git a/man/metrics_quantile.Rd b/man/metrics_quantile.Rd index edf32a8ff..f17e06048 100644 --- a/man/metrics_quantile.Rd +++ b/man/metrics_quantile.Rd @@ -14,9 +14,14 @@ metrics_quantile A named list with functions: \itemize{ \item "wis" = \code{\link[=wis]{wis()}} +\item "overprediction" = \code{\link[=overprediction]{overprediction()}} +\item "underprediction" = \code{\link[=underprediction]{underprediction()}} +\item "dispersion" = \code{\link[=dispersion]{dispersion()}} \item "bias" = \code{\link[=bias_quantile]{bias_quantile()}} -\item "coverage_50" = \(...) {run_safely(..., range = 50, fun = interval_coverage_quantile)} #nolint -\item "coverage_90" = \(...) {run_safely(..., range = 90, fun = interval_coverage_quantile)} #nolint +\item "coverage_50" = \(...) {run_safely(..., range = 50, fun = \link[=interval_coverage_quantile]{interval_coverage_quantile})} +\item "coverage_90" = \(...) {run_safely(..., range = 90, fun = \link[=interval_coverage_quantile]{interval_coverage_quantile})} +\item "coverage_deviation" = \code{\link[=interval_coverage_deviation_quantile]{interval_coverage_deviation_quantile()}}, +\item "ae_median" = \code{\link[=ae_median_quantile]{ae_median_quantile()}} } } \keyword{info} From 2ef9a52948b21967bfd1e89842315b747923e2d9 Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Sat, 11 Nov 2023 16:18:11 +0100 Subject: [PATCH 08/49] Correct error in ae_median_quantile, update data file and documentation --- R/metrics-quantile.R | 2 +- data/metrics_quantile.rda | Bin 12404 -> 13133 bytes man/metrics_quantile.Rd | 2 +- 3 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/metrics-quantile.R b/R/metrics-quantile.R index ecd356d7e..2ee3a7aa0 100644 --- a/R/metrics-quantile.R +++ b/R/metrics-quantile.R @@ -644,7 +644,7 @@ wis_one_to_one <- function(observed, #' @keywords metric ae_median_quantile <- function(observed, predicted, quantile) { assert_input_quantile(observed, predicted, quantile) - if (!any(quantiles == 0.5)) { + if (!any(quantile == 0.5)) { warning( "in order to compute the absolute error of the median, `0.5` must be ", "among the quantiles given. Returning `NA`." diff --git a/data/metrics_quantile.rda b/data/metrics_quantile.rda index 2d9413756a7778a95643a11ae205d5b927d3574d..70a00a9329468320b53b2c7e803ec070df6b33a9 100644 GIT binary patch literal 13133 zcmV-TGqTJ=T4*^jL0KkKS?0UNbpYU7fB*mg|NsC0|NsC0|NsC0|NsC0|NsC0|Nrm* z|NH;{|Nr1UK7Fn4ohP4Yc>C+mwv@a(y@92B|16HJXX#AIL*f?)=XL4?rL zCX9_V84WQs8Vv>k0LiAFp@`E7kT6X!Mwu{%O&Vknq)KXNDi2d?Xw6SivY7^&G-x!_ zN2t>wnvYTH05*_%jDe<1fb^OMo}kg7$j|}l41hEm8Udz&0MGydrkIaV0i$XNltBO{ zfuIS238nU$fav*A3 z#^4}QNQy{E$RYMI0K{QOe0x2%iUWqbW)?rbaihR;W(H-2rFg|-{?RZ=0kQq86#@!s zmAUwcJ3JE#ZZJ1}%`%9eV?j6NAeTl&DHY}MM4r6^(^sGo!14$}`6~!dDV|40fAcUr z7cF}Sfko=NOdO+BhLDd8%Svlfo<=%Kl%njMTm^W(ILI9CHv+;-MG?<)Ic`ZXMb(@& z@=kqnYC_SEkr6vlsg9HgGZ$KwFySg0TQWw!SVD-jh7@yL<;LY#8gqEnaK5cq2_ne} z6jvN^(U%B~&f|@x8GW8==a$PX$_NYmf*>3hUWn{JV%p=U^R^l{=XZdex* zl*CiN1+oQ@3V?VY*?#Bf{m(b*E&ZO`*~r@FN(4;}FiZyy7*0xh+ATh#S*C>%8IlmN z5+mzmK0_VIFh&%Ts--;Gh(&3lrml2tPN`0u!YihcL@U?ED|Ycoh5$NH5PTZ5S$!HxeP0V4X!x(<6G=k42rl`}E+r z@aW7nnW(+C-GXTMcjdYopGfED@TiDGVjI2#IK5tbq(rs=CO-`?0GqDrW zjE-?e!dWgc&|!SHEo}URuxAfh!nE07GWK+lkXwe;MME5QpMG&}R_i-I8Zw%1X))uq z{Ozzu4e4xj&}mSOMm^eeNib6d)3PF9j>=O6L0f3aDiU*et}bU0TD8I<1qdlIClDAT z;ZwY!*B}rCb%!Qy*LZXo-#nYNoB!GL*KdUtJYq-77KlM-eo9e=d0 z8&ZV9LnLZQNb68=Lac<@r3%7`s{*#2pVMJY<+a-@*; zuUN@fu~zXNhyWqtBuYRc1jKD)MYfWw8)&tPpa^dJUn9=>82tYv`2Qo0dmruj|5s=R zD$53B!!p{BBp@Bx4gjMlk2pmUxm00BQ4~bgG@5Ndm`gxYvH^S(ZA1uq^^VhSB;hTo zOa*$`hi3O+S*5y*z*uJYaGsb-vpJoh7{b4bKViU97E(It>&Rnx$9^%ZL{%6s267Zo z)Ut{k6>zvB;DNt3V7oBnfnAn(3Elt*qskH5astxBc8+2Vc#dj3RBusTo#Zb0ZBGRr zS~n#g`tD{C=T{Z>P`5+nxHxk<{QEt)byI6u8&FR@CI zlNFVz^{_o~JFtCl1@*mD&YzEyf8_VIe5~hnaix~WWWH;vX&6!fwvtrg^l1=}Tjlkw z=CT*(>d9V{0>K5gxHztQZYK2O-)7dBElG0#AY-Nq&?bFx^8b z9VMSM=jLCba+ij^khHrBb&QXEilE61kmC%DwaYpQcn4VeDIzh?5<#GIg7K`kN@ zWrSSt>C)Zgz_f>SI!hW>5r#tJTId+aec_QUjn*R_k2;p5+?z2mE6pplSupcXDzMBsOq7uf8#p<<$a&m7%Hg2TIbFSK#HlXLg(R(@ z>zWoLtpxW<`fDVb4J#0D!NiegkH2zhy|Y#)9c7p8H`HtjSLE-M+w49OFS zrgE=oVQ~75rGsEn>-d*5Mg<9W1|Aw3I`&Z>8ezg!s3A*6&$hh8%+B51T9#*8u&&TU z^yS~TX}j*+xmMPqN-UzpH_eIYyxHDzL#txLW7EL&V$Vk(!Q#6oQkeONAiiWn?H4@wsn)Ytt9tZ`Ivet>e9mp@5 zLPZDZL`2KEBSledGFCjvw1)aE!nchMmT!rDH$2+tG{vH+EJm@lu7Oq4$l)sCTCDbz z_Io=|BB2CII48L}1v1F+fEAtaHxp#~d(+T<@D9&9|H6wC(0irB$b*iQiE}~#a`B&12BSM)XN16% z^nSXhtA>|hDF*nRQ}VvpGBE^uVxk3zI2hKenzUg9N^vV3@=AqOTy7&lguHP-nxWb-nfprFi@P+nnyT53C9 zm1fatUFiZ@_^NF8Xka`e7h`u!Hu}T`gfze)8^Z)v;;15ILz7`J2x=w+*zS?J8@*B9 ziYMzukkW@JphpOLy!T}`hP-*g|4y0NzGfGDUreh6c!#F36 zFwe+N#FNU`Jn_;lC$YLlf@dSXeR=W<8BYM7=sLy`&SHdN(Uz6;>y{9Zwjm-0KEPq9 zhfK4V$@exs!yM5kh@;atzb(68SGJVF9>C{R|4L#*E@KdJeD1UPC{{2;7sg`!zm3`entTI-0(*q6yyb;HDszhp z(S#bKc(w&;iD>K_gh;cJYSbl~S3~mc3Y|qty@Feo6CvTLS!qTlV#&m}a;ULz7YtkV z&c|u2Zls&nw5@k}o4%8K1dVp?(`?Zy=@itd1SE>mJOOE-{_Zcrt?#`5clfwELgZTu zf@Q508;hnx#xrQy;S`Jp15;Mi$g-*>2EzP+;3uSJyxrqg$46@v|azg#87R2G&pqLdh=1Xb6fTd}5S z#)h{{FMSC>XzZC=1yL1UpO0X2JI9`@O=4&X$x4QQtDU_OjN-3dL0l1u#@tRqX`l-S z%w_gwDo>P=iY`x32+i2%D&T2OFskN$F9XR6Tj1w`Inx&B|hZVayPGsUDc#pt(e zDh!vzVPCNeY@zJAuUXVau8^Z?V2RR9Y3oqsbJu8;MPrGJi;U4m$YdDw?h&kE(w3&A z-9eKE_T9?ew@k4l&yA{8C1d7{*Qw=lt3(C$rdtRsa9jmbBy@T+;==*T(&V-VLK;REY`w&`obW}BucgB6(MjwN6PpX2DqN2m&`=w%P;e9YAm`la-_?Z zg3o8)nL0+mw)nc+`~Q5}yRz2N%MpmTT7*bojzJnqlo|p=rZ7m9g||wDdJdpzhGxG+ zLt9tC!ip{CU7WSf;LhpSf~J06Mi2d5hdd_%MPUKeiXrXF(98nRv>>qHV)d(5Cy;{J z+Y`QE%xhN&&*1JM>xWqm0-OsG*Kt8!*r2TK1P&r&k5t^s0v$L`oj9fi4DMo3WHD2V zl@G3~P&gnP=LCUgm#b7NFDb-Y<{4+sP8m>O6&nNrA%HeNYUWe5-EBF<*m@Bwa;A{LIW6;^@cOalchu%k@@R9?~qIS&yr zsn$DT7nb)0k!GJWkH+LQ9y`q2ugy1tlw>#OEDB#iX)E?vDm~8sI;O2wX-N(O<9JzK!pO$XQY96f5d~9Qv9x8ZZ3`gVF?~q{PH!cR2^z=Sa*jYyrIiSCA2K9W$ z<>ifYzS1t35Nxr1rn0>Ci%4%UJduvmBWtp)zHVgabeSgU3c%UxP^3>@%0DJ2vmtyX zY4+ixizkbo4<4!y>USs+$DL{vGV%E*wnVYPj8d+ZZ{^@~p<&$6d>#lV{MfE#e+*lUnE$usH+Xhp6wsCR5p8Wxl5U z_orG3d^d;&8d}NVLtf&og{WaImJCJOZ;D#V{?(Y@Q8*E-WJ4p%M*J>k%ar=UlfU5E zIs{5!g^FotuUNt>E+$*laDY|JfzcBR9}GA!=3c}TJWL&06|#?*M_SOQ$~=CJ?RjZ& z>-_}!bluf{E(FgH%l0Yq^3c-?>PkfKiS8U-e~aT^v(E(h3WLK)sb>ReCQiYzQYbXs z#|@@8+Z?}G+QuRme1q+s=(K#F@jKyj#QuI-J{Mdy?LxSouAH2^Zw*AP7 zZ8DnVmdLTVMYp8S+|5J%g+7}nj(8dWpz(9Eee0;iCE(P9T*+}9nb|7*eS|S4@Uz=} z7F|x+pD0qen)=b0O}TmW=LQ((JY2)=5i^9ap>dmci(zp*wEKG{{`DDO@+ zdpoSNpn?@0l_*qtB~m`Ddw9+%w`a$NmKT*@7R7YMu=HTum}nG!4W<76(L9X}qEycx zb@f!u0~vGItCm&sy$YS%%S`qdAk`v7_kVX=`;;5~t?5*W+tSy@gJML9?mL)0-@d`^ zVr$!n>EL!?Y&%p6Ia(x0ks>B$V{mEl-xAludw)!rDLN;9INM!5`#P%p0f;EUf8ZszNMnlN& znfDhW?~F&PMkvU+CBZ~URZ6kkK+i>5&Bjxdz|yzv~X2Z5zc4KY-2a}%?sviLJgux++nMaZrFNc8=Y=FCo#6esUowmbo*M? zO>|-r!(7%oNm@#_c-}N~D!A2(s|#GLv+d0B&z`wx%&F^NGsnAh?!&|8FXXQu(&!)o z(uCZlC>bKrlD@|)l6k2HlfOYt0BWInta|7UrQs#!gY9|fgMu%@(Tc-2aTbX}07#5L zqX0>*HB)O$vuqJ*r9h^eCe({mPTo)v{p(} z2#FR-Lk5Ex84*JyVkBhJS#4{fu8LU8GZQQ$Oe!iyeqU1_Nvr`4j`fcU0}2gG0T56K zMA1PMQNK_pO7#yMx5>IVhcf7!X0lLLMQJFdAh6M(>%6pYme)UO=5s=e2BIjSp{xNO zoTvpNhap3*-av)NVb#ca-oJuEM0%2?1tMl*Bg7dBbR#8uv=2r@ML;~!!G46BkZS^v zzHL}gER2B&Dg2qOR482wYnWU0iXyq-vH%hTaeRlDN<#(%(W~?3xAT4VZ=dOJl++B+ zL77tG7}lsL5K(gumJ?KqQ39zx@6?t5Cf&L9|M9VTX(VJKy+effK!7Vkg%be4FC8un zvcU(l@b-dof{K#->T5eY0aK!_4pw%bJ{n+Dj` z0!g=qXhbVFYe0w;kRk;n2!Ty>CD_{<1c4-kgp*@Ayj(Em^SM_bY~|ZIT#<+fDstz! zS0*u+%v@X(CP_1&<8a1rqug@QN!6Dqst{@FWh|N`A+)+xt5|^#bXey+L`Ww6>OKpk;)(9qUYTMDkdG zk|pzeubn~?M!(XFu$fc8uRkaMcfXhEPu1pkS}n!HdL3s~)&1^2Wg`*vS;>LN9EvBO ziWsBtq;=O_b=O^W*IR}0R+~~(sc0$p=ILmyJoC>y^Upl<&oriTMMSd4TD0GrgUNF* zg__vwZbjNUrXAfhf6h#-FUi<*ByQKco`U+n4z&75K-o$^cs#9 zr_to`^0BaTF7E5EGx_}Y@ZjO%WLwr1nV5V`Yt41-ef|aphYZnS=J8`gQlmph z_oH^~qs;RuN;>JhIp(c3F3;PE1mdWWcSSK+DhjbsD$`z)t}EEGMZ@OI%*_LaWI$15+M@ODja}$uZV=4$6M9xy$Rd6P=YH6Log$WwU5&5+BUIq6;fx3z0}KNJP(jROp3ZfPCWnIo z?6C_OkorF--9q!ufDn@EO~5KGK~R5>6n@S;ibWLzmqDG3VtazXkdlIzmFZt2>mnZw z9fsj*=gSj}w~zIT2Ccqfm$8=W7@1%sugAu6*L!5+0KE)`@96(|E48%*p_PXEnc4no{pJQ7F?Hh9L}Q zq@;>-*6}|JV-=<;pgQ658T6mh$qKEKLdXfOxt4;hNTMj80t=! z@dJDi#cvSLod?Y6xyZangltUViJ*FbW-7JD3sB;jgwIinktDhvgWQ0r4vP8fn2&gl ziqRZxkrI?h%mfU93Pnl;LWELeQJ4n6j8vpTGX+;50+0+r5MdOuTtPE1015?41t}G2 z6{J)<$B-4lPkGN44wc~FLwq{*ih zDiX*t2CXA;Tw@lCTuRE~ZU+iDW7XiC-@st7=`Vg{ZhnnUN5wj4)6(RAh$1u(38nQw2?}TQQoX zkeJd^#HNB~4Kg%ptpPJJG?HywM35|_8D1c1NQFuhniW!j8G&h5HHxho**1#YHzuxl zEhK2U+;OZ`fti(D-Xm5^QE0NHrcJ1{k&29JEL3d>WQ=Ao!zzfhQEOtWOc^Bzv5G|z zH3_7n8yi_EGFl}iYij2r*4Cmy3P1vdQ8XaR$fCTARRa{HFt8Frk`{%46fN>xQSAdw;^03s(b4I-d)mxBR_A(RwDbqb1yePC%ypitwSJ|qk( zebn-yuGPJhIcnrjg^!Tl31mMpF6_#Cf41eQE{Gr+@Y{eDh)61~)F`f*1a}I6cV(7X z#f2S`kVuB*QStB@AVf?dO#!r4h_zJNtW`x(Nv1?u0Jyn!q-qEVT@XOF2pQsS;;dxD z1zsRf3K3u-2Z=yTgkl_(5Ouo5r4`(O!zchG$g?VAB*KZ4wIFBAs?<~>)_{M~7QPA~ zVgvbHy?X&LkrD|;BuJikQ>hwaVMGalJnSG2;Q=8OU}hK*m4|Jtl%+(eY};9omPpEN zEYgW7Qb?O*L_|ch*iAf2-N}M$$m`!b4F^MuYt3Wg$r4-NqgoNJrp+K=Bzb+y3t3}yEz=yps zyo1*x@y7+G(dC8YhU|YZ=|bTVV&?3%W;VDSQFGvzF#HAviKsG_KH#Z4tgQ)9+Rr`XHEQ7IwEz) zOQgeL3WrafIYcG$#(@RZ*j?u71w6c&DblUd$|%ngvq z8gWsgz=qI~KN+ngnA53>9h-0|(U)!5ZMhK*56gh#hmt$a2^z(jYluh_6Bb@MFeo-VYLu zAQ&q_5e7sG!lnz0Zna%!bft(k{u&L{Y{pP|l9I>-#H52gKODM!9%Gtjc)s%=C%N%l z36zLoM+-ngMOQc^j8tL~5cx0f*0mF^ea#dJ{lVO%^>Nuq5AVXc%fS&j>Y!xz2W-_~iQC9F6-0L3@|mJHkr+dz?1t@2MhbA9 z$^tsiA5x&3Mgz~DB5)!`*}|FS*XNhD9?eL16IaDuKd4O&&j? zr|(P)p724zFtQa$4x^sj;X$en&}s=h^<->0WEPt9U(;)eJ|Z1zt6^W)bIRu!@0R>G zc7U_q>0t`lRjpARI(L{GUa@#tXQnsIBX_971hA`?oCTbzUkWCPqtiF$^d)Rc$4GCc z7_ufzKMwOA$vppgX0wNETaRtES{X_d0>L60vf(&vORte&KLEvy#r|SJ`>TNa&;uiw z*NW0=l(Nztu&UuIwi(dKwD_tSQ zcvm78WzJIId|@N4xFzLGdA>OASplKdNKoqt8T>Ul_6jF=THz~dnarYnkSO(dr!CMD z*}C}DQ;JMyiuqvtV%SL%V!&b3vp!5AtcoaU96s)dW`M?~q;}GUgj*rmt3$e+ktp31 z)JZscFzj!;M9^&ILq4}-a=^Utt#OVQQ7E8^ofn@Ca)#aYb+bC>H;1XJNjm*c8%>N+ zR=U2|4W4m}SgtuVWwd}bRI<8@ZY)jdo-qs&$Xbg`$q6A+$gg{Xj)k(Ny|t-K)J{A+ zWkkwPys%BI&4>7M81qb#sVONW(xxio0~#gQ&=eO*1O(@E*Dr7_(TLB@rkP8O=4;m3 zw{&h?vIrT1G9;QXusJJ6C9+f1N=(or3O)#^jIC{wLJ*vXJ`74h{C@FL>U}p9URJQQo&^XUh;A)_W{q0^&{>VX3Pl%6P>%E=uP+uU0I?hS9 z2JBa&6F=MN*y<+@Lx{UCGTTG}IxR6-<{J3JW_N}otq4d2jnJou;eLB)DyBl+>{R1m zA-j}D1O_S_a&yt=iJ;M7+UriQR{?69II%#B-GK4|-RTkr5uxS`O=L1bxf42Ag@KEM zeZJjwH?#*@G9Ph7qyj4ifTSdj#5h!xLXN5=$+=)*&)>Zv^nj?I+40J=WX2f8;xuF= z2?-ehfGT9&cL3?{8@hAo9@naDFNDZaLv0)Pc+M!U?Ft&XONJdhbn9p5kZ6<1f5q8#i(JL@YNaUK*Dq_T3 zLk4Q8U;$xYM9vZlC)GHu{_$96*f2{_ky2Ng;)_291BHB4ITOKfnu`jEsdcVW$B!Xm z8p2G_5akA-ZjvDdYm2}N^eF^c0Bl}?!oga*NC>614I^cOTzpX(2Q-d6eO!f&#{o^G zyzcr1urQsb!yhm0euZ+6Hm&SNX!4NCY}&OXzQTzjww_-q z!N-dko~7J?<-2Ix9ZCYe_6P~%X9s!-u8GVF3*U$WZDcr0u254!)V0<&h^5j36{P{m z3XC(`S_anH#PD3L#8Kt@;)-p=umiNNJT`NA9QfqguC>?Jh7T^r#tRLGF-2K)2V*PD zqRLT8BYq7c4h2z*9hH_-Vlrr~tj%j10x={=HN7&x z#$%+0(rstcUhjw4^Sv&b-OYU=*pf)D1BDE^xVWjWqjJ1{9*^v)bE!G{D(T_|f(lx3 z4pH5^XNL+j6A`|m3q%1lVIzg0f{~;&geWCpLWbYOHx$Qic}^O&@~Nh{{EBY5Z-1YI z!|rk!EKGGNp^28V%Q9M+(BVl-3LF)0-z5|%iohk^4NQkCuIAwS^waS|n|D42D7SOo5 z(yCk&M>;UH!-eBYQ6j<4WolFcg&G7PL+lMURI!N&loCZq08p(86)5d&>Q3(1BrB4| zZY!YO@G-~oc+27a&L7FJkSW?=^=4a+oRaBI+6ClMGL73F?|KNaz*`jxGkg{tmZMgJpq^ zKS|4DvSV*F=qfY{EBc@Bh{CGIYb zsRMDMSW6)1yaa5cguuYV7@PwPJCmJEL^MYykw!6FR1>5JW6!gVvpgY&1VNZ#Mqz|#(~M&V++kc4bh^MGo_LMmpeqy?dc?59 zER2EIdck!AK|pg)SqBh|K=Tldl2XYiwxLpKteO}o2UEpLfl8dx3$hsym{yclWEG_W z3IHht0i;lPNEBq1<$50v>Ad&tfA4kafA1da$$ejuJ|8=dr=UBJ{MUfmsi0Z-fg{6g zGL#x}$DU2KIIis%g}n+>A8#Lj^f50}6D@?;??r_Jgj3KXLAM;FJUi(O@fI&1V@U@J zpNIOQbUE{EWJm6E)m4ylVN-n7A*kS#EeE?F+uSw)V*@LHcH41Q*K@T)f7KaG;|~Q- z03MdGsXXweE-|Cy+=Y$t6C%*SQZ<9v>g7Yx1zKuQJSgmcp}nuLc-|}t2HjIDC~Yh{Hsf~YQSAp6AeVH zXt5tP(6S9xw;t*B*J3x9^x8s($}Kt4_c6+l8$^b9ju^UoI2P^Qk|52Ts~%KD3)lw(9fiPgBUUl>}?Z%3t&AyZ8HFU%YR}@2~wm-LB>u^4$HO6^Gf%vKr{|`d7P*7`&dFAMI}b z?^*PEmA>Z>xcfUiEp{9ouS@Cwm7S$$S}SlBe|g3AVkYiuTs*@t=4W*wc!l`@Ndeka zy39A)`k!5r`)s%9J%;-)FKh241?ZH6_sNeK_b+PC)KbqA#W4aPsi7)SDN-hysv~3& z)J~hJQG-PZuxhAIlZmLCO;}@O5tQb%Ml}|bRu&~LP}NPv2^@}?qNbx08W6_Yq>>sM zKP0CaWI!Akkx3P+Ry>9_!t^Anu3+eji&4ax n0LR4i9G}MM`QKJ5FP1~9FjvvYsPC)n&;J*4ML1B9=DWpp5zsP{ literal 12404 zcmV-)FpJMZT4*^jL0KkKS)kq?y#Un9|NsC0|NsC0|NsC0|NsC0|NsC0|M!3Y_y7O@ z{{R2~|Nr1Q-ZTU5x#*95;Kdw$-rqod?byYDL#lT+O-ER9nAg))xpwJ|H3hLLtx8hZ z$GY%Gz^Z!+2|DE7`610Op=JUA1L;&1NJJ8-`e+hVfOoJ}plL_YPTF0YU=39TP(8P7 z0qw!i06jhA0wd&HE8k%xkpL!0#()Aa0x>6}OrE1gRPZLzPtXzQn?&_Zg-^;n35Jm# znA9?!Y8q3_DYB;ZPa0{d>W7U?lX|9~sy$ClN2EO`>W@k38L8=#JZMu-QR-y!f>96v z6Gk8i2-+rrpwTfIGB8x$Oe%QNC+LakH>Q-@Kzg2|MnKcl$R4ImJxvUrqtpNZ27#kM z007bI002Et6w}nuX^J8tPeV^pJef5cQHkVeMnR#VX_F%$^$d*xqeg%RfuI9Hpa1{> z007Vc0B8Vc000000#8*`Q4JFTFiZdh(*OXN002x(OaK4?0W@FRA zkUdR3AU#8BXlMXr0NRgG27mxPLA3w?13&-FxyUD3pnA8FhO0u8B`u`F^a2(IZ)L?P*GfV(Wr^4qrT<` zKIV-`MME>&K%K1U=Vk;qH?d}pUQeb<(%C+p_ONJcZ5c0`gLw@}3wi zpjrU(7EyTo{+FXeOU~8&xs6WlKq63H1dwpygyg3doo6q!K9%W&ii72em*VEJmLcIF z=Qwy8&omQ|^EkSchnvnyC{Ya67cLm_>?VeWvOxeYCJbK|%W}^J>Y(RzKm~_Sp{Fq8 z+HvYDb$b1H0WKcPwbF395{QT4|4eCuZJ_y<9nNJx0$ zLK)N)GHMhZsG<%(45QqY0yx0>VGNb39%TjR4L}+-)y15<&YreQ=XYPu@$J*Glk0Vj zW7pCYL%;DTdy~ThF)W;1F z3g^T*(ZivN@*fk3^4@j_mOS=iFCm-0tTQt}-03 zQO)GAGJHgx^P!o}&c4XFXBg2k!j>o$*rteX2DJm>@ECbEE^84XEea5&3?`^9Fmpwx z3!BBb8YiuT0QsnS_nEe7NJHnOz?qYmspqxJx@F0SK6Ft}S&7LSXsF8)cQ|3HqE5Cj zymVy*Sc0TzEM%s^F?*tHSJyDrL>VS@*Euv0;}U}wwGeYb3+-x>kQ&`Y$fOkl{%{Qv zB}<0{0kqzydKm*nn)%BD_4^}8is*;ltwT&9uO>G*`0%imx zvYcqSFS*aUt=*JI==VM!lTrp*X91Zo%&-T602$O6h?JBb_(FrjN;^Z-` zV}dcCL^TjC267ZI&oYJ^72K_eY(UqT0yRN;1wQcale^@A$M)hioA9fs(4&TfY$J+{ zRBMq>;c^!JYK?j@k+3zXPFfow9OKJgV(FvLN1%^IAIguyk8yj*_tF0cz`hmn9~ttQ z?JgQM zCRe>&N8^$rR!%^8$um)kiBW$eDqn>N{`C)L^&+7e>iuHnv$xVnI@&rEf58Hgu{ zzK5+#q4bui6ILGIpq)Z3MD)!Fd0rylX_V}3@hO0@Ttw(Re91VHsvvho@-9B&YuxW! zWL$fXB#e1l*+=98Hb=FbdN6vWb zt!j>5WD5?zJAY44an*c?hi@EvZzHJuIUK>!l0J@16Le+WyLoHU7;E)%4idsru_~(# zIBbE`gLA2^UXFak2AH~QJ0n+gAe*?07ZXu)Zd<21VmC1CXl^%}t}_jh6{$Lx*#;V2 z6=iRB9lGi8WrqU}pn7BsZcwo3fWkCV9@U|0-N&$-dtHQY!I#^I2zHLG!& zohN9bmc+38y+|#F{CaxTTYSX`$*}M<=F6d;O&uFEZ*b+WB{|j$aOy_7l3rUfWQ_4B zn(32QFRjY-nhcLmMUH0J+HxQLy@Z5>lSG>Upt`T1c*Cpr8vad!DW6(d2t%wu`Fvkx zQ0<{LMr`V-wikJLhkvXVtm#9o4rcJ^Jpu7?;qx~`0PF{JeDpj)i?xI~9-yhZB@<$Z z2IhPy+OYGIas|;n1Tbxu9CMZ{nBdbxl2#DpI z##3V3*$0LJXxzl$k6#LSQd$+HRPQ|r#6)&E+MMjus)n8PTm^9&9PHmiB^+X$!5ILN z7(|efNf90RrYAFyYBSRGc6Oem=HSC;A_QQlO7i<%lJVYs?&>Nsv*?mPZXOm$*f*I2ba z8{Dnwz&I4asAXXOifFhrxI7F+K~1fQx*FX~C0{DekbolQqNw#o1!=f+`qi67#dqWh zZ-Y&q^$cfL9d4aYbEUSy;+$RmB_J9XDlS4(y~x@MYHbV1>ocl#_$#S$n zOSG8F)<;g=w-RZU|Xyj7;k0nwbXW z8-hF$IkNd0wFQU@yao<=iw??MVCAxSS;}@=uU@;=$#}KSs=Ij3P?U&}rh5fO0WhWm z#XOOPwT84g|mCGyL=P1|!;vC9?953i0a%4sz6+xZhB8TAa07ufVZ>?;_G zBks|C|7yUfRqnJ!LgkWAaojnUsfR#uN-_gHYZduQTs6IdB2`8+>IqaUA^8*+ve-TT|3xfk`uof+6L;jY@W3RM%5wd22DjspO6w_~T%qhvl&E}=b7j~&XP zJO{k`M`GW~^imad^I<_m886`)1aTsv!2@PLh;>LL0cTEJ+ALVJKa7ZBo&bi^gzpCHp)X z3Mbt065l&v0r^9Rb+4T((cs_nCzKWUnMo(3?O(8bv4Iw;`oXe2dIX5bG6}N;*nxMw zLxKU-i>o#}bbhWn0W-)Q2^u4OqWr+tn%{^Ds_QJJaw`Fd*i7u90b4MJBt)-iC?8XW z0sW-afuDMa_@UyJoBGrQEe2Zb_Tz>dG%kt7vq3wAZSgyvWp{29&z>7mcl^DJ#5N&H z$VTCey30+)P8;hq36cAXDWZ;xO1P8}3Y0$Qik69L<#VV8_s#OY_p8rzdFwp7K7{i4 zb8=cr!<&AHaoyOfn$&NJ0f?8cJ)v!MO46siub(yhD(#a)+15grTSg!p7PvK5`lA&NC9erSp~(>8HxD>k2_O>{4$}(2T|u%HALMph$@G`_x@&A0NzqT9k9a; zkenc0TZ5X&3V4;`JhZ%q9DyS?+f|^5S0o9}#lQl!x)Ek!krAG{Pz7;|LPs35SCulZ zRRsgZ0GO#b#I#RON+6R=T4OPemuB!Qwomf;RBx)q9a5D|zwPqq>>2HrTm(ajQg>FM z#Ad>mDbi|MsEBe^IpO+98`Fk&UrL!}X7&^{gSV{|d4eYJ9~9$v0Id%7h`K^Vr+OMG z#R;ZHSo5Ztu#sD+vDTQ<(}cN{5mXk8jQ}84E9xtZ(ib(H5qn0{?iyr2I^;TC;msfV z=YQXAP6p~d?c;E;9cWD0U;SB~8*4J*3WFh&Mr0M3psyKQp~X!<4uVeGLjEqvuX^8O zb^PI^&H8u3y(Bf?sRk&T)AITJk*Za zo~?dN+-v&oW{TR|y=?`VSE$6|swZ1`%gQ3&F10Z+STwCn_nOh}v!lK_sBLlj<^8&e zGIaK|mb&JsF7}Y5=Pm53{)!}NNnrd5K^_X5If|6Z1u05lV~~SW6_o><9m?lXRN}tQ zXSC|i?awNF>0n~HhDQuJOX-iEQ6;Ur6^#(>jomj@Lj)aaTs7dipK*%1X26&vBwkUtz^jE_`P=99gGL zt+w#e;K`+mW(boiC7Z`HI_Y96UFa}55}Rh!^Rq#Wn zlJHna5n6`fBjNHTy~wY^!=*gzD0^@;C#6a~oxtj)4Q-5?3;O;=+luY- z(OwzTtwmkPiH3cH%F_Knd~?dZ-=>n)Nw_2~i!@cd8W6 zqM^#&F_4FL`)ue}IktBiudqW-i#2>_>ry$c%ydKkKBh4^Xja9YbS|#XXCGnw1UVy` z9C{C2;oZ-pnK7jE>N6j+ZF1}=38dG!S_Vn^;cU^;N1Bf@8bor@!bN3;(5IelXWW48 z@a%MVZaHKokzV-0{X%o^>SZ-2FR4$q`l*Xu!trIkq zDDHPZS+|b<1o4jlwX0LNmm%x#b~5f)&i8xMI#veHVud1ob*TNUPazB;D$hJ8$tMR* zM9X6Y_cpL18qH9)Go&ACh3Z!Jfgvq$T`U2D{ZI%rcS70{IqpnE~^56TaU*o)2WNshh)9J2w~zbCn09^HBBSv36-(P8^=U#?oV`N}%$V%!Y<>43leL z_kejK6o{Ci${1%}%o9>39eNeDA3TnWfu8u!seiPtj~>VF5a*$O$Ku3<>UkRs_j0hf zqijKnhWtaak!yIl-|oAyCkI8ZAe!l!BxsNd62*0arV8`Pbs;ElR5L#kLIn$ z-)?Mp=%0p}A;z6``RU%awg&g1Kv z;zWl@;|u2tgwqZVm&y4Q^LrTOw@D+);{`(Ay~G-Vpz{u*rrA$yWiE1K^^F}TjBcu+ zb27d1%-=qVar2ui69m@LP^)5seN_a*@3u6@!^YxdvqR)$J6I@dD)&0{fdmW@B}^bM zjdlqEpCE0usoi!g9T>tQtqK<4Y@PX_K^b#(O~Z>*7%FDb7ltm4CL|5`$k|l6@qDN#G!+fHhFPOnXQUh2`Pl z2giF3DsoHYI(*w5uq>T%D@sb^A_R#b5{%0=f-N+t6w_qdk*%c5Y9`w%i&-|Zl%(1= zn{3ipnoVORMXbvV(xTB>B`}DQWTY}^F_DoJGDadsG?rCs&Q}yz%`+6qG?P#i1!tw` zW5qR!fw1kYciU|(RvRixHq|6WAg#S(9P8FQ@!N}YVjCQaz{C|wRJ4>*kXUHYbPgIf zCf6CN;y94Sf};^djtf=4p|!R|P{BauwITs7_jaHkx8}HjKnGGHP*R3wAUna3CnRJq zR#TcoMM9h-a{ReAl{E%O8tb++8%+d2o|fx01_s&DM~7HqtJ0CBT6i3^cKMOXa(cXe z#_K&tjMod+UW(=D71-1hq7T64cTVOH)c~%_INd!WI zsG_XHD||9)--d%#Qrh>O94N#DIC#GeaH=sF##~qRTswrA$&y1iLEIIiS+7r#Z#n-*RI74(YO3Xy zUfA_x_}b8zr~Bx;UA(?M&f>2-d;T9w&+%UBS+5SYe&XbDV@HRmu&dR{lSwxYO%85v zYiEgRugP=rb@kl)D=KR`+RDD}+bP?9HPodoosLe}wYax+y}iA)#l^%F2l#tEk6!yo z!=HWU;6Unk_l@}?62rF#x5FXF$8793cyiQjwEx$gM> zrt6jeT(9Tg?!7po>@bbVqmBQu^*y`Y;I}rXqIhPaS|XNt=vnGH{I@EIT9&dBiM+olteV5aHR}E`7 zQ5V7benC)lAOquNA2S`8kf4E6D3X~nVd;z{fhZFAJq=Pj2-Ty?M{(a#oyn0SQ{{I@ zNs{UFS7YWcFNaY1N&D2v*wo3s_uRM5@Gb!pD2@?HI`P6FWe9m#`jdJ^fZeBmOnh_R z4-pjzh>sBvA#r~D)#!wb(l1c_8O&a@{t6+ZgpWZF!Gw|*h2%f3L^OC|;{`hZ#f3ER zT?eQc@YjYBenV4D_R-s-*&o!55UUShHo>htQZ)_@W7M0}QKNct&G5!7YBQ2xkH&0b z)PpQ$HA(4PlLC528C{(r^#Ez0Ac^_tg0KIgr=u#30(h0_E+RT56$JXoUSd!{v@QS& z24e)^0DGA#qv5@)e|UPUWGA3OH}%i&)Fr=LHNQO5fTouK+8bmaIt)O%3`1~G)r`i$ zSF4m>qcVwzm=}SFv#PCWQJV>2h#D}&6_}u)y+L{w!5vkmMdGkjNPKPb=q>n9hWvzC z!!5E%NeFY9$PfV7)mYk$isCK$g^jG@tg?teY-DLsjEM-wC78={v6TYGoSZo8yHCn) zO>`5Ix~q~HVFnv=O5^<>F(qOnB#!jKI0F)Z-vNZF77$hj5%&o_HY|jNtLVMV3Lx;; zRdZ3YMk>mvu_J1CuWDA&b64{&aTJ3MvmC-9l8VMrh>4P@QUWCchGHa`2)=AxVu}`( z!2rxx1Op^c3P4IkBQR0OR+K`KK%_*N6lN5#BNZtSjKD?60HgyD02u`=mjF!6QCd+- z1t>*m6`)i*4WEGfaXBncBhfo_5rh{ax3LG$SW+J07(PL2-DNLdQ z1j2}>=xu2=`NRt3lmdt(%8Cn15F6uGC=Du<292$wRbxiA8(ILXX#mN2h}0?}Koo#b zs0Ak4+N9GqF>D25)SGO9RT=>l&^>G*{2#sIee4P7AYVTyg7QL?9A{(b;HMDUO-acQ zppd0GIAMG~A;f^G2mwv4rNU8DXawgfpr-Pwh&*7BX<7l8QG}Hc2@nYom{dxovrR^$ zZMK6(#%!$$Q2+#WDu#p>VSrbrF&U~^XAQx@6;@+O14W31AebtG8c{HW0Wwqy6$(VJ zLmeAZC}gfg1k6z(Qy57=*-?@f4TXua8kja)YgvrdB!tG2mL)V3FlmvZw$ud7#L`8! zv`AG$1vDUSDH4OcfQ2G06Dtr60EGg?r3;MeLxoV0EgUlupc<)}fH%UL$!aYYY?R4r zH6&uA6&5Nj2xN?AFvB*)S}4`AZK;DKp%yVsf@%{76A&)nM%EsFQ&_oR)&>m-j*NLSNQ)ocxNN|-vU?fve zsu>`}IRdI}48W_Ql~h7u8Gvw+bfgXG_FW1Dy1_gYf#p~6J3jlchdNZ`2vQ{oxgZ=V zgg_<(r2+$~6$n8YNrpgWU_lh6DkV#1wV4TIjHc4fD3X;ViMB*UiaYiOLa5P5!25$0SYKUzz_P$fxWXRxe)=d5V;_XBpRI%xDbm3CXytRP-%q& zL^_2u1R^9r5im%u01)6xlq&`6WpQB&W>qUlP=NyaZ%>P|LTgx{2aw4jm{{;Fz|)gz zp%ud|&^~nuW4+V(%tF25;*LYD$XEJ?!I;3Y#%qhR$4p3&1!RD7Nq`IqK!PBF@FzDs zE}$E5WljXrL@IxzWLm(%l^(r=Kt~?44boYVVV%YT?X6WTH~28{xcBM2f>=nntF*!jkH)DtM5d6~?ZOy&fFJVfFV;18g$vkN`t z;JLEMfY|1TNzGODxHp@BcRBxnH+?L^TLdCXY@3k+BouS88jmRa@3-G`T%oc*Bl15( z#mndL7h%dfPEZIzBcnYCGzih_CcD86s2R4JanYh1Vnp^eq>~}Zcw++dPD%nF(t(sn z_Mvc^p8}v{mVlR>*HuiP0@sgIRJ=7CWyZ~z0q}7e7zAJ8!r;dmwFrTa)(_vtxMM)a z94a7rM~?cc8At{AVk^c|w;l6h9k<0AKr#>jX#$ed0}YE`h3fE}b%_{Y3T`=5;x2NZ#z zNG+&5TBVRUND1`%-`Fo)_W|-qqL@rs1%P;VY4+YYTJMi>NF{*XD_mtJ;d9d+-RE#4 zj)!^wPh-{0WALY_9lKOB&eXo6#LAx2OIGuj=`N{ho=~429XglYCGEw%Yh;YN^sec< z+#|kL?a72$6D~UB&f8#Gp95aBF(^sTdd-{TQV;42zpM8N=A&S%iqrqJ%IjFQw?!Dqx;WQe9XsMrv%|2}|HDvH)xk-C% zrfG*EHGvS42Tm3BR|SMAL=X@z2@g$(8n77D-A8dKSc_;?I$~L=)Qw=9gp-S#9Xt-v zG#fe4)z(*^WD@CBu`hp^|5zQ*2>>sx`P&OW}?z-p1uFz~I#! z$J5>oP(eSnx94HwMHANIBhYj`FgMjidI(p#=bMYa1?Gg&{GDx{MDA2OW%``UbpcT8 z+-0|r)0i}yQ2o_J*n}hkM+j5L^`B+96%yPTY1CqYn>q{#Bm_4k=h&;y5}Gb`=VP&f zh?z1#i{FXXJe>$Y#Atd06Il$MyNf{OpT?AUf zsuz_6iBP6Q3>m~?2ChyCjNN6v-8;7uBZ#F%+l`BFQP|RBByWr&jdC<4c4fw5_kVvL z3P34-jvd!@Rxv29=HkNO@Jp24@rUKca6ITi9KXdREq7f@8m2>iUGOV(aHTgXXTI1c zR)cv5YA3{nTs3s%!kV0%-Fsm#JzXMWm@OAk1QMCy?_Ec0a+=YRZ&+Of4be5+qj}=F z;WsRZrc8yzFx0A+MX|}RC@5>#-Q7tOxBbJj#m^rw=nYO2uxaeu#X;VV$Sws+A}MP* zPD&x5Ow>?1z|=Bu2upuK{rHzLv_#ns>sB<+hbAFZ#}Lz#p1qA?>JnTMEsn-=&F2|S zw7~FsrO-NnZ4feCiY4^gAv&$#y^xGlP*p>Qsm1p{1+xaF{81CCX^Ko&IML<|#t2?{ zIhGE5+0AN~@`I~>;krA(fWFK{L${<(7$(XmI;f9^0-?E_u2rF_E}F zu{bhhR5R9E*{)2eaHOS*92LB%($sRNG&E>4gNfMAB~fY!aA4$&i6BBqe6I%kQ#pxR z8j5#xYUie8xx=dskn+|KvWuilw1%c!q@h!^?l3m}AoF}ZO%Ga^>T;zAZRqip+77wM zhiV8&wcSNskT+J5Xd}6`y#V6L+3|Nji%OoJ2G2KM*3-Xgri%hiQICi=BEZ;4K!uJA zXW;JSdz?B0gn2nL;Q`b&NRWvrA_>`m3ToSqR^yA8O^urWqH5w=_+VjqRWJ#y&I~Rw zUZPCdsB0Rn3l^zY{a=hLQs^ZBkU|2&JDYpS-`xQfk&sw*5IXpC2lH5qm)~xEc%qe@ z4z$&X=}9ist!KwP66K@VW92`t{j-JD|huw4$zT0GJ*k?9EcC$lcffxl6ooghZ6vXWrF66Ho@z+!+H3qPQ#&s ze*7F6JE+Jg34_Xy4J)K31DZpYdD|E!`!LMiK#BfNs-BZ0g=P+f`(*Ksh6vN8vLmLTdA zg!Zs+AjA&>1Qe9AN;ar$nrkHuNC#8BK!He{AxB~v5SbR07G*`GL<$w86jG1@K}-k} zCK80kn>+CT*SYxr7wPyMzlV3??aBvpBvYQ>%=I*A4^bMQ{514qA!`-8vq`=e%}dI9 znECjdclWOR56joXL=g?g`o@K4Y_`~4@CGDp8Tlf#f)6X9b>7{+NB+O&{Y@G%#pCWU z<9Ew>DDvEvD5cZ{*R}jJJG!N=0oIu%(nuYdqK%IqED}HHR+jyrdKNC&vNhIwx*eGNnsNk6L3if*V?+2uZV)S zBUEFY`|LT~%ac6(1gTmJYPT&bMo)b>IuZGr-2S5t*>)z=n^rJVJmHl za1~$6l9$&X@p(nUBgx43FVI$$?dv^Hlqep0Dk7?jPkddc0q8AS=J_}Ab_^7@3mNEp z6E_IR`^7HXibtzIL-1eaME-1qi%S~0FLV1ai(B1qe>3mFcXIDG7Q5V3$T3-on897DV$)_SMhg=&uypw z-}HFguju>!|7-R1bM*O%^QGnbSxyFit6Qn!)ZG7ex@qm)OkG#%_jfu7BrmCt<*@@r zYa;tYJv|ShfexDLdOit-tmJtdokdMTi!surd`Ln`4ng^^x(~n^A*O$iE1rM@N5^NC z>j7#=#pq=@@h!I7ZMNHOw%c_jn(1;j`LUbMj7DbOJ=`uv?O}AY@>H3>L`u?pm z_5Wn&K0&tIZ!zp+wKKOf@HGyP)o)ft=IaaiwuCP;aU)@L=pMI^>dkl;+;W}%9|O*y zwo*a*~Wy%~}t;}4UEl2H~p8L=|ubYJ)Uv0(jXz{YTZ%S4|#k^W0 zsp4xikzsixexzsN)4Q_^+RJ`H^=i;{wxY!wA~c-KhfvIlM>RDi?y%W&2($4 zK7FN!uYv4hehu!AKRLT-Z#5jIr996?;QRPICBJ!4=A#9i&i6FI-SmV5AriYv7@}41 z^VdBx`bfW9@_KUq#Qta=tMv0v{r?C7@~HEVQ_tr87u4^w(CD{7vyG5iBO;qsr&_Ye zO=cP+Em-Cnb%Bx=U}PnYnzGfIWnqnwMpK&9V^L`}VPH_@47rT3+HFDwkc&X1K?o9{ zl0qR7^0->VXwv44q^j84Z3foHml4>9VGKiX5F*54#!8yE4a05~vEstlmkbMw=(UZL mbj5J_p8vu6A1~Ya!l3Jc3i`Pf9bZHL;_gVN3KA3>!`Gmg#}{P) diff --git a/man/metrics_quantile.Rd b/man/metrics_quantile.Rd index f17e06048..ea444ee7e 100644 --- a/man/metrics_quantile.Rd +++ b/man/metrics_quantile.Rd @@ -5,7 +5,7 @@ \alias{metrics_quantile} \title{Default metrics for quantile-based forecasts.} \format{ -An object of class \code{list} of length 8. +An object of class \code{list} of length 9. } \usage{ metrics_quantile From 7e635eb06e7f25b95726768c5311adaa0549d3b4 Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Sat, 11 Nov 2023 16:18:54 +0100 Subject: [PATCH 09/49] Correct an issue with `pit()` where this still relies on the computation of coverage_deviation per quantile as a metric --- R/pit.R | 15 +++------------ 1 file changed, 3 insertions(+), 12 deletions(-) diff --git a/R/pit.R b/R/pit.R index 2e00e4b90..ee5e09c7c 100644 --- a/R/pit.R +++ b/R/pit.R @@ -189,18 +189,10 @@ pit <- function(data, data <- remove_na_observed_predicted(data) forecast_type <- get_forecast_type(data) - # if prediction type is quantile, simply extract coverage values from - # score and returned a list with named vectors if (forecast_type == "quantile") { - coverage <- - score(data, metrics = "quantile_coverage") - - coverage <- summarise_scores(coverage, - by = unique(c(by, "quantile")) - ) - # remove all existing attributes and class - coverage <- remove_scoringutils_class(coverage) - + data[, quantile_coverage := (observed <= predicted)] + coverage <- data[, .(quantile_coverage = mean(quantile_coverage)), + by = c(unique(c(by, "quantile")))] coverage <- coverage[order(quantile), .( quantile = c(quantile, 1), @@ -208,7 +200,6 @@ pit <- function(data, ), by = c(get_forecast_unit(coverage)) ] - return(coverage[]) } From 77fcde492473bf235d0779658fd5db9d7a0072bd Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Sat, 11 Nov 2023 16:19:46 +0100 Subject: [PATCH 10/49] commit previously forgotten change in `metrics_quantile` --- inst/create-list-available-forecasts.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/inst/create-list-available-forecasts.R b/inst/create-list-available-forecasts.R index 2778a22c4..fcac2950c 100644 --- a/inst/create-list-available-forecasts.R +++ b/inst/create-list-available-forecasts.R @@ -30,6 +30,7 @@ metrics_quantile <- list( "bias" = bias_quantile, "coverage_50" = \(...) {run_safely(..., range = 50, fun = interval_coverage_quantile)}, "coverage_90" = \(...) {run_safely(..., range = 90, fun = interval_coverage_quantile)}, - "coverage_deviation" = interval_coverage_deviation_quantile + "coverage_deviation" = interval_coverage_deviation_quantile, + "ae_median" = ae_median_quantile ) usethis::use_data(metrics_quantile, overwrite = TRUE) From 295eb518aab76737d5681c99473159b075c74090 Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Sun, 12 Nov 2023 14:59:12 +0100 Subject: [PATCH 11/49] Fix issues with ae_median_sample(), ae_median_quantile() and se_mean_sample() --- R/metrics-quantile.R | 4 ++-- R/metrics-sample.R | 4 ++-- man/ae_median_quantile.Rd | 4 ++-- man/ae_median_sample.Rd | 2 +- man/se_mean_sample.Rd | 2 +- 5 files changed, 8 insertions(+), 8 deletions(-) diff --git a/R/metrics-quantile.R b/R/metrics-quantile.R index 2ee3a7aa0..a321b21bf 100644 --- a/R/metrics-quantile.R +++ b/R/metrics-quantile.R @@ -638,8 +638,8 @@ wis_one_to_one <- function(observed, #' @importFrom stats median #' @examples #' observed <- rnorm(30, mean = 1:30) -#' predicted_values <- rnorm(30, mean = 1:30) -#' ae_median_quantile(observed, predicted_values, quantiles = 0.5) +#' predicted_values <- matrix(rnorm(30, mean = 1:30)) +#' ae_median_quantile(observed, predicted_values, quantile = 0.5) #' @export #' @keywords metric ae_median_quantile <- function(observed, predicted, quantile) { diff --git a/R/metrics-sample.R b/R/metrics-sample.R index 96a3ee0ce..803fb4c4e 100644 --- a/R/metrics-sample.R +++ b/R/metrics-sample.R @@ -96,7 +96,7 @@ bias_sample <- function(observed, predicted) { #' @importFrom stats median #' @examples #' observed <- rnorm(30, mean = 1:30) -#' predicted_values <- rnorm(30, mean = 1:30) +#' predicted_values <- matrix(rnorm(30, mean = 1:30)) #' ae_median_sample(observed, predicted_values) #' @export #' @keywords metric @@ -130,7 +130,7 @@ ae_median_sample <- function(observed, predicted) { #' @seealso [squared_error()] #' @examples #' observed <- rnorm(30, mean = 1:30) -#' predicted_values <- rnorm(30, mean = 1:30) +#' predicted_values <- matrix(rnorm(30, mean = 1:30)) #' se_mean_sample(observed, predicted_values) #' @export #' @keywords metric diff --git a/man/ae_median_quantile.Rd b/man/ae_median_quantile.Rd index e85400121..d96965c7c 100644 --- a/man/ae_median_quantile.Rd +++ b/man/ae_median_quantile.Rd @@ -34,8 +34,8 @@ the function therefore requires 0.5 to be among the quantile levels in } \examples{ observed <- rnorm(30, mean = 1:30) -predicted_values <- rnorm(30, mean = 1:30) -ae_median_quantile(observed, predicted_values, quantiles = 0.5) +predicted_values <- matrix(rnorm(30, mean = 1:30)) +ae_median_quantile(observed, predicted_values, quantile = 0.5) } \seealso{ \code{\link[=ae_median_sample]{ae_median_sample()}}, \code{\link[=abs_error]{abs_error()}} diff --git a/man/ae_median_sample.Rd b/man/ae_median_sample.Rd index d446b3300..1e420fcc4 100644 --- a/man/ae_median_sample.Rd +++ b/man/ae_median_sample.Rd @@ -27,7 +27,7 @@ Absolute error of the median calculated as } \examples{ observed <- rnorm(30, mean = 1:30) -predicted_values <- rnorm(30, mean = 1:30) +predicted_values <- matrix(rnorm(30, mean = 1:30)) ae_median_sample(observed, predicted_values) } \seealso{ diff --git a/man/se_mean_sample.Rd b/man/se_mean_sample.Rd index 08a6d5d16..c2101d4df 100644 --- a/man/se_mean_sample.Rd +++ b/man/se_mean_sample.Rd @@ -28,7 +28,7 @@ The mean prediction is calculated as the mean of the predictive samples. } \examples{ observed <- rnorm(30, mean = 1:30) -predicted_values <- rnorm(30, mean = 1:30) +predicted_values <- matrix(rnorm(30, mean = 1:30)) se_mean_sample(observed, predicted_values) } \seealso{ From 88fcdce4efcd8d7fbc3571fc024ab7dcc3357b02 Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Sun, 12 Nov 2023 15:01:59 +0100 Subject: [PATCH 12/49] Change "interval_score" to "wis" as a metric name. Comment out code for now that cannot be run anymore. --- R/pairwise-comparisons.R | 6 +++--- R/plot.R | 32 ++++++++++++++-------------- R/summarise_scores.R | 2 +- man/add_coverage.Rd | 2 +- man/compare_two_models.Rd | 2 +- man/pairwise_comparison.Rd | 2 +- man/pairwise_comparison_one_group.Rd | 2 +- man/plot_interval_coverage.Rd | 8 +++---- man/plot_ranges.Rd | 16 +++++++------- 9 files changed, 36 insertions(+), 36 deletions(-) diff --git a/R/pairwise-comparisons.R b/R/pairwise-comparisons.R index f23316254..eab561adb 100644 --- a/R/pairwise-comparisons.R +++ b/R/pairwise-comparisons.R @@ -28,7 +28,7 @@ #' #' @param scores A data.table of scores as produced by [score()]. #' @param metric A character vector of length one with the metric to do the -#' comparison on. The default is "auto", meaning that either "interval_score", +#' comparison on. The default is "auto", meaning that either "wis", #' "crps", or "brier_score" will be selected where available. #' @param by character vector with names of columns present in the input #' data.frame. `by` determines how pairwise comparisons will be computed. @@ -366,8 +366,8 @@ compare_two_models <- function(scores, #' @keywords internal infer_rel_skill_metric <- function(scores) { - if ("interval_score" %in% colnames(scores)) { - rel_skill_metric <- "interval_score" + if ("wis" %in% colnames(scores)) { + rel_skill_metric <- "wis" } else if ("crps" %in% colnames(scores)) { rel_skill_metric <- "crps" } else if ("brier_score" %in% colnames(scores)) { diff --git a/R/plot.R b/R/plot.R index f90be0599..59f0f6eca 100644 --- a/R/plot.R +++ b/R/plot.R @@ -221,7 +221,7 @@ plot_wis <- function(scores, #' produced by [score()] or [summarise_scores()]. Note that "range" must be included #' in the `by` argument when running [summarise_scores()] #' @param y The variable from the scores you want to show on the y-Axis. -#' This could be something like "interval_score" (the default) or "dispersion" +#' This could be something like "wis" (the default) or "dispersion" #' @param x The variable from the scores you want to show on the x-Axis. #' Usually this will be "model" #' @param colour Character vector of length one used to determine a variable @@ -233,18 +233,18 @@ plot_wis <- function(scores, #' @export #' @examples #' library(ggplot2) -#' scores <- score(example_quantile) -#' scores <- summarise_scores(scores, by = c("model", "target_type", "range")) +#' # scores <- score(example_quantile) +#' # scores <- summarise_scores(scores, by = c("model", "target_type", "range")) #' -#' plot_ranges(scores, x = "model") + -#' facet_wrap(~target_type, scales = "free") +#' # plot_ranges(scores, x = "model") + +#' # facet_wrap(~target_type, scales = "free") #' #' # visualise dispersion instead of interval score -#' plot_ranges(scores, y = "dispersion", x = "model") + -#' facet_wrap(~target_type) +#' # plot_ranges(scores, y = "dispersion", x = "model") + +#' # facet_wrap(~target_type) plot_ranges <- function(scores, - y = "interval_score", + y = "wis", x = "model", colour = "range") { plot <- ggplot( @@ -296,7 +296,7 @@ plot_ranges <- function(scores, #' @export #' @examples #' scores <- score(example_quantile) -#' scores <- summarise_scores(scores, by = c("model", "target_type", "range")) +#' scores <- summarise_scores(scores, by = c("model", "target_type")) #' #' plot_heatmap(scores, x = "target_type", metric = "bias") @@ -582,10 +582,10 @@ make_na <- make_NA #' @importFrom data.table dcast #' @export #' @examples -#' data.table::setDTthreads(1) # only needed to avoid issues on CRAN -#' scores <- score(example_quantile) -#' scores <- summarise_scores(scores, by = c("model", "range")) -#' plot_interval_coverage(scores) +#' # data.table::setDTthreads(1) # only needed to avoid issues on CRAN +#' # scores <- score(example_quantile) +#' # scores <- summarise_scores(scores, by = c("model", "range")) +#' # plot_interval_coverage(scores) plot_interval_coverage <- function(scores, colour = "model") { @@ -638,9 +638,9 @@ plot_interval_coverage <- function(scores, #' @importFrom data.table dcast #' @export #' @examples -#' scores <- score(example_quantile) -#' scores <- summarise_scores(scores, by = c("model", "quantile")) -#' plot_quantile_coverage(scores) +#' # scores <- score(example_quantile) +#' # scores <- summarise_scores(scores, by = c("model", "quantile")) +#' # plot_quantile_coverage(scores) plot_quantile_coverage <- function(scores, colour = "model") { diff --git a/R/summarise_scores.R b/R/summarise_scores.R index e62bac789..40666b1f3 100644 --- a/R/summarise_scores.R +++ b/R/summarise_scores.R @@ -331,7 +331,7 @@ check_summary_params <- function(scores, #' @examples #' library(magrittr) # pipe operator #' score(example_quantile) %>% -#' add_coverage(by = c("model", "target_type")) %>% +#' # add_coverage(by = c("model", "target_type")) %>% #' summarise_scores(by = c("model", "target_type")) %>% #' summarise_scores(fun = signif, digits = 2) #' @export diff --git a/man/add_coverage.Rd b/man/add_coverage.Rd index 33990a3bc..507db1a4a 100644 --- a/man/add_coverage.Rd +++ b/man/add_coverage.Rd @@ -33,7 +33,7 @@ the unit of a single forecast. \examples{ library(magrittr) # pipe operator score(example_quantile) \%>\% - add_coverage(by = c("model", "target_type")) \%>\% + # add_coverage(by = c("model", "target_type")) \%>\% summarise_scores(by = c("model", "target_type")) \%>\% summarise_scores(fun = signif, digits = 2) } diff --git a/man/compare_two_models.Rd b/man/compare_two_models.Rd index 39780292e..1d4686a1c 100644 --- a/man/compare_two_models.Rd +++ b/man/compare_two_models.Rd @@ -22,7 +22,7 @@ compare_two_models( \item{name_model2}{character, name of the model to compare against} \item{metric}{A character vector of length one with the metric to do the -comparison on. The default is "auto", meaning that either "interval_score", +comparison on. The default is "auto", meaning that either "wis", "crps", or "brier_score" will be selected where available.} \item{one_sided}{Boolean, default is \code{FALSE}, whether two conduct a one-sided diff --git a/man/pairwise_comparison.Rd b/man/pairwise_comparison.Rd index 9288e77fb..d30be1197 100644 --- a/man/pairwise_comparison.Rd +++ b/man/pairwise_comparison.Rd @@ -25,7 +25,7 @@ splitting) and the pairwise comparisons will be computed separately for the split data.frames.} \item{metric}{A character vector of length one with the metric to do the -comparison on. The default is "auto", meaning that either "interval_score", +comparison on. The default is "auto", meaning that either "wis", "crps", or "brier_score" will be selected where available.} \item{baseline}{character vector of length one that denotes the baseline diff --git a/man/pairwise_comparison_one_group.Rd b/man/pairwise_comparison_one_group.Rd index a7d902f15..df59b1472 100644 --- a/man/pairwise_comparison_one_group.Rd +++ b/man/pairwise_comparison_one_group.Rd @@ -10,7 +10,7 @@ pairwise_comparison_one_group(scores, metric, baseline, by, ...) \item{scores}{A data.table of scores as produced by \code{\link[=score]{score()}}.} \item{metric}{A character vector of length one with the metric to do the -comparison on. The default is "auto", meaning that either "interval_score", +comparison on. The default is "auto", meaning that either "wis", "crps", or "brier_score" will be selected where available.} \item{baseline}{character vector of length one that denotes the baseline diff --git a/man/plot_interval_coverage.Rd b/man/plot_interval_coverage.Rd index 9c7da16fe..6c4c3e985 100644 --- a/man/plot_interval_coverage.Rd +++ b/man/plot_interval_coverage.Rd @@ -21,8 +21,8 @@ ggplot object with a plot of interval coverage Plot interval coverage } \examples{ -data.table::setDTthreads(1) # only needed to avoid issues on CRAN -scores <- score(example_quantile) -scores <- summarise_scores(scores, by = c("model", "range")) -plot_interval_coverage(scores) +# data.table::setDTthreads(1) # only needed to avoid issues on CRAN +# scores <- score(example_quantile) +# scores <- summarise_scores(scores, by = c("model", "range")) +# plot_interval_coverage(scores) } diff --git a/man/plot_ranges.Rd b/man/plot_ranges.Rd index a4a999ff2..27922b3c0 100644 --- a/man/plot_ranges.Rd +++ b/man/plot_ranges.Rd @@ -4,7 +4,7 @@ \alias{plot_ranges} \title{Plot Metrics by Range of the Prediction Interval} \usage{ -plot_ranges(scores, y = "interval_score", x = "model", colour = "range") +plot_ranges(scores, y = "wis", x = "model", colour = "range") } \arguments{ \item{scores}{A data.frame of scores based on quantile forecasts as @@ -12,7 +12,7 @@ produced by \code{\link[=score]{score()}} or \code{\link[=summarise_scores]{summ in the \code{by} argument when running \code{\link[=summarise_scores]{summarise_scores()}}} \item{y}{The variable from the scores you want to show on the y-Axis. -This could be something like "interval_score" (the default) or "dispersion"} +This could be something like "wis" (the default) or "dispersion"} \item{x}{The variable from the scores you want to show on the x-Axis. Usually this will be "model"} @@ -31,13 +31,13 @@ sharpness / dispersion changes by range. } \examples{ library(ggplot2) -scores <- score(example_quantile) -scores <- summarise_scores(scores, by = c("model", "target_type", "range")) +# scores <- score(example_quantile) +# scores <- summarise_scores(scores, by = c("model", "target_type", "range")) -plot_ranges(scores, x = "model") + - facet_wrap(~target_type, scales = "free") +# plot_ranges(scores, x = "model") + +# facet_wrap(~target_type, scales = "free") # visualise dispersion instead of interval score -plot_ranges(scores, y = "dispersion", x = "model") + - facet_wrap(~target_type) +# plot_ranges(scores, y = "dispersion", x = "model") + +# facet_wrap(~target_type) } From 337ea1f41ddf1a51193c1ecfac52d48d5a23f0ff Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Sun, 12 Nov 2023 15:03:42 +0100 Subject: [PATCH 13/49] Replace score.scoringutils_quantile() with new function --- NAMESPACE | 2 +- R/score.R | 4 ++-- R/score_quantile.R | 2 +- R/z_globalVariables.R | 1 + man/score.Rd | 6 +++--- 5 files changed, 8 insertions(+), 7 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 32259fd85..ba1aa11be 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -8,7 +8,7 @@ S3method(score,default) S3method(score,scoringutils_binary) S3method(score,scoringutils_point) S3method(score,scoringutils_quantile) -S3method(score,scoringutils_quantile_new) +S3method(score,scoringutils_quantile_old) S3method(score,scoringutils_sample) S3method(validate,default) S3method(validate,scoringutils_binary) diff --git a/R/score.R b/R/score.R index 3d1dc7f07..fb82f6568 100644 --- a/R/score.R +++ b/R/score.R @@ -233,7 +233,7 @@ score.scoringutils_sample <- function(data, metrics = metrics_sample, ...) { #' @rdname score #' @export -score.scoringutils_quantile <- function(data, metrics = NULL, ...) { +score.scoringutils_quantile_old <- function(data, metrics = NULL, ...) { data <- validate(data) data <- remove_na_observed_predicted(data) forecast_unit <- attr(data, "forecast_unit") @@ -261,7 +261,7 @@ score.scoringutils_quantile <- function(data, metrics = NULL, ...) { #' @rdname score #' @export -score.scoringutils_quantile_new <- function(data, metrics = metrics_quantile, ...) { +score.scoringutils_quantile <- function(data, metrics = metrics_quantile, ...) { data <- validate(data) data <- remove_na_observed_predicted(data) forecast_unit <- attr(data, "forecast_unit") diff --git a/R/score_quantile.R b/R/score_quantile.R index f2da97f04..e0a3fb11c 100644 --- a/R/score_quantile.R +++ b/R/score_quantile.R @@ -113,7 +113,7 @@ score_quantile <- function(data, # compute absolute error of the median if ("ae_median" %in% metrics) { quantile_data[, ae_median := ae_median_quantile( - observed, + unique(observed), predicted, quantile ), diff --git a/R/z_globalVariables.R b/R/z_globalVariables.R index b81fb3452..441501932 100644 --- a/R/z_globalVariables.R +++ b/R/z_globalVariables.R @@ -72,6 +72,7 @@ globalVariables(c( "var_of_interest", "variable", "weight", + "wis", "wis_component_name", "x", "y", diff --git a/man/score.Rd b/man/score.Rd index 5cf7a1b14..9ae7ebf37 100644 --- a/man/score.Rd +++ b/man/score.Rd @@ -6,8 +6,8 @@ \alias{score.scoringutils_binary} \alias{score.scoringutils_point} \alias{score.scoringutils_sample} +\alias{score.scoringutils_quantile_old} \alias{score.scoringutils_quantile} -\alias{score.scoringutils_quantile_new} \title{Evaluate forecasts in a data.frame format} \usage{ score(data, ...) @@ -20,9 +20,9 @@ score(data, ...) \method{score}{scoringutils_sample}(data, metrics = metrics_sample, ...) -\method{score}{scoringutils_quantile}(data, metrics = NULL, ...) +\method{score}{scoringutils_quantile_old}(data, metrics = NULL, ...) -\method{score}{scoringutils_quantile_new}(data, metrics = metrics_quantile, ...) +\method{score}{scoringutils_quantile}(data, metrics = metrics_quantile, ...) } \arguments{ \item{data}{A data.frame or data.table with predicted and observed values.} From 7e6dbe8b14f061ac256f606b66655bb6d03b0dc0 Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Sun, 12 Nov 2023 15:04:57 +0100 Subject: [PATCH 14/49] update available_metrics() to include wis and coverage_ values (this is temporary) --- R/utils.R | 3 ++- man/plot_heatmap.Rd | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/R/utils.R b/R/utils.R index 3de1a9eb8..0d160065e 100644 --- a/R/utils.R +++ b/R/utils.R @@ -5,7 +5,8 @@ #' @keywords info available_metrics <- function() { - return(unique(scoringutils::metrics$Name)) + return(unique(c(scoringutils::metrics$Name, + "wis", "coverage_50", "coverage_90"))) } diff --git a/man/plot_heatmap.Rd b/man/plot_heatmap.Rd index 8b1aac549..837ef4243 100644 --- a/man/plot_heatmap.Rd +++ b/man/plot_heatmap.Rd @@ -29,7 +29,7 @@ different locations. } \examples{ scores <- score(example_quantile) -scores <- summarise_scores(scores, by = c("model", "target_type", "range")) +scores <- summarise_scores(scores, by = c("model", "target_type")) plot_heatmap(scores, x = "target_type", metric = "bias") } From 08dab31028a5383a2510086d261a24312189a10f Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Sun, 12 Nov 2023 15:05:25 +0100 Subject: [PATCH 15/49] Update vignette to update / comment out code that cannot be run anymore --- vignettes/scoringutils.Rmd | 21 ++++++++++----------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/vignettes/scoringutils.Rmd b/vignettes/scoringutils.Rmd index 6b55c25b5..6411fad70 100644 --- a/vignettes/scoringutils.Rmd +++ b/vignettes/scoringutils.Rmd @@ -223,7 +223,6 @@ For quantile-based forecasts we are often interested in specific coverage-levels ```{r} score(example_quantile) %>% - add_coverage(ranges = c(50, 90), by = c("model", "target_type")) %>% summarise_scores(by = c("model", "target_type")) %>% summarise_scores(fun = signif, digits = 2) ``` @@ -304,20 +303,20 @@ example_quantile[quantile %in% seq(0.1, 0.9, 0.1), ] %>% facet_grid(model ~ target_type) ``` -Another way to look at calibration are interval coverage and quantile coverage. Interval coverage is the percentage of true values that fall inside a given central prediction interval. Quantile coverage is the percentage of observed values that fall below a given quantile level. + -In order to plot interval coverage, you need to include "range" in the `by` argument to `summarise_scores()`. The green area on the plot marks conservative behaviour, i.e. your empirical coverage is greater than it nominally need be (e.g. 55% of true values covered by all 50% central prediction intervals.) + -```{r} +```{r, eval=FALSE, include=FALSE} example_quantile %>% score() %>% summarise_scores(by = c("model", "range")) %>% plot_interval_coverage() ``` -To visualise quantile coverage, you need to include "quantile" in `by`. Again, the green area corresponds to conservative forecasts, where central prediction intervals would cover more than needed. + -```{r} +```{r, eval=FALSE, include=FALSE} example_quantile %>% score() %>% summarise_scores(by = c("model", "quantile")) %>% @@ -377,11 +376,11 @@ example_quantile %>% plot_correlation() ``` -### Scores by interval ranges + -If you would like to see how different forecast interval ranges contribute to average scores, you can visualise scores by interval range: + -```{r} +```{r, eval = FALSE, include = FALSE} example_quantile %>% score() %>% summarise_scores(by = c("model", "range", "target_type")) %>% @@ -400,8 +399,8 @@ example_integer %>% sample_to_quantile( quantiles = c(0.01, 0.025, seq(0.05, 0.95, 0.05), 0.975, 0.99) ) %>% - score() %>% - add_coverage(by = c("model", "target_type")) + score() # %>% + # add_coverage(by = c("model", "target_type")) ``` ## Available metrics From f4d5d43286e52c444f313648e23a12870ea29d42 Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Sun, 12 Nov 2023 15:08:29 +0100 Subject: [PATCH 16/49] Fix test for ae_median_sample() --- tests/testthat/test-absolute_error.R | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/tests/testthat/test-absolute_error.R b/tests/testthat/test-absolute_error.R index f61493b25..118a182d8 100644 --- a/tests/testthat/test-absolute_error.R +++ b/tests/testthat/test-absolute_error.R @@ -1,9 +1,7 @@ -test_that("absolute error (sample based) works", { +test_that("ae_median_sample works", { observed <- rnorm(30, mean = 1:30) predicted_values <- rnorm(30, mean = 1:30) - - scoringutils <- ae_median_sample(observed, predicted_values) - + scoringutils <- ae_median_sample(observed, matrix(predicted_values)) ae <- abs(observed - predicted_values) expect_equal(ae, scoringutils) }) From 9607615aed28edd6834f1e354fc9ac0239bba967 Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Sun, 12 Nov 2023 16:14:57 +0100 Subject: [PATCH 17/49] Update tests --- .../plot_correlation/plot-correlation.svg | 218 +++++++++++------- .../_snaps/plot_heatmap/plot-heatmap.svg | 162 +------------ .../plot-pairwise-comparison-pval.svg | 8 +- .../plot-pairwise-comparison.svg | 8 +- .../plot_score_table/plot-score-table.svg | 158 +++++++------ .../_snaps/plot_wis/plot-wis-flip.svg | 12 +- .../_snaps/plot_wis/plot-wis-no-relative.svg | 12 +- tests/testthat/_snaps/plot_wis/plot-wis.svg | 12 +- tests/testthat/test-interval_score.R | 50 ++-- tests/testthat/test-pairwise_comparison.R | 6 +- tests/testthat/test-plot_heatmap.R | 4 +- tests/testthat/test-score.R | 26 +-- tests/testthat/test-summarise_scores.R | 2 - 13 files changed, 292 insertions(+), 386 deletions(-) diff --git a/tests/testthat/_snaps/plot_correlation/plot-correlation.svg b/tests/testthat/_snaps/plot_correlation/plot-correlation.svg index f56619980..a33e8a207 100644 --- a/tests/testthat/_snaps/plot_correlation/plot-correlation.svg +++ b/tests/testthat/_snaps/plot_correlation/plot-correlation.svg @@ -25,104 +25,146 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - -1 -0.46 -1 -0.28 -0.15 -1 -0.94 -0.32 --0.03 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +1 +0.94 +1 +0.28 +-0.03 +1 +0.46 +0.32 +0.15 +1 +0.11 +0.22 +-0.35 +0.11 1 --0.34 --0.12 --0.33 --0.25 -1 -0.11 -0.11 --0.35 -0.22 -0.06 -1 -0.99 -0.54 -0.34 -0.9 --0.38 -0.1 -1 +-0.21 +-0.15 +-0.21 +-0.09 +0.01 +1 +-0.41 +-0.32 +-0.36 +-0.09 +0.1 +0.37 +1 +-0.34 +-0.25 +-0.33 +-0.12 +0.06 +0.85 +0.64 +1 +0.99 +0.9 +0.34 +0.54 +0.1 +-0.25 +-0.41 +-0.38 +1 -interval_score -dispersion -underprediction -overprediction -coverage_deviation -bias -ae_median - - - +wis +overprediction +underprediction +dispersion +bias +coverage_50 +coverage_90 +coverage_deviation +ae_median + + + + - - - + + + + - - - + + + + - - - -ae_median -bias -coverage_deviation -overprediction -underprediction -dispersion -interval_score - -0.0 -0.5 + + + + +ae_median +coverage_deviation +coverage_90 +coverage_50 +bias +dispersion +underprediction +overprediction +wis + +0.0 +0.5 1.0 Correlation - - + + - - + + plot__correlation diff --git a/tests/testthat/_snaps/plot_heatmap/plot-heatmap.svg b/tests/testthat/_snaps/plot_heatmap/plot-heatmap.svg index 528aefb09..8c4222d9a 100644 --- a/tests/testthat/_snaps/plot_heatmap/plot-heatmap.svg +++ b/tests/testthat/_snaps/plot_heatmap/plot-heatmap.svg @@ -25,174 +25,20 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + - - - - - - - - - - - -0.1 -0.1 -0.1 -0.1 -0.1 -0.1 -0.1 -0.1 -0.1 -0.1 -0.1 -0.1 --0.06 --0.06 --0.06 --0.06 --0.06 --0.06 --0.06 --0.06 --0.06 -0.06 --0.06 --0.06 --0.08 --0.08 --0.08 --0.08 --0.08 --0.08 --0.08 --0.08 --0.08 --0.08 --0.08 +0.1 -0.08 -0.34 -0.34 -0.34 -0.34 -0.34 -0.34 -0.34 -0.34 -0.34 -0.34 -0.34 -0.34 -0.07 -0.07 -0.07 -0.07 0.07 -0.07 -0.07 -0.07 -0.07 -0.07 -0.07 -0.07 --0.02 --0.02 --0.02 --0.02 --0.02 --0.02 --0.02 --0.02 --0.02 --0.02 --0.02 +0.34 -0.02 -0.01 --0.01 --0.01 --0.01 --0.01 --0.01 --0.01 --0.01 --0.01 --0.01 --0.01 --0.01 diff --git a/tests/testthat/_snaps/plot_pairwise_comparison/plot-pairwise-comparison-pval.svg b/tests/testthat/_snaps/plot_pairwise_comparison/plot-pairwise-comparison-pval.svg index 22e2408dc..458487011 100644 --- a/tests/testthat/_snaps/plot_pairwise_comparison/plot-pairwise-comparison-pval.svg +++ b/tests/testthat/_snaps/plot_pairwise_comparison/plot-pairwise-comparison-pval.svg @@ -28,8 +28,8 @@ - + @@ -37,8 +37,8 @@ < 0.001 < 0.001 1 -0.298 < 0.001 +0.298 1 0.298 < 0.001 @@ -56,9 +56,9 @@ + - @@ -72,9 +72,9 @@ < 0.001 < 0.001 1 +< 0.001 < 0.001 < 0.001 -< 0.001 1 0.007 < 0.001 diff --git a/tests/testthat/_snaps/plot_pairwise_comparison/plot-pairwise-comparison.svg b/tests/testthat/_snaps/plot_pairwise_comparison/plot-pairwise-comparison.svg index 1ff397cfe..3a7599da4 100644 --- a/tests/testthat/_snaps/plot_pairwise_comparison/plot-pairwise-comparison.svg +++ b/tests/testthat/_snaps/plot_pairwise_comparison/plot-pairwise-comparison.svg @@ -28,8 +28,8 @@ - + @@ -37,8 +37,8 @@ 1.37 1.59 1 -0.86 0.63 +0.86 1 1.16 0.73 @@ -56,9 +56,9 @@ + - @@ -72,9 +72,9 @@ 3.03 3.85 1 +0.26 0.62 0.79 -0.26 1 0.74 1.27 diff --git a/tests/testthat/_snaps/plot_score_table/plot-score-table.svg b/tests/testthat/_snaps/plot_score_table/plot-score-table.svg index 95f9fe247..25b15d296 100644 --- a/tests/testthat/_snaps/plot_score_table/plot-score-table.svg +++ b/tests/testthat/_snaps/plot_score_table/plot-score-table.svg @@ -25,62 +25,78 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - -10000 -9000 -50 -10000 -2000 -2000 -30 -3000 -5000 -2000 -20 -2000 -7000 -5000 -9 -6000 -0.002 -0.05 --0.02 --0.06 -0.2 -0.008 --0.02 --0.04 -20000 -10000 -80 -10000 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +9000 +10000 +10000 +50 +5000 +7000 +6000 +9 +2000 +5000 +2000 +20 +2000 +2000 +3000 +30 +0.008 +0.2 +-0.04 +-0.02 +0.6 +0.5 +0.4 +0.5 +0.9 +0.9 +0.8 +0.9 +0.05 +0.002 +-0.06 +-0.02 +10000 +20000 +10000 +80 @@ -93,20 +109,24 @@ - - - + + + + - - - -interval_score -dispersion -underprediction -overprediction -coverage_deviation -bias -ae_median + + + + +wis +overprediction +underprediction +dispersion +bias +coverage_50 +coverage_90 +coverage_deviation +ae_median plot_score_table diff --git a/tests/testthat/_snaps/plot_wis/plot-wis-flip.svg b/tests/testthat/_snaps/plot_wis/plot-wis-flip.svg index 758a3c147..c315cf06d 100644 --- a/tests/testthat/_snaps/plot_wis/plot-wis-flip.svg +++ b/tests/testthat/_snaps/plot_wis/plot-wis-flip.svg @@ -25,14 +25,14 @@ - + - + - + @@ -43,16 +43,16 @@ - + - + - + diff --git a/tests/testthat/_snaps/plot_wis/plot-wis-no-relative.svg b/tests/testthat/_snaps/plot_wis/plot-wis-no-relative.svg index 987072ca4..fea309214 100644 --- a/tests/testthat/_snaps/plot_wis/plot-wis-no-relative.svg +++ b/tests/testthat/_snaps/plot_wis/plot-wis-no-relative.svg @@ -25,14 +25,14 @@ - + - + - + @@ -43,16 +43,16 @@ - + - + - + diff --git a/tests/testthat/_snaps/plot_wis/plot-wis.svg b/tests/testthat/_snaps/plot_wis/plot-wis.svg index 5328b4779..a2bdf8653 100644 --- a/tests/testthat/_snaps/plot_wis/plot-wis.svg +++ b/tests/testthat/_snaps/plot_wis/plot-wis.svg @@ -25,14 +25,14 @@ - + - + - + @@ -43,16 +43,16 @@ - + - + - + diff --git a/tests/testthat/test-interval_score.R b/tests/testthat/test-interval_score.R index 2a75c6fdb..04e0807a5 100644 --- a/tests/testthat/test-interval_score.R +++ b/tests/testthat/test-interval_score.R @@ -1,3 +1,6 @@ +metrics_no_cov <- metrics_quantile[!grepl("coverage", names(metrics_quantile))] +metrics_no_cov_no_ae <- metrics_no_cov[!grepl("ae", names(metrics_no_cov))] + test_that("wis works, median only", { y <- c(1, -15, 22) lower <- upper <- predicted_quantile <- c(1, 2, 3) @@ -28,10 +31,11 @@ test_that("WIS works within score for median forecast", { model = "model1", date = 1:3 ) - eval <- scoringutils::score(test_data, - count_median_twice = TRUE + eval <- score( + test_data, + count_median_twice = TRUE, metrics = metrics_no_cov ) - expect_equal(eval$ae_median, eval$interval_score) + expect_equal(eval$ae_median, eval$wis) }) test_that("wis works, 1 interval only", { @@ -70,8 +74,9 @@ test_that("WIS works within score for one interval", { date = rep(1:3, times = 2) ) - eval <- suppressMessages(scoringutils::score(test_data, - count_median_twice = TRUE + eval <- suppressMessages(score( + test_data, + count_median_twice = TRUE, metrics = metrics_no_cov_no_ae )) eval <- summarise_scores(eval, by = c("model", "date")) @@ -82,7 +87,7 @@ test_that("WIS works within score for one interval", { expected <- (upper - lower) * (alpha / 2) + c(0, 1 - (-15), 22 - 3) - expect_equal(expected, eval$interval_score) + expect_equal(expected, eval$wis) }) test_that("wis works, 1 interval and median", { @@ -94,8 +99,9 @@ test_that("wis works, 1 interval and median", { date = rep(1:3, times = 3) ) - eval <- scoringutils::score(test_data, - count_median_twice = TRUE + eval <- score( + test_data, + count_median_twice = TRUE, metrics = metrics_no_cov ) eval <- summarise_scores(eval, by = c("model", "date")) @@ -117,7 +123,7 @@ test_that("wis works, 1 interval and median", { count_median_twice = TRUE ) - expect_identical(eval$interval_score, expected) + expect_identical(eval$wis, expected) expect_identical(actual_wis, expected) }) @@ -142,8 +148,9 @@ test_that("wis works, 2 intervals and median", { date = rep(1:3, times = 5) ) - eval <- scoringutils::score(test_data, - count_median_twice = TRUE + eval <- score( + test_data, + count_median_twice = TRUE, metrics = metrics_no_cov ) eval <- summarise_scores(eval, by = c("model", "date")) @@ -168,7 +175,7 @@ test_that("wis works, 2 intervals and median", { ) expect_equal( - as.numeric(eval$interval_score), + as.numeric(eval$wis), as.numeric(expected) ) expect_identical(actual_wis, expected) @@ -228,8 +235,9 @@ test_that("wis is correct, median only - test corresponds to covidHubUtils", { data_formatted <- merge(forecasts_formated, truth_formatted) - eval <- scoringutils::score(data_formatted, - count_median_twice = FALSE + eval <- score( + data_formatted, + count_median_twice = FALSE, metrics = metrics_no_cov ) expected <- abs(y - forecast_quantiles_matrix[, 1]) @@ -241,7 +249,7 @@ test_that("wis is correct, median only - test corresponds to covidHubUtils", { count_median_twice = FALSE ) - expect_equal(eval$interval_score, expected) + expect_equal(eval$wis, expected) expect_equal(actual_wis, expected) }) @@ -299,8 +307,8 @@ test_that("wis is correct, 1 interval only - test corresponds to covidHubUtils", data_formatted <- merge(forecasts_formated, truth_formatted) - eval <- suppressMessages(scoringutils::score(data_formatted, - count_median_twice = FALSE + eval <- suppressMessages(score(data_formatted, + count_median_twice = FALSE, metrics = metrics_no_cov_no_ae )) eval <- summarise_scores(eval, @@ -321,7 +329,7 @@ test_that("wis is correct, 1 interval only - test corresponds to covidHubUtils", count_median_twice = FALSE ) - expect_equal(eval$interval_score, expected) + expect_equal(eval$wis, expected) expect_equal(actual_wis, expected) }) @@ -376,8 +384,8 @@ test_that("wis is correct, 2 intervals and median - test corresponds to covidHub data_formatted <- merge(forecasts_formated, truth_formatted) - eval <- scoringutils::score(data_formatted, - count_median_twice = FALSE + eval <- score(data_formatted, + count_median_twice = FALSE, metrics = metrics_no_cov ) eval <- summarise_scores(eval, @@ -402,7 +410,7 @@ test_that("wis is correct, 2 intervals and median - test corresponds to covidHub count_median_twice = FALSE ) - expect_equal(eval$interval_score, expected) + expect_equal(eval$wis, expected) }) test_that("Quantlie score and interval score yield the same result, weigh = FALSE", { diff --git a/tests/testthat/test-pairwise_comparison.R b/tests/testthat/test-pairwise_comparison.R index 3d0120adb..74275a06a 100644 --- a/tests/testthat/test-pairwise_comparison.R +++ b/tests/testthat/test-pairwise_comparison.R @@ -53,7 +53,7 @@ test_that("pairwise_comparison() works", { ) # evaluate the toy forecasts, once with and once without a baseline model specified - eval <- suppressMessages(score(data_formatted)) + eval <- score(data_formatted) # check with relative skills eval_without_rel_skill <- summarise_scores( @@ -85,7 +85,7 @@ test_that("pairwise_comparison() works", { # prepare scores for the code Johannes Bracher wrote scores_johannes <- data.table::copy(eval_without_baseline) # doesn't matter which one data.table::setnames(scores_johannes, - old = c("location", "target_end_date", "interval_score"), + old = c("location", "target_end_date", "wis"), new = c("unit", "timezero", "wis") ) @@ -238,7 +238,7 @@ test_that("pairwise_comparison() works", { model = rep(c("model1", "model2", "model3"), each = 10), date = as.Date("2020-01-01") + rep(1:5, each = 2), location = c(1, 2), - interval_score = (abs(rnorm(30))), + wis = (abs(rnorm(30))), ae_median = (abs(rnorm(30))) ) diff --git a/tests/testthat/test-plot_heatmap.R b/tests/testthat/test-plot_heatmap.R index 9118ff21f..d6453bd45 100644 --- a/tests/testthat/test-plot_heatmap.R +++ b/tests/testthat/test-plot_heatmap.R @@ -1,9 +1,7 @@ library(ggplot2, quietly = TRUE) test_that("plot_heatmap() works as expected", { - scores <- suppressMessages( - summarise_scores(scores_quantile, by = c("model", "target_type", "range")) - ) + scores <- summarise_scores(scores_quantile, by = c("model", "target_type")) p <- plot_heatmap(scores, x = "target_type", metric = "bias") expect_s3_class(p, "ggplot") skip_on_cran() diff --git a/tests/testthat/test-score.R b/tests/testthat/test-score.R index 9b4040723..6252c12c8 100644 --- a/tests/testthat/test-score.R +++ b/tests/testthat/test-score.R @@ -1,3 +1,6 @@ +metrics_no_cov <- metrics_quantile[!grepl("coverage", names(metrics_quantile))] +metrics_no_cov_no_ae <- metrics_no_cov[!grepl("ae", names(metrics_no_cov))] + # common error handling -------------------------------------------------------- test_that("function throws an error if data is missing", { expect_error(suppressMessages(score(data = NULL))) @@ -191,10 +194,12 @@ test_that("score() quantile produces desired metrics", { quantile = rep(c(0.1, 0.9), times = 10) ) - out <- suppressMessages(score(data = data)) + out <- suppressWarnings(suppressMessages( + score(data = data, metrics = metrics_no_cov)) + ) metric_names <- c( "dispersion", "underprediction", "overprediction", - "bias", "ae_median", "coverage_deviation" + "bias", "ae_median" ) expect_true(all(metric_names %in% colnames(out))) @@ -227,27 +232,16 @@ test_that("all quantile and range formats yield the same result", { expect_equal(sort(eval1$ae_median), sort(ae)) }) -test_that("function produces output even if only some metrics are chosen", { - example <- scoringutils::example_quantile - - eval <- suppressMessages(score(example, metrics = "coverage")) - - expect_equal( - nrow(eval) > 1, - TRUE - ) -}) - test_that("WIS is the same with other metrics omitted or included", { eval <- suppressMessages(score(example_quantile, - metrics = "interval_score" + metrics = list("wis" = wis) )) eval2 <- scores_quantile expect_equal( - sum(eval$interval_score), - sum(eval2$interval_score) + sum(eval$wis), + sum(eval2$wis) ) }) diff --git a/tests/testthat/test-summarise_scores.R b/tests/testthat/test-summarise_scores.R index dc3de70e3..dbd2cde4b 100644 --- a/tests/testthat/test-summarise_scores.R +++ b/tests/testthat/test-summarise_scores.R @@ -1,6 +1,4 @@ test_that("summarise_scores() works without any arguments", { - expect_true("quantile" %in% names(scores_quantile)) - summarised_scores <- summarise_scores(scores_quantile) expect_false("quantile" %in% names(summarised_scores)) From c214adec4e8f0ac7c083c20746bd7222bca3c5a7 Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Sun, 12 Nov 2023 16:21:27 +0100 Subject: [PATCH 18/49] comment out / delete failing tests related to ranges in the output of score() --- man/plot_quantile_coverage.Rd | 6 +- tests/testthat/test-add_coverage.R | 62 ++++++++++---------- tests/testthat/test-plot_interval_coverage.R | 17 +++--- tests/testthat/test-plot_quantile_coverage.R | 18 +++--- tests/testthat/test-plot_ranges.R | 38 ++++++------ tests/testthat/test-plot_score_table.R | 1 - 6 files changed, 70 insertions(+), 72 deletions(-) diff --git a/man/plot_quantile_coverage.Rd b/man/plot_quantile_coverage.Rd index 2e6ef489e..c479fb5e3 100644 --- a/man/plot_quantile_coverage.Rd +++ b/man/plot_quantile_coverage.Rd @@ -21,7 +21,7 @@ ggplot object with a plot of interval coverage Plot quantile coverage } \examples{ -scores <- score(example_quantile) -scores <- summarise_scores(scores, by = c("model", "quantile")) -plot_quantile_coverage(scores) +# scores <- score(example_quantile) +# scores <- summarise_scores(scores, by = c("model", "quantile")) +# plot_quantile_coverage(scores) } diff --git a/tests/testthat/test-add_coverage.R b/tests/testthat/test-add_coverage.R index fab1e72a1..50d97e81a 100644 --- a/tests/testthat/test-add_coverage.R +++ b/tests/testthat/test-add_coverage.R @@ -1,31 +1,31 @@ -ex_coverage <- scores_quantile[model == "EuroCOVIDhub-ensemble"] - -test_that("add_coverage() works as expected", { - expect_error( - add_coverage(ex_coverage, by = c("model", "target_type"), range = c()) - ) - expect_error( - add_coverage(ex_coverage, by = c("model", "target_type")), NA - ) - cov <- add_coverage( - scores_quantile, by = c("model", "target_type"), range = c(10, 20) - ) - expect_equal( - grep("coverage_", colnames(cov), value = TRUE), - c("coverage_deviation", "coverage_10", "coverage_20") - ) -}) - - -test_that("Order of `add_coverage()` and `summarise_scores()` doesn't matter", { - # Need to update test. Turns out the order does matter... - # see https://github.com/epiforecasts/scoringutils/issues/367 - pw1 <- add_coverage(ex_coverage, by = "model") - pw1_sum <- summarise_scores(pw1, by = "model") - - pw2 <- summarise_scores(ex_coverage, by = "model") - pw2 <- add_coverage(pw2) - - # expect_true(all(pw1_sum == pw2, na.rm = TRUE)) - # expect_true(all(names(attributes(pw2)) == names(attributes(pw1_sum)))) -}) +# ex_coverage <- scores_quantile[model == "EuroCOVIDhub-ensemble"] +# +# test_that("add_coverage() works as expected", { +# expect_error( +# add_coverage(ex_coverage, by = c("model", "target_type"), range = c()) +# ) +# expect_error( +# add_coverage(ex_coverage, by = c("model", "target_type")), NA +# ) +# cov <- add_coverage( +# scores_quantile, by = c("model", "target_type"), range = c(10, 20) +# ) +# expect_equal( +# grep("coverage_", colnames(cov), value = TRUE), +# c("coverage_deviation", "coverage_10", "coverage_20") +# ) +# }) +# +# +# test_that("Order of `add_coverage()` and `summarise_scores()` doesn't matter", { +# # Need to update test. Turns out the order does matter... +# # see https://github.com/epiforecasts/scoringutils/issues/367 +# pw1 <- add_coverage(ex_coverage, by = "model") +# pw1_sum <- summarise_scores(pw1, by = "model") +# +# pw2 <- summarise_scores(ex_coverage, by = "model") +# pw2 <- add_coverage(pw2) +# +# # expect_true(all(pw1_sum == pw2, na.rm = TRUE)) +# # expect_true(all(names(attributes(pw2)) == names(attributes(pw1_sum)))) +# }) diff --git a/tests/testthat/test-plot_interval_coverage.R b/tests/testthat/test-plot_interval_coverage.R index 04f203b03..49649e090 100644 --- a/tests/testthat/test-plot_interval_coverage.R +++ b/tests/testthat/test-plot_interval_coverage.R @@ -1,11 +1,10 @@ library(ggplot2, quietly = TRUE) -test_that("plot_interval_coverage() works as expected", { - scores <- suppressMessages( - summarise_scores(scores_quantile, by = c("model", "range")) - ) - p <- plot_interval_coverage(scores) - expect_s3_class(p, "ggplot") - skip_on_cran() - vdiffr::expect_doppelganger("plot_interval_coverage", p) -}) +# test_that("plot_interval_coverage() works as expected", { +# scores <- +# summarise_scores(scores_quantile, by = c("model", "range")) +# p <- plot_interval_coverage(scores) +# expect_s3_class(p, "ggplot") +# skip_on_cran() +# vdiffr::expect_doppelganger("plot_interval_coverage", p) +# }) diff --git a/tests/testthat/test-plot_quantile_coverage.R b/tests/testthat/test-plot_quantile_coverage.R index 6c3593c04..84b91157f 100644 --- a/tests/testthat/test-plot_quantile_coverage.R +++ b/tests/testthat/test-plot_quantile_coverage.R @@ -1,9 +1,9 @@ -test_that("plot_quantile_coverage() works as expected", { - scores <- suppressMessages( - summarise_scores(scores_quantile, by = c("model", "quantile")) - ) - p <- plot_quantile_coverage(scores) - expect_s3_class(p, "ggplot") - skip_on_cran() - vdiffr::expect_doppelganger("plot_quantile_coverage", p) -}) +# test_that("plot_quantile_coverage() works as expected", { +# scores <- suppressMessages( +# summarise_scores(scores_quantile, by = c("model", "quantile")) +# ) +# p <- plot_quantile_coverage(scores) +# expect_s3_class(p, "ggplot") +# skip_on_cran() +# vdiffr::expect_doppelganger("plot_quantile_coverage", p) +# }) diff --git a/tests/testthat/test-plot_ranges.R b/tests/testthat/test-plot_ranges.R index e9ae5575b..fad3c8095 100644 --- a/tests/testthat/test-plot_ranges.R +++ b/tests/testthat/test-plot_ranges.R @@ -1,19 +1,19 @@ -sum_scores <- suppressMessages( - summarise_scores(scores_quantile, by = c("model", "target_type", "range")) -) - -test_that("plot_ranges() works as expected with interval score", { - p <- plot_ranges(sum_scores, x = "model") + - facet_wrap(~target_type, scales = "free") - expect_s3_class(p, "ggplot") - skip_on_cran() - vdiffr::expect_doppelganger("plot_ranges_interval", p) -}) - -test_that("plot_ranges() works as expected with dispersion", { - p <- plot_ranges(sum_scores, y = "dispersion", x = "model") + - facet_wrap(~target_type) - expect_s3_class(p, "ggplot") - skip_on_cran() - vdiffr::expect_doppelganger("plot_ranges_dispersion", p) -}) +# sum_scores <- suppressMessages( +# summarise_scores(scores_quantile, by = c("model", "target_type", "range")) +# ) +# +# test_that("plot_ranges() works as expected with interval score", { +# p <- plot_ranges(sum_scores, x = "model") + +# facet_wrap(~target_type, scales = "free") +# expect_s3_class(p, "ggplot") +# skip_on_cran() +# vdiffr::expect_doppelganger("plot_ranges_interval", p) +# }) +# +# test_that("plot_ranges() works as expected with dispersion", { +# p <- plot_ranges(sum_scores, y = "dispersion", x = "model") + +# facet_wrap(~target_type) +# expect_s3_class(p, "ggplot") +# skip_on_cran() +# vdiffr::expect_doppelganger("plot_ranges_dispersion", p) +# }) diff --git a/tests/testthat/test-plot_score_table.R b/tests/testthat/test-plot_score_table.R index 8336de7a9..5ffc0b029 100644 --- a/tests/testthat/test-plot_score_table.R +++ b/tests/testthat/test-plot_score_table.R @@ -1,7 +1,6 @@ test_that("plot_score_table() works as expected", { p <- suppressMessages( scores_quantile %>% - add_coverage(by = c("model")) %>% summarise_scores(by = c("model")) %>% summarise_scores(by = c("model"), fun = signif, digits = 1) %>% plot_score_table() From 71d6d657c3a4e33655d8db8a8694a38e8bb170bc Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Sun, 12 Nov 2023 16:46:32 +0100 Subject: [PATCH 19/49] Delete old version of `score.score_quantile()` --- NAMESPACE | 1 - R/score.R | 29 +------- R/score_quantile.R | 167 ------------------------------------------ man/score.Rd | 3 - man/score_quantile.Rd | 62 ---------------- 5 files changed, 1 insertion(+), 261 deletions(-) delete mode 100644 R/score_quantile.R delete mode 100644 man/score_quantile.Rd diff --git a/NAMESPACE b/NAMESPACE index ba1aa11be..e4ae0d765 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -8,7 +8,6 @@ S3method(score,default) S3method(score,scoringutils_binary) S3method(score,scoringutils_point) S3method(score,scoringutils_quantile) -S3method(score,scoringutils_quantile_old) S3method(score,scoringutils_sample) S3method(validate,default) S3method(validate,scoringutils_binary) diff --git a/R/score.R b/R/score.R index fb82f6568..73998a64d 100644 --- a/R/score.R +++ b/R/score.R @@ -231,34 +231,7 @@ score.scoringutils_sample <- function(data, metrics = metrics_sample, ...) { return(data[]) } -#' @rdname score -#' @export -score.scoringutils_quantile_old <- function(data, metrics = NULL, ...) { - data <- validate(data) - data <- remove_na_observed_predicted(data) - forecast_unit <- attr(data, "forecast_unit") - - if (is.null(metrics)) { - metrics <- available_metrics() - } - metrics <- metrics[metrics %in% available_metrics()] - scores <- score_quantile( - data = data, - forecast_unit = forecast_unit, - metrics = metrics, - ... - ) - - setattr(scores, "metric_names", metrics[metrics %in% colnames(scores)]) - # manual hack to make sure that the correct attributes are there. - setattr(scores, "forecast_unit", forecast_unit) - setattr(scores, "forecast_type", "quantile") - scores <- new_scoringutils(scores, "scoringutils_quantile") - - return(scores[]) -} - - +#' @importFrom data.table `:=` as.data.table rbindlist %like% #' @rdname score #' @export score.scoringutils_quantile <- function(data, metrics = metrics_quantile, ...) { diff --git a/R/score_quantile.R b/R/score_quantile.R deleted file mode 100644 index e0a3fb11c..000000000 --- a/R/score_quantile.R +++ /dev/null @@ -1,167 +0,0 @@ -#' @title Evaluate forecasts in a Quantile-Based Format -#' -#' @inheritParams score -#' @inheritParams interval_score -#' @param count_median_twice logical that controls whether or not to count the -#' median twice when summarising (default is \code{FALSE}). Counting the -#' median twice would conceptually treat it as a 0\% prediction interval, where -#' the median is the lower as well as the upper bound. The alternative is to -#' treat the median as a single quantile forecast instead of an interval. The -#' interval score would then be better understood as an average of quantile -#' scores. -#' @param forecast_unit A character vector with the column names that define -#' the unit of a single forecast, i.e. a forecast was made for a combination -#' of the values in `forecast_unit` -#' -#' @return A data.table with appropriate scores. For more information see -#' [score()] -#' -#' @importFrom data.table ':=' as.data.table rbindlist %like% -#' -#' @author Nikos Bosse \email{nikosbosse@@gmail.com} -#' @inherit score references -#' @keywords internal - -score_quantile <- function(data, - forecast_unit, - metrics, - weigh = TRUE, - count_median_twice = FALSE, - separate_results = TRUE) { - - data <- remove_na_observed_predicted(data) - - # make sure to have both quantile as well as range format -------------------- - range_data <- quantile_to_interval( - data, - keep_quantile_col = FALSE - ) - # adds the range column to the quantile data set - quantile_data <- range_long_to_quantile( - range_data, - keep_range_col = TRUE - ) - - # to deal with point forecasts in a quantile format. This in effect adds - # a third column next to lower and upper after pivoting - range_data[is.na(range), boundary := "point"] - - range_data <- data.table::dcast(range_data, ... ~ boundary, - value.var = "predicted" - ) - - # if we only score point forecasts, it may be true that there are no columns - # upper and lower in the data.frame. If so, these need to be added - if (!all(c("upper", "lower") %in% colnames(range_data))) { - range_data[, c("upper", "lower") := NA] - } - - # set up results data.table that will then be modified throughout ------------ - res <- data.table::copy(range_data) - - # calculate scores on range format ------------------------------------------- - if ("interval_score" %in% metrics) { - # compute separate results if desired - if (separate_results) { - outcols <- c( - "interval_score", "dispersion", - "underprediction", "overprediction" - ) - } else { - outcols <- "interval_score" - } - res <- res[, eval(outcols) := do.call( - scoringutils::interval_score, - list(observed, lower, - upper, range, - weigh, - separate_results = separate_results - ) - )] - } - - # compute coverage for every single observation - if ("coverage" %in% metrics) { - res[, coverage := ifelse(observed <= upper & observed >= lower, 1, 0)] # nolint - res[, coverage_deviation := coverage - range / 100] - } - - # compute bias - if ("bias" %in% metrics) { - res[, bias := bias_range( - range = range, lower = lower, upper = upper, - observed = unique(observed) - ), - by = forecast_unit - ] - } - - # compute absolute and squared error for point forecasts - # these are marked by an NA in range, and a numeric value for point - compute_point <- any( - c("se_point, se_mean, ae_point", "ae_median", "absolute_error") %in% metrics - ) - if (compute_point && "point" %in% colnames(res)) { - res[ - is.na(range) & is.numeric(point), - `:=`(ae_point = abs_error(predicted = point, observed), - se_point = squared_error(predicted = point, observed)) - ] - } - - # calculate scores on quantile format ---------------------------------------- - # compute absolute error of the median - if ("ae_median" %in% metrics) { - quantile_data[, ae_median := ae_median_quantile( - unique(observed), - predicted, - quantile - ), - by = forecast_unit - ] - } - - # compute quantile coverage based on quantile version - if ("quantile_coverage" %in% metrics) { - quantile_data[, quantile_coverage := (observed <= predicted)] - } - - # merge metrics computed on quantile data (i.e. ae_median, quantile_coverage) back - # into metrics computed on range data. One important side effect of this is - # that it controls whether we count the median twice for the interval score - # (row is then duplicated) or only once. However, merge only needs to happen - # if we computed either the interval score or the ae_median or quantile coverage - if (any(c("ae_median", "interval_score", "quantile_coverage") %in% metrics)) { - # delete unnecessary columns before merging back - keep_cols <- unique(c( - forecast_unit, "quantile", "ae_median", "quantile_coverage", - "boundary", "range" - )) - delete_cols <- names(quantile_data)[!(names(quantile_data) %in% keep_cols)] - quantile_data[, eval(delete_cols) := NULL] - - # duplicate median column before merging if median is to be counted twice - # if this is false, then the res will have one entry for every quantile, - # which translates to two rows for every interval, but only one for the median - if (count_median_twice) { - median <- quantile_data[quantile == 0.5, ][, boundary := "upper"] - quantile_data <- data.table::rbindlist(list(quantile_data, median)) - } - - # merge back with other metrics - merge_cols <- setdiff(keep_cols, c( - "ae_median", "quantile_coverage", "quantile", - "boundary" - )) - # specify all.x = TRUE as the point forecasts got deleted when - # going from range to quantile above - res <- merge(res, quantile_data, by = merge_cols, all.x = TRUE) - } - - # delete internal columns before returning result - res <- delete_columns( - res, c("upper", "lower", "boundary", "point", "observed") - ) - - return(res[]) -} diff --git a/man/score.Rd b/man/score.Rd index 9ae7ebf37..c26fbb24c 100644 --- a/man/score.Rd +++ b/man/score.Rd @@ -6,7 +6,6 @@ \alias{score.scoringutils_binary} \alias{score.scoringutils_point} \alias{score.scoringutils_sample} -\alias{score.scoringutils_quantile_old} \alias{score.scoringutils_quantile} \title{Evaluate forecasts in a data.frame format} \usage{ @@ -20,8 +19,6 @@ score(data, ...) \method{score}{scoringutils_sample}(data, metrics = metrics_sample, ...) -\method{score}{scoringutils_quantile_old}(data, metrics = NULL, ...) - \method{score}{scoringutils_quantile}(data, metrics = metrics_quantile, ...) } \arguments{ diff --git a/man/score_quantile.Rd b/man/score_quantile.Rd deleted file mode 100644 index 5f51f94ec..000000000 --- a/man/score_quantile.Rd +++ /dev/null @@ -1,62 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/score_quantile.R -\name{score_quantile} -\alias{score_quantile} -\title{Evaluate forecasts in a Quantile-Based Format} -\usage{ -score_quantile( - data, - forecast_unit, - metrics, - weigh = TRUE, - count_median_twice = FALSE, - separate_results = TRUE -) -} -\arguments{ -\item{data}{A data.frame or data.table with predicted and observed values.} - -\item{forecast_unit}{A character vector with the column names that define -the unit of a single forecast, i.e. a forecast was made for a combination -of the values in \code{forecast_unit}} - -\item{metrics}{A named list of scoring functions. Names will be used as -column names in the output. See \code{\link[=metrics_point]{metrics_point()}}, \code{\link[=metrics_binary]{metrics_binary()}}, -\code{metrics_quantile()}, and \code{\link[=metrics_sample]{metrics_sample()}} for more information on the -default metrics used.} - -\item{weigh}{if TRUE, weigh the score by alpha / 2, so it can be averaged -into an interval score that, in the limit, corresponds to CRPS. Alpha is the -decimal value that represents how much is outside a central prediction -interval (e.g. for a 90 percent central prediction interval, alpha is 0.1) -Default: \code{TRUE}.} - -\item{count_median_twice}{logical that controls whether or not to count the -median twice when summarising (default is \code{FALSE}). Counting the -median twice would conceptually treat it as a 0\\% prediction interval, where -the median is the lower as well as the upper bound. The alternative is to -treat the median as a single quantile forecast instead of an interval. The -interval score would then be better understood as an average of quantile -scores.} - -\item{separate_results}{if \code{TRUE} (default is \code{FALSE}), then the separate -parts of the interval score (dispersion penalty, penalties for over- and -under-prediction get returned as separate elements of a list). If you want a -\code{data.frame} instead, simply call \code{\link[=as.data.frame]{as.data.frame()}} on the output.} -} -\value{ -A data.table with appropriate scores. For more information see -\code{\link[=score]{score()}} -} -\description{ -Evaluate forecasts in a Quantile-Based Format -} -\references{ -Bosse NI, Gruson H, Cori A, van Leeuwen E, Funk S, Abbott S -(2022) Evaluating Forecasts with scoringutils in R. -\doi{10.48550/arXiv.2205.07090} -} -\author{ -Nikos Bosse \email{nikosbosse@gmail.com} -} -\keyword{internal} From 596dcee630248aa3357363b884e4a8d466b6db6d Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Sun, 12 Nov 2023 17:39:15 +0100 Subject: [PATCH 20/49] improve the way that data.frames are split in `score()` to deal with differing quantiles --- R/score.R | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/R/score.R b/R/score.R index 73998a64d..d373fd3e0 100644 --- a/R/score.R +++ b/R/score.R @@ -248,12 +248,13 @@ score.scoringutils_quantile <- function(data, metrics = metrics_quantile, ...) { d_transposed <- data[, .(predicted = list(predicted[order(quantile)]), observed = unique(observed), quantile = list(quantile[order(quantile)]), - N = length(quantile)), by = forecast_unit] + scoringutils_quantile = toString(quantile[order(quantile)])), + by = forecast_unit] # split according to quantile lengths and do calculations for different # quantile lengths separately. The function `wis()` assumes that all # forecasts have the same quantiles - d_split <- split(d_transposed, d_transposed$N) + d_split <- split(d_transposed, d_transposed$scoringutils_quantile) split_result <- lapply(d_split, function(data) { # create a matrix out of the list of predicted values and quantiles @@ -278,6 +279,7 @@ score.scoringutils_quantile <- function(data, metrics = metrics_quantile, ...) { }) data <- rbindlist(split_result) + data[, "scoringutils_quantile" := NULL] setattr(data, "metric_names", names(metrics)) return(data[]) From 6989f5d94cd5ae92d3371d15df485e740c859c6a Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Sun, 12 Nov 2023 18:42:22 +0100 Subject: [PATCH 21/49] Add test file for binary metrics and input checks --- tests/testthat/setup.R | 1 + tests/testthat/test-metrics-binary.R | 66 ++++++++++++++++++++++++++++ 2 files changed, 67 insertions(+) create mode 100644 tests/testthat/test-metrics-binary.R diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R index c157fb958..ac7057386 100644 --- a/tests/testthat/setup.R +++ b/tests/testthat/setup.R @@ -1,5 +1,6 @@ # load common required test packages library(ggplot2, quietly = TRUE) +library(data.table) suppressMessages(library(magrittr)) # compute quantile scores diff --git a/tests/testthat/test-metrics-binary.R b/tests/testthat/test-metrics-binary.R new file mode 100644 index 000000000..5eed53714 --- /dev/null +++ b/tests/testthat/test-metrics-binary.R @@ -0,0 +1,66 @@ +observed <- factor(rbinom(10, size = 1, prob = 0.5)) +predicted <- c(0.425, 0.55, 0.541, 0.52, 0.13, 0.469, 0.86, 0.22, 0.74, 0.9) +df <- data.table( + observed = observed, + predicted = predicted, + model = "m1", + id = 1:10 +) + +# test input handling +test_that("Input checking for binary forecasts works", { + # everything correct + expect_no_condition( + scoringutils:::assert_input_binary(observed, predicted) + ) + + # predicted > 1 + expect_error( + scoringutils:::assert_input_binary(observed, predicted + 1), + "Assertion on 'predicted' failed: Element 1 is not <= 1." + ) + + # predicted < 0 + expect_error( + scoringutils:::assert_input_binary(observed, predicted - 1), + "Assertion on 'predicted' failed: Element 1 is not >= 0." + ) + + # observed value not factor + expect_error( + scoringutils:::assert_input_binary(1:10, predicted), + "Assertion on 'observed' failed: Must be of type 'factor', not 'integer'." + ) + + # observed value has not 2 levels + expect_error( + scoringutils:::assert_input_binary(factor(1:10), predicted), + "Assertion on 'observed' failed: Must have exactly 2 levels." + ) + + # observed is a single number and does not have the same length as predicted + expect_error( + scoringutils:::assert_input_binary(factor(1), predicted), + "`observed` and `predicted` need to be of same length when scoring binary forecasts." + ) + + # predicted is a matrix + expect_error( + scoringutils:::assert_input_binary(observed, matrix(predicted)), + "Assertion on 'predicted' failed: Must be of type 'atomic vector', not 'matrix'." + ) + # Note: maybe we should allow + # 1) observed to be a vector and 2) predicted to be a matrix for consistency +}) + +test_that("Binary metrics work within and outside of `score()`", { + result <- score(df) + expect_equal( + brier_score(observed, predicted), + result$brier_score + ) + expect_equal( + logs_binary(observed, predicted), + result$log_score + ) +}) From 376de95471f9fe237e8231d4bc08e6186e31fef6 Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Sun, 12 Nov 2023 18:46:22 +0100 Subject: [PATCH 22/49] Remove comment (to be turned into an issue) --- tests/testthat/test-metrics-binary.R | 2 -- 1 file changed, 2 deletions(-) diff --git a/tests/testthat/test-metrics-binary.R b/tests/testthat/test-metrics-binary.R index 5eed53714..958262a67 100644 --- a/tests/testthat/test-metrics-binary.R +++ b/tests/testthat/test-metrics-binary.R @@ -49,8 +49,6 @@ test_that("Input checking for binary forecasts works", { scoringutils:::assert_input_binary(observed, matrix(predicted)), "Assertion on 'predicted' failed: Must be of type 'atomic vector', not 'matrix'." ) - # Note: maybe we should allow - # 1) observed to be a vector and 2) predicted to be a matrix for consistency }) test_that("Binary metrics work within and outside of `score()`", { From b13f00ae4a3184308fd8a231af3a2c56ac5331ee Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Sun, 12 Nov 2023 19:05:53 +0100 Subject: [PATCH 23/49] small fix in score.scoringutils_quantile to avoid a warning --- R/score.R | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/R/score.R b/R/score.R index d373fd3e0..7ec7763e3 100644 --- a/R/score.R +++ b/R/score.R @@ -261,7 +261,7 @@ score.scoringutils_quantile <- function(data, metrics = metrics_quantile, ...) { observed <- data$observed predicted <- do.call(rbind, data$predicted) quantile <- unlist(unique(data$quantile)) - data[, c("observed", "predicted", "quantile", "N") := NULL] + data[, c("observed", "predicted", "quantile", "scoringutils_quantile") := NULL] # for each metric, compute score lapply(seq_along(metrics), function(i, ...) { @@ -279,7 +279,6 @@ score.scoringutils_quantile <- function(data, metrics = metrics_quantile, ...) { }) data <- rbindlist(split_result) - data[, "scoringutils_quantile" := NULL] setattr(data, "metric_names", names(metrics)) return(data[]) From 983c03095f8172e6f1d9d532dfae845fd84308a8 Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Sun, 12 Nov 2023 19:20:23 +0100 Subject: [PATCH 24/49] move tests around so they better correspond to file names used for actual functions --- tests/testthat/test-bias.R | 311 ------------------ tests/testthat/test-get_-functions.R | 39 +++ tests/testthat/test-get_duplicate_forecasts.R | 37 --- .../test-lower-level-check-functions.R | 116 ------- tests/testthat/test-metrics-binary.R | 75 +++++ ...-absolute_error.R => test-metrics-point.R} | 60 +--- ...terval_score.R => test-metrics-quantile.R} | 240 ++++++++++++-- tests/testthat/test-metrics-range.R | 45 +++ tests/testthat/test-metrics-sample.R | 146 ++++++++ 9 files changed, 525 insertions(+), 544 deletions(-) delete mode 100644 tests/testthat/test-bias.R delete mode 100644 tests/testthat/test-get_duplicate_forecasts.R delete mode 100644 tests/testthat/test-lower-level-check-functions.R rename tests/testthat/{test-absolute_error.R => test-metrics-point.R} (82%) rename tests/testthat/{test-interval_score.R => test-metrics-quantile.R} (68%) create mode 100644 tests/testthat/test-metrics-range.R create mode 100644 tests/testthat/test-metrics-sample.R diff --git a/tests/testthat/test-bias.R b/tests/testthat/test-bias.R deleted file mode 100644 index 42eefa34f..000000000 --- a/tests/testthat/test-bias.R +++ /dev/null @@ -1,311 +0,0 @@ -test_that("bias_sample() throws an error when missing observed", { - observed <- rpois(10, lambda = 1:10) - predicted <- replicate(50, rpois(n = 10, lambda = 1:10)) - - expect_error( - bias_sample(predicted = predicted), - 'argument "observed" is missing, with no default' - ) -}) - -test_that("bias_sample() throws an error when missing 'predicted'", { - observed <- rpois(10, lambda = 1:10) - predicted <- replicate(50, rpois(n = 10, lambda = 1:10)) - - expect_error( - bias_sample(observed = observed), - 'argument "predicted" is missing, with no default' - ) -}) - -test_that("bias_sample() works for integer observed and predicted", { - observed <- rpois(10, lambda = 1:10) - predicted <- replicate(10, rpois(10, lambda = 1:10)) - output <- bias_sample( - observed = observed, - predicted = predicted - ) - expect_equal( - length(output), - length(observed) - ) - expect_equal( - class(output), - "numeric" - ) -}) - -test_that("bias_sample() works for continuous observed values and predicted", { - observed <- rnorm(10) - predicted <- replicate(10, rnorm(10)) - output <- bias_sample( - observed = observed, - predicted = predicted - ) - expect_equal( - length(output), - length(observed) - ) - expect_equal( - class(output), - "numeric" - ) -}) - -test_that("bias_sample() works as expected", { - observed <- rpois(30, lambda = 1:30) - predicted <- replicate(200, rpois(n = 30, lambda = 1:30)) - expect_true(all(bias_sample(observed, predicted) == bias_sample(observed, predicted))) - - ## continuous forecasts - observed <- rnorm(30, mean = 1:30) - predicted <- replicate(200, rnorm(30, mean = 1:30)) - - scoringutils2 <- bias_sample(observed, predicted) - scoringutils <- bias_sample(observed, predicted) - - expect_equal(scoringutils, scoringutils2) -}) - - -test_that("bias_quantile() works as expected", { - predicted <- c(1, 2, 3) - quantiles <- c(0.1, 0.5, 0.9) - expect_equal( - bias_quantile(observed = 2, predicted, quantiles), - 0 - ) - predicted <- c(0, 1, 2) - quantiles <- c(0.1, 0.5, 0.9) - expect_equal( - bias_quantile(observed = 2, predicted, quantiles), - -0.8 - ) - - predicted <- c( - 705.500, 1127.000, 4006.250, 4341.500, 4709.000, 4821.996, - 5340.500, 5451.000, 5703.500, 6087.014, 6329.500, 6341.000, - 6352.500, 6594.986, 6978.500, 7231.000, 7341.500, 7860.004, - 7973.000, 8340.500, 8675.750, 11555.000, 11976.500 - ) - - quantile <- c(0.01, 0.025, seq(0.05, 0.95, 0.05), 0.975, 0.99) - - observed <- 8062 - expect_equal(bias_quantile(observed, predicted, quantile), -0.8) -}) - -test_that("bias_quantile handles matrix input", { - observed <- seq(10, 0, length.out = 4) - predicted <- matrix(1:12, ncol = 3) - quantiles <- c(0.1, 0.5, 0.9) - expect_equal( - bias_quantile(observed, predicted, quantiles), - c(-1.0, -0.8, 0.8, 1.0) - ) -}) - - -test_that("bias_quantile() handles vector that is too long", { - predicted <- c(NA, 1, 2, 3) - quantiles <- c(0.1, 0.5, 0.9) - - expect_error( - bias_quantile(observed = 2, predicted, quantiles), - "Assertion on 'quantile' failed: Must have length 4, but has length 3." - ) -}) - -test_that("bias_quantile() handles NA values", { - predicted <- c(NA, 1, 2) - quantiles <- c(0.1, 0.5, 0.9) - expect_equal( - bias_quantile(observed = 2, predicted, quantiles), - -0.8 - ) - predicted <- c(0, 1, 2) - quantiles <- c(0.1, 0.5, NA) - expect_equal( - bias_quantile(observed = 2, predicted, quantiles), - -1 - ) - expect_equal( - bias_quantile(observed = 2, predicted, quantiles, na.rm = FALSE), - NA_real_ - ) -}) - -test_that("bias_quantile() errors if no predictions", { - expect_error( - bias_quantile(observed = 2, numeric(0), numeric(0)), - "Assertion on 'quantile' failed: Must have length >= 1, but has length 0" - ) -}) - -test_that("bias_quantile() returns correct bias if value below the median", { - predicted <- c(1, 2, 4, 5) - quantiles <- c(0.1, 0.3, 0.7, 0.9) - suppressMessages( - expect_equal(bias_quantile(observed = 1, predicted, quantiles), 0.8) - ) -}) - -test_that("bias_quantile() returns correct bias if value above median", { - predicted <- c(1, 2, 4, 5) - quantiles <- c(0.1, 0.3, 0.7, 0.9) - suppressMessages( - expect_equal(bias_quantile(observed = 5, predicted, quantiles), -0.8) - ) -}) - -test_that("bias_quantile() returns correct bias if value at the median", { - predicted <- c(1, 2, 3, 4) - quantiles <- c(0.1, 0.3, 0.5, 0.7) - - expect_equal(bias_quantile(observed = 3, predicted, quantiles), 0) -}) - -test_that("bias_quantile() returns 1 if true value below min prediction", { - predicted <- c(2, 3, 4, 5) - quantiles <- c(0.1, 0.3, 0.7, 0.9) - - suppressMessages( - expect_equal(bias_quantile(observed = 1, predicted, quantiles), 1) - ) -}) - -test_that("bias_quantile() returns -1 if true value above max prediction", { - predicted <- c(1, 2, 3, 4) - quantiles <- c(0.1, 0.3, 0.5, 0.7) - - expect_equal(bias_quantile(observed = 6, predicted, quantiles), -1) -}) - -test_that("bias_quantile(): quantiles must be between 0 and 1", { - predicted <- 1:4 - - # Failing example - quantiles <- c(-0.1, 0.3, 0.5, 0.8) - expect_error( - bias_quantile(observed = 3, predicted, quantiles), - "Assertion on 'quantile' failed: Element 1 is not >= 0." - ) - - # Passing counter example - quantiles <- c(0.1, 0.3, 0.5, 0.8) - expect_silent(bias_quantile(observed = 3, predicted, quantiles)) -}) - -test_that("bias_quantile(): quantiles must be increasing", { - predicted <- 1:4 - - # Failing example - quantiles <- c(0.8, 0.3, 0.5, 0.9) - expect_error( - bias_quantile(observed = 3, predicted, quantiles), - "Predictions must not be decreasing with increasing quantile level" - ) - - # Passing counter example - quantiles <- c(0.3, 0.5, 0.8, 0.9) - expect_silent(bias_quantile(observed = 3, predicted, quantiles)) -}) - -test_that("bias_quantile(): predictions must be increasing", { - predicted <- c(1, 2, 4, 3) - quantiles <- c(0.1, 0.3, 0.5, 0.9) - - expect_error( - bias_quantile(observed = 3, predicted, quantiles), - "Predictions must not be decreasing with increasing quantile level" - ) - expect_silent(bias_quantile( observed = 3, 1:4, quantiles)) -}) - -test_that("bias_quantile(): quantiles must be unique", { - predicted <- 1:4 - - # Failing example - quantiles <- c(0.3, 0.3, 0.5, 0.8) - expect_error( - bias_quantile(observed = 3, predicted, quantiles), - "Assertion on 'quantile' failed: Contains duplicated values, position 2." - ) - - # Passing example - quantiles <- c(0.3, 0.5, 0.8, 0.9) - expect_silent(bias_quantile(observed = 3, predicted, quantiles)) -}) - -test_that("bias_sample() approx equals bias_quantile() for many samples", { - set.seed(123) - - # Generate true value - observed <- 3 - - # Generate many sample predictions - predicted <- sample(rnorm(1000, mean = observed, sd = 2), 1000) - - # Get sample based bias - bias_sample_result <- bias_sample( - observed, matrix(predicted, nrow = 1) - ) - - # Convert predictions to quantiles - quantiles <- seq(0, 1, length.out = 100) - quantile_preds <- quantile(predicted, probs = quantiles) - - # Get quantile based bias - bias_quantile_result <- suppressMessages( - bias_quantile(observed, quantile_preds, quantiles) - ) - - # Difference should be small - expect_equal(bias_quantile_result, bias_sample_result, tolerance = 0.1) -}) - -test_that("bias_quantile() and bias_range() give the same result", { - predicted <- sort(rnorm(23)) - lower <- rev(predicted[1:12]) - upper <- predicted[12:23] - - range <- c(0, 10, 20, 30, 40, 50, 60, 70, 80, 90, 95, 98) - quantiles <- c(0.01, 0.025, seq(0.05, 0.95, 0.05), 0.975, 0.99) - observed <- rnorm(1) - - range_bias <- bias_range( - lower = lower, upper = upper, - range = range, observed = observed - ) - range_quantile <- bias_quantile( - observed = observed, - predicted = predicted, - quantile = quantiles - ) - expect_equal(range_bias, range_quantile) -}) - -test_that("bias_range() works with point forecasts", { - predicted <- 1 - observed <- 1 - range <- c(0) - - expect_equal(bias_range(predicted, predicted, range, observed), 0) -}) - -test_that("bias_range(): ranges must be between 0 and 100", { - lower <- 4:1 - upper <- 5:8 - - # Failing example - range <- c(-10, 0, 10, 20) - expect_error( - bias_range(lower, upper, range, observed = 3), - "range must be between 0 and 100" - ) - - # Passing counter example - range <- c(0, 10, 20, 30) - expect_silent(bias_range(lower, upper, range, observed = 3)) -}) - diff --git a/tests/testthat/test-get_-functions.R b/tests/testthat/test-get_-functions.R index 217e954bd..0a499b243 100644 --- a/tests/testthat/test-get_-functions.R +++ b/tests/testthat/test-get_-functions.R @@ -70,3 +70,42 @@ test_that("get_type() handles `NA` values", { expect_equal(get_type(c(1, NA, 3.2)), "continuous") expect_error(get_type(NA), "Can't get type: all values of are NA") }) + + +# `get_duplicate_forecasts()` ================================================== +test_that("get_duplicate_forecasts() works as expected for quantile", { + expect_equal(nrow(get_duplicate_forecasts(example_quantile)), 0) + expect_equal( + nrow( + get_duplicate_forecasts(rbind(example_quantile, example_quantile[1000:1010]))), + 22 + ) +}) + +test_that("get_duplicate_forecasts() works as expected for sample", { + expect_equal(nrow(get_duplicate_forecasts(example_continuous)), 0) + expect_equal( + nrow( + get_duplicate_forecasts(rbind(example_continuous, example_continuous[1040:1050]))), + 22 + ) +}) + + +test_that("get_duplicate_forecasts() works as expected for binary", { + expect_equal(nrow(get_duplicate_forecasts(example_binary)), 0) + expect_equal( + nrow( + get_duplicate_forecasts(rbind(example_binary, example_binary[1000:1010]))), + 22 + ) +}) + +test_that("get_duplicate_forecasts() works as expected for point", { + expect_equal(nrow(get_duplicate_forecasts(example_binary)), 0) + expect_equal( + nrow( + get_duplicate_forecasts(rbind(example_point, example_point[1010:1020]))), + 22 + ) +}) diff --git a/tests/testthat/test-get_duplicate_forecasts.R b/tests/testthat/test-get_duplicate_forecasts.R deleted file mode 100644 index 5487ea0fb..000000000 --- a/tests/testthat/test-get_duplicate_forecasts.R +++ /dev/null @@ -1,37 +0,0 @@ -test_that("get_duplicate_forecasts() works as expected for quantile", { - expect_equal(nrow(get_duplicate_forecasts(example_quantile)), 0) - expect_equal( - nrow( - get_duplicate_forecasts(rbind(example_quantile, example_quantile[1000:1010]))), - 22 - ) -}) - -test_that("get_duplicate_forecasts() works as expected for sample", { - expect_equal(nrow(get_duplicate_forecasts(example_continuous)), 0) - expect_equal( - nrow( - get_duplicate_forecasts(rbind(example_continuous, example_continuous[1040:1050]))), - 22 - ) -}) - - -test_that("get_duplicate_forecasts() works as expected for binary", { - expect_equal(nrow(get_duplicate_forecasts(example_binary)), 0) - expect_equal( - nrow( - get_duplicate_forecasts(rbind(example_binary, example_binary[1000:1010]))), - 22 - ) -}) - -test_that("get_duplicate_forecasts() works as expected for point", { - expect_equal(nrow(get_duplicate_forecasts(example_binary)), 0) - expect_equal( - nrow( - get_duplicate_forecasts(rbind(example_point, example_point[1010:1020]))), - 22 - ) -}) - diff --git a/tests/testthat/test-lower-level-check-functions.R b/tests/testthat/test-lower-level-check-functions.R deleted file mode 100644 index 8d73aa528..000000000 --- a/tests/testthat/test-lower-level-check-functions.R +++ /dev/null @@ -1,116 +0,0 @@ -test_that("Lower-level input check functions work", { - observed <- rpois(30, lambda = 1:30) - predicted <- replicate(20, rpois(n = 30, lambda = 1:30)) - expect_equal(length(crps_sample(observed, predicted)), 30) - - # should error when wrong prediction type is given - predicted2 <- rpois(30, lambda = 1) - expect_error(crps_sample(observed, predicted2), - "Assertion on 'predicted' failed: Must be of type 'matrix', not 'integer'", - fixed = TRUE - ) - - # predictions have wrong number of rows - predicted3 <- replicate(20, rpois(n = 31, lambda = 1)) - expect_error( - crps_sample(observed, predicted3), - "Assertion on 'predicted' failed: Must have exactly 30 rows, but has 31 rows.", - # "Mismatch: 'observed' has length `30`, but 'predicted' has `31` rows.", - fixed = TRUE - ) - - # error with missing argument - expect_error(crps_sample(predicted = predicted), - 'argument "observed" is missing, with no default', - fixed = TRUE - ) - - # checks work for binary forecasts - observed <- factor(sample(c(0, 1), size = 10, replace = TRUE)) - predicted <- runif(n = 10) - expect_equal(length(brier_score(observed, predicted)), 10) - - # predictions are not between 0 and 1 - predicted2 <- predicted + 2 - expect_error( - brier_score(observed, predicted2), - "Assertion on 'predicted' failed: Element 1 is not <= 1.", - fixed = TRUE - ) -}) - - -test_that("function throws an error when missing observed or predicted", { - observed <- sample(c(0, 1), size = 10, replace = TRUE) - predicted <- replicate( - 20, - sample(c(0, 1), size = 10, replace = TRUE) - ) - - expect_error( - brier_score(predicted = predicted), - 'argument "observed" is missing, with no default' - ) - - expect_error( - brier_score(observed = observed), - 'argument "predicted" is missing, with no default' - ) -}) - - - -test_that("function throws an error for wrong format of `observed`", { - observed <- factor(rpois(10, lambda = 1:10)) - predicted <- runif(10, min = 0, max = 1) - - expect_error( - brier_score( - observed = observed, - predicted = predicted - ), - "Assertion on 'observed' failed: Must have exactly 2 levels." - ) - - observed <- rnorm(10) - expect_error( - brier_score( - observed = observed, - predicted = predicted - ), - "Assertion on 'observed' failed: Must be of type 'factor', not 'double'." - ) -}) - -test_that("function throws an error for wrong format of predictions", { - observed <- factor(sample(c(0, 1), size = 10, replace = TRUE)) - predicted <- runif(10, min = 0, max = 3) - expect_error( - brier_score( - observed = observed, - predicted = predicted - ), - #"For a binary forecast, all predictions should be probabilities between 0 or 1." - "Assertion on 'predicted' failed: Element 1 is not <= 1." - ) - - predicted <- runif(10, min = 0, max = 1) - expect_error( - brier_score( - observed = observed, - predicted = as.list(predicted) - ), - "Assertion on 'predicted' failed: Must be of type 'numeric', not 'list'." - ) - - predicted <- runif(15, min = 0, max = 1) - expect_error( - brier_score( - observed = observed, - predicted = predicted - ), - "`observed` and `predicted` need to be of same length when scoring binary forecasts", - # "Arguments to the following function call: 'brier_score(observed = observed, predicted = predicted)' should have the same length (or length one). Actual lengths: 10, 15", - fixed = TRUE - ) -}) diff --git a/tests/testthat/test-metrics-binary.R b/tests/testthat/test-metrics-binary.R index 958262a67..311ae0782 100644 --- a/tests/testthat/test-metrics-binary.R +++ b/tests/testthat/test-metrics-binary.R @@ -8,6 +8,81 @@ df <- data.table( ) # test input handling +test_that("function throws an error when missing observed or predicted", { + observed <- sample(c(0, 1), size = 10, replace = TRUE) + predicted <- replicate( + 20, + sample(c(0, 1), size = 10, replace = TRUE) + ) + + expect_error( + brier_score(predicted = predicted), + 'argument "observed" is missing, with no default' + ) + + expect_error( + brier_score(observed = observed), + 'argument "predicted" is missing, with no default' + ) +}) + + + +test_that("function throws an error for wrong format of `observed`", { + observed <- factor(rpois(10, lambda = 1:10)) + predicted <- runif(10, min = 0, max = 1) + + expect_error( + brier_score( + observed = observed, + predicted = predicted + ), + "Assertion on 'observed' failed: Must have exactly 2 levels." + ) + + observed <- rnorm(10) + expect_error( + brier_score( + observed = observed, + predicted = predicted + ), + "Assertion on 'observed' failed: Must be of type 'factor', not 'double'." + ) +}) + +test_that("function throws an error for wrong format of predictions", { + observed <- factor(sample(c(0, 1), size = 10, replace = TRUE)) + predicted <- runif(10, min = 0, max = 3) + expect_error( + brier_score( + observed = observed, + predicted = predicted + ), + #"For a binary forecast, all predictions should be probabilities between 0 or 1." + "Assertion on 'predicted' failed: Element 1 is not <= 1." + ) + + predicted <- runif(10, min = 0, max = 1) + expect_error( + brier_score( + observed = observed, + predicted = as.list(predicted) + ), + "Assertion on 'predicted' failed: Must be of type 'numeric', not 'list'." + ) + + predicted <- runif(15, min = 0, max = 1) + expect_error( + brier_score( + observed = observed, + predicted = predicted + ), + "`observed` and `predicted` need to be of same length when scoring binary forecasts", + # "Arguments to the following function call: 'brier_score(observed = observed, predicted = predicted)' should have the same length (or length one). Actual lengths: 10, 15", + fixed = TRUE + ) +}) + test_that("Input checking for binary forecasts works", { # everything correct expect_no_condition( diff --git a/tests/testthat/test-absolute_error.R b/tests/testthat/test-metrics-point.R similarity index 82% rename from tests/testthat/test-absolute_error.R rename to tests/testthat/test-metrics-point.R index 118a182d8..2f64226df 100644 --- a/tests/testthat/test-absolute_error.R +++ b/tests/testthat/test-metrics-point.R @@ -1,23 +1,20 @@ -test_that("ae_median_sample works", { - observed <- rnorm(30, mean = 1:30) - predicted_values <- rnorm(30, mean = 1:30) - scoringutils <- ae_median_sample(observed, matrix(predicted_values)) - ae <- abs(observed - predicted_values) - expect_equal(ae, scoringutils) -}) - - -# covidHubUtils-tests +# covidHubUtils-tests on absolute error ======================================== +# test are adapted from the package +# covidHubUtils, https://github.com/reichlab/covidHubUtils/ +y <- c(1, -15, 22) +forecast_quantiles_matrix <- rbind( + c(-1, 0, 1, 2, 3), + c(-2, 1, 2, 2, 4), + c(-2, 0, 3, 3, 4) +) +forecast_quantile_probs <- c(0.1, 0.25, 0.5, 0.75, 0.9) + +target_end_dates <- as.Date("2020-01-01") + c(7, 14, 7) +horizons <- c("1", "2", "1") +locations <- c("01", "01", "02") +target_variables <- rep("inc death", length(y)) test_that("abs error is correct within score, point forecast only", { - # test is adapted from the package covidHubUtils, https://github.com/reichlab/covidHubUtils/ - y <- c(1, -15, 22) - - target_end_dates <- as.Date("2020-01-01") + c(7, 14, 7) - horizons <- c("1", "2", "1") - locations <- c("01", "01", "02") - target_variables <- rep("inc death", length(y)) - forecast_target_end_dates <- rep(target_end_dates, times = 1) forecast_horizons <- rep(horizons, times = 1) @@ -71,21 +68,9 @@ test_that("abs error is correct within score, point forecast only", { }) test_that("abs error is correct, point and median forecasts different", { - y <- c(1, -15, 22) - forecast_quantiles_matrix <- rbind( - c(-1, 0, 1, 2, 3), - c(-2, 1, 2, 2, 4), - c(-2, 0, 3, 3, 4) - ) - forecast_quantile_probs <- c(0.1, 0.25, 0.5, 0.75, 0.9) forecast_quantiles_matrix <- forecast_quantiles_matrix[, 3, drop = FALSE] forecast_quantile_probs <- forecast_quantile_probs[3] - target_end_dates <- as.Date("2020-01-01") + c(7, 14, 7) - horizons <- c("1", "2", "1") - locations <- c("01", "01", "02") - target_variables <- rep("inc death", length(y)) - forecast_target_end_dates <- rep(target_end_dates, times = 1 + ncol(forecast_quantiles_matrix)) forecast_horizons <- rep(horizons, times = 1 + ncol(forecast_quantiles_matrix)) @@ -143,21 +128,9 @@ test_that("abs error is correct, point and median forecasts different", { }) test_that("abs error is correct, point and median forecasts same", { - y <- c(1, -15, 22) - forecast_quantiles_matrix <- rbind( - c(-1, 0, 1, 2, 3), - c(-2, 1, 2, 2, 4), - c(-2, 0, 3, 3, 4) - ) - forecast_quantile_probs <- c(0.1, 0.25, 0.5, 0.75, 0.9) forecast_quantiles_matrix <- forecast_quantiles_matrix[, 3, drop = FALSE] forecast_quantile_probs <- forecast_quantile_probs[3] - target_end_dates <- as.Date("2020-01-01") + c(7, 14, 7) - horizons <- c("1", "2", "1") - locations <- c("01", "01", "02") - target_variables <- rep("inc death", length(y)) - forecast_target_end_dates <- rep(target_end_dates, times = 1 + ncol(forecast_quantiles_matrix)) forecast_horizons <- rep(horizons, times = 1 + ncol(forecast_quantiles_matrix)) @@ -194,7 +167,6 @@ test_that("abs error is correct, point and median forecasts same", { stringsAsFactors = FALSE ) - # bring in scoringutils format truth_scoringutils <- data.table::as.data.table(test_truth) fc_scoringutils <- data.table::as.data.table(test_forecasts) @@ -219,7 +191,5 @@ test_that("abs error is correct, point and median forecasts same", { ) expected <- abs(y - point_forecast) - - # expect_equal(actual$abs_error, expected) expect_equal(eval$ae_point, expected) }) diff --git a/tests/testthat/test-interval_score.R b/tests/testthat/test-metrics-quantile.R similarity index 68% rename from tests/testthat/test-interval_score.R rename to tests/testthat/test-metrics-quantile.R index 04e0807a5..87d16e040 100644 --- a/tests/testthat/test-interval_score.R +++ b/tests/testthat/test-metrics-quantile.R @@ -1,15 +1,12 @@ -metrics_no_cov <- metrics_quantile[!grepl("coverage", names(metrics_quantile))] -metrics_no_cov_no_ae <- metrics_no_cov[!grepl("ae", names(metrics_no_cov))] - -test_that("wis works, median only", { +test_that("wis works standalone, median only", { y <- c(1, -15, 22) lower <- upper <- predicted_quantile <- c(1, 2, 3) quantile_probs <- 0.5 actual <- interval_score(y, - lower = lower, upper = upper, - weigh = TRUE, - interval_range = 0 + lower = lower, upper = upper, + weigh = TRUE, + interval_range = 0 ) actual_wis <- wis( @@ -23,7 +20,10 @@ test_that("wis works, median only", { expect_identical(actual, expected) }) -test_that("WIS works within score for median forecast", { +metrics_no_cov <- metrics_quantile[!grepl("coverage", names(metrics_quantile))] +metrics_no_cov_no_ae <- metrics_no_cov[!grepl("ae", names(metrics_no_cov))] + +test_that("`wis()` works within score for median forecast", { test_data <- data.frame( observed = c(1, -15, 22), predicted = 1:3, @@ -38,7 +38,7 @@ test_that("WIS works within score for median forecast", { expect_equal(eval$ae_median, eval$wis) }) -test_that("wis works, 1 interval only", { +test_that("`wis()` equals `interval_score()`, 1 interval only", { y <- c(1, -15, 22) lower <- c(0, 1, 0) upper <- c(2, 2, 3) @@ -65,7 +65,7 @@ test_that("wis works, 1 interval only", { expect_identical(actual_wis, expected) }) -test_that("WIS works within score for one interval", { +test_that("wis() works within score for one interval", { test_data <- data.frame( observed = rep(c(1, -15, 22), times = 2), quantile = rep(c(0.25, 0.75), each = 3), @@ -74,10 +74,10 @@ test_that("WIS works within score for one interval", { date = rep(1:3, times = 2) ) - eval <- suppressMessages(score( + eval <- score( test_data, count_median_twice = TRUE, metrics = metrics_no_cov_no_ae - )) + ) eval <- summarise_scores(eval, by = c("model", "date")) @@ -90,7 +90,7 @@ test_that("WIS works within score for one interval", { expect_equal(expected, eval$wis) }) -test_that("wis works, 1 interval and median", { +test_that("`wis()` works 1 interval and median", { test_data <- data.frame( observed = rep(c(1, -15, 22), times = 3), quantile = rep(c(0.25, 0.5, 0.75), each = 3), @@ -308,14 +308,14 @@ test_that("wis is correct, 1 interval only - test corresponds to covidHubUtils", data_formatted <- merge(forecasts_formated, truth_formatted) eval <- suppressMessages(score(data_formatted, - count_median_twice = FALSE, metrics = metrics_no_cov_no_ae + count_median_twice = FALSE, metrics = metrics_no_cov_no_ae )) eval <- summarise_scores(eval, - by = c( - "model", "location", "target_variable", - "target_end_date", "forecast_date", "horizon" - ) + by = c( + "model", "location", "target_variable", + "target_end_date", "forecast_date", "horizon" + ) ) alpha1 <- 0.2 @@ -385,14 +385,14 @@ test_that("wis is correct, 2 intervals and median - test corresponds to covidHub data_formatted <- merge(forecasts_formated, truth_formatted) eval <- score(data_formatted, - count_median_twice = FALSE, metrics = metrics_no_cov + count_median_twice = FALSE, metrics = metrics_no_cov ) eval <- summarise_scores(eval, - by = c( - "model", "location", "target_variable", - "target_end_date", "forecast_date", "horizon" - ) + by = c( + "model", "location", "target_variable", + "target_end_date", "forecast_date", "horizon" + ) ) alpha1 <- 0.2 @@ -439,14 +439,14 @@ test_that("Quantlie score and interval score yield the same result, weigh = FALS ) qs_lower <- quantile_score(observed, - predicted = lower, - quantile = alpha / 2, - weigh = w + predicted = lower, + quantile = alpha / 2, + weigh = w ) qs_upper <- quantile_score(observed, - predicted = upper, - quantile = 1 - alpha / 2, - weigh = w + predicted = upper, + quantile = 1 - alpha / 2, + weigh = w ) expect_equal((qs_lower + qs_upper) / 2, is) expect_equal(wis, is) @@ -479,14 +479,14 @@ test_that("Quantlie score and interval score yield the same result, weigh = TRUE ) qs_lower <- quantile_score(observed, - predicted = lower, - quantile = alpha / 2, - weigh = w + predicted = lower, + quantile = alpha / 2, + weigh = w ) qs_upper <- quantile_score(observed, - predicted = upper, - quantile = 1 - alpha / 2, - weigh = w + predicted = upper, + quantile = 1 - alpha / 2, + weigh = w ) expect_equal((qs_lower + qs_upper) / 2, is) expect_equal(wis, is) @@ -503,3 +503,173 @@ test_that("wis works with separate results", { expect_equal(wis$wis, wis$dispersion + wis$overprediction + wis$underprediction) }) + +# `bias_quantile` ============================================================== +test_that("bias_quantile() works as expected", { + predicted <- c(1, 2, 3) + quantiles <- c(0.1, 0.5, 0.9) + expect_equal( + bias_quantile(observed = 2, predicted, quantiles), + 0 + ) + predicted <- c(0, 1, 2) + quantiles <- c(0.1, 0.5, 0.9) + expect_equal( + bias_quantile(observed = 2, predicted, quantiles), + -0.8 + ) + + predicted <- c( + 705.500, 1127.000, 4006.250, 4341.500, 4709.000, 4821.996, + 5340.500, 5451.000, 5703.500, 6087.014, 6329.500, 6341.000, + 6352.500, 6594.986, 6978.500, 7231.000, 7341.500, 7860.004, + 7973.000, 8340.500, 8675.750, 11555.000, 11976.500 + ) + + quantile <- c(0.01, 0.025, seq(0.05, 0.95, 0.05), 0.975, 0.99) + + observed <- 8062 + expect_equal(bias_quantile(observed, predicted, quantile), -0.8) +}) + +test_that("bias_quantile handles matrix input", { + observed <- seq(10, 0, length.out = 4) + predicted <- matrix(1:12, ncol = 3) + quantiles <- c(0.1, 0.5, 0.9) + expect_equal( + bias_quantile(observed, predicted, quantiles), + c(-1.0, -0.8, 0.8, 1.0) + ) +}) + + +test_that("bias_quantile() handles vector that is too long", { + predicted <- c(NA, 1, 2, 3) + quantiles <- c(0.1, 0.5, 0.9) + + expect_error( + bias_quantile(observed = 2, predicted, quantiles), + "Assertion on 'quantile' failed: Must have length 4, but has length 3." + ) +}) + +test_that("bias_quantile() handles NA values", { + predicted <- c(NA, 1, 2) + quantiles <- c(0.1, 0.5, 0.9) + expect_equal( + bias_quantile(observed = 2, predicted, quantiles), + -0.8 + ) + predicted <- c(0, 1, 2) + quantiles <- c(0.1, 0.5, NA) + expect_equal( + bias_quantile(observed = 2, predicted, quantiles), + -1 + ) + expect_equal( + bias_quantile(observed = 2, predicted, quantiles, na.rm = FALSE), + NA_real_ + ) +}) + +test_that("bias_quantile() errors if no predictions", { + expect_error( + bias_quantile(observed = 2, numeric(0), numeric(0)), + "Assertion on 'quantile' failed: Must have length >= 1, but has length 0" + ) +}) + +test_that("bias_quantile() returns correct bias if value below the median", { + predicted <- c(1, 2, 4, 5) + quantiles <- c(0.1, 0.3, 0.7, 0.9) + suppressMessages( + expect_equal(bias_quantile(observed = 1, predicted, quantiles), 0.8) + ) +}) + +test_that("bias_quantile() returns correct bias if value above median", { + predicted <- c(1, 2, 4, 5) + quantiles <- c(0.1, 0.3, 0.7, 0.9) + suppressMessages( + expect_equal(bias_quantile(observed = 5, predicted, quantiles), -0.8) + ) +}) + +test_that("bias_quantile() returns correct bias if value at the median", { + predicted <- c(1, 2, 3, 4) + quantiles <- c(0.1, 0.3, 0.5, 0.7) + + expect_equal(bias_quantile(observed = 3, predicted, quantiles), 0) +}) + +test_that("bias_quantile() returns 1 if true value below min prediction", { + predicted <- c(2, 3, 4, 5) + quantiles <- c(0.1, 0.3, 0.7, 0.9) + + suppressMessages( + expect_equal(bias_quantile(observed = 1, predicted, quantiles), 1) + ) +}) + +test_that("bias_quantile() returns -1 if true value above max prediction", { + predicted <- c(1, 2, 3, 4) + quantiles <- c(0.1, 0.3, 0.5, 0.7) + + expect_equal(bias_quantile(observed = 6, predicted, quantiles), -1) +}) + +test_that("bias_quantile(): quantiles must be between 0 and 1", { + predicted <- 1:4 + + # Failing example + quantiles <- c(-0.1, 0.3, 0.5, 0.8) + expect_error( + bias_quantile(observed = 3, predicted, quantiles), + "Assertion on 'quantile' failed: Element 1 is not >= 0." + ) + + # Passing counter example + quantiles <- c(0.1, 0.3, 0.5, 0.8) + expect_silent(bias_quantile(observed = 3, predicted, quantiles)) +}) + +test_that("bias_quantile(): quantiles must be increasing", { + predicted <- 1:4 + + # Failing example + quantiles <- c(0.8, 0.3, 0.5, 0.9) + expect_error( + bias_quantile(observed = 3, predicted, quantiles), + "Predictions must not be decreasing with increasing quantile level" + ) + + # Passing counter example + quantiles <- c(0.3, 0.5, 0.8, 0.9) + expect_silent(bias_quantile(observed = 3, predicted, quantiles)) +}) + +test_that("bias_quantile(): predictions must be increasing", { + predicted <- c(1, 2, 4, 3) + quantiles <- c(0.1, 0.3, 0.5, 0.9) + + expect_error( + bias_quantile(observed = 3, predicted, quantiles), + "Predictions must not be decreasing with increasing quantile level" + ) + expect_silent(bias_quantile( observed = 3, 1:4, quantiles)) +}) + +test_that("bias_quantile(): quantiles must be unique", { + predicted <- 1:4 + + # Failing example + quantiles <- c(0.3, 0.3, 0.5, 0.8) + expect_error( + bias_quantile(observed = 3, predicted, quantiles), + "Assertion on 'quantile' failed: Contains duplicated values, position 2." + ) + + # Passing example + quantiles <- c(0.3, 0.5, 0.8, 0.9) + expect_silent(bias_quantile(observed = 3, predicted, quantiles)) +}) diff --git a/tests/testthat/test-metrics-range.R b/tests/testthat/test-metrics-range.R new file mode 100644 index 000000000..bd0290e9f --- /dev/null +++ b/tests/testthat/test-metrics-range.R @@ -0,0 +1,45 @@ +test_that("bias_quantile() and bias_range() give the same result", { + predicted <- sort(rnorm(23)) + lower <- rev(predicted[1:12]) + upper <- predicted[12:23] + + range <- c(0, 10, 20, 30, 40, 50, 60, 70, 80, 90, 95, 98) + quantiles <- c(0.01, 0.025, seq(0.05, 0.95, 0.05), 0.975, 0.99) + observed <- rnorm(1) + + range_bias <- bias_range( + lower = lower, upper = upper, + range = range, observed = observed + ) + range_quantile <- bias_quantile( + observed = observed, + predicted = predicted, + quantile = quantiles + ) + expect_equal(range_bias, range_quantile) +}) + +test_that("bias_range() works with point forecasts", { + predicted <- 1 + observed <- 1 + range <- c(0) + + expect_equal(bias_range(predicted, predicted, range, observed), 0) +}) + +test_that("bias_range(): ranges must be between 0 and 100", { + lower <- 4:1 + upper <- 5:8 + + # Failing example + range <- c(-10, 0, 10, 20) + expect_error( + bias_range(lower, upper, range, observed = 3), + "range must be between 0 and 100" + ) + + # Passing counter example + range <- c(0, 10, 20, 30) + expect_silent(bias_range(lower, upper, range, observed = 3)) +}) + diff --git a/tests/testthat/test-metrics-sample.R b/tests/testthat/test-metrics-sample.R new file mode 100644 index 000000000..ded7b52ae --- /dev/null +++ b/tests/testthat/test-metrics-sample.R @@ -0,0 +1,146 @@ +test_that("Input handling", { + observed <- rpois(30, lambda = 1:30) + predicted <- replicate(20, rpois(n = 30, lambda = 1:30)) + expect_equal(length(crps_sample(observed, predicted)), 30) + + # should error when wrong prediction type is given + predicted2 <- rpois(30, lambda = 1) + expect_error(crps_sample(observed, predicted2), + "Assertion on 'predicted' failed: Must be of type 'matrix', not 'integer'", + fixed = TRUE + ) + + # predictions have wrong number of rows + predicted3 <- replicate(20, rpois(n = 31, lambda = 1)) + expect_error( + crps_sample(observed, predicted3), + "Assertion on 'predicted' failed: Must have exactly 30 rows, but has 31 rows.", + # "Mismatch: 'observed' has length `30`, but 'predicted' has `31` rows.", + fixed = TRUE + ) + + # error with missing argument + expect_error(crps_sample(predicted = predicted), + 'argument "observed" is missing, with no default', + fixed = TRUE + ) +}) + + + +test_that("bias_sample() throws an error when missing observed", { + observed <- rpois(10, lambda = 1:10) + predicted <- replicate(50, rpois(n = 10, lambda = 1:10)) + + expect_error( + bias_sample(predicted = predicted), + 'argument "observed" is missing, with no default' + ) +}) + +test_that("bias_sample() throws an error when missing 'predicted'", { + observed <- rpois(10, lambda = 1:10) + predicted <- replicate(50, rpois(n = 10, lambda = 1:10)) + + expect_error( + bias_sample(observed = observed), + 'argument "predicted" is missing, with no default' + ) +}) + +test_that("bias_sample() works for integer observed and predicted", { + observed <- rpois(10, lambda = 1:10) + predicted <- replicate(10, rpois(10, lambda = 1:10)) + output <- bias_sample( + observed = observed, + predicted = predicted + ) + expect_equal( + length(output), + length(observed) + ) + expect_equal( + class(output), + "numeric" + ) +}) + +test_that("bias_sample() works for continuous observed values and predicted", { + observed <- rnorm(10) + predicted <- replicate(10, rnorm(10)) + output <- bias_sample( + observed = observed, + predicted = predicted + ) + expect_equal( + length(output), + length(observed) + ) + expect_equal( + class(output), + "numeric" + ) +}) + +test_that("bias_sample() works as expected", { + observed <- rpois(30, lambda = 1:30) + predicted <- replicate(200, rpois(n = 30, lambda = 1:30)) + expect_true(all(bias_sample(observed, predicted) == bias_sample(observed, predicted))) + + ## continuous forecasts + observed <- rnorm(30, mean = 1:30) + predicted <- replicate(200, rnorm(30, mean = 1:30)) + + scoringutils2 <- bias_sample(observed, predicted) + scoringutils <- bias_sample(observed, predicted) + + expect_equal(scoringutils, scoringutils2) +}) + + +test_that("bias_sample() approx equals bias_quantile() for many samples", { + set.seed(123) + + # Generate true value + observed <- 3 + + # Generate many sample predictions + predicted <- sample(rnorm(1000, mean = observed, sd = 2), 1000) + + # Get sample based bias + bias_sample_result <- bias_sample( + observed, matrix(predicted, nrow = 1) + ) + + # Convert predictions to quantiles + quantiles <- seq(0, 1, length.out = 100) + quantile_preds <- quantile(predicted, probs = quantiles) + + # Get quantile based bias + bias_quantile_result <- suppressMessages( + bias_quantile(observed, quantile_preds, quantiles) + ) + + # Difference should be small + expect_equal(bias_quantile_result, bias_sample_result, tolerance = 0.1) +}) + + +# `ae_median_sample` =========================================================== +test_that("ae_median_sample works", { + observed <- rnorm(30, mean = 1:30) + predicted_values <- rnorm(30, mean = 1:30) + scoringutils <- ae_median_sample(observed, matrix(predicted_values)) + ae <- abs(observed - predicted_values) + expect_equal(ae, scoringutils) +}) + +# `mad_sample()` =============================================================== +test_that("function throws an error when missing 'predicted'", { + predicted <- replicate(50, rpois(n = 10, lambda = 1:10)) + + expect_error( + mad_sample() + ) +}) + From c89b1f53287ce4e25aba2045a50318c43ed32f83 Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Sun, 12 Nov 2023 19:28:29 +0100 Subject: [PATCH 25/49] fix small test issues --- tests/testthat/test-metrics-binary.R | 14 ++------------ tests/testthat/test-metrics-quantile.R | 8 ++++---- 2 files changed, 6 insertions(+), 16 deletions(-) diff --git a/tests/testthat/test-metrics-binary.R b/tests/testthat/test-metrics-binary.R index 311ae0782..9c49e7050 100644 --- a/tests/testthat/test-metrics-binary.R +++ b/tests/testthat/test-metrics-binary.R @@ -51,17 +51,6 @@ test_that("function throws an error for wrong format of `observed`", { }) test_that("function throws an error for wrong format of predictions", { - observed <- factor(sample(c(0, 1), size = 10, replace = TRUE)) - predicted <- runif(10, min = 0, max = 3) - expect_error( - brier_score( - observed = observed, - predicted = predicted - ), - #"For a binary forecast, all predictions should be probabilities between 0 or 1." - "Assertion on 'predicted' failed: Element 1 is not <= 1." - ) - predicted <- runif(10, min = 0, max = 1) expect_error( brier_score( @@ -116,7 +105,8 @@ test_that("Input checking for binary forecasts works", { # observed is a single number and does not have the same length as predicted expect_error( scoringutils:::assert_input_binary(factor(1), predicted), - "`observed` and `predicted` need to be of same length when scoring binary forecasts." + "`observed` and `predicted` need to be of same length when scoring binary forecasts", + fixed = TRUE ) # predicted is a matrix diff --git a/tests/testthat/test-metrics-quantile.R b/tests/testthat/test-metrics-quantile.R index 87d16e040..a40a93d8e 100644 --- a/tests/testthat/test-metrics-quantile.R +++ b/tests/testthat/test-metrics-quantile.R @@ -1,3 +1,6 @@ +metrics_no_cov <- metrics_quantile[!grepl("coverage", names(metrics_quantile))] +metrics_no_cov_no_ae <- metrics_no_cov[!grepl("ae", names(metrics_no_cov))] + test_that("wis works standalone, median only", { y <- c(1, -15, 22) lower <- upper <- predicted_quantile <- c(1, 2, 3) @@ -20,9 +23,6 @@ test_that("wis works standalone, median only", { expect_identical(actual, expected) }) -metrics_no_cov <- metrics_quantile[!grepl("coverage", names(metrics_quantile))] -metrics_no_cov_no_ae <- metrics_no_cov[!grepl("ae", names(metrics_no_cov))] - test_that("`wis()` works within score for median forecast", { test_data <- data.frame( observed = c(1, -15, 22), @@ -76,7 +76,7 @@ test_that("wis() works within score for one interval", { eval <- score( test_data, - count_median_twice = TRUE, metrics = metrics_no_cov_no_ae + count_median_twice = TRUE, metrics = list(wis = wis) ) eval <- summarise_scores(eval, by = c("model", "date")) From cd0d1543e9db8a562780ca9d9e5ce7d1397cf5f4 Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Mon, 13 Nov 2023 10:01:51 +0100 Subject: [PATCH 26/49] Add input checks for quantile-based forecasts --- tests/testthat/test-metrics-quantile.R | 56 ++++++++++++++++++++++++++ 1 file changed, 56 insertions(+) diff --git a/tests/testthat/test-metrics-quantile.R b/tests/testthat/test-metrics-quantile.R index a40a93d8e..f8f15cf0f 100644 --- a/tests/testthat/test-metrics-quantile.R +++ b/tests/testthat/test-metrics-quantile.R @@ -1,3 +1,59 @@ +# Input handling =============================================================== +observed <- c(1, -15, 22) +predicted <- rbind( + c(-1, 0, 1, 2, 3), + c(-2, 1, 2, 2, 4), + c(-2, 0, 3, 3, 4) +) +quantile <- c(0.1, 0.25, 0.5, 0.75, 0.9) + +test_that("Input checking for quantile forecasts works", { + # everything correct + expect_no_condition( + scoringutils:::assert_input_quantile(observed, predicted, quantile) + ) + + # quantile > 1 + expect_error( + scoringutils:::assert_input_quantile(observed, predicted, quantile + 1), + "Assertion on 'quantile' failed: Element 1 is not <= 1." + ) + + # quantile < 0 + expect_error( + scoringutils:::assert_input_quantile(observed, predicted, quantile - 1), + "Assertion on 'quantile' failed: Element 1 is not >= 0." + ) + + # 10 observations, but only 3 forecasts + expect_error( + scoringutils:::assert_input_quantile(1:10, predicted, quantile), + "Assertion on 'predicted' failed: Must have exactly 10 rows, but has 3 rows." + ) + + # observed value is a factor + expect_error( + scoringutils:::assert_input_quantile(factor(1:10), predicted, quantile), + "Assertion on 'observed' failed: Must be of type 'numeric', not 'factor'." + ) + + # observed is a single number and does not have the same length as predicted + expect_error( + scoringutils:::assert_input_quantile(1, predicted, quantile), + "Assertion failed. One of the following must apply: + * check_numeric_vector(predicted): Must be of type 'atomic vector', not 'matrix' + * check_matrix(predicted): Must have exactly 1 rows, but has 3 rows", + fixed = TRUE + ) + + # predicted is a vector + expect_error( + scoringutils:::assert_input_quantile(observed, as.vector(predicted), quantile), + "Assertion on 'predicted' failed: Must be of type 'matrix', not 'double'." + ) +}) + + metrics_no_cov <- metrics_quantile[!grepl("coverage", names(metrics_quantile))] metrics_no_cov_no_ae <- metrics_no_cov[!grepl("ae", names(metrics_no_cov))] From 40807adf6fc2635c10fbf2585a2e04925bde20a9 Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Mon, 13 Nov 2023 10:02:26 +0100 Subject: [PATCH 27/49] remove old test for sharpness (test has been moved to test-metrics-sample.R) --- tests/testthat/test-sharpness.R | 7 ------- 1 file changed, 7 deletions(-) delete mode 100644 tests/testthat/test-sharpness.R diff --git a/tests/testthat/test-sharpness.R b/tests/testthat/test-sharpness.R deleted file mode 100644 index 12dcc4c9f..000000000 --- a/tests/testthat/test-sharpness.R +++ /dev/null @@ -1,7 +0,0 @@ -test_that("function throws an error when missing 'predicted'", { - predicted <- replicate(50, rpois(n = 10, lambda = 1:10)) - - expect_error( - mad_sample() - ) -}) From fa3a7ab2936b3be018623107abc273cd39fa686f Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Mon, 13 Nov 2023 10:39:33 +0100 Subject: [PATCH 28/49] move piece of code around within the metrics-quantile.R file (since metric has a many-to-one relationship) --- R/metrics-quantile.R | 78 ++++++++++++++++++++++---------------------- 1 file changed, 39 insertions(+), 39 deletions(-) diff --git a/R/metrics-quantile.R b/R/metrics-quantile.R index a321b21bf..db187d376 100644 --- a/R/metrics-quantile.R +++ b/R/metrics-quantile.R @@ -454,6 +454,45 @@ bias_quantile_single_vector <- function(observed, predicted, quantile, na.rm) { } +#' @title Absolute Error of the Median (Quantile-based Version) +#' @description +#' Compute the absolute error of the median calculated as +#' \deqn{ +#' \textrm{abs}(\textrm{observed} - \textrm{median prediction}) +#' }{ +#' abs(observed - median_prediction) +#' } +#' The median prediction is the predicted value for which quantile == 0.5, +#' the function therefore requires 0.5 to be among the quantile levels in +#' `quantile`. +#' @inheritParams wis +#' @return numeric vector of length N with the absolute error of the median +#' @seealso [ae_median_sample()], [abs_error()] +#' @importFrom stats median +#' @examples +#' observed <- rnorm(30, mean = 1:30) +#' predicted_values <- matrix(rnorm(30, mean = 1:30)) +#' ae_median_quantile(observed, predicted_values, quantile = 0.5) +#' @export +#' @keywords metric +ae_median_quantile <- function(observed, predicted, quantile) { + assert_input_quantile(observed, predicted, quantile) + if (!any(quantile == 0.5)) { + warning( + "in order to compute the absolute error of the median, `0.5` must be ", + "among the quantiles given. Returning `NA`." + ) + return(NA_real_) + } + if (is.null(dim(predicted))) { + predicted <- matrix(predicted, nrow = 1) + } + predicted <- predicted[, quantile == 0.5] + abs_error_median <- abs(observed - predicted) + return(abs_error_median) +} + + ################################################################################ # Metrics with a one-to-one relationship between input and score ################################################################################ @@ -619,42 +658,3 @@ wis_one_to_one <- function(observed, } } } - - -#' @title Absolute Error of the Median (Quantile-based Version) -#' @description -#' Compute the absolute error of the median calculated as -#' \deqn{ -#' \textrm{abs}(\textrm{observed} - \textrm{median prediction}) -#' }{ -#' abs(observed - median_prediction) -#' } -#' The median prediction is the predicted value for which quantile == 0.5, -#' the function therefore requires 0.5 to be among the quantile levels in -#' `quantile`. -#' @inheritParams wis -#' @return numeric vector of length N with the absolute error of the median -#' @seealso [ae_median_sample()], [abs_error()] -#' @importFrom stats median -#' @examples -#' observed <- rnorm(30, mean = 1:30) -#' predicted_values <- matrix(rnorm(30, mean = 1:30)) -#' ae_median_quantile(observed, predicted_values, quantile = 0.5) -#' @export -#' @keywords metric -ae_median_quantile <- function(observed, predicted, quantile) { - assert_input_quantile(observed, predicted, quantile) - if (!any(quantile == 0.5)) { - warning( - "in order to compute the absolute error of the median, `0.5` must be ", - "among the quantiles given. Returning `NA`." - ) - return(NA_real_) - } - if (is.null(dim(predicted))) { - predicted <- matrix(predicted, nrow = 1) - } - predicted <- predicted[, quantile == 0.5] - abs_error_median <- abs(observed - predicted) - return(abs_error_median) -} From 0d42acc49eef7403ce7414215193644411997417 Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Mon, 13 Nov 2023 10:53:46 +0100 Subject: [PATCH 29/49] Add more tests for quantile metrics --- tests/testthat/test-metrics-quantile.R | 102 ++++++++++++++++++++----- 1 file changed, 83 insertions(+), 19 deletions(-) diff --git a/tests/testthat/test-metrics-quantile.R b/tests/testthat/test-metrics-quantile.R index f8f15cf0f..8ff355f02 100644 --- a/tests/testthat/test-metrics-quantile.R +++ b/tests/testthat/test-metrics-quantile.R @@ -1,12 +1,26 @@ -# Input handling =============================================================== +metrics_no_cov <- metrics_quantile[!grepl("coverage", names(metrics_quantile))] +metrics_no_cov_no_ae <- metrics_no_cov[!grepl("ae", names(metrics_no_cov))] observed <- c(1, -15, 22) predicted <- rbind( c(-1, 0, 1, 2, 3), c(-2, 1, 2, 2, 4), - c(-2, 0, 3, 3, 4) + c(-2, 0, 3, 3, 4) ) quantile <- c(0.1, 0.25, 0.5, 0.75, 0.9) +# covidHubUtils test: +y <- c(1, -15, 22) +forecast_quantiles_matrix <- rbind( + c(-1, 0, 1, 2, 3), + c(-2, 1, 2, 2, 4), + c(-2, 0, 3, 3, 4) +) +forecast_quantile_probs <- c(0.1, 0.25, 0.5, 0.75, 0.9) + + +# ============================================================================ # +# Input handling =============================================================== +# ============================================================================ # test_that("Input checking for quantile forecasts works", { # everything correct expect_no_condition( @@ -38,11 +52,12 @@ test_that("Input checking for quantile forecasts works", { ) # observed is a single number and does not have the same length as predicted + # There seems to be an issue with the error message: there is one \n to many + # such that the test fails when executed alone, but works when executed + # together with others. expect_error( scoringutils:::assert_input_quantile(1, predicted, quantile), - "Assertion failed. One of the following must apply: - * check_numeric_vector(predicted): Must be of type 'atomic vector', not 'matrix' - * check_matrix(predicted): Must have exactly 1 rows, but has 3 rows", + "Assertion failed. One of the following must apply:\n * check_numeric_vector(predicted): Must be of type 'atomic vector',\n * not 'matrix'\n * check_matrix(predicted): Must have exactly 1 rows, but has 3 rows", fixed = TRUE ) @@ -54,9 +69,9 @@ test_that("Input checking for quantile forecasts works", { }) -metrics_no_cov <- metrics_quantile[!grepl("coverage", names(metrics_quantile))] -metrics_no_cov_no_ae <- metrics_no_cov[!grepl("ae", names(metrics_no_cov))] - +# ============================================================================ # +# wis ========================================================================== +# ============================================================================ #a test_that("wis works standalone, median only", { y <- c(1, -15, 22) lower <- upper <- predicted_quantile <- c(1, 2, 3) @@ -183,15 +198,6 @@ test_that("`wis()` works 1 interval and median", { expect_identical(actual_wis, expected) }) -# covidHubUtils test: -y <- c(1, -15, 22) -forecast_quantiles_matrix <- rbind( - c(-1, 0, 1, 2, 3), - c(-2, 1, 2, 2, 4), - c(-2, 0, 3, 3, 4) -) -forecast_quantile_probs <- c(0.1, 0.25, 0.5, 0.75, 0.9) - test_that("wis works, 2 intervals and median", { test_data <- data.frame( observed = rep(c(1, -15, 22), times = 5), @@ -309,7 +315,6 @@ test_that("wis is correct, median only - test corresponds to covidHubUtils", { expect_equal(actual_wis, expected) }) - test_that("wis is correct, 1 interval only - test corresponds to covidHubUtils", { forecast_quantiles_matrix <- forecast_quantiles_matrix[, c(1, 5), drop = FALSE] forecast_quantile_probs <- forecast_quantile_probs[c(1, 5)] @@ -389,7 +394,6 @@ test_that("wis is correct, 1 interval only - test corresponds to covidHubUtils", expect_equal(actual_wis, expected) }) - test_that("wis is correct, 2 intervals and median - test corresponds to covidHubUtils", { target_end_dates <- as.Date("2020-01-01") + c(7, 14, 7) horizons <- c("1", "2", "1") @@ -509,6 +513,10 @@ test_that("Quantlie score and interval score yield the same result, weigh = FALS } }) + +# ============================================================================ # +# Quantile score ============================================================= # +# ============================================================================ # test_that("Quantlie score and interval score yield the same result, weigh = TRUE", { observed <- rnorm(10, mean = 1:10) alphas <- c(0.1, 0.5, 0.9) @@ -560,7 +568,63 @@ test_that("wis works with separate results", { }) +# ============================================================================ # +# overprediction, underprediction, dispersion ================================ # +# ============================================================================ # +test_that("wis is the sum of overprediction, underprediction, dispersion", { + wis <- wis( + observed = y, + predicted = forecast_quantiles_matrix, + quantile = forecast_quantile_probs + ) + + d <- dispersion(y, forecast_quantiles_matrix, forecast_quantile_probs) + o <- overprediction(y, forecast_quantiles_matrix, forecast_quantile_probs) + u <- underprediction(y, forecast_quantiles_matrix, forecast_quantile_probs) + + expect_equal(wis, d + o + u) +}) + + +# ============================================================================ # +# `interval_coverage_quantile` =============================================== # +# ============================================================================ # +test_that("interval_coverage_quantile works", { + expect_equal( + interval_coverage_quantile(observed, predicted, quantile, range = 50), + c(TRUE, FALSE, FALSE) + ) +}) + +test_that("interval_coverage_quantile rejects wrong inputs", { + expect_error( + interval_coverage_quantile(observed, predicted, quantile, range = c(50, 0)), + "Assertion on 'range' failed: Must have length 1." + ) +}) + + +# ============================================================================ # +# `interval_coverage_deviation_quantile` ===================================== # +# ============================================================================ # +test_that("interval_coverage_deviation_quantile works", { + existing_ranges <- unique(get_range_from_quantile(quantile)) + expect_equal(existing_ranges, c(80, 50, 0)) + + cov_50 <- interval_coverage_quantile(observed, predicted, quantile, range = c(50)) + cov_80 <- interval_coverage_quantile(observed, predicted, quantile, range = c(80)) + manual <- 0.5 * (cov_50 - 0.5) + 0.5 * (cov_80 - 0.8) + + expect_equal( + interval_coverage_deviation_quantile(observed, predicted, quantile), + manual + ) +}) + + +# ============================================================================ # # `bias_quantile` ============================================================== +# ============================================================================ # test_that("bias_quantile() works as expected", { predicted <- c(1, 2, 3) quantiles <- c(0.1, 0.5, 0.9) From 32357f1f1a4aafd604f73543922ca3d4c2d3794d Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Mon, 13 Nov 2023 14:18:01 +0100 Subject: [PATCH 30/49] Rework existing `add_coverage()` function to work with raw forecasts --- NAMESPACE | 1 + R/add_coverage.R | 78 +++++++++++++++++++++++++++++++++++++++++++ R/summarise_scores.R | 75 ----------------------------------------- R/z_globalVariables.R | 3 ++ man/add_coverage.Rd | 64 ++++++++++++++++++++++------------- 5 files changed, 122 insertions(+), 99 deletions(-) create mode 100644 R/add_coverage.R diff --git a/NAMESPACE b/NAMESPACE index e4ae0d765..bc2a6b542 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -108,6 +108,7 @@ importFrom(data.table,nafill) importFrom(data.table,rbindlist) importFrom(data.table,setDT) importFrom(data.table,setattr) +importFrom(data.table,setcolorder) importFrom(data.table,setnames) importFrom(ggdist,geom_lineribbon) importFrom(ggplot2,.data) diff --git a/R/add_coverage.R b/R/add_coverage.R new file mode 100644 index 000000000..becdbf089 --- /dev/null +++ b/R/add_coverage.R @@ -0,0 +1,78 @@ +#' @title Add Coverage Values to Quantile-Based Forecasts +#' +#' @description Adds interval coverage of central prediction intervals, +#' quantile coverage for predictive quantiles, as well as the deviation between +#' desired and actual coverage to a data.table. Forecasts should be in a +#' quantile format (following the input requirements of `score()`). +#' +#' **Interval coverage** +#' +#' Coverage for a given interval range is defined as the proportion of +#' observations that fall within the corresponding central prediction intervals. +#' Central prediction intervals are symmetric around the median and and formed +#' by two quantiles that denote the lower and upper bound. For example, the 50% +#' central prediction interval is the interval between the 0.25 and 0.75 +#' quantiles of the predictive distribution. +#' +#' The function `add_coverage()` computes the coverage per central prediction +#' interval, so the coverage will always be either `TRUE` (observed value falls +#' within the interval) or `FALSE` (observed value falls outside the interval). +#' You can summarise the coverage values to get the proportion of observations +#' that fall within the central prediction intervals. +#' +#' **Quantile coverage** +#' +#' Quantile coverage for a given quantile is defined as the proportion of +#' observed values that are smaller than the corresponding predictive quantile. +#' For example, the 0.5 quantile coverage is the proportion of observed values +#' that are smaller than the 0.5 quantile of the predictive distribution. +#' +#' **Coverage deviation** +#' +#' The coverage deviation is the difference between the desired coverage and the +#' actual coverage. For example, if the desired coverage is 90% and the actual +#' coverage is 80%, the coverage deviation is -0.1. +#' +#' @inheritParams score +#' @return a data.table with the input and columns "interval_coverage", +#' "interval_coverage_deviation", "quantile_coverage", +#' "quantile_coverage_deviation" added. +#' @importFrom data.table setcolorder +#' @examples +#' library(magrittr) # pipe operator +#' example_quantile %>% +#' add_coverage() +#' @export +#' @keywords scoring +#' @export +add_coverage <- function(data) { + stored_attributes <- get_scoringutils_attributes(data) + data <- validate(data) + data <- remove_na_observed_predicted(data) + forecast_unit <- get_forecast_unit(data) + data_cols <- colnames(data) # store so we can reset column order later + + # what happens if quantiles are not symmetric around the median? + # should things error? Also write tests for that. + interval_data <- quantile_to_interval(data, format = "wide") + interval_data[, interval_coverage := ifelse( + observed <= upper & observed >= lower, + TRUE, + FALSE) + ][, c("lower", "upper", "observed") := NULL] + + data[, range := get_range_from_quantile(quantile)] + + data <- merge(interval_data, data, by = unique(c(forecast_unit, "range"))) + data[, interval_coverage_deviation := interval_coverage - range / 100] + data[, quantile_coverage := observed <= predicted] + data[, quantile_coverage_deviation := quantile_coverage - quantile] + + # reset column order + setcolorder(data, unique(c(data_cols, "range", "interval_coverage", + "interval_coverage_deviation", "quantile_coverage", + "quantile_coverage_deviation"))) + + data <- assign_attributes(data, stored_attributes) + return(data[]) +} diff --git a/R/summarise_scores.R b/R/summarise_scores.R index 40666b1f3..032026402 100644 --- a/R/summarise_scores.R +++ b/R/summarise_scores.R @@ -306,78 +306,3 @@ check_summary_params <- function(scores, } return(relative_skill) } - - - -#' @title Add coverage of central prediction intervals -#' -#' @description Adds a column with the coverage of central prediction intervals -#' to unsummarised scores as produced by [score()] -#' -#' The coverage values that are added are computed according to the values -#' specified in `by`. If, for example, `by = "model"`, then there will be one -#' coverage value for every model and [add_coverage()] will compute the coverage -#' for every model across the values present in all other columns which define -#' the unit of a single forecast. -#' -#' @inheritParams summarise_scores -#' @param by character vector with column names to add the coverage for. -#' @param ranges numeric vector of the ranges of the central prediction intervals -#' for which coverage values shall be added. -#' @return a data.table with unsummarised scores with columns added for the -#' coverage of the central prediction intervals. While the overall data.table -#' is still unsummarised, note that for the coverage columns some level of -#' summary is present according to the value specified in `by`. -#' @examples -#' library(magrittr) # pipe operator -#' score(example_quantile) %>% -#' # add_coverage(by = c("model", "target_type")) %>% -#' summarise_scores(by = c("model", "target_type")) %>% -#' summarise_scores(fun = signif, digits = 2) -#' @export -#' @keywords scoring - -add_coverage <- function(scores, - by = NULL, - ranges = c(50, 90)) { - - stored_attributes <- get_scoringutils_attributes(scores) - if (!is.null(attr(scores, "unsummarised_scores"))) { - scores <- attr(scores, "unsummarised_scores") - } - - if (is.null(by) && !is.null(stored_attributes[["scoringutils_by"]])) { - by <- stored_attributes[["scoringutils_by"]] - } else if (is.null(by)) { - # Need to check this again. - # (mentioned in https://github.com/epiforecasts/scoringutils/issues/346) - by <- get_forecast_unit(scores) - } - - summarised_scores <- summarise_scores( - scores, - by = c(by, "range") - )[range %in% ranges] - - - # create cast formula - cast_formula <- - paste( - paste(by, collapse = "+"), - "~", - "paste0('coverage_', range)" - ) - - coverages <- dcast( - summarised_scores, - value.var = "coverage", - formula = cast_formula - ) - - scores_with_coverage <- merge(scores, coverages, by = by) - scores_with_coverage <- assign_attributes( - scores_with_coverage, stored_attributes - ) - - return(scores_with_coverage[]) -} diff --git a/R/z_globalVariables.R b/R/z_globalVariables.R index 441501932..28bcfb95b 100644 --- a/R/z_globalVariables.R +++ b/R/z_globalVariables.R @@ -30,9 +30,12 @@ globalVariables(c( "identifCol", "Interval_Score", "interval_range", + "interval_coverage", + "interval_coverage_deviation", "overprediction", "underprediction", "quantile_coverage", + "quantile_coverage_deviation", "LogS", "log_score", "lower", diff --git a/man/add_coverage.Rd b/man/add_coverage.Rd index 507db1a4a..d6c82d467 100644 --- a/man/add_coverage.Rd +++ b/man/add_coverage.Rd @@ -1,40 +1,56 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/summarise_scores.R +% Please edit documentation in R/add_coverage.R \name{add_coverage} \alias{add_coverage} -\title{Add coverage of central prediction intervals} +\title{Add Coverage Values to Quantile-Based Forecasts} \usage{ -add_coverage(scores, by = NULL, ranges = c(50, 90)) +add_coverage(data) } \arguments{ -\item{scores}{A data.table of scores as produced by \code{\link[=score]{score()}}.} - -\item{by}{character vector with column names to add the coverage for.} - -\item{ranges}{numeric vector of the ranges of the central prediction intervals -for which coverage values shall be added.} +\item{data}{A data.frame or data.table with predicted and observed values.} } \value{ -a data.table with unsummarised scores with columns added for the -coverage of the central prediction intervals. While the overall data.table -is still unsummarised, note that for the coverage columns some level of -summary is present according to the value specified in \code{by}. +a data.table with the input and columns "interval_coverage", +"interval_coverage_deviation", "quantile_coverage", +"quantile_coverage_deviation" added. } \description{ -Adds a column with the coverage of central prediction intervals -to unsummarised scores as produced by \code{\link[=score]{score()}} +Adds interval coverage of central prediction intervals, +quantile coverage for predictive quantiles, as well as the deviation between +desired and actual coverage to a data.table. Forecasts should be in a +quantile format (following the input requirements of \code{score()}). + +\strong{Interval coverage} + +Coverage for a given interval range is defined as the proportion of +observations that fall within the corresponding central prediction intervals. +Central prediction intervals are symmetric around the median and and formed +by two quantiles that denote the lower and upper bound. For example, the 50\% +central prediction interval is the interval between the 0.25 and 0.75 +quantiles of the predictive distribution. + +The function \code{add_coverage()} computes the coverage per central prediction +interval, so the coverage will always be either \code{TRUE} (observed value falls +within the interval) or \code{FALSE} (observed value falls outside the interval). +You can summarise the coverage values to get the proportion of observations +that fall within the central prediction intervals. + +\strong{Quantile coverage} + +Quantile coverage for a given quantile is defined as the proportion of +observed values that are smaller than the corresponding predictive quantile. +For example, the 0.5 quantile coverage is the proportion of observed values +that are smaller than the 0.5 quantile of the predictive distribution. + +\strong{Coverage deviation} -The coverage values that are added are computed according to the values -specified in \code{by}. If, for example, \code{by = "model"}, then there will be one -coverage value for every model and \code{\link[=add_coverage]{add_coverage()}} will compute the coverage -for every model across the values present in all other columns which define -the unit of a single forecast. +The coverage deviation is the difference between the desired coverage and the +actual coverage. For example, if the desired coverage is 90\% and the actual +coverage is 80\%, the coverage deviation is -0.1. } \examples{ library(magrittr) # pipe operator -score(example_quantile) \%>\% - # add_coverage(by = c("model", "target_type")) \%>\% - summarise_scores(by = c("model", "target_type")) \%>\% - summarise_scores(fun = signif, digits = 2) +example_quantile \%>\% + add_coverage() } \keyword{scoring} From 1be9055777434c542fa72cdde8e7e0bb0e36ce6b Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Mon, 13 Nov 2023 14:19:54 +0100 Subject: [PATCH 31/49] Update News --- NEWS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/NEWS.md b/NEWS.md index 322b2b25d..a00ab7f95 100644 --- a/NEWS.md +++ b/NEWS.md @@ -22,6 +22,7 @@ The update introduces a lot of breaking changes. If you want to keep using the o - `quantile`: numeric, a vector with quantile-levels. Can alternatively be a matrix of the same shape as `predicted`. - `check_forecasts()` was replaced by a new function `validate()`. `validate()` validates the input and in that sense fulfills the purpose of `check_forecasts()`. It has different methods: `validate.default()` assigns the input a class based on their forecast type. Other methods validate the input specifically for the various forecast types. - The functionality for computing pairwise comparisons was now split from `summarise_scores()`. Instead of doing pairwise comparisons as part of summarising scores, a new function, `add_pairwise_comparison()`, was introduced that takes summarised scores as an input and adds pairwise comparisons to it. +- `add_coverage()` was reworked completely. It's new purpose is now to add coverage information to the raw forecast data (essentially fulfilling some of the functionality that was previously covered by `score_quantile()`) - The function `find_duplicates()` was renamed to `get_duplicate_forecasts()` - Changes to `avail_forecasts()` and `plot_avail_forecasts()`: - The function `avail_forecasts()` was renamed to `available_forecasts()` for consistency with `available_metrics()`. The old function, `avail_forecasts()` is still available as an alias, but will be removed in the future. From 8719dbe88f6d4ee96e3ef1045b1cca0439acadfa Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Mon, 13 Nov 2023 15:10:15 +0100 Subject: [PATCH 32/49] Update `get_protetcted_columns()` with coverage columns --- R/get_-functions.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/get_-functions.R b/R/get_-functions.R index 22aaa47a9..b55e1ef4f 100644 --- a/R/get_-functions.R +++ b/R/get_-functions.R @@ -193,6 +193,8 @@ get_protected_columns <- function(data = NULL) { protected_columns <- c( "predicted", "observed", "sample_id", "quantile", "upper", "lower", "pit_value", "range", "boundary", "relative_skill", "scaled_rel_skill", + "interval_coverage", "interval_coverage_deviation", + "quantile_coverage", "quantile_coverage_deviation", available_metrics(), grep("coverage_", names(data), fixed = TRUE, value = TRUE) ) From 1252e1335747a1d75e6079695545bab097a00218 Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Mon, 13 Nov 2023 15:56:17 +0100 Subject: [PATCH 33/49] Update `quantile_to_interval.data.frame()` to work with NA values --- R/utils_data_handling.R | 4 +++ tests/testthat/test-utils_data_handling.R | 30 ++++++++++++++++++----- 2 files changed, 28 insertions(+), 6 deletions(-) diff --git a/R/utils_data_handling.R b/R/utils_data_handling.R index f1dc27201..66849e2cc 100644 --- a/R/utils_data_handling.R +++ b/R/utils_data_handling.R @@ -230,6 +230,10 @@ quantile_to_interval.data.frame <- function(dt, if (format == "wide") { delete_columns(dt, "quantile") dt <- dcast(dt, ... ~ boundary, value.var = "predicted") + # if there are NA values in `predicted`, this introduces a column "NA" + if ("NA" %in% colnames(dt) && all(is.na(dt[["NA"]]))) { + dt[, "NA" := NULL] + } } return(dt[]) } diff --git a/tests/testthat/test-utils_data_handling.R b/tests/testthat/test-utils_data_handling.R index e627485ab..4521c1f73 100644 --- a/tests/testthat/test-utils_data_handling.R +++ b/tests/testthat/test-utils_data_handling.R @@ -22,7 +22,7 @@ test_that("range_long_to_quantile works", { -test_that("quantile_to_interval works", { +test_that("quantile_to_interval.data.frame() works", { quantile <- data.frame( date = as.Date("2020-01-01") + 1:10, model = "model1", @@ -30,7 +30,6 @@ test_that("quantile_to_interval works", { predicted = c(2:11, 4:13), quantile = rep(c(0.25, 0.75), each = 10) ) - long <- data.frame( date = as.Date("2020-01-01") + 1:10, model = "model1", @@ -39,19 +38,38 @@ test_that("quantile_to_interval works", { range = 50, boundary = rep(c("lower", "upper"), each = 10) ) - long2 <- as.data.frame(quantile_to_interval( quantile, keep_quantile_col = FALSE )) - data.table::setcolorder(long2, names(long)) - # for some reason this is needed to pass the unit tests on gh actions long2$boundary <- as.character(long2$boundary) long$boundary <- as.character(long$boundary) - expect_equal(long, as.data.frame(long2)) + + # check that it handles NA values + setDT(quantile) + quantile[c(1, 3, 11, 13), c("observed", "predicted", "quantile") := NA] + # in this instance, a problem appears because there is an NA value both + # for the upper and lower bound. + expect_message( + quantile_to_interval( + quantile, + keep_quantile_col = FALSE, + format = "wide" + ), + "Aggregate function missing, defaulting to 'length'" + ) + quantile <- quantile[-c(1, 3), ] + wide2 <- scoringutils:::quantile_to_interval( + quantile, + keep_quantile_col = FALSE, + format = "wide" + ) + expect_equal(nrow(wide2), 10) + expect_true(!("NA") %in% colnames(wide2)) + expect_equal(sum(wide2$lower, na.rm = TRUE), 59) }) From 3af9fff05dbe76b4586bf04432a64da7ce1a8ebf Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Mon, 13 Nov 2023 15:58:29 +0100 Subject: [PATCH 34/49] Don't remove NA values in `add_coverage()` anymore --- R/add_coverage.R | 1 - 1 file changed, 1 deletion(-) diff --git a/R/add_coverage.R b/R/add_coverage.R index becdbf089..7aeac496b 100644 --- a/R/add_coverage.R +++ b/R/add_coverage.R @@ -48,7 +48,6 @@ add_coverage <- function(data) { stored_attributes <- get_scoringutils_attributes(data) data <- validate(data) - data <- remove_na_observed_predicted(data) forecast_unit <- get_forecast_unit(data) data_cols <- colnames(data) # store so we can reset column order later From 02c4b1c60c999e25fcdef7727d7a07d50c3d40ce Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Mon, 13 Nov 2023 16:52:44 +0100 Subject: [PATCH 35/49] Update `add_coverage` to store an attribute `metric_names` with the name of the coverage columns --- R/add_coverage.R | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/R/add_coverage.R b/R/add_coverage.R index 7aeac496b..684556026 100644 --- a/R/add_coverage.R +++ b/R/add_coverage.R @@ -68,10 +68,16 @@ add_coverage <- function(data) { data[, quantile_coverage_deviation := quantile_coverage - quantile] # reset column order - setcolorder(data, unique(c(data_cols, "range", "interval_coverage", - "interval_coverage_deviation", "quantile_coverage", - "quantile_coverage_deviation"))) + new_metrics <- c("interval_coverage", "interval_coverage_deviation", + "quantile_coverage", "quantile_coverage_deviation") + setcolorder(data, unique(c(data_cols, "range", new_metrics))) + # add coverage "metrics" to list of stored metrics + # this makes it possible to use `summarise_scores()` later on + stored_attributes[["metric_names"]] <- c( + stored_attributes[["metric_names"]], + new_metrics + ) data <- assign_attributes(data, stored_attributes) return(data[]) } From b41d6554908644519791b28e068ce44631e3ff07 Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Mon, 13 Nov 2023 16:58:55 +0100 Subject: [PATCH 36/49] Update tests and code snippets to get stuff working again that was previously failing due to `add_coverage()` --- R/plot.R | 2 +- README.Rmd | 2 +- .../plot-interval-coverage.svg | 20 ++- .../plot-quantile-coverage.svg | 20 ++- .../plot_ranges/plot-ranges-dispersion.svg | 154 ++++++++--------- .../plot_ranges/plot-ranges-interval.svg | 156 +++++++++--------- tests/testthat/setup.R | 6 +- tests/testthat/test-add_coverage.R | 44 ++--- tests/testthat/test-metrics-quantile.R | 2 - tests/testthat/test-plot_interval_coverage.R | 18 +- tests/testthat/test-plot_quantile_coverage.R | 18 +- tests/testthat/test-plot_ranges.R | 43 ++--- tests/testthat/test-score.R | 3 - vignettes/scoringutils.Rmd | 3 +- 14 files changed, 239 insertions(+), 252 deletions(-) diff --git a/R/plot.R b/R/plot.R index 59f0f6eca..84ae33eb1 100644 --- a/R/plot.R +++ b/R/plot.R @@ -613,7 +613,7 @@ plot_interval_coverage <- function(scores, colour = "grey", linetype = "dashed" ) + - geom_line(aes(y = coverage * 100)) + + geom_line(aes(y = interval_coverage * 100)) + theme_scoringutils() + ylab("% Obs inside interval") + xlab("Nominal interval coverage") + diff --git a/README.Rmd b/README.Rmd index 77584d145..0c4c41223 100644 --- a/README.Rmd +++ b/README.Rmd @@ -91,8 +91,8 @@ Forecasts can be easily and quickly scored using the `score()` function. `score( example_quantile %>% set_forecast_unit(c("location", "target_end_date", "target_type", "horizon", "model")) %>% validate() %>% + add_coverage() %>% score() %>% - add_coverage(ranges = c(50, 90), by = c("model", "target_type")) %>% summarise_scores( by = c("model", "target_type") ) %>% diff --git a/tests/testthat/_snaps/plot_interval_coverage/plot-interval-coverage.svg b/tests/testthat/_snaps/plot_interval_coverage/plot-interval-coverage.svg index 548878c34..91848b1dd 100644 --- a/tests/testthat/_snaps/plot_interval_coverage/plot-interval-coverage.svg +++ b/tests/testthat/_snaps/plot_interval_coverage/plot-interval-coverage.svg @@ -57,15 +57,17 @@ 100 Nominal interval coverage % Obs inside interval -model - - - - -EuroCOVIDhub-baseline -EuroCOVIDhub-ensemble -UMass-MechBayes -epiforecasts-EpiNow2 +model + + + + + +EuroCOVIDhub-baseline +EuroCOVIDhub-ensemble +UMass-MechBayes +epiforecasts-EpiNow2 +NA plot_interval_coverage diff --git a/tests/testthat/_snaps/plot_quantile_coverage/plot-quantile-coverage.svg b/tests/testthat/_snaps/plot_quantile_coverage/plot-quantile-coverage.svg index bf686eedb..76808cc67 100644 --- a/tests/testthat/_snaps/plot_quantile_coverage/plot-quantile-coverage.svg +++ b/tests/testthat/_snaps/plot_quantile_coverage/plot-quantile-coverage.svg @@ -57,15 +57,17 @@ 1.00 Quantile % Obs below quantile -model - - - - -EuroCOVIDhub-baseline -EuroCOVIDhub-ensemble -UMass-MechBayes -epiforecasts-EpiNow2 +model + + + + + +EuroCOVIDhub-baseline +EuroCOVIDhub-ensemble +UMass-MechBayes +epiforecasts-EpiNow2 +NA plot_quantile_coverage diff --git a/tests/testthat/_snaps/plot_ranges/plot-ranges-dispersion.svg b/tests/testthat/_snaps/plot_ranges/plot-ranges-dispersion.svg index 812e1600f..4ad667f8a 100644 --- a/tests/testthat/_snaps/plot_ranges/plot-ranges-dispersion.svg +++ b/tests/testthat/_snaps/plot_ranges/plot-ranges-dispersion.svg @@ -25,42 +25,42 @@ - - - - - - - - - - - + - - - - - - - - - - + - - - - - - - - - - - + - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -82,54 +82,54 @@ - - - - - - - - - - - + - - - - - - - - - - + + - - - - - - - - - - - + - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/testthat/_snaps/plot_ranges/plot-ranges-interval.svg b/tests/testthat/_snaps/plot_ranges/plot-ranges-interval.svg index 15c9ee3e3..98a9a883c 100644 --- a/tests/testthat/_snaps/plot_ranges/plot-ranges-interval.svg +++ b/tests/testthat/_snaps/plot_ranges/plot-ranges-interval.svg @@ -25,42 +25,42 @@ - - - - - - - - - - - + - - - - - - - - - - + - - - - - - - - - - - + - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -82,54 +82,54 @@ - - - - - - - - - - - + - - - - - - - - - - + + - - - - - - - - - - - + - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -203,7 +203,7 @@ model -interval_score +wis 0 25 diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R index ac7057386..a236f299d 100644 --- a/tests/testthat/setup.R +++ b/tests/testthat/setup.R @@ -3,7 +3,11 @@ library(ggplot2, quietly = TRUE) library(data.table) suppressMessages(library(magrittr)) -# compute quantile scores +metrics_no_cov <- metrics_quantile[!grepl("coverage", names(metrics_quantile))] +metrics_no_cov_no_ae <- metrics_no_cov[!grepl("ae", names(metrics_no_cov))] + + +# compute scores scores_quantile <- suppressMessages(score(example_quantile)) scores_continuous <- suppressMessages(score(data = example_continuous)) scores_point <- suppressMessages(score(example_point)) diff --git a/tests/testthat/test-add_coverage.R b/tests/testthat/test-add_coverage.R index 50d97e81a..689b8640b 100644 --- a/tests/testthat/test-add_coverage.R +++ b/tests/testthat/test-add_coverage.R @@ -1,31 +1,13 @@ -# ex_coverage <- scores_quantile[model == "EuroCOVIDhub-ensemble"] -# -# test_that("add_coverage() works as expected", { -# expect_error( -# add_coverage(ex_coverage, by = c("model", "target_type"), range = c()) -# ) -# expect_error( -# add_coverage(ex_coverage, by = c("model", "target_type")), NA -# ) -# cov <- add_coverage( -# scores_quantile, by = c("model", "target_type"), range = c(10, 20) -# ) -# expect_equal( -# grep("coverage_", colnames(cov), value = TRUE), -# c("coverage_deviation", "coverage_10", "coverage_20") -# ) -# }) -# -# -# test_that("Order of `add_coverage()` and `summarise_scores()` doesn't matter", { -# # Need to update test. Turns out the order does matter... -# # see https://github.com/epiforecasts/scoringutils/issues/367 -# pw1 <- add_coverage(ex_coverage, by = "model") -# pw1_sum <- summarise_scores(pw1, by = "model") -# -# pw2 <- summarise_scores(ex_coverage, by = "model") -# pw2 <- add_coverage(pw2) -# -# # expect_true(all(pw1_sum == pw2, na.rm = TRUE)) -# # expect_true(all(names(attributes(pw2)) == names(attributes(pw1_sum)))) -# }) +ex_coverage <- example_quantile[model == "EuroCOVIDhub-ensemble"] + +test_that("add_coverage() works as expected", { + expect_no_condition(cov <- add_coverage(example_quantile)) + + required_names <- c( + "range", "interval_coverage", "interval_coverage_deviation", + "quantile_coverage", "quantile_coverage_deviation" + ) + expect_equal(colnames(cov), c(colnames(example_quantile), required_names)) + + expect_equal(nrow(cov), nrow(example_quantile)) +}) diff --git a/tests/testthat/test-metrics-quantile.R b/tests/testthat/test-metrics-quantile.R index 8ff355f02..8dd6d6a22 100644 --- a/tests/testthat/test-metrics-quantile.R +++ b/tests/testthat/test-metrics-quantile.R @@ -1,5 +1,3 @@ -metrics_no_cov <- metrics_quantile[!grepl("coverage", names(metrics_quantile))] -metrics_no_cov_no_ae <- metrics_no_cov[!grepl("ae", names(metrics_no_cov))] observed <- c(1, -15, 22) predicted <- rbind( c(-1, 0, 1, 2, 3), diff --git a/tests/testthat/test-plot_interval_coverage.R b/tests/testthat/test-plot_interval_coverage.R index 49649e090..0e885219f 100644 --- a/tests/testthat/test-plot_interval_coverage.R +++ b/tests/testthat/test-plot_interval_coverage.R @@ -1,10 +1,8 @@ -library(ggplot2, quietly = TRUE) - -# test_that("plot_interval_coverage() works as expected", { -# scores <- -# summarise_scores(scores_quantile, by = c("model", "range")) -# p <- plot_interval_coverage(scores) -# expect_s3_class(p, "ggplot") -# skip_on_cran() -# vdiffr::expect_doppelganger("plot_interval_coverage", p) -# }) +test_that("plot_interval_coverage() works as expected", { + coverage <- add_coverage(example_quantile) |> + summarise_scores(by = c("model", "range")) + p <- plot_interval_coverage(coverage) + expect_s3_class(p, "ggplot") + skip_on_cran() + suppressWarnings(vdiffr::expect_doppelganger("plot_interval_coverage", p)) +}) diff --git a/tests/testthat/test-plot_quantile_coverage.R b/tests/testthat/test-plot_quantile_coverage.R index 84b91157f..060b9be26 100644 --- a/tests/testthat/test-plot_quantile_coverage.R +++ b/tests/testthat/test-plot_quantile_coverage.R @@ -1,9 +1,9 @@ -# test_that("plot_quantile_coverage() works as expected", { -# scores <- suppressMessages( -# summarise_scores(scores_quantile, by = c("model", "quantile")) -# ) -# p <- plot_quantile_coverage(scores) -# expect_s3_class(p, "ggplot") -# skip_on_cran() -# vdiffr::expect_doppelganger("plot_quantile_coverage", p) -# }) +test_that("plot_quantile_coverage() works as expected", { + coverage <- add_coverage(example_quantile) |> + summarise_scores(by = c("model", "quantile")) + + p <- plot_quantile_coverage(coverage) + expect_s3_class(p, "ggplot") + skip_on_cran() + suppressWarnings(vdiffr::expect_doppelganger("plot_quantile_coverage", p)) +}) diff --git a/tests/testthat/test-plot_ranges.R b/tests/testthat/test-plot_ranges.R index fad3c8095..b4dec124e 100644 --- a/tests/testthat/test-plot_ranges.R +++ b/tests/testthat/test-plot_ranges.R @@ -1,19 +1,24 @@ -# sum_scores <- suppressMessages( -# summarise_scores(scores_quantile, by = c("model", "target_type", "range")) -# ) -# -# test_that("plot_ranges() works as expected with interval score", { -# p <- plot_ranges(sum_scores, x = "model") + -# facet_wrap(~target_type, scales = "free") -# expect_s3_class(p, "ggplot") -# skip_on_cran() -# vdiffr::expect_doppelganger("plot_ranges_interval", p) -# }) -# -# test_that("plot_ranges() works as expected with dispersion", { -# p <- plot_ranges(sum_scores, y = "dispersion", x = "model") + -# facet_wrap(~target_type) -# expect_s3_class(p, "ggplot") -# skip_on_cran() -# vdiffr::expect_doppelganger("plot_ranges_dispersion", p) -# }) +m <- modifyList(metrics_no_cov_no_ae, list("bias" = NULL)) + +sum_scores <- copy(example_quantile) %>% + .[, interval_range := scoringutils:::get_range_from_quantile(quantile)] |> + score(metrics = m) |> + summarise_scores(by = c("model", "target_type", "interval_range")) + +sum_scores[, range := interval_range] + +test_that("plot_ranges() works as expected with interval score", { + p <- plot_ranges(sum_scores, x = "model") + + facet_wrap(~target_type, scales = "free") + expect_s3_class(p, "ggplot") + skip_on_cran() + suppressWarnings(vdiffr::expect_doppelganger("plot_ranges_interval", p)) +}) + +test_that("plot_ranges() works as expected with dispersion", { + p <- plot_ranges(sum_scores, y = "dispersion", x = "model") + + facet_wrap(~target_type) + expect_s3_class(p, "ggplot") + skip_on_cran() + suppressWarnings(vdiffr::expect_doppelganger("plot_ranges_dispersion", p)) +}) diff --git a/tests/testthat/test-score.R b/tests/testthat/test-score.R index 6252c12c8..5e8e76083 100644 --- a/tests/testthat/test-score.R +++ b/tests/testthat/test-score.R @@ -1,6 +1,3 @@ -metrics_no_cov <- metrics_quantile[!grepl("coverage", names(metrics_quantile))] -metrics_no_cov_no_ae <- metrics_no_cov[!grepl("ae", names(metrics_no_cov))] - # common error handling -------------------------------------------------------- test_that("function throws an error if data is missing", { expect_error(suppressMessages(score(data = NULL))) diff --git a/vignettes/scoringutils.Rmd b/vignettes/scoringutils.Rmd index 6411fad70..4f6989834 100644 --- a/vignettes/scoringutils.Rmd +++ b/vignettes/scoringutils.Rmd @@ -399,8 +399,7 @@ example_integer %>% sample_to_quantile( quantiles = c(0.01, 0.025, seq(0.05, 0.95, 0.05), 0.975, 0.99) ) %>% - score() # %>% - # add_coverage(by = c("model", "target_type")) + score() ``` ## Available metrics From 79fc5333e676209b4a31041e70af24688b9fd646 Mon Sep 17 00:00:00 2001 From: GitHub Action Date: Mon, 13 Nov 2023 16:03:19 +0000 Subject: [PATCH 37/49] Automatic readme update --- README.md | 55 +++++++++++++++++++++++++++++++------------------------ 1 file changed, 31 insertions(+), 24 deletions(-) diff --git a/README.md b/README.md index 2b0e1d1f9..0a5f93881 100644 --- a/README.md +++ b/README.md @@ -129,8 +129,8 @@ details. Finally we summarise these scores by model and target type. example_quantile %>% set_forecast_unit(c("location", "target_end_date", "target_type", "horizon", "model")) %>% validate() %>% + add_coverage() %>% score() %>% - add_coverage(ranges = c(50, 90), by = c("model", "target_type")) %>% summarise_scores( by = c("model", "target_type") ) %>% @@ -144,15 +144,15 @@ example_quantile %>% kable() ``` -| model | target_type | interval_score | dispersion | underprediction | overprediction | coverage_deviation | bias | ae_median | coverage_50 | coverage_90 | relative_skill | scaled_rel_skill | -|:----------------------|:------------|---------------:|-----------:|----------------:|---------------:|-------------------:|--------:|----------:|------------:|------------:|---------------:|-----------------:| -| EuroCOVIDhub-baseline | Cases | 28000 | 4100 | 10000.0 | 14000.0 | -0.110 | 0.0980 | 38000 | 0.33 | 0.82 | 1.30 | 1.6 | -| EuroCOVIDhub-baseline | Deaths | 160 | 91 | 2.1 | 66.0 | 0.120 | 0.3400 | 230 | 0.66 | 1.00 | 2.30 | 3.8 | -| EuroCOVIDhub-ensemble | Cases | 18000 | 3700 | 4200.0 | 10000.0 | -0.098 | -0.0560 | 24000 | 0.39 | 0.80 | 0.82 | 1.0 | -| EuroCOVIDhub-ensemble | Deaths | 41 | 30 | 4.1 | 7.1 | 0.200 | 0.0730 | 53 | 0.88 | 1.00 | 0.60 | 1.0 | -| UMass-MechBayes | Deaths | 53 | 27 | 17.0 | 9.0 | -0.023 | -0.0220 | 78 | 0.46 | 0.88 | 0.75 | 1.3 | -| epiforecasts-EpiNow2 | Cases | 21000 | 5700 | 3300.0 | 12000.0 | -0.067 | -0.0790 | 28000 | 0.47 | 0.79 | 0.95 | 1.2 | -| epiforecasts-EpiNow2 | Deaths | 67 | 32 | 16.0 | 19.0 | -0.043 | -0.0051 | 100 | 0.42 | 0.91 | 0.98 | 1.6 | +| model | target_type | wis | overprediction | underprediction | dispersion | bias | coverage_50 | coverage_90 | coverage_deviation | ae_median | relative_skill | scaled_rel_skill | +|:----------------------|:------------|------:|---------------:|----------------:|-----------:|--------:|------------:|------------:|-------------------:|----------:|---------------:|-----------------:| +| EuroCOVIDhub-baseline | Cases | 28000 | 14000.0 | 10000.0 | 4100 | 0.0980 | 0.33 | 0.82 | -0.120 | 38000 | 1.30 | 1.6 | +| EuroCOVIDhub-baseline | Deaths | 160 | 66.0 | 2.1 | 91 | 0.3400 | 0.66 | 1.00 | 0.120 | 230 | 2.30 | 3.8 | +| EuroCOVIDhub-ensemble | Cases | 18000 | 10000.0 | 4200.0 | 3700 | -0.0560 | 0.39 | 0.80 | -0.100 | 24000 | 0.82 | 1.0 | +| EuroCOVIDhub-ensemble | Deaths | 41 | 7.1 | 4.1 | 30 | 0.0730 | 0.88 | 1.00 | 0.200 | 53 | 0.60 | 1.0 | +| UMass-MechBayes | Deaths | 53 | 9.0 | 17.0 | 27 | -0.0220 | 0.46 | 0.88 | -0.025 | 78 | 0.75 | 1.3 | +| epiforecasts-EpiNow2 | Cases | 21000 | 12000.0 | 3300.0 | 5700 | -0.0790 | 0.47 | 0.79 | -0.070 | 28000 | 0.95 | 1.2 | +| epiforecasts-EpiNow2 | Deaths | 67 | 19.0 | 16.0 | 32 | -0.0051 | 0.42 | 0.91 | -0.045 | 100 | 0.98 | 1.6 | `scoringutils` contains additional functionality to transform forecasts, to summarise scores at different levels, to visualise them, and to @@ -174,20 +174,27 @@ example_quantile %>% score %>% summarise_scores(by = c("model", "target_type", "scale")) %>% head() -#> model target_type scale interval_score dispersion -#> 1: EuroCOVIDhub-baseline Cases log 1.169972e+00 0.4373146 -#> 2: EuroCOVIDhub-baseline Cases natural 2.209046e+04 4102.5009443 -#> 3: EuroCOVIDhub-ensemble Cases log 5.500974e-01 0.1011850 -#> 4: EuroCOVIDhub-ensemble Cases natural 1.155071e+04 3663.5245788 -#> 5: epiforecasts-EpiNow2 Cases log 6.005778e-01 0.1066329 -#> 6: epiforecasts-EpiNow2 Cases natural 1.443844e+04 5664.3779484 -#> underprediction overprediction coverage_deviation bias ae_median -#> 1: 3.521964e-01 0.3804607 -0.10940217 0.09726562 1.185905e+00 -#> 2: 1.028497e+04 7702.9836957 -0.10940217 0.09726562 3.208048e+04 -#> 3: 1.356563e-01 0.3132561 -0.09785326 -0.05640625 7.410484e-01 -#> 4: 4.237177e+03 3650.0047554 -0.09785326 -0.05640625 1.770795e+04 -#> 5: 1.858699e-01 0.3080750 -0.06660326 -0.07890625 7.656591e-01 -#> 6: 3.260356e+03 5513.7058424 -0.06660326 -0.07890625 2.153070e+04 +#> model target_type scale wis overprediction +#> 1: EuroCOVIDhub-ensemble Cases natural 11550.70664 3650.004755 +#> 2: EuroCOVIDhub-baseline Cases natural 22090.45747 7702.983696 +#> 3: epiforecasts-EpiNow2 Cases natural 14438.43943 5513.705842 +#> 4: EuroCOVIDhub-ensemble Deaths natural 41.42249 7.138247 +#> 5: EuroCOVIDhub-baseline Deaths natural 159.40387 65.899117 +#> 6: UMass-MechBayes Deaths natural 52.65195 8.978601 +#> underprediction dispersion bias coverage_50 coverage_90 +#> 1: 4237.177310 3663.52458 -0.05640625 0.3906250 0.8046875 +#> 2: 10284.972826 4102.50094 0.09726562 0.3281250 0.8203125 +#> 3: 3260.355639 5664.37795 -0.07890625 0.4687500 0.7890625 +#> 4: 4.103261 30.18099 0.07265625 0.8750000 1.0000000 +#> 5: 2.098505 91.40625 0.33906250 0.6640625 1.0000000 +#> 6: 16.800951 26.87239 -0.02234375 0.4609375 0.8750000 +#> coverage_deviation ae_median +#> 1: -0.10230114 17707.95312 +#> 2: -0.11437500 32080.48438 +#> 3: -0.06963068 21530.69531 +#> 4: 0.20380682 53.13281 +#> 5: 0.12142045 233.25781 +#> 6: -0.02488636 78.47656 ``` ## Citation From f7faff2f3d9e4ff8701499b94d8016737f1dee70 Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Tue, 14 Nov 2023 13:50:17 +0100 Subject: [PATCH 38/49] horrible, but working version of a refactoring of score.scoringutils_quantile --- R/score.R | 42 +++++++++++++++++++++++++++++++----------- 1 file changed, 31 insertions(+), 11 deletions(-) diff --git a/R/score.R b/R/score.R index 7ec7763e3..67efd5126 100644 --- a/R/score.R +++ b/R/score.R @@ -263,18 +263,21 @@ score.scoringutils_quantile <- function(data, metrics = metrics_quantile, ...) { quantile <- unlist(unique(data$quantile)) data[, c("observed", "predicted", "quantile", "scoringutils_quantile") := NULL] - # for each metric, compute score - lapply(seq_along(metrics), function(i, ...) { - metric_name <- names(metrics[i]) - fun <- metrics[[i]] - matching_args <- filter_function_args(fun, args) - - data[, eval(metric_name) := do.call( - fun, c(list(observed), list(predicted), list(quantile), matching_args) + expr <- expression( + data[, (metric_name) := do.call( + fun, c(list(args$internal_first_arg, + args$internal_second_arg, + args$interal_third_arg), + matching_args) )] - return() - }, - ...) + ) + + data <- apply_metrics( + data, metrics, expr, + internal_first_arg = observed, + internal_second_arg = predicted, + interal_third_arg = quantile, + ...) return(data) }) @@ -283,3 +286,20 @@ score.scoringutils_quantile <- function(data, metrics = metrics_quantile, ...) { return(data[]) } + +apply_metrics <- function(data, metrics, expr, ...) { + args <- list(...) + lapply(seq_along(metrics), function(i, data, args) { + + metric_name <- names(metrics[i]) + fun <- metrics[[i]] + matching_args <- filter_function_args(fun, args) + + eval(expr) + + }, data, args) + return(data) +} + + + From cb9bcbe0f95b353943f6a7a59849053698f4ea7c Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Tue, 14 Nov 2023 14:18:51 +0100 Subject: [PATCH 39/49] More elegant version, currently failing for sample-based forecasts because we can't pass the `forecast_unit` arg to apply_metrics --- R/score.R | 75 +++++++++++++++++++------------------------------------ 1 file changed, 26 insertions(+), 49 deletions(-) diff --git a/R/score.R b/R/score.R index 67efd5126..d31800ba0 100644 --- a/R/score.R +++ b/R/score.R @@ -152,18 +152,15 @@ score.scoringutils_binary <- function(data, metrics = metrics_binary, ...) { data <- remove_na_observed_predicted(data) metrics <- validate_metrics(metrics) - # Extract the arguments passed in ... - args <- list(...) - lapply(seq_along(metrics), function(i, ...) { - metric_name <- names(metrics[i]) - fun <- metrics[[i]] - matching_args <- filter_function_args(fun, args) - + expr <- expression( data[, (metric_name) := do.call( - fun, c(list(observed, predicted), matching_args) + run_safely, list(observed, predicted, ..., fun = fun) )] - return() - }, ...) + ) + data <- apply_metrics( + data, metrics, expr, + ... + ) setattr(data, "metric_names", names(metrics)) @@ -180,18 +177,15 @@ score.scoringutils_point <- function(data, metrics = metrics_point, ...) { data <- remove_na_observed_predicted(data) metrics <- validate_metrics(metrics) - # Extract the arguments passed in ... - args <- list(...) - lapply(seq_along(metrics), function(i, ...) { - metric_name <- names(metrics[i]) - fun <- metrics[[i]] - matching_args <- filter_function_args(fun, args) - + expr <- expression( data[, (metric_name) := do.call( - fun, c(list(observed, predicted), matching_args) + run_safely, list(observed, predicted, ..., fun = fun) )] - return() - }, ...) + ) + data <- apply_metrics( + data, metrics, expr, + ... + ) setattr(data, "metric_names", names(metrics)) @@ -206,19 +200,15 @@ score.scoringutils_sample <- function(data, metrics = metrics_sample, ...) { forecast_unit <- attr(data, "forecast_unit") metrics <- validate_metrics(metrics) - # Extract the arguments passed in ... - args <- list(...) - lapply(seq_along(metrics), function(i, ...) { - metric_name <- names(metrics[i]) - fun <- metrics[[i]] - matching_args <- filter_function_args(fun, args) - + expr <- expression( data[, (metric_name) := do.call( - fun, c(list(unique(observed), t(predicted)), matching_args) + run_safely, list(observed, predicted, ..., fun = fun) ), by = forecast_unit] - return() - }, - ...) + ) + data <- apply_metrics( + data, metrics, expr, + ... + ) data <- data[ , lapply(.SD, unique), @@ -264,20 +254,12 @@ score.scoringutils_quantile <- function(data, metrics = metrics_quantile, ...) { data[, c("observed", "predicted", "quantile", "scoringutils_quantile") := NULL] expr <- expression( - data[, (metric_name) := do.call( - fun, c(list(args$internal_first_arg, - args$internal_second_arg, - args$interal_third_arg), - matching_args) - )] + data[, (metric_name) := do.call(run_safely, list(..., fun = fun))] ) - data <- apply_metrics( data, metrics, expr, - internal_first_arg = observed, - internal_second_arg = predicted, - interal_third_arg = quantile, - ...) + observed, predicted, quantile, ... + ) return(data) }) @@ -288,16 +270,11 @@ score.scoringutils_quantile <- function(data, metrics = metrics_quantile, ...) { } apply_metrics <- function(data, metrics, expr, ...) { - args <- list(...) - lapply(seq_along(metrics), function(i, data, args) { - + lapply(seq_along(metrics), function(i, data, ...) { metric_name <- names(metrics[i]) fun <- metrics[[i]] - matching_args <- filter_function_args(fun, args) - eval(expr) - - }, data, args) + }, data, ...) return(data) } From 102370d11303dc3e3b9133dc52de58fcdf2f62c3 Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Tue, 14 Nov 2023 14:29:44 +0100 Subject: [PATCH 40/49] Fix score.scoringutils_sample by using matrices --- R/score.R | 41 ++++++++++++++++++++++++----------------- 1 file changed, 24 insertions(+), 17 deletions(-) diff --git a/R/score.R b/R/score.R index d31800ba0..b0f601d8d 100644 --- a/R/score.R +++ b/R/score.R @@ -200,21 +200,31 @@ score.scoringutils_sample <- function(data, metrics = metrics_sample, ...) { forecast_unit <- attr(data, "forecast_unit") metrics <- validate_metrics(metrics) - expr <- expression( - data[, (metric_name) := do.call( - run_safely, list(observed, predicted, ..., fun = fun) - ), by = forecast_unit] - ) - data <- apply_metrics( - data, metrics, expr, - ... - ) + # transpose the forecasts that belong to the same forecast unit + d_transposed <- data[, .(predicted = list(predicted), + observed = unique(observed), + scoringutils_N = length(list(sample_id))), + by = forecast_unit] - data <- data[ - , lapply(.SD, unique), - .SDcols = colnames(data) %like% paste(names(metrics), collapse = "|"), - by = forecast_unit - ] + # split according to number of samples and do calculations for different + # sample lengths separately + d_split <- split(d_transposed, d_transposed$scoringutils_N) + + split_result <- lapply(d_split, function(data) { + # create a matrix + observed <- data$observed + predicted <- do.call(rbind, data$predicted) + data[, c("observed", "predicted", "scoringutils_N") := NULL] + + expr <- expression( + data[, (metric_name) := do.call(run_safely, list(..., fun = fun))] + ) + data <- apply_metrics( + data, metrics, expr, + observed, predicted, ... + ) + return(data) + }) setattr(data, "metric_names", names(metrics)) @@ -230,9 +240,6 @@ score.scoringutils_quantile <- function(data, metrics = metrics_quantile, ...) { forecast_unit <- attr(data, "forecast_unit") metrics <- validate_metrics(metrics) - # Extract the arguments passed in ... - args <- list(...) - # transpose the forecasts that belong to the same forecast unit # make sure the quantiles and predictions are ordered in the same way d_transposed <- data[, .(predicted = list(predicted[order(quantile)]), From 004d2b852d1d03f42110d0b40ab224baca1ce55c Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Tue, 14 Nov 2023 14:52:30 +0100 Subject: [PATCH 41/49] move the expression into `apply_metrics()` --- R/score.R | 35 +++++++++++------------------------ 1 file changed, 11 insertions(+), 24 deletions(-) diff --git a/R/score.R b/R/score.R index b0f601d8d..29230e6e0 100644 --- a/R/score.R +++ b/R/score.R @@ -152,14 +152,9 @@ score.scoringutils_binary <- function(data, metrics = metrics_binary, ...) { data <- remove_na_observed_predicted(data) metrics <- validate_metrics(metrics) - expr <- expression( - data[, (metric_name) := do.call( - run_safely, list(observed, predicted, ..., fun = fun) - )] - ) data <- apply_metrics( - data, metrics, expr, - ... + data, metrics, + data$observed, data$predicted, ... ) setattr(data, "metric_names", names(metrics)) @@ -177,14 +172,9 @@ score.scoringutils_point <- function(data, metrics = metrics_point, ...) { data <- remove_na_observed_predicted(data) metrics <- validate_metrics(metrics) - expr <- expression( - data[, (metric_name) := do.call( - run_safely, list(observed, predicted, ..., fun = fun) - )] - ) data <- apply_metrics( - data, metrics, expr, - ... + data, metrics, + data$observed, data$predicted, ... ) setattr(data, "metric_names", names(metrics)) @@ -216,16 +206,13 @@ score.scoringutils_sample <- function(data, metrics = metrics_sample, ...) { predicted <- do.call(rbind, data$predicted) data[, c("observed", "predicted", "scoringutils_N") := NULL] - expr <- expression( - data[, (metric_name) := do.call(run_safely, list(..., fun = fun))] - ) data <- apply_metrics( - data, metrics, expr, + data, metrics, observed, predicted, ... ) return(data) }) - + data <- rbindlist(split_result) setattr(data, "metric_names", names(metrics)) return(data[]) @@ -260,11 +247,8 @@ score.scoringutils_quantile <- function(data, metrics = metrics_quantile, ...) { quantile <- unlist(unique(data$quantile)) data[, c("observed", "predicted", "quantile", "scoringutils_quantile") := NULL] - expr <- expression( - data[, (metric_name) := do.call(run_safely, list(..., fun = fun))] - ) data <- apply_metrics( - data, metrics, expr, + data, metrics, observed, predicted, quantile, ... ) return(data) @@ -276,7 +260,10 @@ score.scoringutils_quantile <- function(data, metrics = metrics_quantile, ...) { return(data[]) } -apply_metrics <- function(data, metrics, expr, ...) { +apply_metrics <- function(data, metrics, ...) { + expr <- expression( + data[, (metric_name) := do.call(run_safely, list(..., fun = fun))] + ) lapply(seq_along(metrics), function(i, data, ...) { metric_name <- names(metrics[i]) fun <- metrics[[i]] From 7eb7c96300f0344c70d39c939418abb3852c4d80 Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Tue, 14 Nov 2023 16:09:50 +0100 Subject: [PATCH 42/49] Update metrics_quantile (improved error handling + getting rid of `run_safely()` --- NAMESPACE | 1 + R/metrics-quantile.R | 6 ++++++ data/metrics_quantile.rda | Bin 13133 -> 13024 bytes inst/create-list-available-forecasts.R | 4 ++-- 4 files changed, 9 insertions(+), 2 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index bc2a6b542..d3b6ffe22 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -82,6 +82,7 @@ importFrom(checkmate,assert_data_frame) importFrom(checkmate,assert_data_table) importFrom(checkmate,assert_factor) importFrom(checkmate,assert_list) +importFrom(checkmate,assert_logical) importFrom(checkmate,assert_number) importFrom(checkmate,assert_numeric) importFrom(checkmate,check_atomic_vector) diff --git a/R/metrics-quantile.R b/R/metrics-quantile.R index db187d376..985b00002 100644 --- a/R/metrics-quantile.R +++ b/R/metrics-quantile.R @@ -91,6 +91,7 @@ #' @param count_median_twice if TRUE, count the median twice in the score #' @param na.rm if TRUE, ignore NA values when computing the score #' @importFrom stats weighted.mean +#' @importFrom checkmate assert_logical #' @return #' `wis()`: a numeric vector with WIS values of size n (one per observation), #' or a list with separate entries if `separate_results` is `TRUE`. @@ -105,6 +106,11 @@ wis <- function(observed, assert_input_quantile(observed, predicted, quantile) reformatted <- quantile_to_interval(observed, predicted, quantile) + assert_logical(separate_results, len = 1) + assert_logical(weigh, len = 1) + assert_logical(count_median_twice, len = 1) + assert_logical(na.rm, len = 1) + if (separate_results) { cols <- c("wis", "dispersion", "underprediction", "overprediction") } else { diff --git a/data/metrics_quantile.rda b/data/metrics_quantile.rda index 70a00a9329468320b53b2c7e803ec070df6b33a9..b14a8321c408c6e6d9010c2262f0575fa845a9ea 100644 GIT binary patch literal 13024 zcmV<6G9S%CT4*^jL0KkKS;tuSi~!s@|NsC0|NsC0|NsC0|NsC0|NsC0`|!&WF>;(YUfB*mmtXjZPW-oB=-q@f5 zzE71_t4^8vIaLFKsngqnqPe1}@L|_Frnqx_( zLTxk*g*It2YI!q3Fs9Q1Cyf;J!kM%RZ$xTgHj(5fqZ1QTA*R&z8h)v=O{mjPNMIUG z>Vi=a0Wg{aK$tr%6B8zh>S3v-Pez!K)6!^qo~D{? ziHPw=(^G0R(@#+JnrWs@ig<~L$bP1XdLu&u44PyNj88~upc*s{GBRjrGf*N)2nmpw z0Srlrl=Ng_G{~A$^qx&q)6t4;G%4iGQ_~Ts@F)){^&X%!*&{#z000M~0p%Eb$7Y}g0+2yUDXKt2VgINV3-OydX5CCaI>74NDz;w% z%x5Mf9eMKhX>pN*Dy_n z2G5sSL{E)EZOZtVn*oZbWJ2hHkKK{tisnVW!vJUQM+Jlu-PB-Odjc-G~sSARL0 z0W9vnmS>?RLCo+6enk(=n@GKWhSwetL|$&aBFTHt4u3PjnM{Fzz`&JJT8%(5_7v>D zPx8N&{Qqmi#o<8uZ7+5&NFqoC5&(Vz!9f90FwSr}x4X1thX{az=~FM6n&S+#hhxi> znuiAiY1{c&;m?(cXKYh|#~>d3X-VJf()s)u6C zOLV))uVw-M3!5&lG0$SX1@a%5z=y+DcS-sxQNuRFn!DCBdf*4h$uR^O&SV{vBdR+BP zcNSteG}1+9yWtcR(FQP9i^$xP z(LA-YnYPVsm86A9MC*#%8Ochbvo=~G2n<2--PAYH2#hz4tsL(KHFYE;k{WnX8IeE` zzl2Zs~^6{&w|Mo}ScbNbIT#R04XXv<*$Z&rOzJQZy}S@%Ad*NSb3Gyv1P}@= zO6unHSf-ZJ`l6OMd@U=jj;fPK$}qw=pxV-j>C8~HIUC6Zu?TV2XfoOFdnK7$Z6aEcA`&3RB9aI)2_PuD{(G9; zcD=t7&f=fn7YzM>w-@|sz~bLlF_Gm<1y;F|mEO!lwG$BIC6KaGQcjbToj@im0A5r9 zI>%CwLAy$L9aI`el`(|Qys&cmgMeGQ_hB+6{OQzd0M(B(tu5DV3z-Mq`AT^@@1+mE zow6QUWpf8qp>c<;jxhJnxEJ3c&H>B21Cs}5v;%(VO{-f_6MWUYWDr{GT&{ptJ@$3L6o z50d{v9Hae|^3U>lq2~K25%SRU!_Pl*2cG%i^G{r!v^=ND4;eopJW%=}*c*iE&gkk6 z>^{lnCSdl*U~i}THlwa&LDmpABv+tCMfU`RU<8s35JjzKs&xFNmSb#l7G^#za2NO# z)|?X2mtI*tI9>~QI9`-ON~-50?nglhjtKfPv`ric) z8_;7wPm*Om73TjyJ1+<(1k8iLC@*8;^17x)GLZx%krScOPCeZBpK$;18G_f~MjJhR zZ4f=Vx`pNt=~LaT0P=Blx`k(+xF})Q-b}tTyc>7{7r)& zN#d%YdK-<)8pC&_wp@xzdJeLVbMDf6MYgErEP-L^_ddRU|68zph=(S7eMgbhejfG9 zcbg}B)x~PPPRhj_kKR}`3^u$yLBhmPs;!emIG}fE({Da)qmQ2iI$&hl+Fzq2v}Li9 zZFWr7`Pt{$r)zIMo$T;!Jss=2W$W=-*=%;%CZ?>^U&iH8%_cm$9>+!6C(K*i#S|41 z>)~e3zZlhi%+I9N8yhT@ac(n2PFmDsKt%z=Ilc&)5gxX@;kLJ z3ufjwDzB8y7&ev*)$Q0_eTukOa%7Tx?3&Ic)YiY^WPVr~rtEHG+kpAbqKc}b%>_i7 z$f&xV)3p9>p5v-SGia9~2yqZTX9oFV8wDUX0i~*NM0$X_$sCbBaiXSzgUOI06~KO^ z5~f&GFpw*j0D42*+OB%%#Qq5;i=b7~X8n)sdVt?R_N0%(IF zyQi#9kuJw8xw(*cpcalR+D+*0L_TQ}L;&&ND(KvhDFI9K+B?X%0PfB`KY7+Wy3OO| zsgx3GR%%f=pe`zLC6-NHXSc<*hNd9VyGZ6ag8IK_?|PrOwbu0WovoxieucLR^1heS z`d9Zc3$ErJ;v9Sdy)Gw&M^ag3t|coa3&@4^34~!Q;ltELQrZPy79+CVRE8ZOic+j#MHbkXr+@Zq{?)+$ueGN6jO;?k0URc*YV81 zuJ`|)f3Sgcy6=@^E?UDNJ14{SL7j@D*C%|0Od^af-Ph^IWQido8Y5zuJpPIJ{f!*N zjn`toLqW7fRj5-OW5KxbIGbH_o0Q~vEN2VDu@X>viQZ-OKTpB0`frPGF%)Kc6kOsc zHJ1(-a@DjtHu|VMT^=7DtG8vHwi~NyOO?;ZFZXO79Hj27oEjJ+RaLU6i&koErJZ?) zHg1fQlTCrjg_i$&Glc3@X?u<a=-gJ73P+CBfj4{M>||K6MHSuX99WCENoIC9 zW_9ym&0a`x0^?hYhSv$K!9B_{yS({&)vr1Chj#X{9&uKgf?B{1-^@++CGvIEKp)`@-_y@Qt_D69J@WzINBqI)fdbeiT;Ryu33zxkN zmH_W%-9Hog-qXy%{eu@*dY-J|{qFs}r&wu`>6ZsA4WTw1<_~UzrGXJ$6`^^ToK`@n zBfWr1Ed?B3`-g^`G=I?7(}y0j2W9ScZ;dWfx^MSDwoM{A-CW7N#Lsj`V9}M0ej?3t{_a@+$4O!@7svC*} zPC|@89bNUf(?!w{?>EO!F&lf!NsyO_`0=)=Vu1AiKIIDWwv9CGu^c}}l$7~WrKGeP z=H@J2q)%o*+D^>}Vg@<6iP*b?Bll4Pp(Kd#!+Hgv;wFel9Q1a=P08mUuRqz37S4_^ z1?%acuCY}Bgf}sJ~TvZFkWa-A3 zlb3Z09wZYNGan_~=wscY`0-|-ds5@h^nX8dg9JArxsHb18$H`6MlQ@a;wS8(w)(DC zY9sHZ{zj*x%TIlz$+^={b;^j=L0Da01v^Es887vG`<6ByRMy1eZLT#ismra15j!hW zVMK{Qad@lithvN&8$6xUeCwTtd=ur?l-o>E?~*!`co)~QVCfu;cz)vxc0(7%3>@`W|JDwdays0JOjA;O3sTk79q zsSEMYYyNNJY4*o|pFZi3-F4lhha~FLrhL9ScOn}w6R!g|dr#!W;F)}iDjgZg*Trpc z?CX#h1}5qruY-4_+R<@xw-jw(!5$^n4aQji*^9!wZXhVR2(%3{sL7 zX;?^D#WhD5Wzxp-yjL}cI2Co6CoKPiyx|6Ocn;R_M>9e*Yg$vMX7e*6HS7BOit2HW zAk`6-Ak%`mpdN9pA!Dka82GR_*Li9 z?M)T3OR>%b`b zs|`b^lF8EUy!gVxeMH}5AuVKtLlBfAsT3BIK?w#dY4jp|Rb(%N$!U!A!a8sEfa*MV>73&SifAU!92#|Xd3x2h`wl=s#C@u$L_=vt z6_fC!w%K1BLfj~|1}GC!i?ANBCTE1e6KvfJBoO6P5b}ult?QI2e-As@Qt`%%uIw>; z`?gYpqY-F!M~jJY9U3{MKH}jD-sUhTP(uEO6=7gs|EYpt*rcQ)bGGYqT$M#rYi_Bn zyPv#qrv0IWyk=nby?!kywTL{a5we!f2At3oEm#jNA7jPv-+P$C=WCHUi^nG0({+0R z*1O5b{>!;%W4jsAlhWW%D8-#{uqKgpFW|dbqynt~#;Y_I)cJ^&Ht;2=>}{^Ic?+vN zufKTQSx6y9R0BO0Y=VoSLg6rnc8@w4@|SjbmEFpKrc8l|!ji)l=eiDYQcmuWjy*p`h@4w(#9%xAJMyx;Nn*QIP@xXqmhK~nzX2f+go8>gSAed;KI;J(s94#s zk)UW3>x!&imW-3J5iuh16NUlQoKbJry8MRn zMZ!^+j?6oPh(JUaXar{0TIs`p);K2Ai_n7cFavakcgd)HY#qU-BM(Nsx}(^tm5aU!Kt>{SSLrD?AgE-U65)s9wlD(P&P@87kg57^J00oJ~` zzXpp(MPx0ld*b&yt%*{gH>Y=s`a09L`iyE{ zzfc5a5Q$!~8PF*to=nm1i=;b5gzSMdaoDYcc97!hi4>X8!4F?LB=}f}F;K=Hk(TWX zzruL!Jw!R^V7qP=%!iq!o}RS@a?+x1iR&K6;PZQZJ`W&oJ|!LUY;kw|dpA1MiW@Ky zXl^x<`THuYCyu~`DHU=Ps72KGNR`9PZ3T>1sBWkTj89OB^2`PYkc$$bfkecl{0s+H zjk}9J(-1_hQp$ms3KR4rAHCe(p`=<(q#=2_Nc&hxyKnO>A*`tGL>54Fj?fKs2B7a4 zVx{3vP&v%kD73)@FAGs&g)iA{4iq()d8;ow*>*i8bWBU# zQIAo}EB2S+PT1(*WzQMck_Xc!yN^5^k&J40d(+-gDNzX&O%&mXdLnoCaTDxaVsqg+ zRV;wA0K?ifo1EK|dAiK$V^UE`bHIZO427dWsVNZ4t(aU>ispIz#`TSU!Y*wz6qJxT z8fnk=Ryek{*wYwiIU00F4K!YLWtWH8=zMQ^g5vs^&q5AV%|T8D3GZl1#g9dX=S6nn zS>yZ97basqCX7WG;L=2i=6t+({Jc7laU@8cy_VhtA1?HyiRSt``MY>;K=m*=PQ`e! zvzerc5+orQ&PcQ|FqFi(qI=pbW6)gr_L+(7W2M1qSRKb5U~gG!;USjKnZEkJ9i~7y z_#}@wSM;5 zd+YxW>gakN%GmxsAGV(pu4&H?$)7N}iN8^5lW6n{l16DIF6`(+&3(P*Hi)e+x zWh+O@{rB#_ub97Y9QnB$5=KHR;GIzOlvNj+)8EyYg^+X}M2Qjzh?CTNZI4ceZ;-iXc5%lNbB`K0iv`7pNf5bw zg5a?aC&u^xx4+&&!6EA7kcrce7CPNHl1bz|e;6|doGqC2d9JfPXdtiXilhBvj#vST z3JI4$NxXx7i&_ohfbI=Hal%*>0bDZZUtDHH`Ib!efT{^DJG@Er$ z2!K*RA^}MNhy^(COEB9UiYk|HX6e+WUAf6hyiPeXwQH_&ty+64oLX8*G^c+Y^ImR6 zRaVrkS6&{DtxDH}o0h655-AjwT>yzBmF=Q~42BY_fJCu2s_x^JRSe!X!RZ#;A7gpn z-f&}Y0aREZsgyDJP$Ulks`Pr_KdX1ofrQnH^X01Qyq!=F5ItdCcgh4=hrj?E1ov}N zuSLh(d9dmKT^@@MNloC7VOP5Me)FB}eqZ8w%lSS(?|R&fy`K`?Hh#0?wwYy?s-~XJ zHgIt+ODwX>EV9civC%Pm7prT}^Q~IWJ)-}shPvyny6djG>#n>PE@Q!cR`tAB@7=|V z2mStD=MCqo*LvArO$-;8v|q*-bHZ zjT=J_4E&>Trn8cM-FL}f@K|(v>Y9w*Wn}ejH8n2+#?sdcnqW+Qc7J4wp5;}IzB<1l zXe_NVHkR@jks?K{y}i6*K+Zh)qJ5q3SH8nsU7&IAfYYa475j5cjoWg`1QE*|u}Lj~ z%(F1~tMMTHZ`orRU7wj%n^eb6xj9KmNob;|aHQnKLNgPapP#q&AX4kBy9_*YpHHE8 zE@@hH(@ynUZnph?td1uqV!uA)xOye?ANJlya`aCtvGZt}7;H-v5=Sb?s@{j0KPH}k zE5-b;9?SOUcl*2N-=2BqyY40Qu3Yb^^>1RwUJQ6~EJ^2E^Rvd zYO8FjuIh0YL{*>_AGZO2E(aKpPypv@ni$453ZmNx1XNsIw`aFaB5l*WO~dJ(!_&G4 zK5z=f?ghli)sJjJ-q~wKNOZzv$>)=@={6qg$jT7weDQ%qc&3mt;W7zl`{F?SO`DIN zT(71~e>Xp9`z85so-J5M0!eNG6eMj3q#<^A9kxs4>&P7XH`9NW>0jVsSoG}bUny>le%Wz z^ttx*lX*Q8@6Skwp_h2}N97k~o{{tnHi-|#Ur@KEB61$6<%%o9Pyn7J`usv6k;Jon zGUMy-3=yXe8cYdiLjd2E*-j{+9TDx$i2DWHrd3fN%LUfJLD|(HWd{vt6m+)Dvpfjc zE@tBl$2p?hRSg*wQPk{kG2R*6Iu_fPOnxfdcJq$q+;g8X+?)0k|H_`2egJxB$~QX% zho<)4dU7X0Je2gq@B@qt_#Io*IW*r%j_q7BilJk|xFt;5aw(QfB-EKhlRFdm%%S{np$+-3E5Au=_C?{{m|$N4Yovw-cvl6> z#BE5h@5j!#kqW?!p%w!;7YHDLJ#YtxW{(64AU6Uid+bqhd8_e*G#ZCY^{KB-%b9QB z>36#1om1Am`_~vH%h1F`8KkX-<&CuEIBeXuY^-gHFf~Y#C;@&FHc+S%!DtjJg`*Bk z*i&XxW}M(>EZbJt)q_ykX@<47E*Cb+*iLY5xeTD(!HsOqa#}$Ost`g%2S$RB7NUtF zqavvyC`c&3Zo;$x^sBlJgl{s!!83Q;W~L>YhOEkFS~hw2b`8wkGTXNtkyKK}o1EBK z=59ESGExfL!sBtJib$5UES0LQZ6r5X;lgJ*wpinuX)NM#mR(Gob1P+IjyS0)*EbGx zb6Kq>&U2Kro0+MV#hXPCDoUV|s-r8LMT-(8q8AYs!En*TjvQ-Rjm^$7(W?}!wY3>k zD`jj&rIJfwAtu{q|J#nb#xs$f_?gr?R-0l&7|Ay{<6zrzW1E)+WQ2z!C4~hWRyI`% zW-6;QQL%%Tc#9oaY*9?g+cQ>UW+cj0YHdcTB-w^_uxT_@9ZW>(qA$mQsJCFGfy&0- zstkoEYdW*TH_O|@Hzsqxm%{LP5UUmnmrJ720Rg%uI09xAMNA@tjNThfm9bkjt+QB$ zVHt~IO`9#I)=Z|uNtLxSlS4`kjk9w$+S5!ACA6B@nrpV>irJdlN~>1YlVz=CQ8s5Z zX#>`eDY<~*Hr&>2ovhfb*sZJn6Ukj$HslK1Q<5~LD%vYnt5p)KYiiO}wNkRCrL?OS zsuOLqTD63drK==ONV2u9ERwQ}WU7+UOC*zK%1KogqP1+>y*BV$Zdtc1VvUuJl+DgK z$^{ymR&{ORs>;bLDc{a!p{lKGSz5O3&9t*pwx)!OOJbQy)GJY`l*+Xvm8)8nYP1xl zQAP_@X;e}bsFhh&P?JclTT^XCX&RA6GrJbsHH!y)qiu-{Qw>{YXJF7xwr$`!v5qpa zY*?(bR%m85v=YH-lq4*+p*3pT9tdm>?J%{B;8KaVtj+2duXvnnrHP8wL0d6Fw}E4F z%rWHl(T=vTlVd2@+0~3F+ijj0Fh!lqJP_FF8zqgNCR=#A&CHt_j{1W(Jf@jhs0f)u z&J!UdJzvjl=Ci3-tV~2tk7`2D@n!l6T5fwoVvbHKgosFj0f`Y+keNzV8a8PVXo?H* zq9AM}Lg9c?O@p-`Ej1xFw%c0Pq|#Q2lSHJ8Y0bgJ(#a($OG<-nO3e|n zA|fm@Ac?n`+inr)5zR%9AFg4k(o%}dc@x0g%H-LYB1=#1Ig|2qmIeAh;Mb z(G+lkTuqW}b(U_4w^FmZwNgt|fZElmEhuJHR;B@Dz*iL2vFF?MWnDPTNGG=g$0dmwr<^x#@jnP zCkGHU#m4AH+ekK}Y^>S0ZUc-tHq_G1WMyrd%QKj*gl&W5?yMBD%PbKL2#z8e6gdLx zzahqrh9R#E0j)O1F!axQ4ugt1ZH?PAI(3InP;`6hM~aC_Mx4UNGZD)+5!+$46hNp{ zrXo;9Mg$kEYG{Erkh=x~;Q<*6gHTnZAYY!YVhJP3*1;@@d#mXH3lLE%3Qlm*0CilKi7_6*I3+3CU zsKKRailqAE!TEb1z%##!CQ&%d*@C2rK@mAw9b(Ken!eB@Bnmj-N3*pCSXs(DL?|J; z#&XPaHsH7tyd>N4L1ID&32o3KO3Pys2tqJ|4lw{BVDaP5^tqQc>KjAh{?F)meE(Cz zUyGhQE>H+TBd0wOXd_Q}n(qWQc2k>eNQ>ral1+mlb@N^zZGn%cV&NbeQwp{8335ZT z9{Zn4c(sUmnajf(Wv2V|fOeOLi?Ds%E?uBYy0O*`moCs>OV_Vj0C&f8F}ITNQy^oZ z0)i(f2!oa@;|>*gLAwf3!GjoD)Lal$xCkI1(P&U6^~Lb9n9Yw7guGJ&fUA&i^pId! zRgeKE%(eOQVT6p^`&l_Xeds17F$D+`Dh9TI8jL_<5d}XSATQvwwy+&unLvl=Ji6Y3 z2HD;gvM0}fwfWADmEwlyZ;WgrX&?vHg0v=M0TfOvfi4nk#SFf%>J|~aU_DI3ab+$T zn-1x>U>lhnp~&>ZZwwVf0pC08V~U2mf0J@tiSQwCMOT!DO9rZjZ)-!OF#*iz+>EPy9p6TkW;^8viLbRnu?gAt)Pd@BU| zmX!-{dka-Y;N30@KnN|N7*wJ{t8}xw#_j}l9m%*?UR+Q%Dgdxz%pF3v^j`grbW5)q z$XkhMM#@TuI`L(?$xxis#EQb=CXn8fwghoU017#Q%<#nV3u{G@Gw}WPGd|HgpJR4C z!EZcGyH@PfEKnDr5W7AyizVg@0sTRfY{~S=2l+Sw_0$aRp|1ys$#ADoOf4|SK&XT^ z0U|9h?$S=X!u93ELUM};fhX`ir!!ej8Ga_oLrXdWM8tzhKGd{0`Ta8ZN zOm{AT(a}gzt*5PHUz1tMBp6(1Bi}mt1Z(0BmIQH85R$$F$#k7pj}4mzzB5dA0mw~p z5eVSC`~B%ICP3Cu6gAf;-BKDLFtN8SBwIsisKQICqY>p0+qf}R%<$8FDi&fn5HL@s z>wx*Odzf-NWTX^LD7x7#s2ez}>wk38tI6ndd&WqH#c75ba!=FSw#eLS>iVcu2@v#c-jhh}OecLI!YM&Vd=S znjc>v%aCnRfjLr5kuuvb8Idr>N~${qL=&Frwx?SCT``NROC=sAI{O)+&8l~jU=URi zQ5vk#wI#Tg-lAT()~eC4X%~NB#cSk{geN%YW6C5S5NI(e5@XA`Mropp2H?XFS~k2< zOd*dOH}T%3_=AU3at5N{HXx#QSlT!qugowiQ^gd#~H7)~mz ztzghl9<J4Zxh6@YgA-*QEWgHI0?-wxMy%kKkObBDqWiC)0 zEz+zJ0+$jS;B3+#j$<|vLx9x@Ych+hRj=8o_$K`((vB_C;>fCDd#GIVa~A=wCW;g@ zf;1z-AvO%J&L*u55jMk>VtEs10ALkF#;B^8qr@wRFKX`#V77#{2^~^MIFBYVmk@n8 zeZcC4Kw2PR;36qu{Dk2r>*vw31O6~zRK-gunl zgPSg6O^i7K)Wc}o9l%6iJ|YR~G^xJ?XIqvHA}M*x9r4}6 zXNMp(hEsf1Mu7y=kb#k;MI%tw2oxouMIQ9s6OT3eRhXKML|B7^p(!hf zk+fv!s7f_laz{{w1A!%6R{gLW4P8z|=R;RcaB-aunCb~~fpVeK#^sEOAVwZ`BdfyP zY8eYrp-!evT{@Ly9YOrcaSNhkJ!C*F2u8&$M;NRcZ3WIqacyRqC1cWPL4sOCCtMAv zEDCEFkT#S+RS<2*eK#@C7sSh!N7NC?iWL%f5EM-wwONpi2!JFy2gGAy5&<#9`O3~Q{5#;YtbdAnoXuzZnsy8e zQ|CU6r~n@)+4w)zbS|KXCBmobN$RSqrIJ~tzw|5I-yA}HyEP!2J8tOjZfAILyt11F zST+*YEG(TmxJ#C%G!Oju97OEvw&?7#S?8;)v zy5`4O9GxgwP*VuXA!Mr>q8>?kTSCPG(hUR)+f{>|a+XkS1tbcJ1R$>TL~ekoP*L21 ztwB=&fS{OF0lK1;;UKLM+tW&L_sbXqU?Wj&C@Bnv|AZQ{qFM|F)OX77tU9-KO`1hyhkcE^CWf>q1*2?g1v6~V8_+q1 z>Hs%VAm3o9QbL%G_-=B&H%r`pEuQoE)BB#sxzhGqAJ52Fmg!TX4y-IXZWI+GhT zb=|pe{i$VczBw#EleIZ6RauH_9 zt9Q+t@*7V-=YG6^3sF90$4Pu7aGlzSw4>rTD;irKlWH&h@j>(JG(B zSXZ<6`&<}5_aWS|bI7d7Y^0*=Vs`)F!5=Qbg5cTtKA5r{_@gvo+QD2eM&>`E?`ArK znI=5Z#83EC4`PLYI|GKB$;})bZ_AQx_cqM7qy~y0zt;K^Hyx*A*-~-n`T>O!8V((X z!sibWp4L5{OF`BtLdUiclF48Mmta2Y;&+Kl(V9G$L80?@uxpMr~pLaPmO4_oQ4aZ9hfvb$7n(tOW|_c9Uq za=hT%)H9;WWp%z6>A=U}Iy6l5ZTK!Z+&`iIMD95E{?Oz~BWU;f79ZT(1t>a{pNhFd< zB$7!mu1dA7>v^qCjCg^}cKt*A_3}_gB5%<>HU}@62j+&Td&aRCVT=WqS!I@4Y}dQK zu1!$CVIB4&ZdUvCw$J&x9?qOO)%rRvYyihszrpK0+itibcBbEE<99svk^g1SLv6*a z8|>b(zW8q(xv1Q;&h?hp^1haCym)o)WjIn; zX2dcrUvIFEF6G4Z}ttF!_HA i%KZP6{7;-Buc8LEDle4;N4Ld?{}*yaI8czsSoe%GtddIr literal 13133 zcmV-TGqTJ=T4*^jL0KkKS?0UNbpYU7fB*mg|NsC0|NsC0|NsC0|NsC0|NsC0|Nrm* z|NH;{|Nr1UK7Fn4ohP4Yc>C+mwv@a(y@92B|16HJXX#AIL*f?)=XL4?rL zCX9_V84WQs8Vv>k0LiAFp@`E7kT6X!Mwu{%O&Vknq)KXNDi2d?Xw6SivY7^&G-x!_ zN2t>wnvYTH05*_%jDe<1fb^OMo}kg7$j|}l41hEm8Udz&0MGydrkIaV0i$XNltBO{ zfuIS238nU$fav*A3 z#^4}QNQy{E$RYMI0K{QOe0x2%iUWqbW)?rbaihR;W(H-2rFg|-{?RZ=0kQq86#@!s zmAUwcJ3JE#ZZJ1}%`%9eV?j6NAeTl&DHY}MM4r6^(^sGo!14$}`6~!dDV|40fAcUr z7cF}Sfko=NOdO+BhLDd8%Svlfo<=%Kl%njMTm^W(ILI9CHv+;-MG?<)Ic`ZXMb(@& z@=kqnYC_SEkr6vlsg9HgGZ$KwFySg0TQWw!SVD-jh7@yL<;LY#8gqEnaK5cq2_ne} z6jvN^(U%B~&f|@x8GW8==a$PX$_NYmf*>3hUWn{JV%p=U^R^l{=XZdex* zl*CiN1+oQ@3V?VY*?#Bf{m(b*E&ZO`*~r@FN(4;}FiZyy7*0xh+ATh#S*C>%8IlmN z5+mzmK0_VIFh&%Ts--;Gh(&3lrml2tPN`0u!YihcL@U?ED|Ycoh5$NH5PTZ5S$!HxeP0V4X!x(<6G=k42rl`}E+r z@aW7nnW(+C-GXTMcjdYopGfED@TiDGVjI2#IK5tbq(rs=CO-`?0GqDrW zjE-?e!dWgc&|!SHEo}URuxAfh!nE07GWK+lkXwe;MME5QpMG&}R_i-I8Zw%1X))uq z{Ozzu4e4xj&}mSOMm^eeNib6d)3PF9j>=O6L0f3aDiU*et}bU0TD8I<1qdlIClDAT z;ZwY!*B}rCb%!Qy*LZXo-#nYNoB!GL*KdUtJYq-77KlM-eo9e=d0 z8&ZV9LnLZQNb68=Lac<@r3%7`s{*#2pVMJY<+a-@*; zuUN@fu~zXNhyWqtBuYRc1jKD)MYfWw8)&tPpa^dJUn9=>82tYv`2Qo0dmruj|5s=R zD$53B!!p{BBp@Bx4gjMlk2pmUxm00BQ4~bgG@5Ndm`gxYvH^S(ZA1uq^^VhSB;hTo zOa*$`hi3O+S*5y*z*uJYaGsb-vpJoh7{b4bKViU97E(It>&Rnx$9^%ZL{%6s267Zo z)Ut{k6>zvB;DNt3V7oBnfnAn(3Elt*qskH5astxBc8+2Vc#dj3RBusTo#Zb0ZBGRr zS~n#g`tD{C=T{Z>P`5+nxHxk<{QEt)byI6u8&FR@CI zlNFVz^{_o~JFtCl1@*mD&YzEyf8_VIe5~hnaix~WWWH;vX&6!fwvtrg^l1=}Tjlkw z=CT*(>d9V{0>K5gxHztQZYK2O-)7dBElG0#AY-Nq&?bFx^8b z9VMSM=jLCba+ij^khHrBb&QXEilE61kmC%DwaYpQcn4VeDIzh?5<#GIg7K`kN@ zWrSSt>C)Zgz_f>SI!hW>5r#tJTId+aec_QUjn*R_k2;p5+?z2mE6pplSupcXDzMBsOq7uf8#p<<$a&m7%Hg2TIbFSK#HlXLg(R(@ z>zWoLtpxW<`fDVb4J#0D!NiegkH2zhy|Y#)9c7p8H`HtjSLE-M+w49OFS zrgE=oVQ~75rGsEn>-d*5Mg<9W1|Aw3I`&Z>8ezg!s3A*6&$hh8%+B51T9#*8u&&TU z^yS~TX}j*+xmMPqN-UzpH_eIYyxHDzL#txLW7EL&V$Vk(!Q#6oQkeONAiiWn?H4@wsn)Ytt9tZ`Ivet>e9mp@5 zLPZDZL`2KEBSledGFCjvw1)aE!nchMmT!rDH$2+tG{vH+EJm@lu7Oq4$l)sCTCDbz z_Io=|BB2CII48L}1v1F+fEAtaHxp#~d(+T<@D9&9|H6wC(0irB$b*iQiE}~#a`B&12BSM)XN16% z^nSXhtA>|hDF*nRQ}VvpGBE^uVxk3zI2hKenzUg9N^vV3@=AqOTy7&lguHP-nxWb-nfprFi@P+nnyT53C9 zm1fatUFiZ@_^NF8Xka`e7h`u!Hu}T`gfze)8^Z)v;;15ILz7`J2x=w+*zS?J8@*B9 ziYMzukkW@JphpOLy!T}`hP-*g|4y0NzGfGDUreh6c!#F36 zFwe+N#FNU`Jn_;lC$YLlf@dSXeR=W<8BYM7=sLy`&SHdN(Uz6;>y{9Zwjm-0KEPq9 zhfK4V$@exs!yM5kh@;atzb(68SGJVF9>C{R|4L#*E@KdJeD1UPC{{2;7sg`!zm3`entTI-0(*q6yyb;HDszhp z(S#bKc(w&;iD>K_gh;cJYSbl~S3~mc3Y|qty@Feo6CvTLS!qTlV#&m}a;ULz7YtkV z&c|u2Zls&nw5@k}o4%8K1dVp?(`?Zy=@itd1SE>mJOOE-{_Zcrt?#`5clfwELgZTu zf@Q508;hnx#xrQy;S`Jp15;Mi$g-*>2EzP+;3uSJyxrqg$46@v|azg#87R2G&pqLdh=1Xb6fTd}5S z#)h{{FMSC>XzZC=1yL1UpO0X2JI9`@O=4&X$x4QQtDU_OjN-3dL0l1u#@tRqX`l-S z%w_gwDo>P=iY`x32+i2%D&T2OFskN$F9XR6Tj1w`Inx&B|hZVayPGsUDc#pt(e zDh!vzVPCNeY@zJAuUXVau8^Z?V2RR9Y3oqsbJu8;MPrGJi;U4m$YdDw?h&kE(w3&A z-9eKE_T9?ew@k4l&yA{8C1d7{*Qw=lt3(C$rdtRsa9jmbBy@T+;==*T(&V-VLK;REY`w&`obW}BucgB6(MjwN6PpX2DqN2m&`=w%P;e9YAm`la-_?Z zg3o8)nL0+mw)nc+`~Q5}yRz2N%MpmTT7*bojzJnqlo|p=rZ7m9g||wDdJdpzhGxG+ zLt9tC!ip{CU7WSf;LhpSf~J06Mi2d5hdd_%MPUKeiXrXF(98nRv>>qHV)d(5Cy;{J z+Y`QE%xhN&&*1JM>xWqm0-OsG*Kt8!*r2TK1P&r&k5t^s0v$L`oj9fi4DMo3WHD2V zl@G3~P&gnP=LCUgm#b7NFDb-Y<{4+sP8m>O6&nNrA%HeNYUWe5-EBF<*m@Bwa;A{LIW6;^@cOalchu%k@@R9?~qIS&yr zsn$DT7nb)0k!GJWkH+LQ9y`q2ugy1tlw>#OEDB#iX)E?vDm~8sI;O2wX-N(O<9JzK!pO$XQY96f5d~9Qv9x8ZZ3`gVF?~q{PH!cR2^z=Sa*jYyrIiSCA2K9W$ z<>ifYzS1t35Nxr1rn0>Ci%4%UJduvmBWtp)zHVgabeSgU3c%UxP^3>@%0DJ2vmtyX zY4+ixizkbo4<4!y>USs+$DL{vGV%E*wnVYPj8d+ZZ{^@~p<&$6d>#lV{MfE#e+*lUnE$usH+Xhp6wsCR5p8Wxl5U z_orG3d^d;&8d}NVLtf&og{WaImJCJOZ;D#V{?(Y@Q8*E-WJ4p%M*J>k%ar=UlfU5E zIs{5!g^FotuUNt>E+$*laDY|JfzcBR9}GA!=3c}TJWL&06|#?*M_SOQ$~=CJ?RjZ& z>-_}!bluf{E(FgH%l0Yq^3c-?>PkfKiS8U-e~aT^v(E(h3WLK)sb>ReCQiYzQYbXs z#|@@8+Z?}G+QuRme1q+s=(K#F@jKyj#QuI-J{Mdy?LxSouAH2^Zw*AP7 zZ8DnVmdLTVMYp8S+|5J%g+7}nj(8dWpz(9Eee0;iCE(P9T*+}9nb|7*eS|S4@Uz=} z7F|x+pD0qen)=b0O}TmW=LQ((JY2)=5i^9ap>dmci(zp*wEKG{{`DDO@+ zdpoSNpn?@0l_*qtB~m`Ddw9+%w`a$NmKT*@7R7YMu=HTum}nG!4W<76(L9X}qEycx zb@f!u0~vGItCm&sy$YS%%S`qdAk`v7_kVX=`;;5~t?5*W+tSy@gJML9?mL)0-@d`^ zVr$!n>EL!?Y&%p6Ia(x0ks>B$V{mEl-xAludw)!rDLN;9INM!5`#P%p0f;EUf8ZszNMnlN& znfDhW?~F&PMkvU+CBZ~URZ6kkK+i>5&Bjxdz|yzv~X2Z5zc4KY-2a}%?sviLJgux++nMaZrFNc8=Y=FCo#6esUowmbo*M? zO>|-r!(7%oNm@#_c-}N~D!A2(s|#GLv+d0B&z`wx%&F^NGsnAh?!&|8FXXQu(&!)o z(uCZlC>bKrlD@|)l6k2HlfOYt0BWInta|7UrQs#!gY9|fgMu%@(Tc-2aTbX}07#5L zqX0>*HB)O$vuqJ*r9h^eCe({mPTo)v{p(} z2#FR-Lk5Ex84*JyVkBhJS#4{fu8LU8GZQQ$Oe!iyeqU1_Nvr`4j`fcU0}2gG0T56K zMA1PMQNK_pO7#yMx5>IVhcf7!X0lLLMQJFdAh6M(>%6pYme)UO=5s=e2BIjSp{xNO zoTvpNhap3*-av)NVb#ca-oJuEM0%2?1tMl*Bg7dBbR#8uv=2r@ML;~!!G46BkZS^v zzHL}gER2B&Dg2qOR482wYnWU0iXyq-vH%hTaeRlDN<#(%(W~?3xAT4VZ=dOJl++B+ zL77tG7}lsL5K(gumJ?KqQ39zx@6?t5Cf&L9|M9VTX(VJKy+effK!7Vkg%be4FC8un zvcU(l@b-dof{K#->T5eY0aK!_4pw%bJ{n+Dj` z0!g=qXhbVFYe0w;kRk;n2!Ty>CD_{<1c4-kgp*@Ayj(Em^SM_bY~|ZIT#<+fDstz! zS0*u+%v@X(CP_1&<8a1rqug@QN!6Dqst{@FWh|N`A+)+xt5|^#bXey+L`Ww6>OKpk;)(9qUYTMDkdG zk|pzeubn~?M!(XFu$fc8uRkaMcfXhEPu1pkS}n!HdL3s~)&1^2Wg`*vS;>LN9EvBO ziWsBtq;=O_b=O^W*IR}0R+~~(sc0$p=ILmyJoC>y^Upl<&oriTMMSd4TD0GrgUNF* zg__vwZbjNUrXAfhf6h#-FUi<*ByQKco`U+n4z&75K-o$^cs#9 zr_to`^0BaTF7E5EGx_}Y@ZjO%WLwr1nV5V`Yt41-ef|aphYZnS=J8`gQlmph z_oH^~qs;RuN;>JhIp(c3F3;PE1mdWWcSSK+DhjbsD$`z)t}EEGMZ@OI%*_LaWI$15+M@ODja}$uZV=4$6M9xy$Rd6P=YH6Log$WwU5&5+BUIq6;fx3z0}KNJP(jROp3ZfPCWnIo z?6C_OkorF--9q!ufDn@EO~5KGK~R5>6n@S;ibWLzmqDG3VtazXkdlIzmFZt2>mnZw z9fsj*=gSj}w~zIT2Ccqfm$8=W7@1%sugAu6*L!5+0KE)`@96(|E48%*p_PXEnc4no{pJQ7F?Hh9L}Q zq@;>-*6}|JV-=<;pgQ658T6mh$qKEKLdXfOxt4;hNTMj80t=! z@dJDi#cvSLod?Y6xyZangltUViJ*FbW-7JD3sB;jgwIinktDhvgWQ0r4vP8fn2&gl ziqRZxkrI?h%mfU93Pnl;LWELeQJ4n6j8vpTGX+;50+0+r5MdOuTtPE1015?41t}G2 z6{J)<$B-4lPkGN44wc~FLwq{*ih zDiX*t2CXA;Tw@lCTuRE~ZU+iDW7XiC-@st7=`Vg{ZhnnUN5wj4)6(RAh$1u(38nQw2?}TQQoX zkeJd^#HNB~4Kg%ptpPJJG?HywM35|_8D1c1NQFuhniW!j8G&h5HHxho**1#YHzuxl zEhK2U+;OZ`fti(D-Xm5^QE0NHrcJ1{k&29JEL3d>WQ=Ao!zzfhQEOtWOc^Bzv5G|z zH3_7n8yi_EGFl}iYij2r*4Cmy3P1vdQ8XaR$fCTARRa{HFt8Frk`{%46fN>xQSAdw;^03s(b4I-d)mxBR_A(RwDbqb1yePC%ypitwSJ|qk( zebn-yuGPJhIcnrjg^!Tl31mMpF6_#Cf41eQE{Gr+@Y{eDh)61~)F`f*1a}I6cV(7X z#f2S`kVuB*QStB@AVf?dO#!r4h_zJNtW`x(Nv1?u0Jyn!q-qEVT@XOF2pQsS;;dxD z1zsRf3K3u-2Z=yTgkl_(5Ouo5r4`(O!zchG$g?VAB*KZ4wIFBAs?<~>)_{M~7QPA~ zVgvbHy?X&LkrD|;BuJikQ>hwaVMGalJnSG2;Q=8OU}hK*m4|Jtl%+(eY};9omPpEN zEYgW7Qb?O*L_|ch*iAf2-N}M$$m`!b4F^MuYt3Wg$r4-NqgoNJrp+K=Bzb+y3t3}yEz=yps zyo1*x@y7+G(dC8YhU|YZ=|bTVV&?3%W;VDSQFGvzF#HAviKsG_KH#Z4tgQ)9+Rr`XHEQ7IwEz) zOQgeL3WrafIYcG$#(@RZ*j?u71w6c&DblUd$|%ngvq z8gWsgz=qI~KN+ngnA53>9h-0|(U)!5ZMhK*56gh#hmt$a2^z(jYluh_6Bb@MFeo-VYLu zAQ&q_5e7sG!lnz0Zna%!bft(k{u&L{Y{pP|l9I>-#H52gKODM!9%Gtjc)s%=C%N%l z36zLoM+-ngMOQc^j8tL~5cx0f*0mF^ea#dJ{lVO%^>Nuq5AVXc%fS&j>Y!xz2W-_~iQC9F6-0L3@|mJHkr+dz?1t@2MhbA9 z$^tsiA5x&3Mgz~DB5)!`*}|FS*XNhD9?eL16IaDuKd4O&&j? zr|(P)p724zFtQa$4x^sj;X$en&}s=h^<->0WEPt9U(;)eJ|Z1zt6^W)bIRu!@0R>G zc7U_q>0t`lRjpARI(L{GUa@#tXQnsIBX_971hA`?oCTbzUkWCPqtiF$^d)Rc$4GCc z7_ufzKMwOA$vppgX0wNETaRtES{X_d0>L60vf(&vORte&KLEvy#r|SJ`>TNa&;uiw z*NW0=l(Nztu&UuIwi(dKwD_tSQ zcvm78WzJIId|@N4xFzLGdA>OASplKdNKoqt8T>Ul_6jF=THz~dnarYnkSO(dr!CMD z*}C}DQ;JMyiuqvtV%SL%V!&b3vp!5AtcoaU96s)dW`M?~q;}GUgj*rmt3$e+ktp31 z)JZscFzj!;M9^&ILq4}-a=^Utt#OVQQ7E8^ofn@Ca)#aYb+bC>H;1XJNjm*c8%>N+ zR=U2|4W4m}SgtuVWwd}bRI<8@ZY)jdo-qs&$Xbg`$q6A+$gg{Xj)k(Ny|t-K)J{A+ zWkkwPys%BI&4>7M81qb#sVONW(xxio0~#gQ&=eO*1O(@E*Dr7_(TLB@rkP8O=4;m3 zw{&h?vIrT1G9;QXusJJ6C9+f1N=(or3O)#^jIC{wLJ*vXJ`74h{C@FL>U}p9URJQQo&^XUh;A)_W{q0^&{>VX3Pl%6P>%E=uP+uU0I?hS9 z2JBa&6F=MN*y<+@Lx{UCGTTG}IxR6-<{J3JW_N}otq4d2jnJou;eLB)DyBl+>{R1m zA-j}D1O_S_a&yt=iJ;M7+UriQR{?69II%#B-GK4|-RTkr5uxS`O=L1bxf42Ag@KEM zeZJjwH?#*@G9Ph7qyj4ifTSdj#5h!xLXN5=$+=)*&)>Zv^nj?I+40J=WX2f8;xuF= z2?-ehfGT9&cL3?{8@hAo9@naDFNDZaLv0)Pc+M!U?Ft&XONJdhbn9p5kZ6<1f5q8#i(JL@YNaUK*Dq_T3 zLk4Q8U;$xYM9vZlC)GHu{_$96*f2{_ky2Ng;)_291BHB4ITOKfnu`jEsdcVW$B!Xm z8p2G_5akA-ZjvDdYm2}N^eF^c0Bl}?!oga*NC>614I^cOTzpX(2Q-d6eO!f&#{o^G zyzcr1urQsb!yhm0euZ+6Hm&SNX!4NCY}&OXzQTzjww_-q z!N-dko~7J?<-2Ix9ZCYe_6P~%X9s!-u8GVF3*U$WZDcr0u254!)V0<&h^5j36{P{m z3XC(`S_anH#PD3L#8Kt@;)-p=umiNNJT`NA9QfqguC>?Jh7T^r#tRLGF-2K)2V*PD zqRLT8BYq7c4h2z*9hH_-Vlrr~tj%j10x={=HN7&x z#$%+0(rstcUhjw4^Sv&b-OYU=*pf)D1BDE^xVWjWqjJ1{9*^v)bE!G{D(T_|f(lx3 z4pH5^XNL+j6A`|m3q%1lVIzg0f{~;&geWCpLWbYOHx$Qic}^O&@~Nh{{EBY5Z-1YI z!|rk!EKGGNp^28V%Q9M+(BVl-3LF)0-z5|%iohk^4NQkCuIAwS^waS|n|D42D7SOo5 z(yCk&M>;UH!-eBYQ6j<4WolFcg&G7PL+lMURI!N&loCZq08p(86)5d&>Q3(1BrB4| zZY!YO@G-~oc+27a&L7FJkSW?=^=4a+oRaBI+6ClMGL73F?|KNaz*`jxGkg{tmZMgJpq^ zKS|4DvSV*F=qfY{EBc@Bh{CGIYb zsRMDMSW6)1yaa5cguuYV7@PwPJCmJEL^MYykw!6FR1>5JW6!gVvpgY&1VNZ#Mqz|#(~M&V++kc4bh^MGo_LMmpeqy?dc?59 zER2EIdck!AK|pg)SqBh|K=Tldl2XYiwxLpKteO}o2UEpLfl8dx3$hsym{yclWEG_W z3IHht0i;lPNEBq1<$50v>Ad&tfA4kafA1da$$ejuJ|8=dr=UBJ{MUfmsi0Z-fg{6g zGL#x}$DU2KIIis%g}n+>A8#Lj^f50}6D@?;??r_Jgj3KXLAM;FJUi(O@fI&1V@U@J zpNIOQbUE{EWJm6E)m4ylVN-n7A*kS#EeE?F+uSw)V*@LHcH41Q*K@T)f7KaG;|~Q- z03MdGsXXweE-|Cy+=Y$t6C%*SQZ<9v>g7Yx1zKuQJSgmcp}nuLc-|}t2HjIDC~Yh{Hsf~YQSAp6AeVH zXt5tP(6S9xw;t*B*J3x9^x8s($}Kt4_c6+l8$^b9ju^UoI2P^Qk|52Ts~%KD3)lw(9fiPgBUUl>}?Z%3t&AyZ8HFU%YR}@2~wm-LB>u^4$HO6^Gf%vKr{|`d7P*7`&dFAMI}b z?^*PEmA>Z>xcfUiEp{9ouS@Cwm7S$$S}SlBe|g3AVkYiuTs*@t=4W*wc!l`@Ndeka zy39A)`k!5r`)s%9J%;-)FKh241?ZH6_sNeK_b+PC)KbqA#W4aPsi7)SDN-hysv~3& z)J~hJQG-PZuxhAIlZmLCO;}@O5tQb%Ml}|bRu&~LP}NPv2^@}?qNbx08W6_Yq>>sM zKP0CaWI!Akkx3P+Ry>9_!t^Anu3+eji&4ax n0LR4i9G}MM`QKJ5FP1~9FjvvYsPC)n&;J*4ML1B9=DWpp5zsP{ diff --git a/inst/create-list-available-forecasts.R b/inst/create-list-available-forecasts.R index fcac2950c..fc4926797 100644 --- a/inst/create-list-available-forecasts.R +++ b/inst/create-list-available-forecasts.R @@ -28,8 +28,8 @@ metrics_quantile <- list( "underprediction" = underprediction, "dispersion" = dispersion, "bias" = bias_quantile, - "coverage_50" = \(...) {run_safely(..., range = 50, fun = interval_coverage_quantile)}, - "coverage_90" = \(...) {run_safely(..., range = 90, fun = interval_coverage_quantile)}, + "coverage_50" = \(...) {do.call(interval_coverage_quantile, c(list(...), range = 50))}, + "coverage_90" = \(...) {do.call(interval_coverage_quantile, c(list(...), range = 90))}, "coverage_deviation" = interval_coverage_deviation_quantile, "ae_median" = ae_median_quantile ) From 6c213fc71da27056276dd77e7eeb04e024384d38 Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Tue, 14 Nov 2023 16:14:54 +0100 Subject: [PATCH 43/49] Add global variable to fix failing test --- R/z_globalVariables.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/z_globalVariables.R b/R/z_globalVariables.R index 28bcfb95b..89cfc2eab 100644 --- a/R/z_globalVariables.R +++ b/R/z_globalVariables.R @@ -62,6 +62,7 @@ globalVariables(c( "rel_to_baseline", "relative_skill", "rn", + "sample_id", "scoringutils_InternalDuplicateCheck", "scoringutils_InternalNumCheck", "se_mean", From 97059948dea0a6b7f4ca0f43219874beb6faaa36 Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Tue, 14 Nov 2023 21:13:35 +0100 Subject: [PATCH 44/49] Create function to ensure an object is a data.table --- R/utils.R | 18 ++++++++++++++++++ R/utils_data_handling.R | 14 ++------------ 2 files changed, 20 insertions(+), 12 deletions(-) diff --git a/R/utils.R b/R/utils.R index 0d160065e..53a2d800e 100644 --- a/R/utils.R +++ b/R/utils.R @@ -252,3 +252,21 @@ run_safely <- function(..., fun) { return(result) } + +#' Ensure That an Object is a Data Table +#' @description This function ensures that an object is a data table. +#' If the object is not a data table, it is converted to one. If the object +#' is a data table, a copy of the object is returned. +#' @param data An object to ensure is a data table +#' @return A data table +#' @keywords internal +#' @importFrom data.table copy is.data.table as.data.table +ensure_data.table <- function(data) { + if (!is.data.table(data)) { + data <- as.data.table(data) + } else { + data <- copy(data) + } + return(data) +} + diff --git a/R/utils_data_handling.R b/R/utils_data_handling.R index 66849e2cc..1b1302dbf 100644 --- a/R/utils_data_handling.R +++ b/R/utils_data_handling.R @@ -101,12 +101,7 @@ merge_pred_and_obs <- function(forecasts, observations, sample_to_quantile <- function(data, quantiles = c(0.05, 0.25, 0.5, 0.75, 0.95), type = 7) { - if (!is.data.table(data)) { - data <- data.table::as.data.table(data) - } else { - data <- copy(data) - } - + data <- ensure_data.table(data) reserved_columns <- c("predicted", "sample_id") by <- setdiff(colnames(data), reserved_columns) @@ -208,12 +203,7 @@ quantile_to_interval.data.frame <- function(dt, format = "long", keep_quantile_col = FALSE, ...) { - if (!is.data.table(dt)) { - dt <- data.table::as.data.table(dt) - } else { - # use copy to avoid - dt <- copy(dt) - } + dt <- ensure_data.table(dt) dt[, boundary := ifelse(quantile <= 0.5, "lower", "upper")] dt[, range := get_range_from_quantile(quantile)] From afdd3ac372a38da564b1cfe44872b30b84fbb495 Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Tue, 14 Nov 2023 21:14:25 +0100 Subject: [PATCH 45/49] Simplify set_forcast_unit and ensure that it operates on a data.table --- R/convenience-functions.R | 13 ++++--------- 1 file changed, 4 insertions(+), 9 deletions(-) diff --git a/R/convenience-functions.R b/R/convenience-functions.R index 870e4ac3d..3448df5a3 100644 --- a/R/convenience-functions.R +++ b/R/convenience-functions.R @@ -235,21 +235,16 @@ log_shift <- function(x, offset = 0, base = exp(1)) { #' example_quantile, #' c("location", "target_end_date", "target_type", "horizon", "model") #' ) - set_forecast_unit <- function(data, forecast_unit) { - - datacols <- colnames(data) - missing <- forecast_unit[!(forecast_unit %in% datacols)] - - if (length(missing) > 0) { + data <- ensure_data.table(data) + missing <- check_columns(data, forecast_unit) + if (!is.logical(missing)) { warning( - "Column(s) '", missing, - "' are not columns of the data and will be ignored." + " (stopped checking at the first missing column)." ) forecast_unit <- intersect(forecast_unit, datacols) } - keep_cols <- c(get_protected_columns(data), forecast_unit) out <- unique(data[, .SD, .SDcols = keep_cols])[] return(out) From 218c01c526a332b06bbee808100ddf5e1e1e1751 Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Tue, 14 Nov 2023 22:15:09 +0100 Subject: [PATCH 46/49] Make message in `check_columns_present` nicer --- R/check-input-helpers.R | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/R/check-input-helpers.R b/R/check-input-helpers.R index cfaa24b2c..6437e55df 100644 --- a/R/check-input-helpers.R +++ b/R/check-input-helpers.R @@ -297,12 +297,22 @@ check_columns_present <- function(data, columns) { } assert_character(columns, min.len = 1) colnames <- colnames(data) + missing <- list() for (x in columns){ if (!(x %in% colnames)) { - msg <- paste0("Column '", x, "' not found in data") - return(msg) + missing[[x]] <- x } } + missing <- unlist(missing) + if (length(missing > 1)) { + msg <- paste0( + "Columns '", paste(missing, collapse = "', '"), "' not found in data" + ) + return(msg) + } else if (length(missing) == 1) { + msg <- paste0("Column '", missing, "' not found in data") + return(msg) + } return(TRUE) } From 21d887aebd6b481154162f7be1d7530ba6838f4c Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Tue, 14 Nov 2023 22:40:26 +0100 Subject: [PATCH 47/49] Reintroduce `run_safely()` into `metrics_quantile` - the alternative wasn't working and everything else feels more complicated. --- data/metrics_quantile.rda | Bin 13024 -> 9677 bytes inst/create-list-available-forecasts.R | 4 ++-- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/data/metrics_quantile.rda b/data/metrics_quantile.rda index b14a8321c408c6e6d9010c2262f0575fa845a9ea..b5598113dba4ec1cb98f7628899619b2b8723cda 100644 GIT binary patch literal 9677 zcmZXaXHXMv@aIDkLg)b^(g_f%h#~Z*2?XgHs(^wJdN0zkK0szZq=Sf{p-NRc zNbl06+x33`yL)jn_nGfJv$M0a^L@9oJCC}hvywE{Ld4kOcR=4`Kqlee|IhpXC$;kT z*6KCYZ!112?UOl|=(E?$2UnMTcNE>{ZTXhw-5D=u=``6#TLN9vQvyz214^~q6@qy$ z6dIdX0srAg24HF{Cn~b=)a1W@)n3+549GEqb>TCcP*+CRU`0gYdYp`r@ z@1%Zq_EfjQU4rNq<@}#T3Y6=AoI-K|lW-k1k+6!r7u7*<0yCT@L-qnN2EqUssmNmh=l=qL z?Eh2(#{TyU06>kj)$tdidpYvcXuil%{gB)wkN`>6mXyQcB0K)GTwsf@To&d$-onVq z0Y($h1PI0%%_!?U;IfA%0J@!R*uZ1Xf*J8aReQ3ZWkb^0G+1_Ns#+MU$Sy^@TvVw$ zg+=5GMs6`iwYyUn29-~Xon_TvAZ!W7*`-BxKo$*&(7^m>g{r7UwM1VKA4>%g5h#yK z7YHNfapj`3@4BWKaOG*AreK6zIVRzQzrP@_xYzoI=ni~MRydP*S8qh_%LGCs|!iC>I=@Fj7pSN zNP7rLE#(X01ugyh7yjcGTj%AUJ4oLc?SYIUIx4d27HcCyc<14^xA{SR@KDjPpq*Sh z@E~_Vh2--sPWfuhCnYcR!}p~r?20kNte>nCriiY&6ygB|Qs#EzFS2a640O?`4dEF*TRR3wm0yM6als;S@R*?jyHx7X5Ghd&D&3p zH@@6E@L|R<`&>buwZu&Oo%c^OWBU?s?8-*ml08dZ~D>wz{b)wo)J}s zooI(`iyQuteK@F5!GuFLXG6SD5?1{h3OkezeXe4!5CvsW#=d{?a=YDplSA7MK*O#c zhIqID57@$FD`VCwd435^L9ldk!$Yg8`A4RD>XhObCxcf{Z72wDN)cMBlXZpFe6^;j zgqsu8K$fhXy0P06XooekGF!dX5Z;FtZdc(`SABW{@~iV36>qcL63!jZ^By83@qqjCVKY$$x zJE{RtnKJ?j!dVAr-`hXgwKZP;Y+GJ=cMcT6a}K!5sJ*qJT8#WzSfpv31vI)2Hh`ls zI5B{Gwq$b1isp~G)6RyPcXJ}VeXt&Id`X}@=pCDQhO(5+hyyx@hgk7Aurj}Plb&j+ zpsSKQTm50bA6Eb&g&E9v2WDOB8rB4GDopyxh=#Lb z!j^p}$0O~BP5N1I?*Ut4U{*t@D4)sPE5jFT7)RDl)u}0wDm9Z|#z#-jj+v)g@6O%w zo6hSD5J0a*hagG|EX`;vd2O*WB9X6Uu_Y30l~PO{Z=~XBt#N|K_B05IxKwBqK@b8q zK{obj7D^d%S_D_+fcvviopqNvQ#~;(viV|Fx_FLgBbEvzP>K>jeLS?R&D5tN)VJ*U zTl0wR@h@(B%D<)v!Pz{0S>d=aiUmVQNCw2p;a-TFN5q`?VMA23>_rmXG zF5&Vtd(0ew?fH;22gw4i_>18tqC|_NR#XGJ)M5$Wf-E0_EYoJHf?+@4-tR6vbuH{+ zrWKyNb55gGkDMa!i9DaojrhT6`;4-(Lk;NU!^DV0{OuBa{eg0p@1b!qnP zYlr@Te&4OkrQ)Sd?-YX5q72xTO_jL5(f#I4$aUs#7GftQTa=U%)WWb{$l_DTwP~ld zbdArZf23nxoyf*O5vCT(Id2^9zm+xM&3*Dz)UhdnUTE}flYD<``b;DHV_vrtkNLdY zu82-6E~!#Q!E3X&6($CHZy69TT|>Md*gwesIhyWU<=FYUXitrnCs1C^{XV=iMEQoB z_vYNpr-s6j`*Z_td1i-7gdG39oiB-<#V_~*5$~SuK{tG3p<(|N6`3i6qdJ=E$Y~x{ zs&jb>13$fA)L%=U>Lce}qm9C_dbKe(UPe@A=30gv4rqe~wZ*%`9h*T_69a$Vy{2@! z*FWm9OLOrWwk>!%(*C9P^T4~_I6?Za1TjZ>OJK6DMp%)dyK%iDDB!z=4mHUhg0c34 zN3G!|gp{b=ZG~h%=xj{vgG@ z>B+Z+fTBs&QTNrKszqo4)$0Xb<~x3NM=}uG{^W!Ua44N=rXu+*3^7bpFEORP3V2kE zi~7-BdqhSp@zGm5cFA{Ur_u0(Jmp*W=Fb%xrJ_Q+*x5$OAr{&h-s3!tG6X*oZ5|RW zxh=Klp7`S0&g0OxaS2y$9C_PZ1bOvDXZu8a>lD4lqLF(?d$_p1wY*rW8EMt_^#aaR zn7$Ege$2Zx!nsY9ds}^QJ$yT*08aMf!7LCs{n{6OgB5;aV(IB&U^F{%TxmjH%jxLz z%^oJ*d7~Acj)|`p5j_Rg<@ar}^n7-&NtQ{b6W!1H?!E=>hB zTL$_+c*{;Nh6_8t#rRnfDPh$e+aUP9TfM8;%^K2^HnW!f+M&a5G6Gah&FWzeh!CN7 zD(S^)*l_e(8c(vdW#;bGP}K3tzNNk&H;$wx!=x|3(=_k3Kxyiu=Z4sz6%&@NcuiK? z&75CtUnJKRvOe0mx3)eMeckoomz86f81FY`oiCSIzNAR4*Sbf~j8L_I9QSYPr|u}U z!ObbElrnXH;DvTNMa?l|(H3{Gzd9vrb_9k%k6WXBlhvKarx6_ec3n|iy^I<5)RW6?|PRbMvEwV@#-TX9=cZ-#b`3?7LWvm3g)<^ ze9^+>Y>miclhu10+Zkp#`S$zhBF_yr*059Z`r!?sO>T#ZMvylB ztszCYKRaHPS3Mh8XC)&fpBVfAc6|Kp@kCaW@6&tokGp}Rm8v^m7T^8iy`yo<$Y6dU z6SB$RZcV5raREwEJi3ix)csw={#z<0c@0KChL6qH>l!cLOdM>D!#^F+hkIh@W)%{v z&}Y+(SWL&8+z$%9KY2PoaW~5qKuQ#UU+rEjse?_$=Nev~$Zd4zWtQ8olJMAxNTx1j z@a~7TxMj$?cl2-1Zypvi3GwVp#*#heIXZ``4o6?k6w6l}UN0s!-81+$eEQp6I;gph zuWWiHZ+jBIKoZw%V8z;)C&aU4x(q9x{Zb0~_%L!MA`ADHWvE}jR^|E`e<%^?v zsJ@~?m#*ey6ThhVpD>s?B9r(Bzi^RD69T=E+U%_4)* zrrxuFa;Km%pIWP!oY#k4-7&@C9&yXwTXcKRxsb@YA{bFCGCqvb`=McSnXW^J>WJrn zM;VH8t-d&)Q8XBo)+iDr_jxw7J9L8II$lh0nmAwAm*(cKmXsSPt}tEG~a0&0?CH8waF5pkAp(hgTJwJ?e5%}{EkSeFv3~2sJYnGOoaQWeW{ff>aHZ==x!gQ&a33i`N_hvm-pXSsq3ts zt%i>q^%BKQV2x$F=8#W|U{S>O;h>89qq#wT&*B(rc61B`P4&sVaO&pV3$?+?!44<< zBQm8iT)%*AAuA(~PG5WTLmlyLq>|FHqA(fGr`N(IF|e*Ou00VsG9Ew;m20y5lzHu~ zj8WD`h01dJ)l4;?p`P@ZRiUaYi*XMYLi&WlhI^yv!oTU;_Ex$nZrsU$@$TNpE`(Nm z7;eK(@c2?z)XqzSL&|0ki;>?fz-2rUo(9|pVb+gQeu{#hn@+FBowi^mz*ug3GCTK5 zYPV44Z7iP;=c#I=N~7QmJ?)3n7u#1OJmp6tT-5`V*G1zC0vP1ebX*QsgN-mpz&!x+%om$ z{TN#T-wei%#2kPnjH<{f-<6?D?lYBj;VhgtaKI#|i}r_9z5&_>z%dn2Lw9p7K|j5w z01vhrt)$D)y>|lpwJDG6tJ_PxxNFq92CGt3Q~Rqzy6FC6rDG@zUuLdiJDi?qL@PyV zdO}|aIS5;LO;H)OyD@Syreo)8nwYV(J8+bfuW^wjZP5);u!r1D1?pF zjzmC#EHgP4JP=5*U8+{k<*)Mohjo~St^LsVp$!|CN&s5%3hDhfPiE=QgZYl}N1cD9 zamQqT7@a1w17CMDO;cMPtEouXW-gLv4N$K;07Gx{5{o0`BTYt4EOKD+vNc++7)RM* zBqS3vHAV65!;%mRAvJP4{8z>cwTT*)lboHHM?%8us|oQuS=2{|a03spk>5x2Gy^vVe_?rB1bO zaSl1}i<}mRvV3to!IDat+VG9BWM%2=?casX^ggyg;ARh&A#w`f*&pql1k zr0TqVd2_q{omS|9a7y*> zc9$J7SITtasCq6TgLVC1pi#SbgK7DT*Lk9o7Hx3?;PZGO?ds3MB*bxWoDZHHOla}Y zaKc`k29P7{fIW;6tU5>{6cPJ7DeO)$$n&dxUOEFRHl?T#($ipg0FBBTVy7b=hCD3V zuRX_mX$PCH3(#etDKCv81)v&yCODJXu)1rZy=&&wppSi2w^p3ZV#RJyVe|n!=JFq` zmse}xhMHGAa&k!1*__$-Q5HFIcgDj8s9Qk@_Bno$r#t3IcgDc%@sw%{x$YwXvy zIZaJ1JN-I%%(c4BQQtN$%A+;Hv24&%aN-)J%Y4784M6G-lt% zKT7=Hl2_`?{Y`?4W=P!prQ(R#N3%)fKcHTX-e%a=DHd9zh% zI>`T{zW7gBa>H7^!&x`j`ESh(OOkdFznFnFofrPIR{vL9qZKK9wfR4hIXe@g6@}WV zf)RDQzp}mlGDUp+aNXonAZKO0*c(&p&6(jO{%0}$7h8Yt^dt=5RBLHrEGyYvvNva5 zRgc`hn&b4);y;qug=H7!GORe>DE$jqINiBPAA0S@WN~TxnAyylmD8cm;o;dmc6rW~ z_rX&Cw#|*=%??BLet$b@dP8Yx8?&}fc)4)MNBv7-c6N?~gM(-Jl6Hl=Kw$b$^5aE5 zkn~~U4PFGTdWJ-n1A{Cu(otEd#b^1paxYxeLVjkxkngpqQtzO^%c}c}-?f$h*PW6{r z>gA{}n;D9fg}4|!7$PQ_w2Lc=b-cxOaOBTGC4f62v8-fqz3Tz z57k;5ve~9EX-bhFw6Y$yBF~3S zC-YMkmeA!4c?R&h`4iXgHE&Y2tHt3=LGwDV->glHB$fC#6 zg{P6u>AH7le`Tf~076r++9W*`3mUIIgaV*V=&nGX1BGFSmD`BxMc#%ZSK<03T$xd% zoix=TtO!#ID820f$kqa(*q;lbz`iD8RJ{NomR^{GAE5xmU}Z*8FmXt@F0PCLX+jpa zL%A~;L(z{wfc)Y-1>0BmRDw7lC4N*Lk#ZfZ=IRf6^&hY@@W?Pg^HE4`hD@;!C=n4T zXOR%pN2k14zoAH6Tg1qPRfYkVv_^FG8_SS|%MvR?i%oD=x`(gf%2-V)odAMCHZ3wTNeB?eO6iRf)S%Nh z5%ZvoC%2F9!kj{O~cHZWusCk1+wAkz?tdP&C>Ut*uuCvK}lAL%j-4( z7$9w2Y#11(FRMW-2JVCDXfVJuSfv>ZHD`{yBf)7@i2o)Ck(MEq5;gb$deex(8L4_s z|B3?#PpI#T%)l8+V!^U$$z}JZ2I>Hji?HauVirse+@WfFLwn9ZL$x z5R22L6>x#2!FmPuf<8Zf7UA3SYSzjZM5HaNjV|U@bv*S&JmFxc1PQHj(3_t+ncrLE zTlM0iG(63567TOg9FFItPxw7(GbfY%r@{8Kgn6&6VjlFEvjxVUh609zIbdI$#_81a zw5|LPz@<2~=hsY1;m%;MPkJbb)=Yl#Q*eFR@<-xzZNLl)!8Dt{|I&|}2qfh#sAKHw$#nz0RK(W938Gy3Z7Zdp_`^xKGwS~au z*N%XbtJJ&nwml~LpsPJuR{prq)US}N^>SoS4C8Yp5gBR|eJbwtW~k~wMD(@KN#|{X z^FI-sxr_j{2V{V4O*i1T)#rhLqw7aQJQL^qpRsL{VZpmY&*N#;sOMxh-u>YG!Tm?_ zJ#Y&|%;#Yt1Agyrk@4N6`cA#`9kXK3JBGyA7*bDw;Muy{N2L!^mHdjoyojrNweZ#8 z>mU=hGlUd+6&o}S`-p*x+(7vb3qI5A##<+2+p61ZKR20rqg9{__*GE$TAfz9Ub z`$@bzRO8d942aza*=97ic=?rQMf>O6MW$IJ|6^@TF`1$z)O?r&V4#Q!JON%Zfs1G( zQan-dIy_v?r0nc;svHp6ElwFv9j%KyegBO(!J8)8fquq9FP_R5+v={V zzCXyp9752W*QeM?|;Cd<)+{itbtnf zr`4qLrQ;I!7;FCJR9Ba-Bb{vO#I`XqV}EsSy#-H*6xXe8<*ua{?sMxCk+R5+qJtGd zIdx;)e2q%eSam$Tsn0o#P@>v+ahe+lDUK1_&kNH`hR{jFx-iQ!WuTu=&IwV%_F z!ER!=gYqGds_IRFCHn_73l8q!0}^_0HiF3odEobrim#Q1Bkx-UbZToRo*DV4<#!kgx&8ne2!I3_`xMW zw1t8vKHV2dkQ#h)f?x#~!Bb{YRe-mSZ-PacKP`u6YPW|pGsZ&l2Vq0G9jWA;hOgP@ z_M@&K9i3q_f2j{DL)9tOV&v#+pewCQQYp+f`Vw>?-ppM0P9A4NSHEWQ*x+@2hd(Qh zJHmMiKDZKa{3SHOTT#uERTy_y$ zTX^<^!lC3E8YRj4E^vUB`uYu}S?^$W0Em`wb*nmiilw{yIT4}1ZUpJ*=9}vlucU0| z)IA4&x&G)vBiCcxe=2B87eM8o*sl3eeHcHCn@(^4%LB|2 z{D?is0(%Ab)}UU%6@`^rd`HH<>}=YWDL(N?ta_BXz(Sp%* zWSWwg3SHod#!F8V5nWI~kkR25#zqV__L|VPfQ4zPs5?*KvPHO^$KL{4Vr&!$c{p*z z0Ger=LT3T%LQtX;SyAZ>(yCX&MOU=58(~Nm(}9WquXmLi3f0|Fi$et5DLwo8qB`9?F_0pop8E>%>Lg7Q`7ox`WnGOk>kb$`(5$wGqd>90#h z{O+Z@**d$=*MIBB+`NW8JK)E{vB$w(vK+@*8{ZqAxD5D+sEYf)4BdV*OMxc5h@DKn z&*+`;rMfo$`9b7_<>=e59UcY;Ux99}8~1D1l#kvH9YsP@tJ=pWJ1c9mG^C~Z?BbHK z7Jt<%efp@#++{DHoViyihKiP0augZ@$vS8zzncs-C`+qC3n(+9a*EsE&DcivtyK9Pg5;5cL=yx(>t7?)0_O;!He2n&#rCuf~6mk z8xlsE;E)wjoyuI=O!lh#Lt(A-v_*Yd1VEy2mw>y;(rmQYQ_6T;8-+R@rfOwl=Bz{X?_w@Mt-645!mVhw{(XK)S|J`n#y3@@op{()V#rEe`$} z#T8KwM!C?}jc+!^k6p^k8-TLX#fbiMf-p)4eOxs}SlyM7yZG%6f)g=`C{#fI))~V;4|xn#t|c3W_Z$vP|KYM<)x2 zp4WxYZ_v8n@xSHiJFWla=2fQsdz{$tN~=QE3s1YI9=k{WOgw77Go8LOEw9`jbXo(B zZT6Nz+xgMoZ;c(Dzge_0qv(w2w+)o?w(O%L4DRgyzF9clw%qhC%b&XP1;5an=zpQJ zzP~m*a=1VGJE%m)7_O^0*|Ge-`$G4ZPbe3-f4}h(E@n*=AwKK$<>sCiUHD`K!&WF>;(YUfB*mmtXjZPW-oB=-q@f5 zzE71_t4^8vIaLFKsngqnqPe1}@L|_Frnqx_( zLTxk*g*It2YI!q3Fs9Q1Cyf;J!kM%RZ$xTgHj(5fqZ1QTA*R&z8h)v=O{mjPNMIUG z>Vi=a0Wg{aK$tr%6B8zh>S3v-Pez!K)6!^qo~D{? ziHPw=(^G0R(@#+JnrWs@ig<~L$bP1XdLu&u44PyNj88~upc*s{GBRjrGf*N)2nmpw z0Srlrl=Ng_G{~A$^qx&q)6t4;G%4iGQ_~Ts@F)){^&X%!*&{#z000M~0p%Eb$7Y}g0+2yUDXKt2VgINV3-OydX5CCaI>74NDz;w% z%x5Mf9eMKhX>pN*Dy_n z2G5sSL{E)EZOZtVn*oZbWJ2hHkKK{tisnVW!vJUQM+Jlu-PB-Odjc-G~sSARL0 z0W9vnmS>?RLCo+6enk(=n@GKWhSwetL|$&aBFTHt4u3PjnM{Fzz`&JJT8%(5_7v>D zPx8N&{Qqmi#o<8uZ7+5&NFqoC5&(Vz!9f90FwSr}x4X1thX{az=~FM6n&S+#hhxi> znuiAiY1{c&;m?(cXKYh|#~>d3X-VJf()s)u6C zOLV))uVw-M3!5&lG0$SX1@a%5z=y+DcS-sxQNuRFn!DCBdf*4h$uR^O&SV{vBdR+BP zcNSteG}1+9yWtcR(FQP9i^$xP z(LA-YnYPVsm86A9MC*#%8Ochbvo=~G2n<2--PAYH2#hz4tsL(KHFYE;k{WnX8IeE` zzl2Zs~^6{&w|Mo}ScbNbIT#R04XXv<*$Z&rOzJQZy}S@%Ad*NSb3Gyv1P}@= zO6unHSf-ZJ`l6OMd@U=jj;fPK$}qw=pxV-j>C8~HIUC6Zu?TV2XfoOFdnK7$Z6aEcA`&3RB9aI)2_PuD{(G9; zcD=t7&f=fn7YzM>w-@|sz~bLlF_Gm<1y;F|mEO!lwG$BIC6KaGQcjbToj@im0A5r9 zI>%CwLAy$L9aI`el`(|Qys&cmgMeGQ_hB+6{OQzd0M(B(tu5DV3z-Mq`AT^@@1+mE zow6QUWpf8qp>c<;jxhJnxEJ3c&H>B21Cs}5v;%(VO{-f_6MWUYWDr{GT&{ptJ@$3L6o z50d{v9Hae|^3U>lq2~K25%SRU!_Pl*2cG%i^G{r!v^=ND4;eopJW%=}*c*iE&gkk6 z>^{lnCSdl*U~i}THlwa&LDmpABv+tCMfU`RU<8s35JjzKs&xFNmSb#l7G^#za2NO# z)|?X2mtI*tI9>~QI9`-ON~-50?nglhjtKfPv`ric) z8_;7wPm*Om73TjyJ1+<(1k8iLC@*8;^17x)GLZx%krScOPCeZBpK$;18G_f~MjJhR zZ4f=Vx`pNt=~LaT0P=Blx`k(+xF})Q-b}tTyc>7{7r)& zN#d%YdK-<)8pC&_wp@xzdJeLVbMDf6MYgErEP-L^_ddRU|68zph=(S7eMgbhejfG9 zcbg}B)x~PPPRhj_kKR}`3^u$yLBhmPs;!emIG}fE({Da)qmQ2iI$&hl+Fzq2v}Li9 zZFWr7`Pt{$r)zIMo$T;!Jss=2W$W=-*=%;%CZ?>^U&iH8%_cm$9>+!6C(K*i#S|41 z>)~e3zZlhi%+I9N8yhT@ac(n2PFmDsKt%z=Ilc&)5gxX@;kLJ z3ufjwDzB8y7&ev*)$Q0_eTukOa%7Tx?3&Ic)YiY^WPVr~rtEHG+kpAbqKc}b%>_i7 z$f&xV)3p9>p5v-SGia9~2yqZTX9oFV8wDUX0i~*NM0$X_$sCbBaiXSzgUOI06~KO^ z5~f&GFpw*j0D42*+OB%%#Qq5;i=b7~X8n)sdVt?R_N0%(IF zyQi#9kuJw8xw(*cpcalR+D+*0L_TQ}L;&&ND(KvhDFI9K+B?X%0PfB`KY7+Wy3OO| zsgx3GR%%f=pe`zLC6-NHXSc<*hNd9VyGZ6ag8IK_?|PrOwbu0WovoxieucLR^1heS z`d9Zc3$ErJ;v9Sdy)Gw&M^ag3t|coa3&@4^34~!Q;ltELQrZPy79+CVRE8ZOic+j#MHbkXr+@Zq{?)+$ueGN6jO;?k0URc*YV81 zuJ`|)f3Sgcy6=@^E?UDNJ14{SL7j@D*C%|0Od^af-Ph^IWQido8Y5zuJpPIJ{f!*N zjn`toLqW7fRj5-OW5KxbIGbH_o0Q~vEN2VDu@X>viQZ-OKTpB0`frPGF%)Kc6kOsc zHJ1(-a@DjtHu|VMT^=7DtG8vHwi~NyOO?;ZFZXO79Hj27oEjJ+RaLU6i&koErJZ?) zHg1fQlTCrjg_i$&Glc3@X?u<a=-gJ73P+CBfj4{M>||K6MHSuX99WCENoIC9 zW_9ym&0a`x0^?hYhSv$K!9B_{yS({&)vr1Chj#X{9&uKgf?B{1-^@++CGvIEKp)`@-_y@Qt_D69J@WzINBqI)fdbeiT;Ryu33zxkN zmH_W%-9Hog-qXy%{eu@*dY-J|{qFs}r&wu`>6ZsA4WTw1<_~UzrGXJ$6`^^ToK`@n zBfWr1Ed?B3`-g^`G=I?7(}y0j2W9ScZ;dWfx^MSDwoM{A-CW7N#Lsj`V9}M0ej?3t{_a@+$4O!@7svC*} zPC|@89bNUf(?!w{?>EO!F&lf!NsyO_`0=)=Vu1AiKIIDWwv9CGu^c}}l$7~WrKGeP z=H@J2q)%o*+D^>}Vg@<6iP*b?Bll4Pp(Kd#!+Hgv;wFel9Q1a=P08mUuRqz37S4_^ z1?%acuCY}Bgf}sJ~TvZFkWa-A3 zlb3Z09wZYNGan_~=wscY`0-|-ds5@h^nX8dg9JArxsHb18$H`6MlQ@a;wS8(w)(DC zY9sHZ{zj*x%TIlz$+^={b;^j=L0Da01v^Es887vG`<6ByRMy1eZLT#ismra15j!hW zVMK{Qad@lithvN&8$6xUeCwTtd=ur?l-o>E?~*!`co)~QVCfu;cz)vxc0(7%3>@`W|JDwdays0JOjA;O3sTk79q zsSEMYYyNNJY4*o|pFZi3-F4lhha~FLrhL9ScOn}w6R!g|dr#!W;F)}iDjgZg*Trpc z?CX#h1}5qruY-4_+R<@xw-jw(!5$^n4aQji*^9!wZXhVR2(%3{sL7 zX;?^D#WhD5Wzxp-yjL}cI2Co6CoKPiyx|6Ocn;R_M>9e*Yg$vMX7e*6HS7BOit2HW zAk`6-Ak%`mpdN9pA!Dka82GR_*Li9 z?M)T3OR>%b`b zs|`b^lF8EUy!gVxeMH}5AuVKtLlBfAsT3BIK?w#dY4jp|Rb(%N$!U!A!a8sEfa*MV>73&SifAU!92#|Xd3x2h`wl=s#C@u$L_=vt z6_fC!w%K1BLfj~|1}GC!i?ANBCTE1e6KvfJBoO6P5b}ult?QI2e-As@Qt`%%uIw>; z`?gYpqY-F!M~jJY9U3{MKH}jD-sUhTP(uEO6=7gs|EYpt*rcQ)bGGYqT$M#rYi_Bn zyPv#qrv0IWyk=nby?!kywTL{a5we!f2At3oEm#jNA7jPv-+P$C=WCHUi^nG0({+0R z*1O5b{>!;%W4jsAlhWW%D8-#{uqKgpFW|dbqynt~#;Y_I)cJ^&Ht;2=>}{^Ic?+vN zufKTQSx6y9R0BO0Y=VoSLg6rnc8@w4@|SjbmEFpKrc8l|!ji)l=eiDYQcmuWjy*p`h@4w(#9%xAJMyx;Nn*QIP@xXqmhK~nzX2f+go8>gSAed;KI;J(s94#s zk)UW3>x!&imW-3J5iuh16NUlQoKbJry8MRn zMZ!^+j?6oPh(JUaXar{0TIs`p);K2Ai_n7cFavakcgd)HY#qU-BM(Nsx}(^tm5aU!Kt>{SSLrD?AgE-U65)s9wlD(P&P@87kg57^J00oJ~` zzXpp(MPx0ld*b&yt%*{gH>Y=s`a09L`iyE{ zzfc5a5Q$!~8PF*to=nm1i=;b5gzSMdaoDYcc97!hi4>X8!4F?LB=}f}F;K=Hk(TWX zzruL!Jw!R^V7qP=%!iq!o}RS@a?+x1iR&K6;PZQZJ`W&oJ|!LUY;kw|dpA1MiW@Ky zXl^x<`THuYCyu~`DHU=Ps72KGNR`9PZ3T>1sBWkTj89OB^2`PYkc$$bfkecl{0s+H zjk}9J(-1_hQp$ms3KR4rAHCe(p`=<(q#=2_Nc&hxyKnO>A*`tGL>54Fj?fKs2B7a4 zVx{3vP&v%kD73)@FAGs&g)iA{4iq()d8;ow*>*i8bWBU# zQIAo}EB2S+PT1(*WzQMck_Xc!yN^5^k&J40d(+-gDNzX&O%&mXdLnoCaTDxaVsqg+ zRV;wA0K?ifo1EK|dAiK$V^UE`bHIZO427dWsVNZ4t(aU>ispIz#`TSU!Y*wz6qJxT z8fnk=Ryek{*wYwiIU00F4K!YLWtWH8=zMQ^g5vs^&q5AV%|T8D3GZl1#g9dX=S6nn zS>yZ97basqCX7WG;L=2i=6t+({Jc7laU@8cy_VhtA1?HyiRSt``MY>;K=m*=PQ`e! zvzerc5+orQ&PcQ|FqFi(qI=pbW6)gr_L+(7W2M1qSRKb5U~gG!;USjKnZEkJ9i~7y z_#}@wSM;5 zd+YxW>gakN%GmxsAGV(pu4&H?$)7N}iN8^5lW6n{l16DIF6`(+&3(P*Hi)e+x zWh+O@{rB#_ub97Y9QnB$5=KHR;GIzOlvNj+)8EyYg^+X}M2Qjzh?CTNZI4ceZ;-iXc5%lNbB`K0iv`7pNf5bw zg5a?aC&u^xx4+&&!6EA7kcrce7CPNHl1bz|e;6|doGqC2d9JfPXdtiXilhBvj#vST z3JI4$NxXx7i&_ohfbI=Hal%*>0bDZZUtDHH`Ib!efT{^DJG@Er$ z2!K*RA^}MNhy^(COEB9UiYk|HX6e+WUAf6hyiPeXwQH_&ty+64oLX8*G^c+Y^ImR6 zRaVrkS6&{DtxDH}o0h655-AjwT>yzBmF=Q~42BY_fJCu2s_x^JRSe!X!RZ#;A7gpn z-f&}Y0aREZsgyDJP$Ulks`Pr_KdX1ofrQnH^X01Qyq!=F5ItdCcgh4=hrj?E1ov}N zuSLh(d9dmKT^@@MNloC7VOP5Me)FB}eqZ8w%lSS(?|R&fy`K`?Hh#0?wwYy?s-~XJ zHgIt+ODwX>EV9civC%Pm7prT}^Q~IWJ)-}shPvyny6djG>#n>PE@Q!cR`tAB@7=|V z2mStD=MCqo*LvArO$-;8v|q*-bHZ zjT=J_4E&>Trn8cM-FL}f@K|(v>Y9w*Wn}ejH8n2+#?sdcnqW+Qc7J4wp5;}IzB<1l zXe_NVHkR@jks?K{y}i6*K+Zh)qJ5q3SH8nsU7&IAfYYa475j5cjoWg`1QE*|u}Lj~ z%(F1~tMMTHZ`orRU7wj%n^eb6xj9KmNob;|aHQnKLNgPapP#q&AX4kBy9_*YpHHE8 zE@@hH(@ynUZnph?td1uqV!uA)xOye?ANJlya`aCtvGZt}7;H-v5=Sb?s@{j0KPH}k zE5-b;9?SOUcl*2N-=2BqyY40Qu3Yb^^>1RwUJQ6~EJ^2E^Rvd zYO8FjuIh0YL{*>_AGZO2E(aKpPypv@ni$453ZmNx1XNsIw`aFaB5l*WO~dJ(!_&G4 zK5z=f?ghli)sJjJ-q~wKNOZzv$>)=@={6qg$jT7weDQ%qc&3mt;W7zl`{F?SO`DIN zT(71~e>Xp9`z85so-J5M0!eNG6eMj3q#<^A9kxs4>&P7XH`9NW>0jVsSoG}bUny>le%Wz z^ttx*lX*Q8@6Skwp_h2}N97k~o{{tnHi-|#Ur@KEB61$6<%%o9Pyn7J`usv6k;Jon zGUMy-3=yXe8cYdiLjd2E*-j{+9TDx$i2DWHrd3fN%LUfJLD|(HWd{vt6m+)Dvpfjc zE@tBl$2p?hRSg*wQPk{kG2R*6Iu_fPOnxfdcJq$q+;g8X+?)0k|H_`2egJxB$~QX% zho<)4dU7X0Je2gq@B@qt_#Io*IW*r%j_q7BilJk|xFt;5aw(QfB-EKhlRFdm%%S{np$+-3E5Au=_C?{{m|$N4Yovw-cvl6> z#BE5h@5j!#kqW?!p%w!;7YHDLJ#YtxW{(64AU6Uid+bqhd8_e*G#ZCY^{KB-%b9QB z>36#1om1Am`_~vH%h1F`8KkX-<&CuEIBeXuY^-gHFf~Y#C;@&FHc+S%!DtjJg`*Bk z*i&XxW}M(>EZbJt)q_ykX@<47E*Cb+*iLY5xeTD(!HsOqa#}$Ost`g%2S$RB7NUtF zqavvyC`c&3Zo;$x^sBlJgl{s!!83Q;W~L>YhOEkFS~hw2b`8wkGTXNtkyKK}o1EBK z=59ESGExfL!sBtJib$5UES0LQZ6r5X;lgJ*wpinuX)NM#mR(Gob1P+IjyS0)*EbGx zb6Kq>&U2Kro0+MV#hXPCDoUV|s-r8LMT-(8q8AYs!En*TjvQ-Rjm^$7(W?}!wY3>k zD`jj&rIJfwAtu{q|J#nb#xs$f_?gr?R-0l&7|Ay{<6zrzW1E)+WQ2z!C4~hWRyI`% zW-6;QQL%%Tc#9oaY*9?g+cQ>UW+cj0YHdcTB-w^_uxT_@9ZW>(qA$mQsJCFGfy&0- zstkoEYdW*TH_O|@Hzsqxm%{LP5UUmnmrJ720Rg%uI09xAMNA@tjNThfm9bkjt+QB$ zVHt~IO`9#I)=Z|uNtLxSlS4`kjk9w$+S5!ACA6B@nrpV>irJdlN~>1YlVz=CQ8s5Z zX#>`eDY<~*Hr&>2ovhfb*sZJn6Ukj$HslK1Q<5~LD%vYnt5p)KYiiO}wNkRCrL?OS zsuOLqTD63drK==ONV2u9ERwQ}WU7+UOC*zK%1KogqP1+>y*BV$Zdtc1VvUuJl+DgK z$^{ymR&{ORs>;bLDc{a!p{lKGSz5O3&9t*pwx)!OOJbQy)GJY`l*+Xvm8)8nYP1xl zQAP_@X;e}bsFhh&P?JclTT^XCX&RA6GrJbsHH!y)qiu-{Qw>{YXJF7xwr$`!v5qpa zY*?(bR%m85v=YH-lq4*+p*3pT9tdm>?J%{B;8KaVtj+2duXvnnrHP8wL0d6Fw}E4F z%rWHl(T=vTlVd2@+0~3F+ijj0Fh!lqJP_FF8zqgNCR=#A&CHt_j{1W(Jf@jhs0f)u z&J!UdJzvjl=Ci3-tV~2tk7`2D@n!l6T5fwoVvbHKgosFj0f`Y+keNzV8a8PVXo?H* zq9AM}Lg9c?O@p-`Ej1xFw%c0Pq|#Q2lSHJ8Y0bgJ(#a($OG<-nO3e|n zA|fm@Ac?n`+inr)5zR%9AFg4k(o%}dc@x0g%H-LYB1=#1Ig|2qmIeAh;Mb z(G+lkTuqW}b(U_4w^FmZwNgt|fZElmEhuJHR;B@Dz*iL2vFF?MWnDPTNGG=g$0dmwr<^x#@jnP zCkGHU#m4AH+ekK}Y^>S0ZUc-tHq_G1WMyrd%QKj*gl&W5?yMBD%PbKL2#z8e6gdLx zzahqrh9R#E0j)O1F!axQ4ugt1ZH?PAI(3InP;`6hM~aC_Mx4UNGZD)+5!+$46hNp{ zrXo;9Mg$kEYG{Erkh=x~;Q<*6gHTnZAYY!YVhJP3*1;@@d#mXH3lLE%3Qlm*0CilKi7_6*I3+3CU zsKKRailqAE!TEb1z%##!CQ&%d*@C2rK@mAw9b(Ken!eB@Bnmj-N3*pCSXs(DL?|J; z#&XPaHsH7tyd>N4L1ID&32o3KO3Pys2tqJ|4lw{BVDaP5^tqQc>KjAh{?F)meE(Cz zUyGhQE>H+TBd0wOXd_Q}n(qWQc2k>eNQ>ral1+mlb@N^zZGn%cV&NbeQwp{8335ZT z9{Zn4c(sUmnajf(Wv2V|fOeOLi?Ds%E?uBYy0O*`moCs>OV_Vj0C&f8F}ITNQy^oZ z0)i(f2!oa@;|>*gLAwf3!GjoD)Lal$xCkI1(P&U6^~Lb9n9Yw7guGJ&fUA&i^pId! zRgeKE%(eOQVT6p^`&l_Xeds17F$D+`Dh9TI8jL_<5d}XSATQvwwy+&unLvl=Ji6Y3 z2HD;gvM0}fwfWADmEwlyZ;WgrX&?vHg0v=M0TfOvfi4nk#SFf%>J|~aU_DI3ab+$T zn-1x>U>lhnp~&>ZZwwVf0pC08V~U2mf0J@tiSQwCMOT!DO9rZjZ)-!OF#*iz+>EPy9p6TkW;^8viLbRnu?gAt)Pd@BU| zmX!-{dka-Y;N30@KnN|N7*wJ{t8}xw#_j}l9m%*?UR+Q%Dgdxz%pF3v^j`grbW5)q z$XkhMM#@TuI`L(?$xxis#EQb=CXn8fwghoU017#Q%<#nV3u{G@Gw}WPGd|HgpJR4C z!EZcGyH@PfEKnDr5W7AyizVg@0sTRfY{~S=2l+Sw_0$aRp|1ys$#ADoOf4|SK&XT^ z0U|9h?$S=X!u93ELUM};fhX`ir!!ej8Ga_oLrXdWM8tzhKGd{0`Ta8ZN zOm{AT(a}gzt*5PHUz1tMBp6(1Bi}mt1Z(0BmIQH85R$$F$#k7pj}4mzzB5dA0mw~p z5eVSC`~B%ICP3Cu6gAf;-BKDLFtN8SBwIsisKQICqY>p0+qf}R%<$8FDi&fn5HL@s z>wx*Odzf-NWTX^LD7x7#s2ez}>wk38tI6ndd&WqH#c75ba!=FSw#eLS>iVcu2@v#c-jhh}OecLI!YM&Vd=S znjc>v%aCnRfjLr5kuuvb8Idr>N~${qL=&Frwx?SCT``NROC=sAI{O)+&8l~jU=URi zQ5vk#wI#Tg-lAT()~eC4X%~NB#cSk{geN%YW6C5S5NI(e5@XA`Mropp2H?XFS~k2< zOd*dOH}T%3_=AU3at5N{HXx#QSlT!qugowiQ^gd#~H7)~mz ztzghl9<J4Zxh6@YgA-*QEWgHI0?-wxMy%kKkObBDqWiC)0 zEz+zJ0+$jS;B3+#j$<|vLx9x@Ych+hRj=8o_$K`((vB_C;>fCDd#GIVa~A=wCW;g@ zf;1z-AvO%J&L*u55jMk>VtEs10ALkF#;B^8qr@wRFKX`#V77#{2^~^MIFBYVmk@n8 zeZcC4Kw2PR;36qu{Dk2r>*vw31O6~zRK-gunl zgPSg6O^i7K)Wc}o9l%6iJ|YR~G^xJ?XIqvHA}M*x9r4}6 zXNMp(hEsf1Mu7y=kb#k;MI%tw2oxouMIQ9s6OT3eRhXKML|B7^p(!hf zk+fv!s7f_laz{{w1A!%6R{gLW4P8z|=R;RcaB-aunCb~~fpVeK#^sEOAVwZ`BdfyP zY8eYrp-!evT{@Ly9YOrcaSNhkJ!C*F2u8&$M;NRcZ3WIqacyRqC1cWPL4sOCCtMAv zEDCEFkT#S+RS<2*eK#@C7sSh!N7NC?iWL%f5EM-wwONpi2!JFy2gGAy5&<#9`O3~Q{5#;YtbdAnoXuzZnsy8e zQ|CU6r~n@)+4w)zbS|KXCBmobN$RSqrIJ~tzw|5I-yA}HyEP!2J8tOjZfAILyt11F zST+*YEG(TmxJ#C%G!Oju97OEvw&?7#S?8;)v zy5`4O9GxgwP*VuXA!Mr>q8>?kTSCPG(hUR)+f{>|a+XkS1tbcJ1R$>TL~ekoP*L21 ztwB=&fS{OF0lK1;;UKLM+tW&L_sbXqU?Wj&C@Bnv|AZQ{qFM|F)OX77tU9-KO`1hyhkcE^CWf>q1*2?g1v6~V8_+q1 z>Hs%VAm3o9QbL%G_-=B&H%r`pEuQoE)BB#sxzhGqAJ52Fmg!TX4y-IXZWI+GhT zb=|pe{i$VczBw#EleIZ6RauH_9 zt9Q+t@*7V-=YG6^3sF90$4Pu7aGlzSw4>rTD;irKlWH&h@j>(JG(B zSXZ<6`&<}5_aWS|bI7d7Y^0*=Vs`)F!5=Qbg5cTtKA5r{_@gvo+QD2eM&>`E?`ArK znI=5Z#83EC4`PLYI|GKB$;})bZ_AQx_cqM7qy~y0zt;K^Hyx*A*-~-n`T>O!8V((X z!sibWp4L5{OF`BtLdUiclF48Mmta2Y;&+Kl(V9G$L80?@uxpMr~pLaPmO4_oQ4aZ9hfvb$7n(tOW|_c9Uq za=hT%)H9;WWp%z6>A=U}Iy6l5ZTK!Z+&`iIMD95E{?Oz~BWU;f79ZT(1t>a{pNhFd< zB$7!mu1dA7>v^qCjCg^}cKt*A_3}_gB5%<>HU}@62j+&Td&aRCVT=WqS!I@4Y}dQK zu1!$CVIB4&ZdUvCw$J&x9?qOO)%rRvYyihszrpK0+itibcBbEE<99svk^g1SLv6*a z8|>b(zW8q(xv1Q;&h?hp^1haCym)o)WjIn; zX2dcrUvIFEF6G4Z}ttF!_HA i%KZP6{7;-Buc8LEDle4;N4Ld?{}*yaI8czsSoe%GtddIr diff --git a/inst/create-list-available-forecasts.R b/inst/create-list-available-forecasts.R index fc4926797..07105a7f4 100644 --- a/inst/create-list-available-forecasts.R +++ b/inst/create-list-available-forecasts.R @@ -28,8 +28,8 @@ metrics_quantile <- list( "underprediction" = underprediction, "dispersion" = dispersion, "bias" = bias_quantile, - "coverage_50" = \(...) {do.call(interval_coverage_quantile, c(list(...), range = 50))}, - "coverage_90" = \(...) {do.call(interval_coverage_quantile, c(list(...), range = 90))}, + "coverage_50" = interval_coverage_quantile, + "coverage_90" = \(...) {run_safely(..., range = 90, fun = interval_coverage_quantile)}, "coverage_deviation" = interval_coverage_deviation_quantile, "ae_median" = ae_median_quantile ) From ebe38695b30d066cea117506f8f2d7c7f1ab8394 Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Tue, 14 Nov 2023 22:40:49 +0100 Subject: [PATCH 48/49] correct `check_columns_present()` --- R/check-input-helpers.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/check-input-helpers.R b/R/check-input-helpers.R index 6437e55df..95869f02b 100644 --- a/R/check-input-helpers.R +++ b/R/check-input-helpers.R @@ -304,7 +304,7 @@ check_columns_present <- function(data, columns) { } } missing <- unlist(missing) - if (length(missing > 1)) { + if (length(missing) > 1) { msg <- paste0( "Columns '", paste(missing, collapse = "', '"), "' not found in data" ) From ba9adbf9235a0d1e6756d635628e3f7bcfbfa853 Mon Sep 17 00:00:00 2001 From: nikosbosse Date: Tue, 14 Nov 2023 22:54:33 +0100 Subject: [PATCH 49/49] Update `set_forecast_unit()` and add tests --- R/convenience-functions.R | 9 ++--- man/ensure_data.table.Rd | 20 +++++++++++ tests/testthat/test-convenience-functions.R | 39 +++++++++++++-------- tests/testthat/test-score.R | 8 ++--- 4 files changed, 49 insertions(+), 27 deletions(-) create mode 100644 man/ensure_data.table.Rd diff --git a/R/convenience-functions.R b/R/convenience-functions.R index 3448df5a3..31f3ab5ab 100644 --- a/R/convenience-functions.R +++ b/R/convenience-functions.R @@ -237,13 +237,10 @@ log_shift <- function(x, offset = 0, base = exp(1)) { #' ) set_forecast_unit <- function(data, forecast_unit) { data <- ensure_data.table(data) - missing <- check_columns(data, forecast_unit) + missing <- check_columns_present(data, forecast_unit) if (!is.logical(missing)) { - warning( - missing, - " (stopped checking at the first missing column)." - ) - forecast_unit <- intersect(forecast_unit, datacols) + warning(missing) + forecast_unit <- intersect(forecast_unit, colnames(data)) } keep_cols <- c(get_protected_columns(data), forecast_unit) out <- unique(data[, .SD, .SDcols = keep_cols])[] diff --git a/man/ensure_data.table.Rd b/man/ensure_data.table.Rd new file mode 100644 index 000000000..6d2457ee5 --- /dev/null +++ b/man/ensure_data.table.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{ensure_data.table} +\alias{ensure_data.table} +\title{Ensure That an Object is a Data Table} +\usage{ +ensure_data.table(data) +} +\arguments{ +\item{data}{An object to ensure is a data table} +} +\value{ +A data table +} +\description{ +This function ensures that an object is a data table. +If the object is not a data table, it is converted to one. If the object +is a data table, a copy of the object is returned. +} +\keyword{internal} diff --git a/tests/testthat/test-convenience-functions.R b/tests/testthat/test-convenience-functions.R index ecfc86653..98d784cd4 100644 --- a/tests/testthat/test-convenience-functions.R +++ b/tests/testthat/test-convenience-functions.R @@ -38,46 +38,55 @@ test_that("function transform_forecasts works", { }) +# ============================================================================ # +# `set_forecast_unit()` +# ============================================================================ # test_that("function set_forecast_unit() works", { - # some columns in the example data have duplicated information. So we can remove # these and see whether the result stays the same. - - scores1 <- suppressMessages(score(example_quantile)) - scores1 <- scores1[order(location, target_end_date, target_type, horizon, model), ] + scores1 <- scores_quantile[order(location, target_end_date, target_type, horizon, model), ] ex2 <- set_forecast_unit( example_quantile, c("location", "target_end_date", "target_type", "horizon", "model") ) - scores2 <- suppressMessages(score(ex2)) + scores2 <- score(ex2) scores2 <- scores2[order(location, target_end_date, target_type, horizon, model), ] expect_equal(scores1$interval_score, scores2$interval_score) }) +test_that("set_forecast_unit() works on input that's not a data.table", { + df <- data.frame( + a = 1:2, + b = 2:3, + c = 3:4 + ) + expect_equal( + colnames(set_forecast_unit(df, c("a", "b"))), + c("a", "b") + ) + # apparently it also works on a matrix... good to know :) + expect_equal( + names(set_forecast_unit(as.matrix(df), "a")), + "a" + ) +}) -test_that("function set_forecast_unit() gives warning when column is not there", { +test_that("function set_forecast_unit() gives warning when column is not there", { expect_warning( set_forecast_unit( example_quantile, - c("location", "target_end_date", "target_type", "horizon", "model", "test") + c("location", "target_end_date", "target_type", "horizon", "model", "test1", "test2") ) ) }) - test_that("function get_forecast_unit() and set_forecast_unit() work together", { - fu_set <- c("location", "target_end_date", "target_type", "horizon", "model") - - ex <- set_forecast_unit( - example_binary, - fu_set - ) - + ex <- set_forecast_unit(example_binary, fu_set) fu_get <- get_forecast_unit(ex) expect_equal(fu_set, fu_get) }) diff --git a/tests/testthat/test-score.R b/tests/testthat/test-score.R index 5e8e76083..a67575984 100644 --- a/tests/testthat/test-score.R +++ b/tests/testthat/test-score.R @@ -168,17 +168,13 @@ test_that("score.scoringutils_point() errors with only NA values", { test_that("score_quantile correctly handles separate results = FALSE", { df <- example_quantile[model == "EuroCOVIDhub-ensemble" & target_type == "Cases" & location == "DE"] - eval <- suppressMessages( - score( - df[!is.na(predicted)], - separate_results = FALSE - ) - ) + eval <- score(df[!is.na(predicted)], separate_results = FALSE) expect_equal( nrow(eval) > 1, TRUE ) + expect_true(all(names(metrics_quantile) %in% colnames(eval))) })