|
| 1 | +#' @include Range.R StepOne.R |
| 2 | + |
| 3 | +Validation <- R6::R6Class("Validation", |
| 4 | + private = list( |
| 5 | + .backend = NULL, |
| 6 | + .recommendation = NULL, |
| 7 | + .validator = NULL, |
| 8 | + |
| 9 | + # Extract the recommendation for `StepThree` samples. |
| 10 | + .set_recommendation = function(step_3, ci = 0.5) { |
| 11 | + private$.recommendation <- step_3$samples[paste0(ci * 100, "%")] |
| 12 | + }, |
| 13 | + |
| 14 | + # Configure new `StepOne` instance (aka `validator`) based on previous one. |
| 15 | + .configure_validator = function(step_3) { |
| 16 | + # Create instance of `StepOne` that will act as the validator. |
| 17 | + private$.validator <- StepOne$new() |
| 18 | + |
| 19 | + # Set set the `validator` instance based on the configuration used to obtain the current results. |
| 20 | + private$.validator$set_model(step_3$step_1$model_type) |
| 21 | + private$.validator$set_true_model_parameters(matrix = step_3$step_1$true_model_parameters) |
| 22 | + private$.validator$set_measure(step_3$step_1$measure_type, step_3$step_1$measure_value) |
| 23 | + private$.validator$set_statistic(step_3$step_1$statistic_type, step_3$step_1$statistic_value) |
| 24 | + }, |
| 25 | + |
| 26 | + # Run the validation for a request sample size. |
| 27 | + .run = function(sample, replications) { |
| 28 | + # Create `Range` instance with the recommended sample size. |
| 29 | + range <- Range$new(sample, sample, tolerance = -1) |
| 30 | + |
| 31 | + # Feed the range to the validator. |
| 32 | + private$.validator$set_range(range) |
| 33 | + |
| 34 | + # Run the validation. |
| 35 | + private$.validator$simulate(replications, private$.backend) |
| 36 | + |
| 37 | + # Compute the statistics. |
| 38 | + private$.validator$compute() |
| 39 | + } |
| 40 | + ), |
| 41 | + |
| 42 | + public = list( |
| 43 | + # Register backend. |
| 44 | + register_backend = function(backend) { |
| 45 | + # Make sure we are provided an active backend. |
| 46 | + if (!is.null(backend) && !backend$active) { |
| 47 | + # Warn the users. |
| 48 | + warning("Please provide an active backend. Will not use this one.") |
| 49 | + } else { |
| 50 | + # Register the backend. |
| 51 | + private$.backend <- backend |
| 52 | + } |
| 53 | + }, |
| 54 | + |
| 55 | + # Prepare for validation. |
| 56 | + configure_validator = function(step_3, ci = 0.5) { |
| 57 | + # Extract and store the recommended sample size. |
| 58 | + private$.set_recommendation(step_3, ci) |
| 59 | + |
| 60 | + # Configure the `validator` instance. |
| 61 | + private$.configure_validator(step_3) |
| 62 | + }, |
| 63 | + |
| 64 | + # Perform the validation. |
| 65 | + run = function(sample, replications = 3000) { |
| 66 | + # If no sample is provided, then use the recommendation. |
| 67 | + if(missing(sample)) { |
| 68 | + sample <- private$.recommendation |
| 69 | + } |
| 70 | + |
| 71 | + # Run. |
| 72 | + private$.run(sample, replications) |
| 73 | + }, |
| 74 | + |
| 75 | + # Plot the validation results. |
| 76 | + plot = function() { |
| 77 | + # Revert the changes on exit. |
| 78 | + on.exit({ |
| 79 | + # Restore margins to default. |
| 80 | + par(mar = c(5.1, 4.1, 4.1, 2.1)) |
| 81 | + }) |
| 82 | + |
| 83 | + # Adjust margins for layout. |
| 84 | + par(mar = c(5.1, 4.1, 4.1, 2.1) + 1) |
| 85 | + |
| 86 | + # Plot histogram of performance measures. |
| 87 | + hist( |
| 88 | + private$.validator$measures, |
| 89 | + col = "#00000023", |
| 90 | + border = FALSE, |
| 91 | + main = paste0("Sample: ", private$.validator$range$partition, " | ", |
| 92 | + "Measure at ", self$percentile, " pert.: ", round(self$percentile_value, 3), " | ", |
| 93 | + "Statistic: ", round(private$.validator$statistics, 3)), |
| 94 | + xaxt = "n", |
| 95 | + xlab = "" |
| 96 | + ) |
| 97 | + title( |
| 98 | + xlab = paste0("Performance measure values (", toupper(private$.validator$measure_type), ")"), |
| 99 | + line = 4.5, |
| 100 | + cex.main = 1, |
| 101 | + cex.lab = 1 |
| 102 | + ) |
| 103 | + axis( |
| 104 | + side = 1, |
| 105 | + at = round(seq(min(private$.validator$measures), max(private$.validator$measures), length.out = 15), 2), |
| 106 | + line = 1.5, |
| 107 | + las = 2, |
| 108 | + cex.axis = .9 |
| 109 | + ) |
| 110 | + # Value at percentile of interest, |
| 111 | + abline(v = self$percentile_value, lwd = 2, lty = 3, col = "darkred") |
| 112 | + mtext(round(self$percentile_value, 3), side = 1, at = self$percentile_value, col = "darkred", font = 2, line = 0.3, cex = 1) |
| 113 | + } |
| 114 | + ), |
| 115 | + |
| 116 | + active = list( |
| 117 | + recommendation = function() { return(private$.recommendation) }, |
| 118 | + validator = function() { return(private$.validator) }, |
| 119 | + measures = function() { return(private$.validator$measures) }, |
| 120 | + statistic = function() { return(private$.validator$statistics) }, |
| 121 | + sample = function() { return(private$.validator$range$partition) }, |
| 122 | + |
| 123 | + # The desired percentile as a string. |
| 124 | + percentile = function() { |
| 125 | + return(paste0((1 - private$.validator$statistic_value) * 100, "th")) |
| 126 | + }, |
| 127 | + |
| 128 | + # The performance measure value at the desired percentile. |
| 129 | + percentile_value = function() { |
| 130 | + return(quantile(private$.validator$measures, probs = 1 - private$.validator$statistic_value)) |
| 131 | + } |
| 132 | + ) |
| 133 | +) |
0 commit comments