mrc-ide / SIMPLEGEN
Showing 7 of 60 files from the diff.
Newly tracked file
R/assertions_v9.R changed.
Other files ignored by Codecov
docs/index.html has changed.
docs/pkgdown.css has changed.
docs/pkgdown.yml has changed.
index.md has changed.
docs/authors.html has changed.
docs/pkgdown.js has changed.
_pkgdown.yml has changed.

@@ -120,10 +120,16 @@
Loading
120 120
  // objects for storing results
121 121
  daily_values = vector<vector<vector<double>>>(params->n_demes, vector<vector<double>>(params->max_time));
122 122
  // age distributions. Final level: 0 = Sh, 1 = Eh, 2 = Ah, 3 = Ch, 4 = Ph
123 -
  age_distributions = vector<vector<vector<vector<double>>>>(params->n_output_age_times, vector<vector<vector<double>>>(params->n_demes, vector<vector<double>>(params->n_life_table, vector<double>(5))));
123 +
  age_distributions = vector<vector<vector<vector<double>>>>(params->n_output_age_times,
124 +
                              vector<vector<vector<double>>>(params->n_demes,
125 +
                                      vector<vector<double>>(params->n_life_table, vector<double>(8))));
124 126
  
125 127
  // misc
126 128
  EIR = vector<double>(params->n_demes);
129 +
  prob_infectious_bite = vector<double>(params->n_demes);
130 +
  inc_infection = vector<double>(params->n_demes);
131 +
  inc_acute = vector<double>(params->n_demes);
132 +
  inc_chronic = vector<double>(params->n_demes);
127 133
  
128 134
}
129 135
@@ -192,7 +198,8 @@
Loading
192 198
      // get number of new infectious bites on humans
193 199
      EIR[k] = params->a * Iv[k] / double(H[k]);
194 200
     
195 -
      double prob_infectious_bite = 1 - exp(-EIR[k]);  // probability of new infectious bite on host
201 +
      // probability of new infectious bite on host
202 +
      prob_infectious_bite[k] = 1 - exp(-EIR[k]);
196 203
      
197 204
      // one method of drawing infections in humans would be to draw the total
198 205
      // number of infectious bites from Binomial(H[k], prob_infectious_bite),
@@ -206,17 +213,17 @@
Loading
206 213
      // host-specific and changes over inoculations. Therefore, as a
207 214
      // middleground, draw from Binomial(H[k],
208 215
      // max_prob_infection*prob_infectious_bite), where max_prob_infection is
209 -
      // the largest value that prob_infection could possibly take. Loop
216 +
      // the largest value that prob_infection could possibly take. Then loop
210 217
      // through these query infectious bites and draw from a Bernoulli
211 218
      // distribution relative to this value.
212 219
      //
213 220
      // For example, if prob_infection = {0.1, 0.05} then filter based on the
214 221
      // value 0.1, i.e. draw the number of query infected hosts from
215 -
      // Binomial(H[k], 0.1). Then loop these query hosts and draw from the
216 -
      // relative probability of infection, which is Bernoulli with
217 -
      // probability {0.1, 0.05}/0.1 = {1.0, 0.5}.
222 +
      // Binomial(H[k], 0.1*prob_infectious_bite). Then loop through these query
223 +
      // hosts and draw from the relative probability of infection, which is
224 +
      // Bernoulli with probability {0.1, 0.05}/0.1 = {1.0, 0.5}.
218 225
      
219 -
      int host_query_infection = rbinom1(H[k], params->max_prob_infection * prob_infectious_bite);
226 +
      int host_query_infection = rbinom1(H[k], params->max_prob_infection * prob_infectious_bite[k]);
220 227
      for (int i = 0; i < host_query_infection; ++i) {
221 228
        
222 229
        // choose host at random
@@ -344,11 +351,14 @@
Loading
344 351
    // update counts of each host status in each deme
345 352
    update_host_counts(t);
346 353
    
354 +
    // update incidence measures
355 +
    update_incidence(t);
356 +
    
347 357
    // store daily values
348 358
    for (int k = 0; k < params->n_demes; ++k) {
349 359
      daily_values[k][t] = {double(H[k]), double(Sh[k]), double(Eh[k]), double(Ah[k]), double(Ch[k]), double(Ph[k]),
350 360
                            double(Sv[k]), double(Ev[k]), double(Iv[k]),
351 -
                            EIR[k],
361 +
                            EIR[k], inc_infection[k], inc_acute[k], inc_chronic[k],
352 362
                            Ah_detectable_microscopy[k], Ch_detectable_microscopy[k],
353 363
                            Ah_detectable_PCR[k], Ch_detectable_PCR[k],n_inoc[k]};
354 364
    }
@@ -356,6 +366,7 @@
Loading
356 366
    // store age distributions
357 367
    if (params->output_age_distributions && (params->output_age_times[index_age_distributions] == t+1)) {
358 368
      
369 +
      // get age distribution
359 370
      get_age_distribution(index_age_distributions);
360 371
      
361 372
      // update index
@@ -371,9 +382,10 @@
Loading
371 382
        // get sampling parameters
372 383
        int this_deme = params->ss_deme[index_obtain_samples];
373 384
        int this_n = params->ss_n[index_obtain_samples];
385 +
        Diagnosis this_diagnosis = params->ss_diagnosis[index_obtain_samples];
374 386
        
375 387
        // obtain samples
376 -
        get_sample_details(t, this_deme, this_n);
388 +
        get_sample_details(t, this_deme, this_n, this_diagnosis);
377 389
        
378 390
        // increment index
379 391
        index_obtain_samples++;
@@ -447,12 +459,41 @@
Loading
447 459
    H[k] = Sh[k] + Eh[k] + Ah[k] + Ch[k] + Ph[k];
448 460
  }
449 461
  
462 +
}
463 +
464 +
//------------------------------------------------
465 +
// update incidence measures
466 +
void Dispatcher::update_incidence(int t) {
467 +
  
468 +
  // reset values
469 +
  fill(inc_infection.begin(), inc_infection.end(), 0.0);
470 +
  fill(inc_acute.begin(), inc_acute.end(), 0.0);
471 +
  fill(inc_chronic.begin(), inc_chronic.end(), 0.0);
472 +
  
473 +
  // loop through all hosts, update incidence in given deme
474 +
  for (unsigned int i = 0; i < host_pop.size(); ++i) {
475 +
    int this_deme = host_pop[i].deme;
476 +
    
477 +
    // incidence of infection
478 +
    double inc1 = prob_infectious_bite[this_deme] * host_pop[i].get_prob_infection() / double(H[this_deme]);
479 +
    inc_infection[this_deme] += inc1;
480 +
    
481 +
    // incidence of acute and chronic infection
482 +
    double inc2 = host_pop[i].get_prob_acute();
483 +
    inc_acute[this_deme] += inc1 * inc2;
484 +
    inc_chronic[this_deme] += inc1 * (1.0 - inc2);
485 +
  }
450 486
  
451 487
}
452 488
453 489
//------------------------------------------------
454 490
// draw sample from deme
455 -
void Dispatcher::get_sample_details(int t, int deme, int n) {
491 +
void Dispatcher::get_sample_details(int t, int deme, int n, Diagnosis diag) {
492 +
  
493 +
  // n cannot exceed human population size at this point in time
494 +
  if (n > H[deme]) {
495 +
    n = H[deme];
496 +
  }
456 497
  
457 498
  // draw vector by sampling without replacement
458 499
  vector<int> samp = sample4(n, 0, H[deme] - 1);
@@ -465,8 +506,31 @@
Loading
465 506
    int this_host_ID = host_pop[this_index].host_ID;
466 507
    
467 508
    // find if positive for malaria parasites
509 +
    bool test_positive =  false;
468 510
    Status_host this_host_status = host_pop[this_index].get_host_status();
469 -
    bool test_positive = (this_host_status == Host_Ah || this_host_status == Host_Ch);
511 +
    if (this_host_status == Host_Ah) {
512 +
      
513 +
      // get positive prob for acute microscopy vs PCR
514 +
      double prob_positive = 0.0;
515 +
      if (diag == microscopy) {
516 +
        prob_positive = host_pop[this_index].get_detectability_microscopy_acute(t);
517 +
      } else if (diag == PCR) {
518 +
        prob_positive = host_pop[this_index].get_detectability_PCR_acute(t);
519 +
      }
520 +
      test_positive = rbernoulli1(prob_positive);
521 +
      
522 +
    } else if (this_host_status == Host_Ch) {
523 +
      
524 +
      // get positive prob for chronic microscopy vs PCR
525 +
      double prob_positive = 0.0;
526 +
      if (diag == microscopy) {
527 +
        prob_positive = host_pop[this_index].get_detectability_microscopy_chronic(t);
528 +
      } else if (diag == PCR) {
529 +
        prob_positive = host_pop[this_index].get_detectability_PCR_chronic(t);
530 +
      }
531 +
      test_positive = rbernoulli1(prob_positive);
532 +
      
533 +
    }
470 534
    
471 535
    // save basic details
472 536
    vector<int> this_details = {t+1, deme+1, this_host_ID, test_positive};
@@ -495,7 +559,7 @@
Loading
495 559
  // get current time
496 560
  int t = params->output_age_times[t_index];
497 561
  
498 -
  // loop through all hosts, update age distribution
562 +
  // loop through all hosts, update age distributions
499 563
  for (unsigned int i = 0; i < host_pop.size(); ++i) {
500 564
    int this_deme = host_pop[i].deme;
501 565
    int this_age = host_pop[i].get_age(t);
@@ -519,6 +583,16 @@
Loading
519 583
    default:
520 584
      Rcpp::stop("invalid host status in get_age_distribution()");
521 585
    }
522 -
  }
586 +
    
587 +
    // incidence of infection
588 +
    double inc1 = prob_infectious_bite[this_deme] * host_pop[i].get_prob_infection() / double(H[this_deme]);
589 +
    age_distributions[t_index][this_deme][this_age][5] += inc1;
590 +
    
591 +
    // incidence of acute and chronic infection
592 +
    double inc2 = host_pop[i].get_prob_acute();
593 +
    age_distributions[t_index][this_deme][this_age][6] += inc1 * inc2;
594 +
    age_distributions[t_index][this_deme][this_age][7] += inc1 * (1.0 - inc2);
595 +
    
596 +
  }  // end loop through hosts
