R version 4.4.0 RC (2024-04-16 r86468 ucrt) -- "Puppy Cup" Copyright (C) 2024 The R Foundation for Statistical Computing Platform: x86_64-w64-mingw32/x64 R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > ## This file is part of SimInf, a framework for stochastic > ## disease spread simulations. > ## > ## Copyright (C) 2022 Ivana Rodriguez Ewerlöf > ## Copyright (C) 2015 -- 2024 Stefan Widgren > ## > ## SimInf is free software: you can redistribute it and/or modify > ## it under the terms of the GNU General Public License as published by > ## the Free Software Foundation, either version 3 of the License, or > ## (at your option) any later version. > ## > ## SimInf is distributed in the hope that it will be useful, > ## but WITHOUT ANY WARRANTY; without even the implied warranty of > ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the > ## GNU General Public License for more details. > ## > ## You should have received a copy of the GNU General Public License > ## along with this program. If not, see . > > library(SimInf) > library(tools) > source("util/check.R") > > ## Specify the number of threads to use. > set_num_threads(1) > > ## For debugging > sessionInfo() R version 4.4.0 RC (2024-04-16 r86468 ucrt) Platform: x86_64-w64-mingw32/x64 Running under: Windows Server 2022 x64 (build 20348) Matrix products: default locale: [1] LC_COLLATE=C LC_CTYPE=German_Germany.utf8 [3] LC_MONETARY=C LC_NUMERIC=C [5] LC_TIME=C time zone: Europe/Berlin tzcode source: internal attached base packages: [1] tools stats graphics grDevices utils datasets methods [8] base other attached packages: [1] SimInf_9.7.0 loaded via a namespace (and not attached): [1] MASS_7.3-60.2 compiler_4.4.0 Matrix_1.7-0 grid_4.4.0 digest_0.6.35 [6] lattice_0.22-6 > > ## Check to pass vectors of different lengths. > res <- assertError(.Call( + SimInf:::SimInf_clean_indiv_events, + integer(0), + c(0L, 3L), + c(1L, 2L), + c(1L, 1L), + c(0L, 2L))) > check_error(res, "'event' must be an integer vector with length 0.") > > res <- assertError(.Call( + SimInf:::SimInf_clean_indiv_events, + c(1L, 1L), + c(0L), + c(1L, 2L), + c(1L, 1L), + c(0L, 2L))) > check_error(res, "'event' must be an integer vector with length 2.") > > res <- assertError(.Call( + SimInf:::SimInf_clean_indiv_events, + c(1L, 1L), + c(0L, 3L), + c(1L), + c(1L, 1L), + c(0L, 2L))) > check_error(res, "'time' must be an integer vector with length 2.") > > res <- assertError(.Call( + SimInf:::SimInf_clean_indiv_events, + c(1L, 1L), + c(0L, 3L), + c(1L, 2L), + c(1L), + c(0L, 2L))) > check_error(res, "'node' must be an integer vector with length 2.") > > res <- assertError(.Call( + SimInf:::SimInf_clean_indiv_events, + c(1L, 1L), + c(0L, 3L), + c(1L, 2L), + c(1L, 1L), + c(0L))) > check_error(res, "'dest' must be an integer vector with length 2.") > > res <- assertError(.Call( + SimInf:::SimInf_clean_indiv_events, + c(1L, 1L), + c(0L, 2L), + c(1L, 2L), + c(1L, 1L), + c(0L, 2L))) > check_error(res, "'event[2]' is invalid.") > > ## Check various errors in event data. > res <- assertError(individual_events(1L)) > check_error(res, "Missing columns in 'events'.") > > events <- data.frame( + id = c(1L, 1L, 1L, 1L), + event = c(1L, NA_integer_, 3L, 0L), + time = c(1L, 2L, 3L, 4L), + node = c(1L, 1L, 2L, 2L), + dest = c(0L, 2L, 2L, 1L)) > res <- assertError(individual_events(events)) > check_error( + res, + "'event' must be an integer or character vector with non-NA values.") > > events <- data.frame( + id = c(1L, 1L, 1L, 1L), + event = c(1, 3.1, 3, 0), + time = c(1L, 2L, 3L, 4L), + node = c(1L, 1L, 2L, 2L), + dest = c(0L, 2L, 2L, 1L)) > res <- assertError(individual_events(events)) > check_error( + res, + "'event' must be an integer or character vector with non-NA values.") > > events <- data.frame( + id = c(1L, 1L, 1L, 1L), + event = c(1L, 4L, 3L, 0L), + time = c(1L, 2L, 3L, 4L), + node = c(1L, 1L, 2L, 2L), + dest = c(0L, 2L, 2L, 1L)) > res <- assertError(individual_events(events)) > check_error( + res, + "'event' must be an integer or character vector with non-NA values.") > > events <- data.frame( + id = c(1L, 1L, 1L, 1L), + event = c("enter", "unknown", "extTrans", "exit"), + time = c(1L, 2L, 3L, 4L), + node = c(1L, 1L, 2L, 2L), + dest = c(0L, 2L, 2L, 1L)) > res <- assertError(individual_events(events)) > check_error( + res, + "'event' type must be 'enter', 'exit', or 'extTrans'.") > > events <- data.frame( + id = c(1L, 1L, 1L, 1L), + event = c(TRUE, TRUE, TRUE, TRUE), + time = c(1L, 2L, 3L, 4L), + node = c(1L, 1L, 2L, 2L), + dest = c(0L, 2L, 2L, 1L)) > res <- assertError(individual_events(events)) > check_error( + res, + "'event' must be an integer or character vector with non-NA values.") > > events <- data.frame( + id = c(1L, 1L, 1L, 1L), + event = c(1L, 3L, 3L, 0L), + time = c(1L, NA_integer_, 3L, 4L), + node = c(1L, 1L, 2L, 2L), + dest = c(0L, 2L, 2L, 1L)) > res <- assertError(individual_events(events)) > check_error( + res, + "'time' must be an integer or character vector with non-NA values.") > > events <- data.frame( + id = c(1L, 1L, 1L, 1L), + event = c(1L, 3L, 3L, 0L), + time = c(1, 2.1, 3, 4), + node = c(1L, 1L, 2L, 2L), + dest = c(0L, 2L, 2L, 1L)) > res <- assertError(individual_events(events)) > check_error( + res, + "'time' must be an integer or character vector with non-NA values.") > > events <- data.frame( + id = c(1L, 1L, 1L, 1L), + event = c(1L, 3L, 3L, 0L), + time = c(TRUE, TRUE, TRUE, TRUE), + node = c(1L, 1L, 2L, 2L), + dest = c(0L, 2L, 2L, 1L)) > res <- assertError(individual_events(events)) > check_error( + res, + "'time' must be an integer or character vector with non-NA values.") > > events <- data.frame( + id = c(1L, 1L, 1L, 1L), + event = c(1L, 3L, 3L, 0L), + time = c(1L, 2L, 3L, 4L), + node = c(NA_integer_, 1L, 2L, 2L), + dest = c(0L, 2L, 2L, 1L)) > res <- assertError(individual_events(events)) > check_error( + res, + "'node' or 'dest' contain NA values.") > > events <- data.frame( + id = c(1L, 1L, 1L, 1L), + event = c(1L, 3L, 3L, 0L), + time = c(1L, 2L, 3L, 4L), + node = c(1L, 1L, 2L, 2L), + dest = c(0L, NA_integer_, 2L, 1L)) > res <- assertError(individual_events(events)) > check_error( + res, + "'node' or 'dest' contain NA values.") > > ## Check individual events. > events <- data.frame( + id = c(1L, 1L, 1L, 1L), + event = c(1L, 3L, 3L, 0L), + time = c(1L, 2L, 3L, 4L), + node = c(1L, 1L, 2L, 2L), + dest = c(0L, 2L, 2L, 1L)) > > events_obs <- as.data.frame(individual_events(events)) > > events_exp <- data.frame( + id = c(1L, 1L, 1L), + event = c(1L, 3L, 0L), + time = c(1L, 2L, 4L), + node = c(1L, 1L, 2L), + dest = c(NA_integer_, 2L, NA_integer_)) > > stopifnot(identical(events_obs, events_exp)) > > events <- data.frame( + id = c(1L, 1L, 1L, 1L), + event = c(1L, 3L, 3L, 0L), + time = c(1L, 2L, 3L, 4L), + node = c("1", "1", "2", "2"), + dest = c("0", "2", "2", "1")) > > events_obs <- as.data.frame(individual_events(events)) > > events_exp <- data.frame( + id = c(1L, 1L, 1L), + event = c(1L, 3L, 0L), + time = c(1L, 2L, 4L), + node = c("1", "1", "2"), + dest = c(NA_character_, "2", NA_character_)) > > stopifnot(identical(events_obs, events_exp)) > > events <- data.frame( + id = c(1L, 1L, 1L, 1L), + event = c(1L, 3L, 3L, 0L), + time = c(1L, 2L, 3L, 4L), + node = c(1L, 1L, 2L, 2L), + dest = c(0L, 2L, 2L, 0L)) > > events_obs <- as.data.frame(individual_events(events)) > > events_exp <- data.frame( + id = c(1L, 1L, 1L), + event = c(1L, 3L, 0L), + time = c(1L, 2L, 4L), + node = c(1L, 1L, 2L), + dest = c(NA_integer_, 2L, NA_integer_)) > > stopifnot(identical(events_obs, events_exp)) > > events <- data.frame( + id = c(1L, 1L, 1L, 1L), + event = c(1L, 3L, 3L, 0L), + time = c(1L, 2L, 3L, 4L), + node = c("A", "A", "B", "B"), + dest = c("0", "B", "B", "0")) > > events_obs <- as.data.frame(individual_events(events)) > > events_exp <- data.frame( + id = c(1L, 1L, 1L), + event = c(1L, 3L, 0L), + time = c(1L, 2L, 4L), + node = c("A", "A", "B"), + dest = c(NA_character_, "B", NA_character_)) > > stopifnot(identical(events_obs, events_exp)) > > events <- data.frame( + id = c("A", "A", "A", "A"), + event = c("enter", "extTrans", "extTrans", "exit"), + time = c("2019-02-02", "2020-03-07", "2021-04-14", "2022-05-11"), + node = c(1L, 1L, 2L, 2L), + dest = c(0L, 2L, 2L, 0L)) > > events_obs <- as.data.frame(individual_events(events)) > > events_exp <- data.frame( + id = c("A", "A", "A"), + event = c("enter", "extTrans", "exit"), + time = as.Date(c("2019-02-02", "2020-03-07", "2022-05-11")), + node = c(1L, 1L, 2L), + dest = c(NA_integer_, 2L, NA_integer_)) > > stopifnot(identical(events_obs, events_exp)) > > events$id[2] <- NA_integer_ > res <- assertError(individual_events(events)) > check_error( + res, + "'id' must be an integer or character vector with non-NA values.") > events$id[2] <- 1L > > events$node[2] <- 1.1 > res <- assertError(individual_events(events)) > check_error( + res, + "'node' and 'dest' must both be integer or character.") > events$node <- c(1L, 1L, 2L, 2L) > > events$dest <- as.Date(events$dest, origin = "1970-01-01") > res <- assertError(individual_events(events)) > check_error( + res, + "'node' and 'dest' must both be integer or character.") > events$dest <- c(0L, 2L, 2L, 0L) > > events <- data.frame( + id = c("A", "A", "A", "A"), + event = c("enter", "extTrans", "extTrans", "exit"), + time = c("2001-02-01", 2L, 3L, 4L), + node = c(1L, 1L, 2L, 2L), + dest = c(0L, 2L, 2L, 0L)) > res <- assertError(individual_events(events)) > check_error( + res, + "'time' must be an integer or character vector with non-NA values.") > > ## Testing animal with only one enter event, keep > events <- data.frame( + id = 1L, + event = 1L, + time = 1L, + node = 1L, + dest = 0L) > > events_obs <- as.data.frame(individual_events(events)) > > events_exp <- data.frame( + id = 1L, + event = 1L, + time = 1L, + node = 1L, + dest = NA_integer_) > > stopifnot(identical(events_obs, events_exp)) > > ## Testing animal with only one exit event, keep > events <- data.frame( + id = 1L, + event = 0L, + time = 1L, + node = 1L, + dest = 0L) > > events_obs <- as.data.frame(individual_events(events)) > > events_exp <- data.frame( + id = 1L, + event = 0L, + time = 1L, + node = 1L, + dest = NA_integer_) > > stopifnot(identical(events_obs, events_exp)) > > ## Testing animal with only one external transfer event, keep > events <- data.frame( + id = 1L, + event = 3L, + time = 1L, + node = 1L, + dest = 2L) > > stopifnot(identical(events, as.data.frame(individual_events(events)))) > > ## Testing animal with two enter events, keep first > events <- data.frame( + id = c(1L, 1L), + event = c(1L, 1L), + time = c(1L, 2L), + node = c(1L, 1L), + dest = c(0L, 0L)) > > events_obs <- as.data.frame(individual_events(events)) > > events_exp <- data.frame( + id = 1L, + event = 1L, + time = 1L, + node = 1L, + dest = NA_integer_) > > stopifnot(identical(events_obs, events_exp)) > > ## Testing animal with two exit events, keep first > events <- data.frame( + id = c(1L, 1L), + event = c(0L, 0L), + time = c(1L, 2L), + node = c(1L, 1L), + dest = c(0L, 0L)) > > events_obs <- as.data.frame(individual_events(events)) > > events_exp <- data.frame( + id = 1L, + event = 0L, + time = 1L, + node = 1L, + dest = NA_integer_) > > stopifnot(identical(events_obs, events_exp)) > > ## Testing animal with two enter events and exit, keep path > events <- data.frame( + id = c(1L, 1L, 1L), + event = c(1L, 1L, 0L), + time = c(1L, 2L, 3L), + node = c(1L, 2L, 2L), + dest = c(0L, 0L, 0L)) > > events_obs <- as.data.frame(individual_events(events)) > > events_exp <- data.frame( + id = c(1L, 1L), + event = c(1L, 0L), + time = c(2L, 3L), + node = c(2L, 2L), + dest = c(NA_integer_, NA_integer_)) > > stopifnot(identical(events_obs, events_exp)) > > ## Testing animal with two enter events, a movement and an exit, keep > ## path > events <- data.frame( + id = c(1L, 1L, 1L, 1L), + event = c(1L, 1L, 3L, 0L), + time = c(1L, 2L, 3L, 4L), + node = c(1L, 2L, 1L, 3L), + dest = c(0L, 0L, 3L, 0L)) > > events_obs <- as.data.frame(individual_events(events)) > > events_exp <- data.frame( + id = c(1L, 1L, 1L), + event = c(1L, 3L, 0L), + time = c(1L, 3L, 4L), + node = c(1L, 1L, 3L), + dest = c(NA_integer_, 3L, NA_integer_)) > > stopifnot(identical(events_obs, events_exp)) > > ## Testing animal with one enter event and two exit events, keep path > events <- data.frame( + id = c(1L, 1L, 1L), + event = c(1L, 0L, 0L), + time = c(1L, 2L, 3L), + node = c(1L, 2L, 1L), + dest = c(0L, 0L, 0L)) > > events_obs <- as.data.frame(individual_events(events)) > > events_exp <- data.frame( + id = c(1L, 1L), + event = c(1L, 0L), + time = c(1L, 3L), + node = c(1L, 1L), + dest = c(NA_integer_, NA_integer_)) > > stopifnot(identical(events_obs, events_exp)) > > ## Testing animal with one enter event and two exit events, keep path > events <- data.frame( + id = c(1L, 1L, 1L), + event = c(1L, 0L, 0L), + time = c(1L, 2L, 3L), + node = c(1L, 1L, 2L), + dest = c(0L, 0L, 0L)) > > events_obs <- as.data.frame(individual_events(events)) > > events_exp <- data.frame( + id = c(1L, 1L), + event = c(1L, 0L), + time = c(1L, 2L), + node = c(1L, 1L), + dest = c(NA_integer_, NA_integer_)) > > stopifnot(identical(events_obs, events_exp)) > > ## Testing animal with another event after exit event, exit event > ## should be last > events <- data.frame( + id = c(1L, 1L, 1L, 1L), + event = c(1L, 3L, 0L, 3L), + time = c(1L, 2L, 3L, 4L), + node = c(1L, 1L, 2L, 2L), + dest = c(0L, 2L, 0L, 3L)) > > events_obs <- as.data.frame(individual_events(events)) > > events_exp <- data.frame( + id = c(1L, 1L, 1L), + event = c(1L, 3L, 0L), + time = c(1L, 2L, 3L), + node = c(1L, 1L, 2L), + dest = c(NA_integer_, 2L, NA_integer_)) > > stopifnot(identical(events_obs, events_exp)) > > ## Testing animal with another event after exit event, > ## no path to exit, don't keep > events <- data.frame( + id = c(1L, 1L, 1L, 1L), + event = c(1L, 3L, 0L, 3L), + time = c(1L, 2L, 3L, 4L), + node = c(1L, 1L, 3L, 2L), + dest = c(0L, 2L, 0L, 3L)) > > events_obs <- as.data.frame(individual_events(events)) > > events_exp <- data.frame( + id = integer(0), + event = integer(0), + time = integer(0), + node = integer(0), + dest = integer(0)) > > stopifnot(identical(events_obs, events_exp)) > > ## Testing animal with another event before enter event, enter event > ## should be first > events <- data.frame( + id = c(1L, 1L, 1L, 1L), + event = c(3L, 1L, 3L, 0L), + time = c(1L, 2L, 3L, 4L), + node = c(1L, 1L, 1L, 2L), + dest = c(2L, 0L, 2L, 0L)) > > events_obs <- as.data.frame(individual_events(events)) > > events_exp <- data.frame( + id = c(1L, 1L, 1L), + event = c(1L, 3L, 0L), + time = c(2L, 3L, 4L), + node = c(1L, 1L, 2L), + dest = c(NA_integer_, 2L, NA_integer_)) > > stopifnot(identical(events_obs, events_exp)) > > pdf_file <- tempfile(fileext = ".pdf") > pdf(pdf_file) > plot(individual_events(events)) > dev.off() null device 1 > stopifnot(file.exists(pdf_file)) > unlink(pdf_file) > > ## Testing animal with another event before enter event, keep path if > ## starting on enter event and ending with exit > events <- data.frame( + id = c(1L, 1L, 1L, 1L), + event = c(3L, 1L, 3L, 0L), + time = c(1L, 2L, 3L, 4L), + node = c(1L, 2L, 1L, 2L), + dest = c(2L, 0L, 2L, 0L)) > > events_obs <- as.data.frame(individual_events(events)) > > events_exp <- data.frame( + id = c(1L, 1L), + event = c(1L, 0L), + time = c(2L, 4L), + node = c(2L, 2L), + dest = c(NA_integer_, NA_integer_)) > > stopifnot(identical(events_obs, events_exp)) > > ## Testing animal with no path from enter to exit event, don't keep > events <- data.frame( + id = c(1L, 1L, 1L, 1L), + event = c(3L, 1L, 3L, 0L), + time = c(1L, 2L, 3L, 4L), + node = c(1L, 2L, 2L, 3L), + dest = c(2L, 0L, 1L, 0L)) > > events_obs <- as.data.frame(individual_events(events)) > > events_exp <- data.frame( + id = integer(0), + event = integer(0), + time = integer(0), + node = integer(0), + dest = integer(0)) > > stopifnot(identical(events_obs, events_exp)) > > ## Testing animal with no enter event, keep path > events <- data.frame( + id = c(1L, 1L, 1L), + event = c(3L, 3L, 0L), + time = c(1L, 2L, 3L), + node = c(1L, 2L, 1L), + dest = c(2L, 1L, 0L)) > > events_obs <- as.data.frame(individual_events(events)) > > events_exp <- data.frame( + id = c(1L, 1L, 1L), + event = c(3L, 3L, 0L), + time = c(1L, 2L, 3L), + node = c(1L, 2L, 1L), + dest = c(2L, 1L, NA_integer_)) > > stopifnot(identical(events_obs, events_exp)) > > ## Testing animal with no enter or exit event, keep path > events <- data.frame( + id = c(1L, 1L), + event = c(3L, 3L), + time = c(1L, 2L), + node = c(1L, 2L), + dest = c(2L, 3L)) > > events_obs <- as.data.frame(individual_events(events)) > > stopifnot(identical(events_obs, events)) > > ## Testing animal with no exit event, keep path > events <- data.frame( + id = c(1L, 1L), + event = c(1L, 3L), + time = c(1L, 2L), + node = c(1L, 1L), + dest = c(0L, 2L)) > > events_obs <- as.data.frame(individual_events(events)) > > events_exp <- data.frame( + id = c(1L, 1L), + event = c(1L, 3L), + time = c(1L, 2L), + node = c(1L, 1L), + dest = c(NA_integer_, 2L)) > > stopifnot(identical(events_obs, events_exp)) > > ## Testing animal with only enter and exit event, keep path > events <- data.frame( + id = c(1L, 1L), + event = c(1L, 0L), + time = c(1L, 2L), + node = c(1L, 1L), + dest = c(0L, 0L)) > > events_obs <- as.data.frame(individual_events(events)) > > events_exp <- data.frame( + id = c(1L, 1L), + event = c(1L, 0L), + time = c(1L, 2L), + node = c(1L, 1L), + dest = c(NA_integer_, NA_integer_)) > > stopifnot(identical(events_obs, events_obs)) > > ## Testing animal with enter and exit event in wrong order, don't keep > events <- data.frame( + id = c(1L, 1L), + event = c(0L, 1L), + time = c(1L, 2L), + node = c(1L, 1L), + dest = c(0L, 0L)) > > events_obs <- as.data.frame(individual_events(events)) > > events_exp <- data.frame( + id = integer(0), + event = integer(0), + time = integer(0), + node = integer(0), + dest = integer(0)) > > stopifnot(identical(events_obs, events_exp)) > > ## Check converting individual events to u0 > events <- data.frame( + id = c(1, 1, 1, 1, + 2, 2, 2, 2), + event = c(1, 3, 3, 0, + 1, 3, 3, 0), + time = c(1, 2, 3, 4, + 2, 3, 4, 5), + node = c(10, 10, 20, 20, + 10, 10, 20, 20), + dest = c(NA, 20, 20, NA, + NA, 20, 20, NA)) > > stopifnot(identical( + u0(individual_events(events), time = 0), + data.frame(key = c(10, 20), + node = c(1L, 2L), + S_1 = c(0L, 0L)))) > > stopifnot(identical( + u0(individual_events(events), time = 1), + data.frame(key = c(10, 20), + node = c(1L, 2L), + S_1 = c(1L, 0L)))) > > stopifnot(identical( + u0(individual_events(events), time = 2), + data.frame(key = c(10, 20), + node = c(1L, 2L), + S_1 = c(1L, 1L)))) > > stopifnot(identical( + u0(individual_events(events), time = 2, target = "SIS"), + data.frame(key = c(10, 20), + node = c(1L, 2L), + S = c(1L, 1L), + I = c(0L, 0L)))) > > stopifnot(identical( + u0(individual_events(events), time = 2, target = "SISe"), + data.frame(key = c(10, 20), + node = c(1L, 2L), + S = c(1L, 1L), + I = c(0L, 0L)))) > > stopifnot(identical( + u0(individual_events(events), time = 2, target = "SISe_sp"), + data.frame(key = c(10, 20), + node = c(1L, 2L), + S = c(1L, 1L), + I = c(0L, 0L)))) > > stopifnot(identical( + u0(individual_events(events), time = 2, target = "SIR"), + data.frame(key = c(10, 20), + node = c(1L, 2L), + S = c(1L, 1L), + I = c(0L, 0L), + R = c(0L, 0L)))) > > stopifnot(identical( + u0(individual_events(events), time = 2, target = "SEIR"), + data.frame(key = c(10, 20), + node = c(1L, 2L), + S = c(1L, 1L), + E = c(0L, 0L), + I = c(0L, 0L), + R = c(0L, 0L)))) > > stopifnot(identical( + u0(individual_events(events), time = 2, age = c(1, 2), target = "SISe3"), + data.frame(key = c(10, 20), + node = c(1L, 2L), + S_1 = c(1L, 0L), + S_2 = c(0L, 1L), + S_3 = c(0L, 0L), + I_1 = c(0L, 0L), + I_2 = c(0L, 0L), + I_3 = c(0L, 0L)))) > > stopifnot(identical( + u0(individual_events(events), time = 2, age = c(1, 2), target = "SISe3_sp"), + data.frame(key = c(10, 20), + node = c(1L, 2L), + S_1 = c(1L, 0L), + S_2 = c(0L, 1L), + S_3 = c(0L, 0L), + I_1 = c(0L, 0L), + I_2 = c(0L, 0L), + I_3 = c(0L, 0L)))) > > stopifnot(identical( + u0(individual_events(events), time = 3), + data.frame(key = c(10, 20), + node = c(1L, 2L), + S_1 = c(0L, 2L)))) > > stopifnot(identical( + u0(individual_events(events), time = 4), + data.frame(key = c(10, 20), + node = c(1L, 2L), + S_1 = c(0L, 1L)))) > > stopifnot(identical( + u0(individual_events(events), time = 5), + data.frame(key = c(10, 20), + node = c(1L, 2L), + S_1 = c(0L, 0L)))) > > stopifnot(identical( + u0(individual_events(events), time = 3, age = 2), + data.frame(key = c(10, 20), + node = c(1L, 2L), + S_1 = c(0L, 1L), + S_2 = c(0L, 1L)))) > > stopifnot(identical( + u0(individual_events(events), time = 3, age = 5), + data.frame(key = c(10, 20), + node = c(1L, 2L), + S_1 = c(0L, 2L), + S_2 = c(0L, 0L)))) > > stopifnot(identical( + u0(individual_events(events), time = 3, age = 1), + data.frame(key = c(10, 20), + node = c(1L, 2L), + S_1 = c(0L, 0L), + S_2 = c(0L, 2L)))) > > res <- assertError(u0(individual_events(events), + time = 3, + age = 1, + target = "SIR")) > check_error( + res, + "Invalid 'age' for 'target' model.") > > res <- assertError(u0(individual_events(events), time = 4.3)) > check_error( + res, + "'time' must be an integer or date.") > > res <- assertError(u0(individual_events(events), + time = c("2021-01-01", "2022-01-01"))) > check_error( + res, + "'time' must be an integer or date.") > > res <- assertError(u0(individual_events(events), time = "2021-01-01")) > check_error( + res, + "'time' must be an integer.") > > res <- assertError(u0(individual_events(events), time = list())) > check_error( + res, + "'time' must be an integer or date.") > > res <- assertError(u0(individual_events(events), time = 3, age = -1)) > check_error( + res, + "'age' must be an integer vector with values > 0.") > > res <- assertError(SimInf:::u0_target(u0(individual_events(events), + time = 2), + target = "Unknown")) > check_error( + res, + "Invalid 'target' for 'u0'.") > > events <- data.frame( + id = c("individual-1", "individual-1", "individual-1", "individual-1", + "individual-2", "individual-2", "individual-2", "individual-2"), + event = c("enter", "extTrans", "extTrans", "exit", + "enter", "extTrans", "extTrans", "exit"), + time = c("2019-02-02", "2020-03-07", "2021-04-14", "2022-05-11", + "2019-02-02", "2020-03-07", "2021-04-14", "2022-05-11"), + node = c("node-1", "node-1", "node-2", "node-2", + "node-1", "node-1", "node-2", "node-2"), + dest = c(NA, "node-2", "node-2", NA, + NA, "node-2", "node-2", NA)) > > u0_obs <- u0(individual_events(events)) > > u0_exp <- data.frame( + key = c("node-1", "node-2"), + node = c(1L, 2L), + S_1 = c(2L, 0L)) > > stopifnot(identical(u0_obs, u0_exp)) > > u0_obs <- u0(individual_events(events[rev(seq_len(nrow(events))), ])) > > stopifnot(identical(u0_obs, u0_exp)) > > stopifnot(identical( + get_individuals(individual_events(events), "2019-02-02"), + data.frame( + id = c("individual-1", "individual-2"), + node = c("node-1", "node-1"), + age = c(0L, 0L)))) > > stopifnot(identical( + get_individuals(individual_events(events), "2019-02-04"), + data.frame( + id = c("individual-1", "individual-2"), + node = c("node-1", "node-1"), + age = c(2L, 2L)))) > > stopifnot(identical( + get_individuals(individual_events(events), "2019-02-01"), + data.frame( + id = character(0), + node = logical(0), + age = integer(0)))) > > show_expected <- c( + "Number of individuals: 2", + "Number of events: 6") > show_observed <- capture.output(show(individual_events(events))) > stopifnot(identical(show_observed, show_expected)) > > summary_expected <- c( + "Number of individuals: 2", + "Number of events: 6", + " - Exit: 2", + " - Enter: 2", + " - Internal transfer: 0", + " - External transfer: 2") > summary_observed <- capture.output(summary(individual_events(events))) > stopifnot(identical(summary_observed, summary_expected)) > > events <- data.frame( + id = c(1, 1), + event = c("extTrans", "exit"), + time = c(2, 3), + node = c(1, 2), + dest = c(2, 0)) > res <- assertError(get_individuals(individual_events(events))) > check_error( + res, + "All individuals must have an 'enter' event.") > > res <- assertError(node_events(individual_events(events))) > check_error( + res, + "All individuals must have an 'enter' event.") > > res <- assertError(SimInf:::check_indiv_events_id(3.2)) > check_error( + res, + "'id' must be an integer or character vector with non-NA values.") > > res <- assertError(SimInf:::check_indiv_events_id(NULL)) > check_error( + res, + "'id' must be an integer or character vector with non-NA values.") > > ## Test to generate events and u0 > events <- data.frame( + id = c("animal-06", "animal-03", "animal-03", "animal-03", + "animal-08", "animal-03", "animal-03", "animal-06", + "animal-08", "animal-08", "animal-06", "animal-08", + "animal-08", "animal-06", "animal-06", "animal-05", + "animal-07", "animal-05", "animal-05", "animal-05", + "animal-05", "animal-10", "animal-01", "animal-04", + "animal-04", "animal-04", "animal-01", "animal-01", + "animal-05", "animal-05", "animal-08", "animal-08", + "animal-01", "animal-01", "animal-09", "animal-10", + "animal-09", "animal-09", "animal-02", "animal-11", + "animal-11", "animal-11", "animal-11", "animal-11", + "animal-11", "animal-11"), + event = c("enter", "enter", "extTrans", "extTrans", "enter", + "exit", "exit", "extTrans", "extTrans", "extTrans", + "extTrans", "extTrans", "extTrans", "exit", "exit", + "enter", "enter", "extTrans", "extTrans", "extTrans", + "extTrans", "enter", "enter", "enter", "exit", "exit", + "extTrans", "extTrans", "exit", "exit", "exit", "exit", + "exit", "exit", "enter", "exit", "extTrans", "extTrans", + "enter", "enter", "extTrans", "extTrans", "extTrans", + "extTrans", "exit", "exit"), + time = c("2015-01-31", "2015-04-01", "2015-05-27", "2015-05-27", + "2015-10-14", "2015-12-25", "2015-12-26", "2016-05-23", + "2016-06-01", "2016-10-12", "2016-10-28", "2017-03-01", + "2017-03-01", "2017-03-09", "2017-03-09", "2017-04-25", + "2017-08-30", "2017-12-21", "2017-12-21", "2017-12-22", + "2017-12-22", "2018-03-30", "2019-05-30", "2019-07-06", + "2019-07-16", "2019-07-17", "2019-08-14", "2019-08-14", + "2020-03-31", "2020-04-01", "2020-07-13", "2020-07-14", + "2021-02-09", "2021-02-09", "2022-02-01", "2022-04-10", + "2022-07-25", "2022-07-25", "2022-12-09", "2017-04-25", + "2017-12-21", "2017-12-21", "2017-12-22", "2017-12-22", + "2020-03-31", "2020-04-01"), + node = c("node-08", "node-03", "node-03", "node-03", "node-12", + "node-05", "node-05", "node-08", "node-12", "node-13", + "node-07", "node-12", "node-12", "node-08", "node-08", + "node-06", "node-11", "node-06", "node-06", "node-09", + "node-09", "node-17", "node-01", "node-04", "node-04", + "node-04", "node-01", "node-01", "node-16", "node-16", + "node-18", "node-18", "node-10", "node-10", "node-14", + "node-17", "node-14", "node-14", "node-02", "node-06", + "node-06", "node-06", "node-09", "node-09", "node-16", + "node-16"), + dest = c(NA, NA, "node-05", "node-05", NA, NA, NA, "node-07", + "node-13", "node-12", "node-08", "node-18", "node-18", + NA, NA, NA, NA, "node-09", "node-09", "node-16", + "node-16", NA, NA, NA, NA, NA, "node-10", "node-10", NA, + NA, NA, NA, NA, NA, NA, NA, "node-15", "node-15", NA, + NA, "node-09", "node-09", "node-16", "node-16", NA, NA)) > > events_expected <- data.frame( + event = c("enter", "extTrans", "enter", "exit", "extTrans", + "extTrans", "extTrans", "extTrans", "extTrans", "exit", + "enter", "enter", "extTrans", "extTrans", "enter", + "enter", "enter", "exit", "extTrans", "exit", "exit", + "exit", "enter", "exit", "extTrans", "enter"), + time = c("2015-04-01", "2015-05-27", "2015-10-14", "2015-12-25", + "2016-05-23", "2016-06-01", "2016-10-12", "2016-10-28", + "2017-03-01", "2017-03-09", "2017-04-25", "2017-08-30", + "2017-12-21", "2017-12-22", "2018-03-30", "2019-05-30", + "2019-07-06", "2019-07-16", "2019-08-14", "2020-03-31", + "2020-07-13", "2021-02-09", "2022-02-01", "2022-04-10", + "2022-07-25", "2022-12-09"), + node = c(3L, 3L, 12L, 5L, 8L, 12L, 13L, 7L, 12L, 8L, 6L, 11L, 6L, + 9L, 17L, 1L, 4L, 4L, 1L, 16L, 18L, 10L, 14L, 17L, 14L, + 2L), + dest = c(0L, 5L, 0L, 0L, 7L, 13L, 12L, 8L, 18L, 0L, 0L, 0L, 9L, + 16L, 0L, 0L, 0L, 0L, 10L, 0L, 0L, 0L, 0L, 0L, 15L, 0L), + n = c(1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 1L, 2L, 2L, 1L, + 1L, 1L, 1L, 1L, 2L, 1L, 1L, 1L, 1L, 1L, 1L), + proportion = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0), + select = c(1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L), + shift = c(0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, + 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L)) > > events_observed <- node_events(individual_events(events)) > > stopifnot(identical(events_observed, events_expected)) > > ## Check that an intTrans event is added. > events <- data.frame( + id = c(1, 1, 1, 1, 2, 2), + event = c("enter", "extTrans", "extTrans", "exit", "enter", "exit"), + time = c(1, 3, 5, 7, 1, 3), + node = c(1, 1, 2, 3, 1, 1), + dest = c(NA, 2, 3, NA, NA, NA)) > > events_expected <- data.frame( + event = c("enter", "exit", "extTrans", "extTrans", "intTrans", "exit"), + time = c(1, 3, 3, 5, 6, 7), + node = c(1L, 1L, 1L, 2L, 3L, 3L), + dest = c(0L, 0L, 2L, 3L, 0L, 0L), + n = c(2L, 1L, 1L, 1L, 1L, 1L), + proportion = c(0, 0, 0, 0, 0, 0), + select = c(1L, 3L, 3L, 3L, 3L, 4L), + shift = c(0L, 0L, 0L, 0L, 1L, 0L)) > > events_observed <- node_events(individual_events(events), time = 0, age = 5) > > stopifnot(identical(events_observed, events_expected)) > > ## Check that target works for 'SEIR', 'SIS', 'SISe', and > ## 'SISe_sp'. > events <- data.frame( + id = c(1, 1, 1, 1, 2, 2), + event = c("enter", "extTrans", "extTrans", "exit", "enter", "exit"), + time = c(1, 3, 5, 7, 1, 3), + node = c(1, 1, 2, 3, 1, 1), + dest = c(NA, 2, 3, NA, NA, NA)) > > events_expected <- data.frame( + event = c("enter", "exit", "extTrans", "extTrans", "exit"), + time = c(1, 3, 3, 5, 7), + node = c(1L, 1L, 1L, 2L, 3L), + dest = c(0L, 0L, 2L, 3L, 0L), + n = c(2L, 1L, 1L, 1L, 1L), + proportion = c(0, 0, 0, 0, 0), + select = c(1L, 2L, 2L, 2L, 2L), + shift = c(0L, 0L, 0L, 0L, 0L)) > > events_observed <- node_events(individual_events(events), + time = 0, target = "SEIR") > stopifnot(identical(events_observed, events_expected)) > > events_observed <- node_events(individual_events(events), + time = 0, target = "SIS") > stopifnot(identical(events_observed, events_expected)) > > events_observed <- node_events(individual_events(events), + time = 0, target = "SISe") > stopifnot(identical(events_observed, events_expected)) > > events_observed <- node_events(individual_events(events), + time = 0, target = "SISe_sp") > stopifnot(identical(events_observed, events_expected)) > > ## Check that target works for 'SIR'. > events <- data.frame( + id = c(1, 1, 1, 1, 2, 2), + event = c("enter", "extTrans", "extTrans", "exit", "enter", "exit"), + time = c(1, 3, 5, 7, 1, 3), + node = c(1, 1, 2, 3, 1, 1), + dest = c(NA, 2, 3, NA, NA, NA)) > > events_expected <- data.frame( + event = c("enter", "exit", "extTrans", "extTrans", "exit"), + time = c(1, 3, 3, 5, 7), + node = c(1L, 1L, 1L, 2L, 3L), + dest = c(0L, 0L, 2L, 3L, 0L), + n = c(2L, 1L, 1L, 1L, 1L), + proportion = c(0, 0, 0, 0, 0), + select = c(1L, 4L, 4L, 4L, 4L), + shift = c(0L, 0L, 0L, 0L, 0L)) > > events_observed <- node_events(individual_events(events), + time = 0, target = "SIR") > stopifnot(identical(events_observed, events_expected)) > > ## Check that target works for 'NULL', 'SISe3', and 'SISe3_sp'. > events <- data.frame( + id = c(1, 1, 1, 1, 2, 2), + event = c("enter", "extTrans", "extTrans", "exit", "enter", "exit"), + time = c(1, 3, 5, 7, 1, 3), + node = c(1, 1, 2, 3, 1, 1), + dest = c(NA, 2, 3, NA, NA, NA)) > > events_expected <- data.frame( + event = c("enter", "exit", "extTrans", "intTrans", "extTrans", + "intTrans", "exit"), + time = c(1, 3, 3, 4, 5, 6, 7), + node = c(1L, 1L, 1L, 2L, 2L, 3L, 3L), + dest = c(0L, 0L, 2L, 0L, 3L, 0L, 0L), + n = c(2L, 1L, 1L, 1L, 1L, 1L, 1L), + proportion = c(0, 0, 0, 0, 0, 0, 0), + select = c(1L, 4L, 4L, 4L, 5L, 5L, 6L), + shift = c(0L, 0L, 0L, 1L, 0L, 2L, 0L)) > > events_observed <- node_events(individual_events(events), + time = 0, age = c(3, 5), target = NULL) > > stopifnot(identical(events_observed, events_expected)) > events_observed <- node_events(individual_events(events), + time = 0, age = c(3L, 5L), target = "SISe3") > > stopifnot(identical(events_observed, events_expected)) > > events_observed <- node_events(individual_events(events), + time = 0, age = c(3, 5), target = "SISe3_sp") > stopifnot(identical(events_observed, events_expected)) > > ## Check generating tex-code from events > events <- data.frame( + id = c(1, 1, 1, 1, 1, 1, 1, 1), + event = c(1, 1, 3, 3, 3, 0, 0, 3), + time = c(1, 1, 2, 2, 3, 4, 4, 5), + node = c(1, 2, 1, 1, 2, 2, 1, 3), + dest = c(0, 0, 2, 3, 2, 0, 0, 2)) > > tex_expected <- c( + "\\documentclass[tikz]{standalone}", + "\\usepackage{tikz}", + "\\begin{document}", + "\\begin{tikzpicture}", + " \\sffamily", + "", + " \\draw[>=stealth,->] (0,0.5) -- (6,0.5);", + " \\node at (3,0) {\\tiny Time};", + "", + " \\draw[>=stealth, gray!40] (0.5,1) -- (5.5,1);", + " \\node at (0,1) {\\tiny Node 1};", + "", + " \\draw[>=stealth, gray!40] (0.5,2) -- (5.5,2);", + " \\node at (0,2) {\\tiny Node 2};", + "", + " \\draw[>=stealth, gray!40] (0.5,3) -- (5.5,3);", + " \\node at (0,3) {\\tiny Node 3};", + "", + " \\node at (1,0.3) {\\tiny $t_{1}$};", + " \\draw (1,0.55) -- (1,0.45);", + " \\node at (2,0.3) {\\tiny $t_{2}$};", + " \\draw (2,0.55) -- (2,0.45);", + " \\node at (3,0.3) {\\tiny $t_{3}$};", + " \\draw (3,0.55) -- (3,0.45);", + " \\node at (4,0.3) {\\tiny $t_{4}$};", + " \\draw (4,0.55) -- (4,0.45);", + " \\node at (5,0.3) {\\tiny $t_{5}$};", + " \\draw (5,0.55) -- (5,0.45);", + "", + " \\node at (1,1.1) {\\textborn};", + " \\node at (1,2.1) {\\textcolor{gray!60}\\textborn};", + " \\path[>=stealth,->] (2,1) edge [out=135, in=225] (2,2);", + " \\path[>=stealth,gray!60,->] (2,1) edge [out=135, in=225] (2,3);", + " \\path[>=stealth,gray!60,->] (3,2) edge [out=135, in=45, loop] (3,2);", + " \\node at (4,2.2) {\\textdagger};", + " \\node at (4,1.2) {\\textcolor{gray!60}\\textdagger};", + " \\path[>=stealth,gray!60,->] (5,3) edge [out=315, in=45] (5,2);", + "", + "\\end{tikzpicture}", + "\\end{document}") > > tex_observed <- SimInf:::events_to_tex(events) > stopifnot(identical(tex_observed, tex_expected)) > > events <- data.frame( + id = c(1, 1, 1, 1, 1, 1, 1, 1), + event = c(1, 1, 3, 3, 3, 0, 0, 3), + time = c(1, 1, 2, 2, 3, 4, 4, 5), + node = c(1, 2, 1, 1, 3, 2, 1, 2), + dest = c(0, 0, 2, 3, 2, 0, 0, 2)) > > events_expected <- data.frame( + id = c(1, 1, 1, 1), + event = c(1L, 3L, 3L, 0L), + time = c(1L, 2L, 3L, 4L), + node = c(1, 1, 3, 2), + dest = c(NA, 3, 2, NA)) > > events_observed <- as.data.frame(individual_events(events)) > > stopifnot(identical(events_observed, events_expected)) > > events <- data.frame( + id = c(1, 1, 1, 1, 1, 1), + event = c(1, 3, 3, 3, 3, 0), + time = c(1, 2, 2, 3, 3, 4), + node = c(1, 1, 1, 3, 3, 2), + dest = c(0, 2, 3, 1, 2, 0)) > > events_expected <- data.frame( + id = c(1, 1, 1, 1), + event = c(1L, 3L, 3L, 0L), + time = c(1L, 2L, 3L, 4L), + node = c(1, 1, 3, 2), + dest = c(NA, 3, 2, NA)) > > events_observed <- as.data.frame(individual_events(events)) > > stopifnot(identical(events_observed, events_expected)) > > proc.time() user system elapsed 1.09 0.07 1.15