523 597
  
524 598
}

@@ -1,653 +1,653 @@
Loading
1 -
2 -
#### HELPER FUNCTIONS ####################################################################
3 -
4 -
#------------------------------------------------
5 -
# for single value, return value as string. For vector of values return string
6 -
# of comma-separated values enclosed in curly brackets
7 -
#' @noRd
8 -
nice_format <- function(x) {
9 -
  if (is.null(x)) {
10 -
    return("")
11 -
  }
12 -
  if (length(x)==1) {
13 -
    ret <- as.character(x)
14 -
  } else {
15 -
    ret <- paste0("{", paste(x, collapse = ", "), "}")
16 -
  }
17 -
  return(ret)
18 -
}
19 -
20 -
#### BASIC OBJECT TYPES ####################################################################
21 -
22 -
#------------------------------------------------
23 -
# x is NULL
24 -
#' @noRd
25 -
assert_null <- function(x, message = "%s must be null",
26 -
                        name = paste(deparse(substitute(x)), collapse = "")) {
27 -
  if (!is.null(x)) {
28 -
    stop(sprintf(message, name), call. = FALSE)
29 -
  }
30 -
  return(TRUE)
31 -
}
32 -
33 -
#------------------------------------------------
34 -
# x is not NULL
35 -
#' @noRd
36 -
assert_non_null <- function(x, message = "%s cannot be null",
37 -
                            name = paste(deparse(substitute(x)), collapse = "")) {
38 -
  if (is.null(x)) {
39 -
    stop(sprintf(message, name), call. = FALSE)
40 -
  }
41 -
  return(TRUE)
42 -
}
43 -
44 -
#------------------------------------------------
45 -
# x is atomic
46 -
#' @noRd
47 -
assert_atomic <- function(x, message = "%s must be atomic (see ?is.atomic)",
48 -
                          name = paste(deparse(substitute(x)), collapse = "")) {
49 -
  if (!is.atomic(x)) {
50 -
    stop(sprintf(message, name), call. = FALSE)
51 -
  }
52 -
  return(TRUE)
53 -
}
54 -
55 -
#------------------------------------------------
56 -
# x is atomic and single valued (has length 1)
57 -
#' @noRd
58 -
assert_single <- function(x, message = "%s must be a single value",
59 -
                          name = paste(deparse(substitute(x)), collapse = "")) {
60 -
  assert_non_null(x, name = name)
61 -
  assert_atomic(x, name = name)
62 -
  assert_length(x, 1, name = name)
63 -
  return(TRUE)
64 -
}
65 -
66 -
#------------------------------------------------
67 -
# x is character string
68 -
#' @noRd
69 -
assert_string <- function(x, message = "%s must be character string",
70 -
                          name = paste(deparse(substitute(x)), collapse = "")) {
71 -
  if (!is.character(x)) {
72 -
    stop(sprintf(message, name), call. = FALSE)
73 -
  }
74 -
  return(TRUE)
75 -
}
76 -
77 -
#------------------------------------------------
78 -
# x is single character string
79 -
#' @noRd
80 -
assert_single_string <- function(x, name = paste(deparse(substitute(x)), collapse = "")) {
81 -
  assert_length(x, n = 1, name = name)
82 -
  assert_string(x, name = name)
83 -
  return(TRUE)
84 -
}
85 -
86 -
#------------------------------------------------
87 -
# x is logical
88 -
#' @noRd
89 -
assert_logical <- function(x, message = "%s must be logical",
90 -
                           name = paste(deparse(substitute(x)), collapse = "")) {
91 -
  if (!is.logical(x)) {
92 -
    stop(sprintf(message, name), call. = FALSE)
93 -
  }
94 -
  return(TRUE)
95 -
}
96 -
97 -
#------------------------------------------------
98 -
# x is single logical
99 -
#' @noRd
100 -
assert_single_logical <- function(x, name = paste(deparse(substitute(x)), collapse = "")) {
101 -
  assert_length(x, n = 1, name = name)
102 -
  assert_logical(x, name = name)
103 -
  return(TRUE)
104 -
}
105 -
106 -
#------------------------------------------------
107 -
# x is numeric
108 -
#' @noRd
109 -
assert_numeric <- function(x, message = "%s must be numeric",
110 -
                           name = paste(deparse(substitute(x)), collapse = "")) {
111 -
  if (!is.numeric(x)) {
112 -
    stop(sprintf(message, name), call. = FALSE)
113 -
  }
114 -
  return(TRUE)
115 -
}
116 -
117 -
#------------------------------------------------
118 -
# x is single numeric
119 -
#' @noRd
120 -
assert_single_numeric <- function(x, name = paste(deparse(substitute(x)), collapse = "")) {
121 -
  assert_length(x, n = 1, name = name)
122 -
  assert_numeric(x, name = name)
123 -
  return(TRUE)
124 -
}
125 -
126 -
#------------------------------------------------
127 -
# x is integer
128 -
#' @noRd
129 -
assert_int <- function(x, message = "%s must be integer valued",
130 -
                       name = paste(deparse(substitute(x)), collapse = "")) {
131 -
  assert_numeric(x, name = name)
132 -
  if (!isTRUE(all.equal(x, as.integer(x), check.attributes = FALSE))) {
133 -
    stop(sprintf(message, name), call. = FALSE)
134 -
  }
135 -
  return(TRUE)
136 -
}
137 -
138 -
#------------------------------------------------
139 -
# x is single integer
140 -
#' @noRd
141 -
assert_single_int <- function(x, name = paste(deparse(substitute(x)), collapse = "")) {
142 -
  assert_length(x, n = 1, name = name)
143 -
  assert_int(x, name = name)
144 -
  return(TRUE)
145 -
}
146 -
147 -
#------------------------------------------------
148 -
# x is positive (with or without zero allowed)
149 -
#' @noRd
150 -
assert_pos <- function(x, zero_allowed = TRUE, message1 = "%s must be greater than or equal to zero",
151 -
                       message2 = "%s must be greater than zero",
152 -
                       name = paste(deparse(substitute(x)), collapse = "")) {
153 -
  assert_numeric(x, name = name)
154 -
  if (zero_allowed) {
155 -
    if (!all(x>=0)) {
156 -
      stop(sprintf(message1, name), call. = FALSE)
157 -
    }
158 -
  } else {
159 -
    if (!all(x>0)) {
160 -
      stop(sprintf(message2, name), call. = FALSE)
161 -
    }
162 -
  }
163 -
  return(TRUE)
164 -
}
165 -
166 -
#------------------------------------------------
167 -
# x is single positive (with or without zero allowed)
168 -
#' @noRd
169 -
assert_single_pos <- function(x, zero_allowed = TRUE, name = paste(deparse(substitute(x)), collapse = "")) {
170 -
  assert_length(x, n = 1, name = name)
171 -
  assert_pos(x, zero_allowed = zero_allowed, name = name)
172 -
  return(TRUE)
173 -
}
174 -
175 -
#------------------------------------------------
176 -
# x is positive integer (with or without zero allowed)
177 -
#' @noRd
178 -
assert_pos_int <- function(x, zero_allowed = TRUE, name = paste(deparse(substitute(x)), collapse = "")) {
179 -
  assert_int(x, name = name)
180 -
  assert_pos(x, zero_allowed = zero_allowed, name = name)
181 -
  return(TRUE)
182 -
}
183 -
184 -
#------------------------------------------------
185 -
# x is single positive integer (with or without zero allowed)
186 -
#' @noRd
187 -
assert_single_pos_int <- function(x, zero_allowed = TRUE, name = paste(deparse(substitute(x)), collapse = "")) {
188 -
  assert_length(x, n = 1, name = name)
189 -
  assert_pos_int(x, zero_allowed = zero_allowed, name = name)
190 -
  return(TRUE)
191 -
}
192 -
193 -
#------------------------------------------------
194 -
# x is single value bounded between limits
195 -
#' @noRd
196 -
assert_single_bounded <- function(x, left = 0, right = 1, inclusive_left = TRUE, inclusive_right = TRUE,
197 -
                                  name = paste(deparse(substitute(x)), collapse = "")) {
198 -
  assert_length(x, n = 1, name = name)
199 -
  assert_bounded(x, left = left, right = right,
200 -
                 inclusive_left = inclusive_left, inclusive_right = inclusive_right,
201 -
                 name = name)
202 -
  return(TRUE)
203 -
}
204 -
205 -
#------------------------------------------------
206 -
# x is a vector (and is not a list or another recursive type)
207 -
#' @noRd
208 -
assert_vector <- function(x, message = "%s must be a non-recursive vector",
209 -
                          name = paste(deparse(substitute(x)), collapse = "")) {
210 -
  if (!is.vector(x) || is.recursive(x)) {
211 -
    stop(sprintf(message, name), call. = FALSE)
212 -
  }
213 -
  return(TRUE)
214 -
}
215 -
216 -
#------------------------------------------------
217 -
# x is a numeric vector
218 -
#' @noRd
219 -
assert_vector_numeric <- function(x, message = "%s must be a non-recursive vector of numeric values",
220 -
                                  name = paste(deparse(substitute(x)), collapse = "")) {
221 -
  assert_numeric(x, message = message, name = name)
222 -
  assert_vector(x, message = message, name = name)
223 -
  return(TRUE)
224 -
}
225 -
226 -
#------------------------------------------------
227 -
# x is a vector of integers
228 -
#' @noRd
229 -
assert_vector_int <- function(x, message = "%s must be a non-recursive vector of integers",
230 -
                              name = paste(deparse(substitute(x)), collapse = "")) {
231 -
  assert_int(x, message = message, name = name)
232 -
  assert_vector(x, message = message, name = name)
233 -
  return(TRUE)
234 -
}
235 -
236 -
#------------------------------------------------
237 -
# x is a vector of positive values
238 -
#' @noRd
239 -
assert_vector_pos <- function(x, zero_allowed = TRUE,
240 -
                              message1 = "%s must be a non-recursive vector of positive values or zero",
241 -
                              message2 = "%s must be a non-recursive vector of positive values",
242 -
                              name = paste(deparse(substitute(x)), collapse = "")) {
243 -
  assert_pos(x, zero_allowed = zero_allowed, message1 = message1, message2 = message2, name = name)
244 -
  if (zero_allowed) {
245 -
    assert_vector(x, message = message1, name = name)
246 -
  } else {
247 -
    assert_vector(x, message = message2, name = name)
248 -
  }
249 -
  return(TRUE)
250 -
}
251 -
252 -
#------------------------------------------------
253 -
# x is a vector of positive integers
254 -
#' @noRd
255 -
assert_vector_pos_int <- function(x, zero_allowed = TRUE,
256 -
                                  message1 = "%s must be a non-recursive vector of positive integers or zero",
257 -
                                  message2 = "%s must be a non-recursive vector of positive integers",
258 -
                                  name = paste(deparse(substitute(x)), collapse = "")) {
259 -
  assert_pos(x, zero_allowed = zero_allowed, message1 = message1, message2 = message2, name = name)
260 -
  
261 -
  if (zero_allowed) {
262 -
    message_final = message1
263 -
  } else {
264 -
    message_final = message2
265 -
  }
266 -
  assert_vector(x, message = message_final, name = name)
267 -
  assert_int(x, message = message_final, name = name)
268 -
  return(TRUE)
269 -
}
270 -
271 -
#------------------------------------------------
272 -
# x is a vector of bounded values
273 -
#' @noRd
274 -
assert_vector_bounded <- function(x, left = 0, right = 1, inclusive_left = TRUE, inclusive_right = TRUE,
275 -
                                  name = paste(deparse(substitute(x)), collapse = "")) {
276 -
  assert_vector(x, name = name)
277 -
  assert_bounded(x, left = left, right = right,
278 -
                 inclusive_left = inclusive_left, inclusive_right = inclusive_right,
279 -
                 name = name)
280 -
  return(TRUE)
281 -
}
282 -
283 -
#------------------------------------------------
284 -
# x is a matrix
285 -
#' @noRd
286 -
assert_matrix <- function(x, message = "%s must be a matrix",
287 -
                          name = paste(deparse(substitute(x)), collapse = "")) {
288 -
  if (!is.matrix(x)) {
289 -
    stop(sprintf(message, name), call. = FALSE)
290 -
  }
291 -
  return(TRUE)
292 -
}
293 -
294 -
#------------------------------------------------
295 -
# x is a matrix of numeric values
296 -
#' @noRd
297 -
assert_matrix_numeric <- function(x, message = "%s must be a numeric matrix",
298 -
                                  name = paste(deparse(substitute(x)), collapse = "")) {
299 -
  assert_matrix(x, message = message, name = name)
300 -
  assert_numeric(x, message = message, name = name)
301 -
  return(TRUE)
302 -
}
303 -
304 -
#------------------------------------------------
305 -
# x is a list
306 -
assert_list <- function(x, message = "%s must be a list",
307 -
                        name = paste(deparse(substitute(x)), collapse = "")) {
308 -
  if (!is.list(x)) {
309 -
    stop(sprintf(message, name), call. = FALSE)
310 -
  }
311 -
  return(TRUE)
312 -
}
313 -
314 -
#------------------------------------------------
315 -
# x is a data frame
316 -
assert_dataframe <- function(x, message = "%s must be a data frame",
317 -
                             name = paste(deparse(substitute(x)), collapse = "")) {
318 -
  if (!is.data.frame(x)) {
319 -
    stop(sprintf(message, name), call. = FALSE)
320 -
  }
321 -
  return(TRUE)
322 -
}
323 -
324 -
#------------------------------------------------
325 -
# x inherits from custom class c
326 -
assert_custom_class <- function(x, c, message = "%s must inherit from class '%s'",
327 -
                                name = paste(deparse(substitute(x)), collapse = "")) {
328 -
  if (!inherits(x, c)) {
329 -
    stop(sprintf(message, name, c), call. = FALSE)
330 -
  }
331 -
  return(TRUE)
332 -
}
333 -
334 -
#------------------------------------------------
335 -
# x is a plotting limit, i.e. contains two increasing values
336 -
assert_limit <- function(x, message = "%s must be a valid plotting limit, i.e. contain two increasing values",
337 -
                         name = paste(deparse(substitute(x)), collapse = "")) {
338 -
  assert_vector(x, name = name)
339 -
  assert_length(x, 2, name = name)
340 -
  assert_numeric(x, name = name)
341 -
  assert_increasing(x, name = name)
342 -
  return(TRUE)
343 -
}
344 -
345 -
346 -
#### VALUE COMPARISONS ####################################################################
347 -
348 -
#------------------------------------------------
349 -
# x and y are equal in all matched comparisons. x and y can be any type
350 -
#' @noRd
351 -
assert_eq <- function(x, y, message = "%s must equal %s",
352 -
                      name_x = paste(deparse(substitute(x)), collapse = ""), name_y = nice_format(y)) {
353 -
  assert_non_null(x, name = name_x)
354 -
  assert_non_null(y, name = name_y)
355 -
  assert_same_length(x, y, name_x = name_x, name_y = name_y)
356 -
  if (!isTRUE(all.equal(x, y, check.attributes = FALSE))) {
357 -
    stop(sprintf(message, name_x, name_y), call. = FALSE)
358 -
  }
359 -
  return(TRUE)
360 -
}
361 -
362 -
#------------------------------------------------
363 -
# x and y are unequal in all matched comparisons. x and y can be any type
364 -
#' @noRd
365 -
assert_neq <- function(x, y, message = "%s cannot equal %s",
366 -
                       name_x = paste(deparse(substitute(x)), collapse = ""), name_y = nice_format(y)) {
367 -
  assert_non_null(x, name = name_x)
368 -
  assert_non_null(y, name = name_y)
369 -
  assert_same_length(x, y, name_x = name_x, name_y = name_y)
370 -
  if (any(x == y)) {
371 -
    stop(sprintf(message, name_x, name_y), call. = FALSE)
372 -
  }
373 -
  return(TRUE)
374 -
}
375 -
376 -
#------------------------------------------------
377 -
# x is greater than y in all matched comparisons
378 -
#' @noRd
379 -
assert_gr <- function(x, y, message = "%s must be greater than %s",
380 -
                      name_x = paste(deparse(substitute(x)), collapse = ""),
381 -
                      name_y = nice_format(y)) {
382 -
  assert_numeric(x, name = name_x)
383 -
  assert_numeric(y, name = name_y)
384 -
  assert_in(length(y), c(1,length(x)))
385 -
  if (!all(x>y)) {
386 -
    stop(sprintf(message, name_x, name_y), call. = FALSE)
387 -
  }
388 -
  return(TRUE)
389 -
}
390 -
391 -
#------------------------------------------------
392 -
# x is greater than or equal to y in all matched comparisons
393 -
#' @noRd
394 -
assert_greq <- function(x, y, message = "%s must be greater than or equal to %s",
395 -
                        name_x = paste(deparse(substitute(x)), collapse = ""), name_y = nice_format(y)) {
396 -
  assert_numeric(x, name = name_x)
397 -
  assert_numeric(y, name = name_y)
398 -
  assert_in(length(y), c(1,length(x)))
399 -
  if (!all(x >= y)) {
400 -
    stop(sprintf(message, name_x, name_y), call. = FALSE)
401 -
  }
402 -
  return(TRUE)
403 -
}
404 -
405 -
#------------------------------------------------
406 -
# x is less than y in all matched comparisons
407 -
#' @noRd
408 -
assert_le <- function(x, y, message = "%s must be less than %s",
409 -
                      name_x = paste(deparse(substitute(x)), collapse = ""), name_y = nice_format(y)) {
410 -
  assert_numeric(x, name = name_x)
411 -
  assert_numeric(y, name = name_y)
412 -
  assert_in(length(y), c(1,length(x)))
413 -
  if (!all(x<y)) {
414 -
    stop(sprintf(message, name_x, name_y), call. = FALSE)
415 -
  }
416 -
  return(TRUE)
417 -
}
418 -
419 -
#------------------------------------------------
420 -
# x is less than or equal to y in all matched comparisons
421 -
#' @noRd
422 -
assert_leq <- function(x, y, message = "%s must be less than or equal to %s",
423 -
                       name_x = paste(deparse(substitute(x)), collapse = ""), name_y = nice_format(y)) {
424 -
  assert_numeric(x, name = name_x)
425 -
  assert_numeric(y, name = name_y)
426 -
  assert_in(length(y), c(1,length(x)))
427 -
  if (!all(x<=y)) {
428 -
    stop(sprintf(message, name_x, name_y), call. = FALSE)
429 -
  }
430 -
  return(TRUE)
431 -
}
432 -
433 -
#------------------------------------------------
434 -
# x is between bounds (inclusive or exclusive)
435 -
#' @noRd
436 -
assert_bounded <- function(x, left = 0, right = 1, inclusive_left = TRUE, inclusive_right = TRUE,
437 -
                           name = paste(deparse(substitute(x)), collapse = "")) {
438 -
  assert_numeric(x, name = name)
439 -
  if (inclusive_left) {
440 -
    if (!all(x>=left)) {
441 -
      stop(sprintf("%s must be greater than or equal to %s", name, left), call. = FALSE)
442 -
    }
443 -
  } else {
444 -
    if (!all(x>left)) {
445 -
      stop(sprintf("%s must be greater than %s", name, left), call. = FALSE)
446 -
    }
447 -
  }
448 -
  if (inclusive_right) {
449 -
    if (!all(x<=right)) {
450 -
      stop(sprintf("%s must be less than or equal to %s", name, right), call. = FALSE)
451 -
    }
452 -
  } else {
453 -
    if (!all(x<right)) {
454 -
      stop(sprintf("%s must be less than %s", name, right), call. = FALSE)
455 -
    }
456 -
  }
457 -
  return(TRUE)
458 -
}
459 -
460 -
#------------------------------------------------
461 -
# all x are in y
462 -
#' @noRd
463 -
assert_in <- function(x, y, message = "all %s must be in %s",
464 -
                      name_x = paste(deparse(substitute(x)), collapse = ""), name_y = nice_format(y)) {
465 -
  assert_non_null(x, name = name_x)
466 -
  assert_non_null(y, name = name_y)
467 -
  if (!all(x %in% y)) {
468 -
    stop(sprintf(message, name_x, name_y), call. = FALSE)
469 -
  }
470 -
  return(TRUE)
471 -
}
472 -
473 -
#------------------------------------------------
474 -
# none of x are in y
475 -
#' @noRd
476 -
assert_not_in <- function(x, y, message = "none of %s can be in %s",
477 -
                          name_x = paste(deparse(substitute(x)), collapse = ""), name_y = nice_format(y)) {
478 -
  assert_non_null(x, name = name_x)
479 -
  assert_non_null(y, name = name_y)
480 -
  if (any(x %in% y)) {
481 -
    stop(sprintf(message, name_x, name_y), call. = FALSE)
482 -
  }
483 -
  return(TRUE)
484 -
}
485 -
486 -
487 -
#### DIMENSIONS ####################################################################
488 -
489 -
#------------------------------------------------
490 -
# length(x) equals n
491 -
#' @noRd
492 -
assert_length <- function(x, n, message = "%s must be of length %s",
493 -
                          name = paste(deparse(substitute(x)), collapse = "")) {
494 -
  assert_pos_int(n)
495 -
  if (length(x) != n[1]) {
496 -
    stop(sprintf(message, name, n), call. = FALSE)
497 -
  }
498 -
  return(TRUE)
499 -
}
500 -
501 -
#------------------------------------------------
502 -
# x and y are same length
503 -
#' @noRd
504 -
assert_same_length <- function(x, y, message =  "%s and %s must be the same length",
505 -
                               name_x = paste(deparse(substitute(x)), collapse = ""),
506 -
                               name_y = paste(deparse(substitute(y)))) {
507 -
  if (length(x) != length(y)) {
508 -
    stop(sprintf(message, name_x, name_y), call. = FALSE)
509 -
  }
510 -
  return(TRUE)
511 -
}
512 -
513 -
#------------------------------------------------
514 -
# multiple objects all same length
515 -
#' @noRd
516 -
assert_same_length_multiple <- function(...) {
517 -
  l <- mapply(length, list(...))
518 -
  if (length(unique(l)) != 1) {
519 -
    l_names <- sapply(match.call(expand.dots = FALSE)$..., deparse)
520 -
    stop(sprintf("variables %s must be the same length", nice_format(l_names)), call. = FALSE)
521 -
  }
522 -
  return(TRUE)
523 -
}
524 -
525 -
#------------------------------------------------
526 -
# x is two-dimensional
527 -
#' @noRd
528 -
assert_2d <- function(x, message = "%s must be two-dimensional",
529 -
                      name = paste(deparse(substitute(x)), collapse = "")) {
530 -
  is_2d <- FALSE
531 -
  if (!is.null(dim(x))) {
532 -
    if (length(dim(x)) == 2) {
533 -
      is_2d <- TRUE
534 -
    }
535 -
  }
536 -
  if (!is_2d) {
537 -
    stop(sprintf(message, name), call. = FALSE)
538 -
  }
539 -
  return(TRUE)
540 -
}
541 -
542 -
#------------------------------------------------
543 -
# nrow(x) equals n
544 -
#' @noRd
545 -
assert_nrow <- function(x, n, message = "%s must have %s rows",
546 -
                        name = paste(deparse(substitute(x)), collapse = "")) {
547 -
  assert_2d(x, name = name)
548 -
  if (nrow(x) != n) {
549 -
    stop(sprintf(message, name, n), call. = FALSE)
550 -
  }
551 -
  return(TRUE)
552 -
}
553 -
554 -
#------------------------------------------------
555 -
# ncol(x) equals n
556 -
#' @noRd
557 -
assert_ncol <- function(x, n, message = "%s must have %s cols",
558 -
                        name = paste(deparse(substitute(x)), collapse = "")) {
559 -
  assert_2d(x, name = name)
560 -
  if (ncol(x) != n) {
561 -
    stop(sprintf(message, name, n), call. = FALSE)
562 -
  }
563 -
  return(TRUE)
564 -
}
565 -
566 -
#------------------------------------------------
567 -
# dim(x) equals y
568 -
#' @noRd
569 -
assert_dim <- function(x, y, message = "%s must have %s rows and %s columns",
570 -
                       name = paste(deparse(substitute(x)), collapse = "")) {
571 -
  assert_2d(x, name = name)
572 -
  assert_pos_int(y, name = "y variable in assert_dim()")
573 -
  assert_length(y, 2, name = "y variable in assert_dim()")
574 -
  if (nrow(x) != y[1] | ncol(x) != y[2]) {
575 -
    stop(sprintf(message, name, y[1], y[2]), call. = FALSE)
576 -
  }
577 -
  return(TRUE)
578 -
}
579 -
580 -
#------------------------------------------------
581 -
# x is square matrix
582 -
#' @noRd
583 -
assert_square_matrix <- function(x, message = "%s must be a square matrix",
584 -
                                 name = paste(deparse(substitute(x)), collapse = "")) {
585 -
  assert_matrix(x, name = name)
586 -
  if (nrow(x) != ncol(x)) {
587 -
    stop(sprintf(message, name), call. = FALSE)
588 -
  }
589 -
  return(TRUE)
590 -
}
591 -
592 -
#------------------------------------------------
593 -
# is symmetric matrix
594 -
#' @noRd
595 -
assert_symmetric_matrix <- function(x, message = "%s must be a symmetric matrix",
596 -
                                    name = paste(deparse(substitute(x)), collapse = "")) {
597 -
  assert_square_matrix(x, name = name)
598 -
  if (!isSymmetric(x)) {
599 -
    stop(sprintf(message, name), call. = FALSE)
600 -
  }
601 -
  return(TRUE)
602 -
}
603 -
604 -
#### MISC ####################################################################
605 -
606 -
#------------------------------------------------
607 -
# x contains no duplicates
608 -
#' @noRd
609 -
assert_noduplicates <- function(x, message = "%s must contain no duplicates",
610 -
                                name = paste(deparse(substitute(x)), collapse = "")) {
611 -
  if (any(duplicated(x))) {
612 -
    stop(sprintf(message, name), call. = FALSE)
613 -
  }
614 -
  return(TRUE)
615 -
}
616 -
617 -
#------------------------------------------------
618 -
# file exists at chosen path
619 -
#' @noRd
620 -
assert_file_exists <- function(x, message = "file not found at path %s",
621 -
                               name = paste(deparse(substitute(x)), collapse = "")) {
622 -
  if (!file.exists(x)) {
623 -
    stop(sprintf(message, name), call. = FALSE)
624 -
  }
625 -
  return(TRUE)
626 -
}
627 -
628 -
#------------------------------------------------
629 -
# x is increasing
630 -
#' @noRd
631 -
assert_increasing <- function(x, message = "%s must be increasing",
632 -
                              name = paste(deparse(substitute(x)), collapse = "")) {
633 -
  assert_non_null(x, name = name)
634 -
  assert_numeric(x, name = name)
635 -
  if (!all.equal(x, sort(x))) {
636 -
    stop(sprintf(message, name), call. = FALSE)
637 -
  }
638 -
  return(TRUE)
639 -
}
640 -
641 -
#------------------------------------------------
642 -
# x is decreasing
643 -
#' @noRd
644 -
assert_decreasing <- function(x, message = "%s must be decreasing",
645 -
                              name = paste(deparse(substitute(x)), collapse = "")) {
646 -
  assert_non_null(x, name = name)
647 -
  assert_numeric(x, name = name)
648 -
  if (!all.equal(x, sort(x, decreasing = TRUE))) {
649 -
    stop(sprintf(message, name), call. = FALSE)
650 -
  }
651 -
  return(TRUE)
652 -
}
653 -
1 +
2 +
#### HELPER FUNCTIONS ####################################################################
3 +
4 +
#------------------------------------------------
5 +
# for single value, return value as string. For vector of values return string
6 +
# of comma-separated values enclosed in curly brackets
7 +
#' @noRd
8 +
nice_format <- function(x) {
9 +
  if (is.null(x)) {
10 +
    return("")
11 +
  }
12 +
  if (length(x)==1) {
13 +
    ret <- as.character(x)
14 +
  } else {
15 +
    ret <- paste0("{", paste(x, collapse = ", "), "}")
16 +
  }
17 +
  return(ret)
18 +
}
19 +
20 +
#### BASIC OBJECT TYPES ####################################################################
21 +
22 +
#------------------------------------------------
23 +
# x is NULL
24 +
#' @noRd
25 +
assert_null <- function(x, message = "%s must be null",
26 +
                        name = paste(deparse(substitute(x)), collapse = "")) {
27 +
  if (!is.null(x)) {
28 +
    stop(sprintf(message, name), call. = FALSE)
29 +
  }
30 +
  return(TRUE)
31 +
}
32 +
33 +
#------------------------------------------------
34 +
# x is not NULL
35 +
#' @noRd
36 +
assert_non_null <- function(x, message = "%s cannot be null",
37 +
                            name = paste(deparse(substitute(x)), collapse = "")) {
38 +
  if (is.null(x)) {
39 +
    stop(sprintf(message, name), call. = FALSE)
40 +
  }
41 +
  return(TRUE)
42 +
}
43 +
44 +
#------------------------------------------------
45 +
# x is atomic
46 +
#' @noRd
47 +
assert_atomic <- function(x, message = "%s must be atomic (see ?is.atomic)",
48 +
                          name = paste(deparse(substitute(x)), collapse = "")) {
49 +
  if (!is.atomic(x)) {
50 +
    stop(sprintf(message, name), call. = FALSE)
51 +
  }
52 +
  return(TRUE)
53 +
}
54 +
55 +
#------------------------------------------------
56 +
# x is atomic and single valued (has length 1)
57 +
#' @noRd
58 +
assert_single <- function(x, message = "%s must be a single value",
59 +
                          name = paste(deparse(substitute(x)), collapse = "")) {
60 +
  assert_non_null(x, name = name)
61 +
  assert_atomic(x, name = name)
62 +
  assert_length(x, 1, name = name)
63 +
  return(TRUE)
64 +
}
65 +
66 +
#------------------------------------------------
67 +
# x is character string
68 +
#' @noRd
69 +
assert_string <- function(x, message = "%s must be character string",
70 +
                          name = paste(deparse(substitute(x)), collapse = "")) {
71 +
  if (!is.character(x)) {
72 +
    stop(sprintf(message, name), call. = FALSE)
73 +
  }
74 +
  return(TRUE)
75 +
}
76 +
77 +
#------------------------------------------------
78 +
# x is single character string
79 +
#' @noRd
80 +
assert_single_string <- function(x, name = paste(deparse(substitute(x)), collapse = "")) {
81 +
  assert_length(x, n = 1, name = name)
82 +
  assert_string(x, name = name)
83 +
  return(TRUE)
84 +
}
85 +
86 +
#------------------------------------------------
87 +
# x is logical
88 +
#' @noRd
89 +
assert_logical <- function(x, message = "%s must be logical",
90 +
                           name = paste(deparse(substitute(x)), collapse = "")) {
91 +
  if (!is.logical(x)) {
92 +
    stop(sprintf(message, name), call. = FALSE)
93 +
  }
94 +
  return(TRUE)
95 +
}
96 +
97 +
#------------------------------------------------
98 +
# x is single logical
99 +
#' @noRd
100 +
assert_single_logical <- function(x, name = paste(deparse(substitute(x)), collapse = "")) {
101 +
  assert_length(x, n = 1, name = name)
102 +
  assert_logical(x, name = name)
103 +
  return(TRUE)
104 +
}
105 +
106 +
#------------------------------------------------
107 +
# x is numeric
108 +
#' @noRd
109 +
assert_numeric <- function(x, message = "%s must be numeric",
110 +
                           name = paste(deparse(substitute(x)), collapse = "")) {
111 +
  if (!is.numeric(x)) {
112 +
    stop(sprintf(message, name), call. = FALSE)
113 +
  }
114 +
  return(TRUE)
115 +
}
116 +
117 +
#------------------------------------------------
118 +
# x is single numeric
119 +
#' @noRd
120 +
assert_single_numeric <- function(x, name = paste(deparse(substitute(x)), collapse = "")) {
121 +
  assert_length(x, n = 1, name = name)
122 +
  assert_numeric(x, name = name)
123 +
  return(TRUE)
124 +
}
125 +
126 +
#------------------------------------------------
127 +
# x is integer
128 +
#' @noRd
129 +
assert_int <- function(x, message = "%s must be integer valued",
130 +
                       name = paste(deparse(substitute(x)), collapse = "")) {
131 +
  assert_numeric(x, name = name)
132 +
  if (!isTRUE(all.equal(x, as.integer(x), check.attributes = FALSE))) {
133 +
    stop(sprintf(message, name), call. = FALSE)
134 +
  }
135 +
  return(TRUE)
136 +
}
137 +
138 +
#------------------------------------------------
139 +
# x is single integer
140 +
#' @noRd
141 +
assert_single_int <- function(x, name = paste(deparse(substitute(x)), collapse = "")) {
142 +
  assert_length(x, n = 1, name = name)
143 +
  assert_int(x, name = name)
144 +
  return(TRUE)
145 +
}
146 +
147 +
#------------------------------------------------
148 +
# x is positive (with or without zero allowed)
149 +
#' @noRd
150 +
assert_pos <- function(x, zero_allowed = TRUE, message1 = "%s must be greater than or equal to zero",
151 +
                       message2 = "%s must be greater than zero",
152 +
                       name = paste(deparse(substitute(x)), collapse = "")) {
153 +
  assert_numeric(x, name = name)
154 +
  if (zero_allowed) {
155 +
    if (!all(x>=0)) {
156 +
      stop(sprintf(message1, name), call. = FALSE)
157 +
    }
158 +
  } else {
159 +
    if (!all(x>0)) {
160 +
      stop(sprintf(message2, name), call. = FALSE)
161 +
    }
162 +
  }
163 +
  return(TRUE)
164 +
}
165 +
166 +
#------------------------------------------------
167 +
# x is single positive (with or without zero allowed)
168 +
#' @noRd
169 +
assert_single_pos <- function(x, zero_allowed = TRUE, name = paste(deparse(substitute(x)), collapse = "")) {
170 +
  assert_length(x, n = 1, name = name)
171 +
  assert_pos(x, zero_allowed = zero_allowed, name = name)
172 +
  return(TRUE)
173 +
}
174 +
175 +
#------------------------------------------------
176 +
# x is positive integer (with or without zero allowed)
177 +
#' @noRd
178 +
assert_pos_int <- function(x, zero_allowed = TRUE, name = paste(deparse(substitute(x)), collapse = "")) {
179 +
  assert_int(x, name = name)
180 +
  assert_pos(x, zero_allowed = zero_allowed, name = name)
181 +
  return(TRUE)
182 +
}
183 +
184 +
#------------------------------------------------
185 +
# x is single positive integer (with or without zero allowed)
186 +
#' @noRd
187 +
assert_single_pos_int <- function(x, zero_allowed = TRUE, name = paste(deparse(substitute(x)), collapse = "")) {
188 +
  assert_length(x, n = 1, name = name)
189 +
  assert_pos_int(x, zero_allowed = zero_allowed, name = name)
190 +
  return(TRUE)
191 +
}
192 +
193 +
#------------------------------------------------
194 +
# x is single value bounded between limits
195 +
#' @noRd
196 +
assert_single_bounded <- function(x, left = 0, right = 1, inclusive_left = TRUE, inclusive_right = TRUE,
197 +
                                  name = paste(deparse(substitute(x)), collapse = "")) {
198 +
  assert_length(x, n = 1, name = name)
199 +
  assert_bounded(x, left = left, right = right,
200 +
                 inclusive_left = inclusive_left, inclusive_right = inclusive_right,
201 +
                 name = name)
202 +
  return(TRUE)
203 +
}
204 +
205 +
#------------------------------------------------
206 +
# x is a vector (and is not a list or another recursive type)
207 +
#' @noRd
208 +
assert_vector <- function(x, message = "%s must be a non-recursive vector",
209 +
                          name = paste(deparse(substitute(x)), collapse = "")) {
210 +
  if (!is.vector(x) || is.recursive(x)) {
211 +
    stop(sprintf(message, name), call. = FALSE)
212 +
  }
213 +
  return(TRUE)
214 +
}
215 +
216 +
#------------------------------------------------
217 +
# x is a numeric vector
218 +
#' @noRd
219 +
assert_vector_numeric <- function(x, message = "%s must be a non-recursive vector of numeric values",
220 +
                                  name = paste(deparse(substitute(x)), collapse = "")) {
221 +
  assert_numeric(x, message = message, name = name)
222 +
  assert_vector(x, message = message, name = name)
223 +
  return(TRUE)
224 +
}
225 +
226 +
#------------------------------------------------
227 +
# x is a vector of integers
228 +
#' @noRd
229 +
assert_vector_int <- function(x, message = "%s must be a non-recursive vector of integers",
230 +
                              name = paste(deparse(substitute(x)), collapse = "")) {
231 +
  assert_int(x, message = message, name = name)
232 +
  assert_vector(x, message = message, name = name)
233 +
  return(TRUE)
234 +
}
235 +
236 +
#------------------------------------------------
237 +
# x is a vector of positive values
238 +
#' @noRd
239 +
assert_vector_pos <- function(x, zero_allowed = TRUE,
240 +
                              message1 = "%s must be a non-recursive vector of positive values or zero",
241 +
                              message2 = "%s must be a non-recursive vector of positive values",
242 +
                              name = paste(deparse(substitute(x)), collapse = "")) {
243 +
  assert_pos(x, zero_allowed = zero_allowed, message1 = message1, message2 = message2, name = name)
244 +
  if (zero_allowed) {
245 +
    assert_vector(x, message = message1, name = name)
246 +
  } else {
247 +
    assert_vector(x, message = message2, name = name)
248 +
  }
249 +
  return(TRUE)
250 +
}
251 +
252 +
#------------------------------------------------
253 +
# x is a vector of positive integers
254 +
#' @noRd
255 +
assert_vector_pos_int <- function(x, zero_allowed = TRUE,
256 +
                                  message1 = "%s must be a non-recursive vector of positive integers or zero",
257 +
                                  message2 = "%s must be a non-recursive vector of positive integers",
258 +
                                  name = paste(deparse(substitute(x)), collapse = "")) {
259 +
  assert_pos(x, zero_allowed = zero_allowed, message1 = message1, message2 = message2, name = name)
260 +
  
261 +
  if (zero_allowed) {
262 +
    message_final = message1
263 +
  } else {
264 +
    message_final = message2
265 +
  }
266 +
  assert_vector(x, message = message_final, name = name)
267 +
  assert_int(x, message = message_final, name = name)
268 +
  return(TRUE)
269 +
}
270 +
271 +
#------------------------------------------------
272 +
# x is a vector of bounded values
273 +
#' @noRd
274 +
assert_vector_bounded <- function(x, left = 0, right = 1, inclusive_left = TRUE, inclusive_right = TRUE,
275 +
                                  name = paste(deparse(substitute(x)), collapse = "")) {
276 +
  assert_vector(x, name = name)
277 +
  assert_bounded(x, left = left, right = right,
278 +
                 inclusive_left = inclusive_left, inclusive_right = inclusive_right,
279 +
                 name = name)
280 +
  return(TRUE)
281 +
}
282 +
283 +
#------------------------------------------------
284 +
# x is a matrix
285 +
#' @noRd
286 +
assert_matrix <- function(x, message = "%s must be a matrix",
287 +
                          name = paste(deparse(substitute(x)), collapse = "")) {
288 +
  if (!is.matrix(x)) {
289 +
    stop(sprintf(message, name), call. = FALSE)
290 +
  }
291 +
  return(TRUE)
292 +
}
293 +
294 +
#------------------------------------------------
295 +
# x is a matrix of numeric values
296 +
#' @noRd
297 +
assert_matrix_numeric <- function(x, message = "%s must be a numeric matrix",
298 +
                                  name = paste(deparse(substitute(x)), collapse = "")) {
299 +
  assert_matrix(x, message = message, name = name)
300 +
  assert_numeric(x, message = message, name = name)
301 +
  return(TRUE)
302 +
}
303 +
304 +
#------------------------------------------------
305 +
# x is a list
306 +
assert_list <- function(x, message = "%s must be a list",
307 +
                        name = paste(deparse(substitute(x)), collapse = "")) {
308 +
  if (!is.list(x)) {
309 +
    stop(sprintf(message, name), call. = FALSE)
310 +
  }
311 +
  return(TRUE)
312 +
}
313 +
314 +
#------------------------------------------------
315 +
# x is a data frame
316 +
assert_dataframe <- function(x, message = "%s must be a data frame",
317 +
                             name = paste(deparse(substitute(x)), collapse = "")) {
318 +
  if (!is.data.frame(x)) {
319 +
    stop(sprintf(message, name), call. = FALSE)
320 +
  }
321 +
  return(TRUE)
322 +
}
323 +
324 +
#------------------------------------------------
325 +
# x inherits from custom class c
326 +
assert_custom_class <- function(x, c, message = "%s must inherit from class '%s'",
327 +
                                name = paste(deparse(substitute(x)), collapse = "")) {
328 +
  if (!inherits(x, c)) {
329 +
    stop(sprintf(message, name, c), call. = FALSE)
330 +
  }
331 +
  return(TRUE)
332 +
}
333 +
334 +
#------------------------------------------------
335 +
# x is a plotting limit, i.e. contains two increasing values
336 +
assert_limit <- function(x, message = "%s must be a valid plotting limit, i.e. contain two increasing values",
337 +
                         name = paste(deparse(substitute(x)), collapse = "")) {
338 +
  assert_vector(x, name = name)
339 +
  assert_length(x, 2, name = name)
340 +
  assert_numeric(x, name = name)
341 +
  assert_increasing(x, name = name)
342 +
  return(TRUE)
343 +
}
344 +
345 +
346 +
#### VALUE COMPARISONS ####################################################################
347 +
348 +
#------------------------------------------------
349 +
# x and y are equal in all matched comparisons. x and y can be any type
350 +
#' @noRd
351 +
assert_eq <- function(x, y, message = "%s must equal %s",
352 +
                      name_x = paste(deparse(substitute(x)), collapse = ""), name_y = nice_format(y)) {
353 +
  assert_non_null(x, name = name_x)
354 +
  assert_non_null(y, name = name_y)
355 +
  assert_same_length(x, y, name_x = name_x, name_y = name_y)
356 +
  if (!isTRUE(all.equal(x, y, check.attributes = FALSE))) {
357 +
    stop(sprintf(message, name_x, name_y), call. = FALSE)
358 +
  }
359 +
  return(TRUE)
360 +
}
361 +
362 +
#------------------------------------------------
363 +
# x and y are unequal in all matched comparisons. x and y can be any type
364 +
#' @noRd
365 +
assert_neq <- function(x, y, message = "%s cannot equal %s",
366 +
                       name_x = paste(deparse(substitute(x)), collapse = ""), name_y = nice_format(y)) {
367 +
  assert_non_null(x, name = name_x)
368 +
  assert_non_null(y, name = name_y)
369 +
  assert_same_length(x, y, name_x = name_x, name_y = name_y)
370 +
  if (any(x == y)) {
371 +
    stop(sprintf(message, name_x, name_y), call. = FALSE)
372 +
  }
373 +
  return(TRUE)
374 +
}
375 +
376 +
#------------------------------------------------
377 +
# x is greater than y in all matched comparisons
378 +
#' @noRd
379 +
assert_gr <- function(x, y, message = "%s must be greater than %s",
380 +
                      name_x = paste(deparse(substitute(x)), collapse = ""),
381 +
                      name_y = nice_format(y)) {
382 +
  assert_numeric(x, name = name_x)
383 +
  assert_numeric(y, name = name_y)
384 +
  assert_in(length(y), c(1,length(x)))
385 +
  if (!all(x>y)) {
386 +
    stop(sprintf(message, name_x, name_y), call. = FALSE)
387 +
  }
388 +
  return(TRUE)
389 +
}
390 +
391 +
#------------------------------------------------
392 +
# x is greater than or equal to y in all matched comparisons
393 +
#' @noRd
394 +
assert_greq <- function(x, y, message = "%s must be greater than or equal to %s",
395 +
                        name_x = paste(deparse(substitute(x)), collapse = ""), name_y = nice_format(y)) {
396 +
  assert_numeric(x, name = name_x)
397 +
  assert_numeric(y, name = name_y)
398 +
  assert_in(length(y), c(1,length(x)))
399 +
  if (!all(x >= y)) {
400 +
    stop(sprintf(message, name_x, name_y), call. = FALSE)
401 +
  }
402 +
  return(TRUE)
403 +
}
404 +
405 +
#------------------------------------------------
406 +
# x is less than y in all matched comparisons
407 +
#' @noRd
408 +
assert_le <- function(x, y, message = "%s must be less than %s",
409 +
                      name_x = paste(deparse(substitute(x)), collapse = ""), name_y = nice_format(y)) {
410 +
  assert_numeric(x, name = name_x)
411 +
  assert_numeric(y, name = name_y)
412 +
  assert_in(length(y), c(1,length(x)))
413 +
  if (!all(x<y)) {
414 +
    stop(sprintf(message, name_x, name_y), call. = FALSE)
415 +
  }
416 +
  return(TRUE)
417 +
}
418 +
419 +
#------------------------------------------------
420 +
# x is less than or equal to y in all matched comparisons
421 +
#' @noRd
422 +
assert_leq <- function(x, y, message = "%s must be less than or equal to %s",
423 +
                       name_x = paste(deparse(substitute(x)), collapse = ""), name_y = nice_format(y)) {
424 +
  assert_numeric(x, name = name_x)
425 +
  assert_numeric(y, name = name_y)
426 +
  assert_in(length(y), c(1,length(x)))
427 +
  if (!all(x<=y)) {
428 +
    stop(sprintf(message, name_x, name_y), call. = FALSE)
429 +
  }
430 +
  return(TRUE)
431 +
}
432 +
433 +
#------------------------------------------------
434 +
# x is between bounds (inclusive or exclusive)
435 +
#' @noRd
436 +
assert_bounded <- function(x, left = 0, right = 1, inclusive_left = TRUE, inclusive_right = TRUE,
437 +
                           name = paste(deparse(substitute(x)), collapse = "")) {
438 +
  assert_numeric(x, name = name)
439 +
  if (inclusive_left) {
440 +
    if (!all(x>=left)) {
441 +
      stop(sprintf("%s must be greater than or equal to %s", name, left), call. = FALSE)
442 +
    }
443 +
  } else {
444 +
    if (!all(x>left)) {
445 +
      stop(sprintf("%s must be greater than %s", name, left), call. = FALSE)
446 +
    }
447 +
  }
448 +
  if (inclusive_right) {
449 +
    if (!all(x<=right)) {
450 +
      stop(sprintf("%s must be less than or equal to %s", name, right), call. = FALSE)
451 +
    }
452 +
  } else {
453 +
    if (!all(x<right)) {
454 +
      stop(sprintf("%s must be less than %s", name, right), call. = FALSE)
455 +
    }
456 +
  }
457 +
  return(TRUE)
458 +
}
459 +
460 +
#------------------------------------------------
461 +
# all x are in y
462 +
#' @noRd
463 +
assert_in <- function(x, y, message = "all %s must be in %s",
464 +
                      name_x = paste(deparse(substitute(x)), collapse = ""), name_y = nice_format(y)) {
465 +
  assert_non_null(x, name = name_x)
466 +
  assert_non_null(y, name = name_y)
467 +
  if (!all(x %in% y)) {
468 +
    stop(sprintf(message, name_x, name_y), call. = FALSE)
469 +
  }
470 +
  return(TRUE)
471 +
}
472 +
473 +
#------------------------------------------------
474 +
# none of x are in y
475 +
#' @noRd
476 +
assert_not_in <- function(x, y, message = "none of %s can be in %s",
477 +
                          name_x = paste(deparse(substitute(x)), collapse = ""), name_y = nice_format(y)) {
478 +
  assert_non_null(x, name = name_x)
479 +
  assert_non_null(y, name = name_y)
480 +
  if (any(x %in% y)) {
481 +
    stop(sprintf(message, name_x, name_y), call. = FALSE)
482 +
  }
483 +
  return(TRUE)
484 +
}
485 +
486 +
487 +
#### DIMENSIONS ####################################################################
488 +
489 +
#------------------------------------------------
490 +
# length(x) equals n
491 +
#' @noRd
492 +
assert_length <- function(x, n, message = "%s must be of length %s",
493 +
                          name = paste(deparse(substitute(x)), collapse = "")) {
494 +
  assert_pos_int(n)
495 +
  if (length(x) != n[1]) {
496 +
    stop(sprintf(message, name, n), call. = FALSE)
497 +
  }
498 +
  return(TRUE)
499 +
}
500 +
501 +
#------------------------------------------------
502 +
# x and y are same length
503 +
#' @noRd
504 +
assert_same_length <- function(x, y, message =  "%s and %s must be the same length",
505 +
                               name_x = paste(deparse(substitute(x)), collapse = ""),
506 +
                               name_y = paste(deparse(substitute(y)))) {
507 +
  if (length(x) != length(y)) {
508 +
    stop(sprintf(message, name_x, name_y), call. = FALSE)
509 +
  }
510 +
  return(TRUE)
511 +
}
512 +
513 +
#------------------------------------------------
514 +
# multiple objects all same length
515 +
#' @noRd
516 +
assert_same_length_multiple <- function(...) {
517 +
  l <- mapply(length, list(...))
518 +
  if (length(unique(l)) != 1) {
519 +
    l_names <- sapply(match.call(expand.dots = FALSE)$..., deparse)
520 +
    stop(sprintf("variables %s must be the same length", nice_format(l_names)), call. = FALSE)
521 +
  }
522 +
  return(TRUE)
523 +
}
524 +
525 +
#------------------------------------------------
526 +
# x is two-dimensional
527 +
#' @noRd
528 +
assert_2d <- function(x, message = "%s must be two-dimensional",
529 +
                      name = paste(deparse(substitute(x)), collapse = "")) {
530 +
  is_2d <- FALSE
531 +
  if (!is.null(dim(x))) {
532 +
    if (length(dim(x)) == 2) {
533 +
      is_2d <- TRUE
534 +
    }
535 +
  }
536 +
  if (!is_2d) {
537 +
    stop(sprintf(message, name), call. = FALSE)
538 +
  }
539 +
  return(TRUE)
540 +
}
541 +
542 +
#------------------------------------------------
543 +
# nrow(x) equals n
544 +
#' @noRd
545 +
assert_nrow <- function(x, n, message = "%s must have %s rows",
546 +
                        name = paste(deparse(substitute(x)), collapse = "")) {
547 +
  assert_2d(x, name = name)
548 +
  if (nrow(x) != n) {
549 +
    stop(sprintf(message, name, n), call. = FALSE)
550 +
  }
551 +
  return(TRUE)
552 +
}
553 +
554 +
#------------------------------------------------
555 +
# ncol(x) equals n
556 +
#' @noRd
557 +
assert_ncol <- function(x, n, message = "%s must have %s cols",
558 +
                        name = paste(deparse(substitute(x)), collapse = "")) {
559 +
  assert_2d(x, name = name)
560 +
  if (ncol(x) != n) {
561 +
    stop(sprintf(message, name, n), call. = FALSE)
562 +
  }
563 +
  return(TRUE)
564 +
}
565 +
566 +
#------------------------------------------------
567 +
# dim(x) equals y
568 +
#' @noRd
569 +
assert_dim <- function(x, y, message = "%s must have %s rows and %s columns",
570 +
                       name = paste(deparse(substitute(x)), collapse = "")) {
571 +
  assert_2d(x, name = name)
572 +
  assert_pos_int(y, name = "y variable in assert_dim()")
573 +
  assert_length(y, 2, name = "y variable in assert_dim()")
574 +
  if (nrow(x) != y[1] | ncol(x) != y[2]) {
575 +
    stop(sprintf(message, name, y[1], y[2]), call. = FALSE)
576 +
  }
577 +
  return(TRUE)
578 +
}
579 +
580 +
#------------------------------------------------
581 +
# x is square matrix
582 +
#' @noRd
583 +
assert_square_matrix <- function(x, message = "%s must be a square matrix",
584 +
                                 name = paste(deparse(substitute(x)), collapse = "")) {
585 +
  assert_matrix(x, name = name)
586 +
  if (nrow(x) != ncol(x)) {
587 +
    stop(sprintf(message, name), call. = FALSE)
588 +
  }
589 +
  return(TRUE)
590 +
}
591 +
592 +
#------------------------------------------------
593 +
# is symmetric matrix
594 +
#' @noRd
595 +
assert_symmetric_matrix <- function(x, message = "%s must be a symmetric matrix",
596 +
                                    name = paste(deparse(substitute(x)), collapse = "")) {
597 +
  assert_square_matrix(x, name = name)
598 +
  if (!isSymmetric(x)) {
599 +
    stop(sprintf(message, name), call. = FALSE)
600 +
  }
601 +
  return(TRUE)
602 +
}
603 +
604 +
#### MISC ####################################################################
605 +
606 +
#------------------------------------------------
607 +
# x contains no duplicates
608 +
#' @noRd
609 +
assert_noduplicates <- function(x, message = "%s must contain no duplicates",
610 +
                                name = paste(deparse(substitute(x)), collapse = "")) {
611 +
  if (any(duplicated(x))) {
612 +
    stop(sprintf(message, name), call. = FALSE)
613 +
  }
614 +
  return(TRUE)
615 +
}
616 +
617 +
#------------------------------------------------
618 +
# file exists at chosen path
619 +
#' @noRd
620 +
assert_file_exists <- function(x, message = "file not found at path %s",
621 +
                               name = paste(deparse(substitute(x)), collapse = "")) {
622 +
  if (!file.exists(x)) {
623 +
    stop(sprintf(message, name), call. = FALSE)
624 +
  }
625 +
  return(TRUE)
626 +
}
627 +
628 +
#------------------------------------------------
629 +
# x is increasing
630 +
#' @noRd
631 +
assert_increasing <- function(x, message = "%s must be increasing",
632 +
                              name = paste(deparse(substitute(x)), collapse = "")) {
633 +
  assert_non_null(x, name = name)
634 +
  assert_numeric(x, name = name)
635 +
  if (!isTRUE(all.equal(x, sort(x)))) {
636 +
    stop(sprintf(message, name), call. = FALSE)
637 +
  }
638 +
  return(TRUE)
639 +
}
640 +
641 +
#------------------------------------------------
642 +
# x is decreasing
643 +
#' @noRd
644 +
assert_decreasing <- function(x, message = "%s must be decreasing",
645 +
                              name = paste(deparse(substitute(x)), collapse = "")) {
646 +
  assert_non_null(x, name = name)
647 +
  assert_numeric(x, name = name)
648 +
  if (!isTRUE(all.equal(x, sort(x, decreasing = TRUE)))) {
649 +
    stop(sprintf(message, name), call. = FALSE)
650 +
  }
651 +
  return(TRUE)
652 +
}
653 +

@@ -378,7 +378,7 @@
Loading
378 378
#'
379 379
#' @param project a SIMPLEGEN project, as produced by the
380 380
#'   \code{simplegen_project()} function.
381 -
#' @param x a dataframe containing all of the following columns:
381 +
#' @param df_sample a dataframe containing all of the following columns:
382 382
#'   \itemize{
383 383
#'     \item time: the time (in days) at which samples are taken.
384 384
#'     \item deme: the deme from which samples are taken.
@@ -393,24 +393,25 @@
Loading
393 393
#'
394 394
#' @export
395 395
396 -
define_sampling_strategy <- function(project, x) {
396 +
define_sampling_strategy <- function(project, df_sample) {
397 397
  
398 398
  # check inputs
399 399
  assert_custom_class(project, "simplegen_project")
400 -
  assert_dataframe(x)
401 -
  assert_eq(names(x), c("time", "deme", "case_detection", "diagnosis", "n"))
402 -
  assert_pos_int(x$time, zero_allowed = FALSE)
403 -
  assert_pos_int(x$deme, zero_allowed = FALSE)
404 -
  assert_in(x$case_detection, c("active", "passive"))
405 -
  assert_in(x$diagnosis, c("microscopy", "PCR"))
406 -
  assert_pos_int(x$n, zero_allowed = FALSE)
400 +
  assert_dataframe(df_sample)
401 +
  assert_eq(names(df_sample), c("time", "deme", "case_detection", "diagnosis", "n"))
402 +
  assert_pos_int(df_sample$time, zero_allowed = FALSE)
403 +
  assert_increasing(df_sample$time)
404 +
  assert_pos_int(df_sample$deme, zero_allowed = FALSE)
405 +
  assert_in(df_sample$case_detection, c("active", "passive"))
406 +
  assert_in(df_sample$diagnosis, c("microscopy", "PCR"))
407 +
  assert_pos_int(df_sample$n, zero_allowed = FALSE)
407 408
  
408 409
  # specify formats
409 -
  x$case_detection <- as.character(x$case_detection)
410 -
  x$diagnosis <- as.character(x$diagnosis)
410 +
  df_sample$case_detection <- as.character(df_sample$case_detection)
411 +
  df_sample$diagnosis <- as.character(df_sample$diagnosis)
411 412
  
412 413
  # load into project
413 -
  project$sampling_strategy <- x
414 +
  project$sampling_strategy <- df_sample
414 415
  
415 416
  invisible(project)
416 417
}
@@ -468,8 +469,7 @@
Loading
468 469
  assert_single_logical(overwrite_transmission_record)
469 470
  assert_single_logical(output_daily_counts)
470 471
  assert_single_logical(output_age_distributions)
471 -
  assert_vector(output_age_times)
472 -
  assert_pos_int(output_age_times)
472 +
  assert_vector_pos_int(output_age_times, zero_allowed = FALSE)
473 473
  assert_leq(output_age_times, max_time)
474 474
  assert_single_logical(pb_markdown)
475 475
  assert_single_logical(silent)
@@ -486,6 +486,13 @@
Loading
486 486
    stop("no epi parameters defined. See ?define_epi_params")
487 487
  }
488 488
  
489 +
  # check that inputs are compatible with sampling strategy
490 +
  if (!is.null(project$sampling_strategy)) {
491 +
    ss <- project$sampling_strategy
492 +
    
493 +
    assert_greq(max_time, max(ss$time), message = "%s exceeded by sampling time (%s)")
494 +
    assert_greq(nrow(project$epi_parameters$mig_mat), max(ss$deme), "number of demes defined in sampling strategy exceeds number defined in epi parameters")
495 +
  }
489 496
  
490 497
  # ---------- define argument lists ----------
491 498
  
@@ -559,7 +566,7 @@
Loading
559 566
      ret <- as.data.frame(cbind(seq_len(nrow(ret)), i, ret))
560 567
      names(ret) <- c("time", "deme", "H", "S", "E", "A", "C", "P",
561 568
                      "Sv", "Ev", "Iv",
562 -
                      "EIR",
569 +
                      "EIR", "inc_infection", "inc_acute", "inc_chronic",
563 570
                      "A_detectable_microscopy", "C_detectable_microscopy",
564 571
                      "A_detectable_PCR", "C_detectable_PCR","n_inoc")
565 572
      return(ret)
@@ -572,7 +579,7 @@
Loading
572 579
    age_distributions <- do.call(rbind, mapply(function(j) {
573 580
      ret <- do.call(rbind, mapply(function(i) {
574 581
        ret <- do.call(rbind, output_raw$age_distributions[[j]][[i]])
575 -
        colnames(ret) <- c("S", "E", "A", "C", "P")
582 +
        colnames(ret) <- c("S", "E", "A", "C", "P", "inc_infection", "inc_acute", "inc_chronic")
576 583
        data.frame(cbind(deme = i, age = seq_len(nrow(ret)) - 1, ret))
577 584
      }, seq_along(output_raw$age_distributions[[j]]), SIMPLIFY = FALSE))
578 585
      cbind(sample_time = j, ret)

@@ -260,7 +260,7 @@
Loading
260 260
  
261 261
  # subset data
262 262
  dat <- project$epi_output$age_distributions
263 -
  dat <- dat[dat$sample_time == sample_time & dat$deme == deme, c("age", state)]
263 +
  dat <- dat[(dat$sample_time == sample_time) & (dat$deme == deme), c("age", state)]
264 264
  names(dat) <- c("age", "y")
265 265
  
266 266
  # produce plot

@@ -474,7 +474,7 @@
Loading
474 474
  for (int i = 0; i < params->max_inoculations; ++i) {
475 475
    
476 476
    // anything that is currently in the acute or chronic stages is cured
477 -
    if (inoc_status_asexual[i] == Acute_asexual || inoc_status_asexual[i] == Chronic_asexual) {
477 +
    if ((inoc_status_asexual[i] == Acute_asexual) || (inoc_status_asexual[i] == Chronic_asexual)) {
478 478
      
479 479
      // if due to become infective at a future timepoint then store this
480 480
      // timepoint
@@ -509,7 +509,8 @@
Loading
509 509
    // prophylactic period is cured immediately upon emergence
510 510
    if (inoc_status_asexual[i] == Liverstage_asexual) {
511 511
      
512 -
      if (inoc_events[i].count(Event_Eh_to_Ah) != 0 && inoc_events[i][Event_Eh_to_Ah] <= t2) {
512 +
      // acute
513 +
      if ((inoc_events[i].count(Event_Eh_to_Ah) != 0) && (inoc_events[i][Event_Eh_to_Ah] <= t2)) {
513 514
        
514 515
        // store time at which due to emerge
515 516
        int t_emerge = inoc_events[i][Event_Eh_to_Ah];
@@ -522,7 +523,8 @@
Loading
522 523
        new_inoc_event(t_emerge, Event_Ah_to_Sh, i);
523 524
        new_inoc_event(t_emerge, Event_end_infective, i);
524 525
        
525 -
      } else if (inoc_events[i].count(Event_Eh_to_Ch) != 0 && inoc_events[i][Event_Eh_to_Ch] <= t2) {
526 +
      // chronic
527 +
      } else if ((inoc_events[i].count(Event_Eh_to_Ch) != 0) && (inoc_events[i][Event_Eh_to_Ch] <= t2)) {
526 528
        
527 529
        // store time at which due to emerge
528 530
        int t_emerge = inoc_events[i][Event_Eh_to_Ch];
@@ -544,6 +546,8 @@
Loading
544 546
  t_next_inoc_event = params->max_time + 1;
545 547
  for (int i = 0; i < params->max_inoculations; ++i) {
546 548
    for (const auto & x : inoc_events[i]) {
549 +
      
550 +
      // catch to ensure that events cannot predate current time
547 551
      if (x.second < t) {
548 552
        print("time =", t);
549 553
        print_inoc_status();
@@ -814,6 +818,13 @@
Loading
814 818
//------------------------------------------------
815 819
// get current probability of infection
816 820
double Host::get_prob_infection() {
821 +
  
822 +
  // situations in which zero chance of infection
823 +
  if ((get_n_active_inoc() == params->max_inoculations) || prophylaxis_on) {
824 +
    return 0.0;
825 +
  }
826 +
  
827 +
  // get probability from flexible distribution
817 828
  int index = (infection_index < params->n_prob_infection) ? infection_index : params->n_prob_infection - 1;
818 829
  return params->prob_infection[index];
819 830
}
820 831
imilarity index 97%
821 832
ename from tests/testthat/test-assertions_v8.R
822 833
ename to tests/testthat/test-assertions_v9.R

@@ -78,6 +78,10 @@
Loading
78 78
  
79 79
  // misc
80 80
  std::vector<double> EIR;
81 +
  std::vector<double> prob_infectious_bite;
82 +
  std::vector<double> inc_infection;
83 +
  std::vector<double> inc_acute;
84 +
  std::vector<double> inc_chronic;
81 85
  
82 86
  // number of active inoculations
83 87
  std::vector<double> n_inoc;
@@ -91,7 +95,8 @@
Loading
91 95
  void init(Parameters &params);
92 96
  void run_simulation(Rcpp::List &args_functions, Rcpp::List &args_progress);
93 97
  void update_host_counts(int t);
94 -
  void get_sample_details(int t, int deme, int n);
98 +
  void update_incidence(int t);
99 +
  void get_sample_details(int t, int deme, int n, Diagnosis diag);
95 100
  void get_age_distribution(int t_index);
96 101
  
97 102
};

@@ -1,54 +1,81 @@
Loading
1 -
2 -
#------------------------------------------------
3 -
#' @title Define new SIMPLEGEN project
4 -
#'
5 -
#' @description Define a new SIMPLEGEN project. This project will hold all
6 -
#'   simulation inputs and outputs for a given analysis, and is initialised with
7 -
#'   the default values of all parameters.
8 -
#'
9 -
#' @export
10 -
11 -
simplegen_project <- function() {
12 -
  
13 -
  # create empty project
14 -
  project <- list(epi_parameters = NULL,
15 -
                  sampling_strategy = NULL,
16 -
                  epi_output = NULL,
17 -
                  sample_details = NULL,
18 -
                  relatedness = NULL,
19 -
                  true_genotypes = NULL,
20 -
                  observed_genotypes = NULL)
21 -
  
22 -
  class(project) <- "simplegen_project"
23 -
  
24 -
  # return
25 -
  invisible(project)
26 -
}
27 -
28 -
#------------------------------------------------
29 -
# overload print() function for simplegen_project
30 -
#' @method print simplegen_project
31 -
#' @export
32 -
print.simplegen_project <- function(x, ...) {
33 -
  
34 -
  # print summary
35 -
  summary(x)
36 -
  
37 -
  # return invisibly
38 -
  invisible(x)
39 -
}
40 -
41 -
#------------------------------------------------
42 -
# overload summary() function for simplegen_project
43 -
#' @method summary simplegen_project
44 -
#' @export
45 -
summary.simplegen_project <- function(object, ...) {
46 -
  
47 -
  
48 -
  
49 -
  message("TODO - some default print method")
50 -
  
51 -
  # return invisibly
52 -
  invisible(object)
53 -
}
54 -
1 +
2 +
#------------------------------------------------
3 +
#' @title Define new SIMPLEGEN project
4 +
#'
5 +
#' @description Define a new SIMPLEGEN project. This project will hold all
6 +
#'   simulation inputs and outputs for a given analysis, and is initialised with
7 +
#'   the default values of all parameters.
8 +
#'
9 +
#' @export
10 +
11 +
simplegen_project <- function() {
12 +
  
13 +
  # create empty project
14 +
  project <- list(epi_parameters = NULL,
15 +
                  sampling_strategy = NULL,
16 +
                  epi_output = NULL,
17 +
                  sample_details = NULL,
18 +
                  relatedness = NULL,
19 +
                  true_genotypes = NULL,
20 +
                  observed_genotypes = NULL)
21 +
  
22 +
  class(project) <- "simplegen_project"
23 +
  
24 +
  # return
25 +
  invisible(project)
26 +
}
27 +
28 +
#------------------------------------------------
29 +
# overload print() function for simplegen_project
30 +
#' @method print simplegen_project
31 +
#' @export
32 +
print.simplegen_project <- function(x, ...) {
33 +
  
34 +
  # print summary
35 +
  summary(x)
36 +
  
37 +
  # return invisibly
38 +
  invisible(x)
39 +
}
40 +
41 +
#------------------------------------------------
42 +
# overload summary() function for simplegen_project
43 +
#' @method summary simplegen_project
44 +
#' @export
45 +
summary.simplegen_project <- function(object, ...) {
46 +
  p <- object
47 +
  
48 +
  # if empty project
49 +
  if (all(mapply(is.null, p))) {
50 +
    message("(empty project)")
51 +
    invisible(object)
52 +
  }
53 +
  
54 +
  # print epi parameters
55 +
  if (!is.null(p$epi_parameters)) {
56 +
    message("Epidemiological model:")
57 +
    n_demes <- length(p$epi_parameters$H)
58 +
    message(sprintf("  demes: %s", n_demes))
59 +
    message(sprintf("  H:\t %s", paste(p$epi_parameters$H, collapse = ", ")))
60 +
    message(sprintf("  M:\t %s", paste(p$epi_parameters$M, collapse = ", ")))
61 +
    message(sprintf("  seed infections: %s", paste(p$epi_parameters$seed_infections, collapse = ", ")))
62 +
  }
63 +
  
64 +
  # print sampling strategy
65 +
  if (!is.null(p$sampling_strategy)) {
66 +
    message("Sampling strategy:")
67 +
    n_time <- unique(p$sampling_strategy$time)
68 +
    n_samp_time <- mapply(sum, split(p$sampling_strategy$n, f = p$sampling_strategy$time))
69 +
    if (length(n_time) <= 5) {
70 +
      message(sprintf("  time: %s", paste(n_time, collapse = ", ")))
71 +
      message(sprintf("  n: %s", paste(n_samp_time, collapse = ", ")))
72 +
    } else {
73 +
      message("  time: (more than 5)")
74 +
      message("  n: (more than 5)")
75 +
    }
76 +
    
77 +
  }
78 +
  
79 +
  invisible(object)
80 +
}
81 +
Files Coverage
R 64.93%
src 53.04%
Project Totals (24 files) 56.67%
1
comment: false
2

3
coverage:
4
  status:
5
    project:
6
      default:
7
        target: auto
8
        threshold: 1%
9
    patch:
10
      default:
11
        target: auto
12
        threshold: 1%
Sunburst
The inner-most circle is the entire project, moving away from the center are folders then, finally, a single file. The size and color of each slice is representing the number of statements and the coverage, respectively.
Icicle
The top section represents the entire project. Proceeding with folders and finally individual files. The size and color of each slice is representing the number of statements and the coverage, respectively.
Grid
Each block represents a single file in the project. The size and color of each block is represented by the number of statements and the coverage, respectively.
Loading