├── .Rbuildignore ├── .gitignore ├── .travis.yml ├── DESCRIPTION ├── LICENSE ├── NAMESPACE ├── R ├── core_internal.R ├── dynamic-class.R ├── landscape-class.R ├── parameters-method.R ├── pop.R ├── projection-class.R ├── simulation-class.R ├── transfun-class.R ├── transfun_dispersal.R ├── transfun_probability.R ├── transfun_rate.R └── transition-class.R ├── man ├── as.transfun.Rd ├── dispersal.Rd ├── dynamic.Rd ├── landscape.Rd ├── parameters.Rd ├── pop.Rd ├── probability.Rd ├── projection.Rd ├── rate.Rd ├── simulation.Rd ├── transfun.Rd └── transition.Rd ├── readme.Rmd ├── readme.md ├── readme_files └── figure-markdown_github │ ├── all_dynamics-1.png │ ├── dd_function-1.png │ ├── define_metapop-1.png │ ├── deterministic_dd-1.png │ ├── plot_dynamics-1.png │ ├── popdemo-1.png │ ├── simulate_metapop-1.png │ ├── simulate_metapop2-1.png │ └── simulation-1.png └── tests ├── test-all.R └── testthat ├── test_deterministic_analyses.R ├── test_dynamic_class.R ├── test_landscape_class.R ├── test_stochastic_analyses.R ├── test_transfun_class.R ├── test_transfun_constructors.R └── test_transition_class.R /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | pop.Rproj 4 | readme.Rmd 5 | readme.md 6 | readme_files 7 | .travis.yml 8 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # RStudio stuff 2 | .Rproj.user 3 | .Rhistory 4 | .RData 5 | pop.RProj 6 | 7 | # plots from tests 8 | tests/testthat/Rplots.pdf 9 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: r 2 | cache: packages 3 | sudo: required 4 | 5 | # Install the suggested packages 6 | r_packages: 7 | - testthat 8 | - covr 9 | 10 | ## After success update the code coverage 11 | after_success: 12 | - Rscript -e 'library(covr);codecov()' 13 | 14 | # Warnings don't fail build 15 | warnings_are_errors: false 16 | 17 | ## Email notification if the package pass status changes 18 | notifications: 19 | email: 20 | on_success: change 21 | on_failure: change 22 | 23 | ## Set up the matrix of different runs 24 | env: 25 | matrix: 26 | - r: release 27 | not_cran: false 28 | r_check_args: "--no-manual --as--cran" 29 | - r: devel 30 | not_cran: false 31 | r_check_args: "--no-manual --as--cran" 32 | 33 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: pop 2 | Type: Package 3 | Title: A Flexible Syntax for Population Dynamic Modelling 4 | Version: 0.2 5 | Date: 2016-06-07 6 | Author: Nick Golding 7 | Maintainer: Nick Golding 8 | Description: Population dynamic models underpin a range of analyses and applications in ecology and epidemiology. The various approaches for analysing population dynamics models (MPMs, IPMs, ODEs, POMPs, PVA) each require the model to be defined in a different way. This makes it difficult to combine different modelling approaches and data types to solve a given problem. 'pop' aims to provide a flexible and easy to use common interface for constructing population dynamic models and enabling to them to be fitted and analysed in lots of different ways. 9 | License: MIT + file LICENSE 10 | Imports: 11 | igraph, 12 | MASS 13 | Suggests: 14 | knitr, 15 | testthat 16 | LazyData: TRUE 17 | RoxygenNote: 5.0.1 18 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | YEAR: 2016 2 | COPYRIGHT HOLDER: Nick Golding 3 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method("*",transfun) 4 | S3method("*",transition) 5 | S3method("[[",landscape) 6 | S3method("parameters<-",dynamic) 7 | S3method("parameters<-",transfun) 8 | S3method("parameters<-",transition) 9 | S3method(as.matrix,dynamic) 10 | S3method(parameters,dynamic) 11 | S3method(parameters,transfun) 12 | S3method(parameters,transition) 13 | S3method(plot,dynamic) 14 | S3method(plot,pop_projection) 15 | S3method(plot,simulation) 16 | S3method(print,dynamic) 17 | S3method(print,landscape) 18 | S3method(print,transfun) 19 | S3method(print,transition) 20 | export("area<-") 21 | export("distance<-") 22 | export("features<-") 23 | export("landscape<-") 24 | export("parameters<-") 25 | export("population<-") 26 | export(area) 27 | export(as.landscape) 28 | export(as.transfun) 29 | export(d) 30 | export(dispersal) 31 | export(distance) 32 | export(dynamic) 33 | export(features) 34 | export(is.dispersal) 35 | export(is.dynamic) 36 | export(is.landscape) 37 | export(is.pop_projection) 38 | export(is.probability) 39 | export(is.rate) 40 | export(is.simulation) 41 | export(is.transfun) 42 | export(is.transition) 43 | export(landscape) 44 | export(p) 45 | export(parameters) 46 | export(population) 47 | export(probability) 48 | export(projection) 49 | export(r) 50 | export(rate) 51 | export(simulation) 52 | export(states) 53 | export(tr) 54 | export(transition) 55 | import(igraph) 56 | import(parallel) 57 | importFrom(MASS,ginv) 58 | importFrom(grDevices,grey) 59 | importFrom(graphics,lines) 60 | importFrom(graphics,plot) 61 | importFrom(graphics,polygon) 62 | importFrom(stats,dist) 63 | importFrom(stats,na.omit) 64 | importFrom(stats,quantile) 65 | importFrom(stats,rbinom) 66 | importFrom(stats,rmultinom) 67 | importFrom(stats,rpois) 68 | -------------------------------------------------------------------------------- /R/core_internal.R: -------------------------------------------------------------------------------- 1 | # core internal functions 2 | 3 | getStates <- function (transitions) { 4 | # given a list of transitions, extract all of the mentioned states 5 | all_states <- lapply(transitions, 6 | function (x) c(x$to, x$from)) 7 | states <- unique(unlist(all_states)) 8 | return (states) 9 | } 10 | 11 | expandPopulation <- function (population, dynamic) { 12 | 13 | # convert the population to a dataframe if required 14 | if (!is.data.frame(population)) { 15 | 16 | # check the population vector makes sense 17 | stopifnot(is.numeric(population)) 18 | stopifnot(length(population) == length(states(dynamic))) 19 | stopifnot(all(sort(names(population)) == sort(states(dynamic)))) 20 | 21 | # make it into a dataframe 22 | names <- names(population) 23 | population <- as.data.frame(as.list(population)) 24 | names(population) <- names 25 | 26 | } 27 | 28 | # if it's a one-row dataframe, replicate for the number of habitat patches 29 | if (nrow(population) == 1) { 30 | stopifnot(ncol(population) == length(states(dynamic))) 31 | stopifnot(all(sort(names(population)) == sort(states(dynamic)))) 32 | n_patches <- nrow(population(landscape(dynamic))) 33 | population <- population[rep(1, n_patches), ] 34 | } 35 | 36 | return (population) 37 | 38 | } 39 | 40 | 41 | captureDots <- function (...) { 42 | # capture arguments passed as dots, and grab their names even if not directly 43 | # named 44 | ans <- list(...) 45 | dots <- substitute(list(...))[-1] 46 | names(ans) <- sapply(dots, deparse) 47 | ans 48 | } 49 | -------------------------------------------------------------------------------- /R/dynamic-class.R: -------------------------------------------------------------------------------- 1 | # dynamic class functions 2 | 3 | #' @title dynamic objects 4 | #' @name dynamic 5 | #' @rdname dynamic 6 | #' @param \dots for \code{dynamic()}: one or more \code{transition} (or other 7 | #' \code{dynamic}) objects making up the dynamic. For \code{plot()} and 8 | #' \code{print()}: further arguments passed to or from other methods 9 | #' @description creates a \code{dynamic} object, comprising multiple 10 | #' \code{transition} objects to define a dynamical system. \code{dynamic} 11 | #' objects are the core of \code{pop}, since they can be created and updated 12 | #' using various methods (MPMs, IPMs etc.), combined (by addition of two 13 | #' \code{dynamic} objects to make another) and and analysed in various ways 14 | #' (deterministically to obtain demographic parameters, simulated to evaluate 15 | #' population viability etc.) 16 | #' @export 17 | #' @examples 18 | #' # define transitions for a simple three-stage system (with implicit 19 | #' # mortality): 20 | #' stasis_egg <- tr(egg ~ egg, p(0.4)) 21 | #' stasis_larva <- tr(larva ~ larva, p(0.3)) 22 | #' stasis_adult <- tr(adult ~ adult, p(0.8)) 23 | #' hatching <- tr(larva ~ egg, p(0.5)) 24 | #' fecundity <- tr(egg ~ adult, r(3)) 25 | #' pupation <- tr(adult ~ larva, p(0.2)) 26 | #' 27 | #' # combine these into separate dynamics 28 | #' stasis <- dynamic(stasis_egg, 29 | #' stasis_larva, 30 | #' stasis_adult) 31 | #' growth <- dynamic(hatching, 32 | #' pupation) 33 | #' reproduction <- dynamic(fecundity) 34 | #' 35 | #' # combine these into one dynamic (the same as listing all the transitions 36 | #' # separately) 37 | #' all <- dynamic(stasis, growth, reproduction) 38 | #' 39 | dynamic <- function (...) { 40 | # given a bunch of transition functions, build an object representing a 41 | # dynamical system 42 | 43 | # capture objects 44 | object <- captureDots(...) 45 | 46 | # unpack any dynamics into their component transitions, keeping names etc 47 | object <- unpackDynamics(object) 48 | 49 | # check they're transitions 50 | stopifnot(all(sapply(object, is.transition))) 51 | 52 | # set class, add default landscape and return 53 | object <- as.dynamic(object) 54 | landscape(object) <- as.landscape(object) 55 | return (object) 56 | } 57 | 58 | #' @rdname dynamic 59 | #' @export 60 | is.dynamic <- function (x) inherits(x, 'dynamic') 61 | 62 | as.dynamic <- function (x) { 63 | if (!is.dynamic(x)) { 64 | class(x) <- c('dynamic', class(x)) 65 | } 66 | return (x) 67 | } 68 | 69 | #' @rdname dynamic 70 | #' @param x a dynamic object to print, plot, convert to a transition matrix, or 71 | #' an object to test as a dynamic object (for \code{is.dynamic}), 72 | #' @export 73 | #' @examples 74 | #' # plot these 75 | #' plot(stasis) 76 | #' plot(growth) 77 | #' plot(all) 78 | #' 79 | plot.dynamic <- function (x, ...) { 80 | # plot a dynamic using igraph 81 | 82 | # extract the transition matrix & create an igraph graph object 83 | textmat <- t(textMatrix(x)) 84 | linkmat <- textmat != '' 85 | g <- graph.adjacency(linkmat, weighted = TRUE) 86 | 87 | # extract edge labels 88 | labels <- textmat[get.edges(g, seq_len(sum(linkmat)))] 89 | 90 | # vertex plotting details 91 | V(g)$color <- grey(0.9) 92 | V(g)$label.color <- grey(0.4) 93 | V(g)$label.family <- 'sans' 94 | V(g)$size <- 50 95 | V(g)$frame.color <- NA 96 | 97 | # edge plotting details 98 | E(g)$color <- grey(0.5) 99 | E(g)$curved <- curve_multiple(g, 0.1) 100 | E(g)$arrow.size <- 0.5 101 | E(g)$label <- labels 102 | E(g)$loop.angle <- 4 103 | E(g)$label.color <- grey(0.4) 104 | 105 | plot(g) 106 | 107 | # return the igraph object 108 | return (invisible(g)) 109 | 110 | } 111 | 112 | #' @rdname dynamic 113 | #' @name states 114 | #' @export 115 | #' @examples 116 | #' # get component states 117 | #' states(all) 118 | #' 119 | states <- function (x) { 120 | getStates(x) 121 | } 122 | 123 | #' @rdname dynamic 124 | #' @export 125 | #' @examples 126 | #' # print method 127 | #' print(all) 128 | #' 129 | print.dynamic <- function (x, ...) { 130 | text <- sprintf('dynamic:\ttransitions between: %s\n', 131 | paste(states(x), collapse = ', ')) 132 | cat(text) 133 | } 134 | 135 | #' @rdname dynamic 136 | #' @param which which type of matrix to build: the overall population growth 137 | #' matrix (\code{'A'}), the probabilistic progression matrix (\code{'P'}), the 138 | #' fecundity matrix (\code{'F'}) or the intrinsic reproduction matrix 139 | #' (\code{'R'}) 140 | #' @export 141 | #' @importFrom MASS ginv 142 | #' @examples 143 | #' # convert to a transition matrix 144 | #' as.matrix(all) 145 | as.matrix.dynamic <- function (x, which = c('A', 'P', 'F', 'R'), ...) { 146 | 147 | # build the overall, reproduction (R), progression (P) of fecundity (F) matrix 148 | which <- match.arg(which) 149 | 150 | # find the numbers of patches and states 151 | n_patches <- nrow(landscape(x)) 152 | n_states <- length(states(x)) 153 | n_cells <- n_patches * n_states 154 | 155 | # split the dynamic into demographic and dispersal components 156 | is_disp <- sapply(x, function (x) contains(x$transfun, 'dispersal')) 157 | x_disp <- subDynamic(x, which(is_disp)) 158 | x_demog <- subDynamic(x, which(!is_disp)) 159 | 160 | if (n_patches > 1) { 161 | 162 | # if there are multiple patches, set up metamatrix 163 | mat <- matrix(0, n_cells, n_cells) 164 | 165 | # loop through them patches getting the demographic components 166 | for (patch in seq_len(n_patches)) { 167 | # remove dispersals 168 | sub_dynamic <- x_demog 169 | landscape(sub_dynamic) <- landscape(x_disp)[[patch]] 170 | sub_mat <- as.matrix(sub_dynamic, which = which, ...) 171 | idx <- (patch - 1) * n_states + seq_len(n_states) 172 | mat[idx, idx] <- sub_mat 173 | } 174 | 175 | # for all except fecundity 176 | if (which != 'F') { 177 | 178 | # get the dispersal probabilities and add to matrix in correct places 179 | for (trans in x_disp) { 180 | 181 | # find indices in meta matrix 182 | from_state <- match(trans$from, states(x)) 183 | to_state <- match(trans$to, states(x)) 184 | from_idx <- from_state + (seq_len(n_patches) - 1) * n_states 185 | to_idx <- to_state + (seq_len(n_patches) - 1) * n_states 186 | cells <- as.matrix(expand.grid(to_idx, from_idx)) 187 | 188 | # get expectation of dispersal 189 | disp <- trans$transfun(landscape(x)) 190 | 191 | # make it sum to 1, row-wise 192 | disp <- sweep(disp, 1, rowSums(disp), '/') 193 | 194 | # apply diagonal transitions (some fraction staying in state) 195 | disp <- sweep(disp, 1, diag(mat)[from_idx], '*') 196 | 197 | # insert into meta matrix 198 | mat[cells] <- as.numeric(disp) 199 | 200 | } 201 | 202 | } 203 | 204 | } else { 205 | 206 | # if only one patch, just get the demographic component 207 | mat <- switch(which, 208 | `A` = getA(x_demog), 209 | `P` = getP(x_demog), 210 | `F` = getF(x_demog), 211 | `R` = getR(x_demog)) 212 | 213 | } 214 | 215 | # set class and return 216 | class(mat) <- c(class(mat), 'transition_matrix') 217 | return (mat) 218 | 219 | } 220 | 221 | getA <- function (x) { 222 | 223 | # get the full population projection matrix from a dynamic 224 | # set up empty matrix 225 | mat <- diag(length(states(x))) 226 | rownames(mat) <- colnames(mat) <- states(x) 227 | landscape <- landscape(x) 228 | 229 | # apply the transitions 230 | for (t in x) { 231 | 232 | # get the expectation 233 | expectation <- t$transfun(landscape) 234 | 235 | # if it's a rate (or compound containing a rate) 236 | if (contains(t$transfun, 'rate')) { 237 | 238 | if (t$to == t$from) { 239 | 240 | # if it's the diagonal (clonal reproduction), multiply by the expectation and add 241 | mat[t$to, t$from] <- mat[t$to, t$from] * (1 + expectation) 242 | 243 | } else { 244 | 245 | # if it's the off-diagonal, get the diagonal probability 246 | diag_prob <- mat[t$from, t$from] 247 | 248 | # multiply by probability (proportion surviving) 249 | mat[t$to, t$from] <- mat[t$to, t$from] + diag_prob * expectation 250 | 251 | } 252 | 253 | } else { 254 | # if it's not a rate (nor compound containing a rate) 255 | 256 | if (t$to == t$from) { 257 | # if it's the diagonal, multiply by the expectation 258 | mat[t$to, t$from] <- mat[t$to, t$from] * expectation 259 | } else { 260 | # if it's the off-diagonal, get the diagonal probability 261 | diag_prob <- mat[t$from, t$from] 262 | 263 | # multiply by probability and not probability 264 | mat[t$to, t$from] <- mat[t$to, t$from] + diag_prob * expectation 265 | 266 | # reduce the diagonal by the reciprocal 267 | mat[t$from, t$from] <- diag_prob * (1 - expectation) 268 | } 269 | 270 | } 271 | 272 | } 273 | 274 | return (mat) 275 | 276 | } 277 | 278 | getR <- function (x) { 279 | # get the reproduction matrix from a dynamic; 280 | # combine P & F accounting for clonal 281 | # reproduction (rates on diagonal) 282 | P <- getP(x) 283 | eye <- diag(nrow(P)) 284 | mat <- getF(x) %*% ginv(eye - P) 285 | return (mat) 286 | } 287 | 288 | getF <- function (x) { 289 | 290 | # set up empty matrix 291 | mat <- diag(length(states(x))) * 0 292 | rownames(mat) <- colnames(mat) <- states(x) 293 | landscape <- landscape(x) 294 | 295 | # apply the transitions 296 | for (t in x) { 297 | 298 | # if it's a rate (or compound containing a rate) 299 | if (contains(t$transfun, 'rate')) { 300 | 301 | # get the expectation and add it in 302 | expectation <- t$transfun(landscape) 303 | mat[t$to, t$from] <- expectation 304 | 305 | } 306 | 307 | } 308 | 309 | return (mat) 310 | 311 | } 312 | 313 | getP <- function (x) { 314 | 315 | # set up empty matrix 316 | mat <- diag(length(states(x))) 317 | rownames(mat) <- colnames(mat) <- states(x) 318 | landscape <- landscape(x) 319 | 320 | # apply the transitions 321 | for (t in x) { 322 | 323 | # if it's not a rate (nor compound containing a rate) 324 | if (!contains(t$transfun, 'rate')) { 325 | 326 | # get the expectation 327 | expectation <- t$transfun(landscape) 328 | 329 | if (t$to == t$from) { 330 | # if it's the diagonal, multiply by the expectation 331 | mat[t$to, t$from] <- mat[t$to, t$from] * expectation 332 | } else { 333 | # if it's the off-diagonal, get the diagonal probability 334 | diag_prob <- mat[t$from, t$from] 335 | 336 | # multiply by probability and not probability 337 | mat[t$to, t$from] <- mat[t$to, t$from] + diag_prob * expectation 338 | 339 | # reduce the diagonal by the reciprocal 340 | mat[t$from, t$from] <- diag_prob * (1 - expectation) 341 | } 342 | 343 | } 344 | 345 | } 346 | 347 | return (mat) 348 | 349 | } 350 | 351 | contains <- function (transfun, which = c('probability', 'rate', 'dispersal')) { 352 | # check whether a transition contains a rate transition (rather than pure 353 | # probability) 354 | which <- match.arg(which) 355 | type <- transfunType(transfun) 356 | if (type == 'compound') { 357 | # if it's a compound, call recursively to look for any 358 | tf_x <- environment(transfun)$x 359 | tf_y <- environment(transfun)$y 360 | ans <- contains(tf_x, which) | contains(tf_y, which) 361 | } else if (type == which) { 362 | ans <- TRUE 363 | } else { 364 | ans <- FALSE 365 | } 366 | return (ans) 367 | } 368 | 369 | # create a matrix contining text reporting the transition 370 | textMatrix <- function (x) { 371 | states <- states(x) 372 | mat <- matrix('', length(states), length(states)) 373 | rownames(mat) <- colnames(mat) <- states 374 | for (t in x) { 375 | mat[t$to, t$from] <- transfun2text(t$transfun) 376 | } 377 | return (mat) 378 | } 379 | 380 | transfun2text <- function (transfun) { 381 | # create a short text representation of a transfun, for use in plotting 382 | type <- transfunType(transfun) 383 | if (type == 'compound') { 384 | tf_x <- environment(transfun)$x 385 | tf_y <- environment(transfun)$y 386 | text <- paste0(transfun2text(tf_x), 387 | ' * ', 388 | transfun2text(tf_y)) 389 | } else { 390 | 391 | # make a nice simple text representation 392 | prefix <- switch(type, 393 | probability = 'p', 394 | rate = 'r', 395 | dispersal = 'd') 396 | 397 | # don't try to find the expectation if it's user-defined 398 | landscape <- as.landscape(NULL) 399 | expect <- ifelse(containsUserTransfun(transfun), 400 | '?', 401 | round(transfun(landscape), 2)) 402 | 403 | text <- sprintf('%s(%s)', 404 | prefix, 405 | expect) 406 | 407 | } 408 | return (text) 409 | } 410 | 411 | #' @rdname dynamic 412 | #' @export 413 | #' @examples 414 | #' # extract the parameters 415 | #' (param_stasis <- parameters(stasis)) 416 | #' (param_all <- parameters(all)) 417 | #' 418 | parameters.dynamic <- function (x) { 419 | lapply(x, parameters) 420 | } 421 | 422 | #' @rdname dynamic 423 | #' @export 424 | #' @param value a nested named list of parameters within each transition 425 | #' matching those currently defined for \code{x} 426 | #' @examples 427 | #' # update the parameters of these transfuns 428 | #' param_stasis$stasis_egg$p <- 0.6 429 | #' parameters(stasis) <- param_stasis 430 | #' parameters(stasis) 431 | #' 432 | #' param_all$fecundity$r <- 15 433 | #' parameters(all) <- param_all 434 | #' parameters(all) 435 | `parameters<-.dynamic` <- function (x, value) { 436 | for (i in 1:length(x)) { 437 | parameters(x[[i]]) <- value[[i]] 438 | } 439 | return (x) 440 | } 441 | 442 | unpackDynamics <- function (object) { 443 | # given a named list of (hopefully) transition and dynamic objects, expand out 444 | # all the component transitions of the dynamics, in order, into a named list 445 | # of dynamics. This is harder than it should be, but is the tidiest way I 446 | # found to keep the transition names without prepending the dynamic name to it 447 | 448 | # look for dynamics 449 | dynamics <- sapply(object, is.dynamic) 450 | 451 | # if it's just one dynamic, return it as is 452 | if (length(dynamics) == 1 && dynamics) { 453 | 454 | object <- object[[1]] 455 | 456 | } else if (any(dynamics)) { 457 | 458 | # grab the first one 459 | elem <- which(dynamics)[1] 460 | 461 | if (elem == 1) { 462 | # if it's the first element (can't be only element) 463 | object <- c(object[[elem]], object[-elem]) 464 | } else if (elem == length(object)) { 465 | # if it's the last element (can't be only element) 466 | object <- c(object[-elem], object[[elem]]) 467 | } else { 468 | # it must be in the middle 469 | object <- c(object[1:(elem - 1)], object[[elem]], object[(elem + 1):length(object)]) 470 | } 471 | 472 | # one down, now recursively look for more 473 | object <- unpackDynamics(object) 474 | 475 | } 476 | 477 | # return 478 | return (object) 479 | 480 | } 481 | 482 | 483 | subDynamic <- function (x, i) { 484 | attrib <- attributes(x) 485 | attrib$names <- attrib$names[i] 486 | x <- x[i] 487 | attributes(x) <- attrib 488 | return (x) 489 | } 490 | -------------------------------------------------------------------------------- /R/landscape-class.R: -------------------------------------------------------------------------------- 1 | #' @title landscape objects 2 | #' @rdname landscape 3 | #' @name landscape 4 | #' @description \code{landscape} objects represent sets of patches forming a 5 | #' metapopulation, storing information (such as area, population and 6 | #' environmental features) that may impact on the dynamic transitions 7 | #' occurring in each component patch. \code{dynamic} objects all have a 8 | #' \code{landscape} object (by default a single-patch landscape) as a an 9 | #' attribute which can be accessed and set via the function \code{landscape}. 10 | #' \code{as.landscape} is used to create landscape objects, and the functions 11 | #' \code{population}, \code{area}, \code{distance} and \code{features} 12 | #' access and set each of the elements of a landscape. 13 | #' @param dynamic an object of class \code{dynamic} 14 | #' @param value an object of class \code{landscape} (for 15 | #' \code{landscape(dynamic) <- value}) or the value to assign to the 16 | #' \code{distance}, \code{area}, \code{population}, or \code{features} 17 | #' elements of a \code{landscape} object 18 | 19 | #' @export 20 | #' @details The accessor function \code{landscape} either returns or sets the 21 | #' landscape structure of the dynamic, encoded as a \code{\link{landscape}} 22 | #' object 23 | landscape <- function (dynamic) { 24 | stopifnot(is.dynamic(dynamic)) 25 | value <- attr(dynamic, 'landscape') 26 | return (value) 27 | } 28 | 29 | #' @rdname landscape 30 | #' @export 31 | `landscape<-` <- function (dynamic, value) { 32 | stopifnot(is.dynamic(dynamic)) 33 | stopifnot(is.landscape(value)) 34 | attr(dynamic, 'landscape') <- value 35 | return (dynamic) 36 | } 37 | 38 | #' @rdname landscape 39 | #' @name as.landscape 40 | #' @param patches an object to turn into a \code{landscape} object. Currently 41 | #' this can either be a dynamic, a list or \code{NULL} (see \code{details}), 42 | #' though more approaches will be added in the future 43 | #' @return an object of class \code{landscape}, essentially a dataframe 44 | #' containing the coordinates, area, population and features (as columns) for 45 | #' each patch (rows) 46 | #' @export 47 | #' @details \code{patches} can be a list containing the following elements: 48 | #' \code{population}, a dataframe giving the number of individuals of each 49 | #' stage (columns) within each patch (rows); \code{area}, a one-column 50 | #' dataframe giving the areas of the patches in square kilometres; 51 | #' \code{coordinates}, a dataframe giving the coordinates of the habitat 52 | #' patches; and \code{features}, a dataframe containing miscellaneous features 53 | #' (columns) of the patches (rows), such as measures of patch quality or 54 | #' environmental variables. Alternatively, \code{patches = NULL}, will set up 55 | #' a 'default' one-patch landscape with \code{area = data.frame(area =1)}, 56 | #' \code{coordinates = data.frame(x = 0, y = 0)} and blank \code{population} 57 | #' and \code{features} elements. The other option is to pass a \code{dynamic} 58 | #' object as \code{patches}, in which case the set up will be the same as for 59 | #' \code{patches = NULL} except that \code{population} will be a one-row 60 | #' dataframe of 0s, with columns corresponding to the states in the dynamic. 61 | #' This is what's used when analysing a \code{dynamic} object without 62 | #' user-specified metapopulation structure. 63 | #' @examples 64 | #' # create a default landscape 65 | #' landscape <- as.landscape(NULL) 66 | #' 67 | #' # create a marginally more interesting one-patch landscape 68 | #' landscape <- as.landscape(list(coordinates = data.frame(x = c(10, 11), 69 | #' y = c(11, 12)), 70 | #' area = data.frame(area = 10), 71 | #' population = data.frame(adult = 10, 72 | #' larva = 3, 73 | #' egg = 20), 74 | #' features = data.frame(temperature = 10))) 75 | as.landscape <- function (patches) { 76 | switch(class(patches)[1], 77 | NULL = landscapeDefault(), 78 | dynamic = dynamicLandscapeDefault(patches), 79 | list = list2landscape(patches)) 80 | } 81 | 82 | #' @rdname landscape 83 | #' @export 84 | is.landscape <- function (x) inherits(x, 'landscape') 85 | 86 | #' @rdname landscape 87 | #' @param x an object to print or test as a landscape object 88 | #' @param \dots further arguments passed to or from other methods. 89 | #' @export 90 | #' @examples 91 | #' # print method 92 | #' print(landscape) 93 | #' 94 | print.landscape <- function(x, ...) { 95 | text <- sprintf('landscape with %s patches\n', 96 | nrow(x)) 97 | cat(text) 98 | } 99 | 100 | #' @rdname landscape 101 | #' @export 102 | #' @param landscape an object of class \code{landscape} 103 | #' @details the accessor functions \code{distance}, \code{area}, 104 | #' \code{population} and \code{features} either return or set corresponding 105 | #' sub-dataframes of the \code{landscape} object 106 | #' @examples 107 | #' # get and set the area 108 | #' area(landscape) 109 | #' area(landscape) <- area(landscape) * 2 110 | #' area(landscape) 111 | #' 112 | area <- function (landscape) { 113 | stopifnot(is.landscape(landscape)) 114 | ans <- landscape[, attr(landscape, 'area'), drop = FALSE] 115 | ans <- squashLandscape(ans) 116 | return (ans) 117 | } 118 | 119 | #' @rdname landscape 120 | #' @export 121 | `area<-` <- function (landscape, value) { 122 | areaCheck(value) 123 | stopifnot(is.landscape(landscape)) 124 | landscape[, attr(landscape, 'area')] <- value 125 | landscape 126 | } 127 | 128 | #' @rdname landscape 129 | #' @export 130 | #' @examples 131 | #'# get and set the population 132 | #' population(landscape) 133 | #' population(landscape) <- population(landscape) * 2 134 | #' population(landscape) 135 | #' 136 | population <- function (landscape) { 137 | stopifnot(is.landscape(landscape)) 138 | ans <- landscape[, attr(landscape, 'population'), drop = FALSE] 139 | ans <- squashLandscape(ans) 140 | return (ans) 141 | } 142 | 143 | #' @rdname landscape 144 | #' @export 145 | `population<-` <- function (landscape, value) { 146 | stopifnot(is.landscape(landscape)) 147 | populationCheck(value) 148 | stopifnot(all.equal(names(population(landscape)), names(value))) 149 | landscape[, attr(landscape, 'population')] <- value 150 | landscape 151 | } 152 | 153 | #' @rdname landscape 154 | #' @export 155 | #' @examples 156 | #'# get and set the features 157 | #' features(landscape) 158 | #' features(landscape) <- cbind(features(landscape), rainfall = 100) 159 | #' features(landscape) 160 | #' 161 | features <- function (landscape) { 162 | stopifnot(is.landscape(landscape)) 163 | ans <- landscape[, attr(landscape, 'features'), drop = FALSE] 164 | ans <- squashLandscape(ans) 165 | return (ans) 166 | } 167 | 168 | #' @rdname landscape 169 | #' @export 170 | `features<-` <- function (landscape, value) { 171 | stopifnot(is.landscape(landscape)) 172 | stopifnot(is.data.frame(value)) 173 | 174 | # for features, just overwrite whatever's there - including column numbers 175 | feature_cols <- attr(landscape, 'features') 176 | 177 | if (is.null(feature_cols) | length(feature_cols) == 0) { 178 | # if null (currently no features), add them 179 | attr(landscape, 'features') <- ncol(landscape) + 1:ncol(value) 180 | } else { 181 | # if not null (currently some features), overwrite them 182 | attrib <- attributes(landscape) 183 | attrib$names <- attrib$names[-feature_cols] 184 | # attrib$names 185 | landscape <- landscape[, -feature_cols] 186 | attributes(landscape) <- attrib 187 | attr(landscape, 'features') <- ncol(landscape) + seq_len(ncol(value)) 188 | } 189 | landscape[, attr(landscape, 'features')] <- value 190 | landscape 191 | } 192 | 193 | #' @rdname landscape 194 | #' @export 195 | #' @examples 196 | #'# get and set the distance matrix 197 | #' distance(landscape) 198 | #' distance(landscape) <- sqrt(distance(landscape)) 199 | #' distance(landscape) 200 | #' 201 | distance <- function (landscape) { 202 | stopifnot(is.landscape(landscape)) 203 | ans <- attr(landscape, 'distance') 204 | return (ans) 205 | } 206 | 207 | #' @rdname landscape 208 | #' @export 209 | `distance<-` <- function (landscape, value) { 210 | stopifnot(is.landscape(landscape)) 211 | distanceCheck(value, landscape) 212 | attr(landscape, 'distance') <- value 213 | return (landscape) 214 | } 215 | 216 | #' @rdname landscape 217 | #' @param i index specifying the patches to include in the subset 218 | #' \code{landscape} object 219 | #' @export 220 | #' @examples 221 | #' # landscapes can be subsetted to get sub-landscapes of patches with double 222 | #' # braces 223 | #' landscape 224 | #' landscape[[1]] 225 | #' landscape[[1:2]] 226 | #' 227 | `[[.landscape` <- function (x, i) { 228 | attrib <- attributes(x) 229 | attrib$row.names <- attrib$row.names[i] 230 | d <- attrib$distance[i, i, drop = FALSE] 231 | rownames(d) <- colnames(d) <- seq_along(i) 232 | attrib$distance <- d 233 | x <- squashLandscape(x) 234 | x <- x[i, ] 235 | attributes(x) <- attrib 236 | return (x) 237 | } 238 | 239 | coordinates <- function (landscape) { 240 | stopifnot(is.landscape(landscape)) 241 | ans <- landscape[, attr(landscape, 'coordinates'), drop = FALSE] 242 | ans <- squashLandscape(ans) 243 | return (ans) 244 | } 245 | 246 | areaCheck <- function (area) { 247 | stopifnot(ncol(area) == 1) 248 | stopifnot(is.numeric(area[, 1])) 249 | stopifnot(all(is.finite(area[, 1]))) 250 | stopifnot(all(area[, 1] > 0)) 251 | } 252 | 253 | populationCheck <- function (population) { 254 | stopifnot(all(sapply(population, is.finite))) 255 | stopifnot(all(sapply(population, function(x) all(x >= 0)))) 256 | } 257 | 258 | distanceCheck <- function (distance, landscape) { 259 | stopifnot(is.matrix(distance)) 260 | stopifnot(nrow(distance) == ncol(distance)) 261 | stopifnot(nrow(distance) == nrow(landscape)) 262 | stopifnot(all(is.finite(distance))) 263 | stopifnot(all(distance >= 0)) 264 | stopifnot(all(diag(distance) == 0)) 265 | } 266 | 267 | list2landscape <- function (list) { 268 | 269 | # check the elements 270 | stopifnot(length(list) == 4) 271 | stopifnot(sort(names(list)) == c('area', 'coordinates', 'features', 'population')) 272 | stopifnot(all(sapply(list, is.data.frame))) 273 | 274 | # check components 275 | areaCheck(list$area) 276 | populationCheck(list$population) 277 | 278 | # reset order and tidy up row names 279 | suppressWarnings(landscape <- data.frame(list$coordinates, 280 | area = list$area, 281 | list$population, 282 | list$features)) 283 | rownames(landscape) <- 1:nrow(landscape) 284 | 285 | # work out column numbers 286 | ncoord <- ncol(list$coordinates) 287 | narea <- 1 288 | npop <- ncol(list$population) 289 | nfeat <- ncol(list$features) 290 | 291 | attr(landscape, 'coordinates') <- seq_len(ncoord) 292 | attr(landscape, 'area') <- narea + ncoord 293 | attr(landscape, 'population') <- seq_len(npop) + narea + ncoord 294 | attr(landscape, 'features') <- seq_len(nfeat) + npop + narea + ncoord 295 | 296 | # set class 297 | class(landscape) <- c('landscape', class(landscape)) 298 | 299 | # add distance matrix 300 | coord <- coordinates(landscape) 301 | distance <- as.matrix(dist(coord)) 302 | distance(landscape) <- distance 303 | 304 | # set class & return 305 | return (landscape) 306 | 307 | } 308 | 309 | # default standalone landscape 310 | landscapeDefault <- function () { 311 | landscape_list <- list(coordinates = data.frame(x = 0, y = 0), 312 | area = data.frame(area = 1), 313 | population = data.frame()[1, ], 314 | features = data.frame()[1, ]) 315 | landscape <- list2landscape(landscape_list) 316 | return (landscape) 317 | } 318 | 319 | # default landscape for a dynamic 320 | dynamicLandscapeDefault <- function (dynamic) { 321 | population <- as.list(rep(0, length(states(dynamic)))) 322 | names(population) <- states(dynamic) 323 | population <- as.data.frame(population) 324 | landscape_list <- list(coordinates = data.frame(x = 0, y = 0), 325 | area = data.frame(area = 1), 326 | population = population, 327 | features = data.frame()[1, ]) 328 | landscape <- list2landscape(landscape_list) 329 | return (landscape) 330 | } 331 | 332 | squashLandscape <- function (x) { 333 | # if an object is a landscape, remove the landscape class (to make it a 334 | # dataframe again) 335 | if (is.landscape(x)) { 336 | classes <- class(x) 337 | classes <- classes[-which(classes == 'landscape')] 338 | class(x) <- classes 339 | } 340 | return (x) 341 | } 342 | -------------------------------------------------------------------------------- /R/parameters-method.R: -------------------------------------------------------------------------------- 1 | # define S3 generic to get/set parameters from objects 2 | 3 | #' @title get and set parameters 4 | #' @rdname parameters 5 | #' @description this documents the S3 generic functions \code{parameters} to 6 | #' extract or assign parameter values from objects in the \code{pop} package. 7 | #' Methods of this function are defined for various object classes, including 8 | #' \code{transfun}, \code{transition} and \code{dynamic} objects. 9 | #' @param x an object from which to extract parameters, or in which to set them 10 | #' @param value an object to assign as the parameters of \code{x} 11 | #' @details each class-specific method will return parameters in a slightly 12 | #' different structure, and will require \code{value} to be provided in a 13 | #' different format (though the structures returned and required will 14 | #' generally be the same for all classes. See the helpfile for each class for 15 | #' the specific details and examples. 16 | #' @export 17 | parameters <- function (x) { 18 | UseMethod('parameters', x) 19 | } 20 | 21 | #' @rdname parameters 22 | #' @export 23 | `parameters<-` <- function (x, value) { 24 | UseMethod('parameters<-', x) 25 | } 26 | # 27 | # 28 | # 29 | # parameter.transfun <- function (x) { 30 | # parameters(x) 31 | # } 32 | # 33 | # parameter.transition <- function (x) { 34 | # parameter(x$transfun) 35 | # } 36 | # 37 | # parameter.dynamic <- function (x) { 38 | # lapply(x, parameter) 39 | # } 40 | # 41 | # 42 | # 43 | # 44 | # `parameter<-.transfun` <- function (x, value) { 45 | # parameters(x) <- value 46 | # x 47 | # } 48 | # 49 | # `parameter<-.transition` <- function (x, value) { 50 | # parameters(x) <- value 51 | # x 52 | # } 53 | # 54 | # `parameter<-.dynamic` <- function (x, value) { 55 | # parameters(x) <- value 56 | # x 57 | # } 58 | # 59 | # parameter(stasis_egg$transfun) 60 | # parameter(stasis_egg) 61 | # str(parameter(all), 2) 62 | # 63 | # tr <- stasis_egg$transfun 64 | # 65 | # parameters(tr) 66 | # parameters(tr) <- list(p = 0.1) 67 | # class(tr) 68 | # 69 | # 70 | # parameter(tr) <- list(p = 0.2) 71 | # parameters(tr) 72 | # 73 | # 74 | # parameter(stasis_egg$transfun) 75 | # a <- b <- 'blah' 76 | # class(a) <- 'foo' 77 | # parameter() 78 | -------------------------------------------------------------------------------- /R/pop.R: -------------------------------------------------------------------------------- 1 | #' @title pop: A Flexible Syntax for Population Dynamic Modelling 2 | #' @name pop 3 | #' @description Models of population dynamics underpin a range of analyses and 4 | #' applications in ecology and epidemiology. The various approaches for 5 | #' fitting and analysing these models (MPMs, IPMs, ODEs, POMPs, PVA, with and 6 | #' without metapopulation structure) are generally fitted using different 7 | #' software, each with a different interface. This makes it difficult to 8 | #' combine various modelling approaches and data types to solve a given 9 | #' problem. pop aims to provide a flexible and easy to use common interface 10 | #' for constructing population dynamic models and enabling to them to be 11 | #' fitted and analysed in various ways. 12 | #' @docType package 13 | #' @import igraph 14 | #' @importFrom graphics lines plot polygon 15 | #' @importFrom grDevices grey 16 | #' @importFrom stats dist na.omit quantile rbinom rpois rmultinom 17 | NULL 18 | -------------------------------------------------------------------------------- /R/projection-class.R: -------------------------------------------------------------------------------- 1 | # projection class 2 | 3 | #' @title Deterministic projection 4 | #' @name projection 5 | #' @rdname projection 6 | #' @description Project a population dynamic model in discrete time, recording 7 | #' the number of individuals in each state at each time point. 8 | #' @param dynamic a population dynamic model of class \code{\link{dynamic}} 9 | #' @param population a dataframe or named vector of positive integers, giving 10 | #' the number of individuals in each state of \code{dynamic}. If a dataframe, 11 | #' it should have only one row (as in the examples below), or as many rows as 12 | #' patches in the metapopulation if a multi-patch landscape has been defined 13 | #' for \code{dynamic} (using \code{\link{landscape}}). If a multi-patch 14 | #' landscape has been defined for \code{dynamic}, but \code{population} has 15 | #' only one row or is a vector, this population will be duplicated for all 16 | #' patches in the landscape. 17 | ##' @param timesteps a positive integer giving the number of time steps 18 | #' (iterations) over which to simulate the model 19 | #' @return an object of class \code{pop_projection} 20 | #' @export 21 | #' @examples 22 | #' # set up a three-stage model 23 | #' stasis_egg <- tr(egg ~ egg, p(0.6)) 24 | #' stasis_larva <- tr(larva ~ larva, p(0.4)) 25 | #' stasis_adult <- tr(adult ~ adult, p(0.9)) 26 | #' hatching <- tr(larva ~ egg, p(0.35)) 27 | #' fecundity <- tr(egg ~ adult, r(20)) 28 | #' pupation <- tr(adult ~ larva, p(0.2)) 29 | #' 30 | #' pd <- dynamic(stasis_egg, 31 | #' stasis_larva, 32 | #' stasis_adult, 33 | #' hatching, 34 | #' pupation, 35 | #' fecundity) 36 | #' 37 | #' population <- data.frame(egg = 1200, larva = 250, adult = 50) 38 | #' 39 | #' # simulate for 50 timesteps, 30 times 40 | #' proj <- projection(dynamic = pd, 41 | #' population = population, 42 | #' timesteps = 50) 43 | #' 44 | projection <- function (dynamic, population, timesteps = 1) { 45 | # given a dynamic and starting population, project the population for some 46 | # timesteps 47 | 48 | # coerce the population to the correct format 49 | population <- expandPopulation(population, dynamic) 50 | 51 | # update the dynamic's landscape population with the requested starting population 52 | population(landscape(dynamic)) <- population 53 | 54 | # get the number of patches 55 | n_patches <- nrow(landscape(dynamic)) 56 | 57 | # set up results matrix 58 | result <- matrix(0, 59 | nrow = timesteps + 1, 60 | ncol = length(states(dynamic)) * n_patches) 61 | rownames(result) <- 0:timesteps 62 | colnames(result) <- popvecNames(population) 63 | 64 | # add population to first row 65 | popvec <- pop2vec(population) 66 | result[1, ] <- popvec 67 | 68 | # loop through timesteps projecting according to the landscape state 69 | for(i in seq_len(timesteps)) { 70 | 71 | # get the time-dependent transition matrix 72 | A <- as.matrix(dynamic) 73 | 74 | # project to the next timestep 75 | popvec <- (A %*% popvec)[, 1] 76 | 77 | # update the landscape population 78 | population(landscape(dynamic)) <- vec2pop(popvec, population) 79 | 80 | # store the result 81 | result[i + 1, ] <- popvec 82 | 83 | } 84 | 85 | # return simulations ina pop_simulation object 86 | result <- list(dynamic = dynamic, 87 | projection = result) 88 | result <- as.pop_projection(result) 89 | return (result) 90 | 91 | } 92 | 93 | #' @rdname projection 94 | #' @param x a \code{pop_projection} object, or an object to be tested as one 95 | #' @export 96 | #' @examples 97 | #' is.pop_projection(proj) 98 | #' 99 | is.pop_projection <- function (x) { 100 | inherits(x, 'pop_projection') 101 | } 102 | 103 | #' @rdname projection 104 | #' @param \dots further arguments passed to or from other methods. 105 | #' @param states character vector naming the states in the \code{dynamic} object 106 | #' used to run the projection that should be plotted. By default all of them 107 | #' are plotted. 108 | #' @param patches vector of positive integers identifying the patches for which 109 | #' to plot the projections. By default only projections for the first patch 110 | #' are plotted. 111 | #' @export 112 | #' @examples 113 | #' par(mfrow = c(3, 1)) 114 | #' plot(proj) 115 | plot.pop_projection <- function (x, states = NULL, patches = 1, ...) { 116 | 117 | # get states if they aren't specified 118 | if (is.null(states)) states <- states(x$dynamic) 119 | 120 | # check they're sane 121 | n_states <- length(states(x$dynamic)) 122 | n_patches <- nrow(landscape(x$dynamic)) 123 | stopifnot(states %in% states(x$dynamic)) 124 | stopifnot(all(patches %in% seq_len(n_patches))) 125 | 126 | # plot them one at a time 127 | for (patch in patches) { 128 | for (state in states) { 129 | 130 | if (n_patches == 1) { 131 | title <- state 132 | } else { 133 | title <- sprintf('%s in patch %i', 134 | state, 135 | patch) 136 | } 137 | 138 | # get column index & column 139 | idx <- (patch - 1) * n_states + match(state, states(x$dynamic)) 140 | state_population <- x$projection[, idx] 141 | 142 | # get y axis range 143 | ylim = range(state_population, na.rm = TRUE) 144 | 145 | # get x axis 146 | xaxs <- as.numeric(rownames(x$projection)) 147 | 148 | # set up an empty plot 149 | plot(state_population ~ xaxs, 150 | type = 'n', 151 | ylim = ylim, 152 | ylab = 'population', 153 | xlab = 'time', 154 | main = title) 155 | 156 | lines(state_population ~ xaxs, 157 | lwd = 2, 158 | col = grey(0.4)) 159 | 160 | } 161 | } 162 | # name and return result 163 | return (invisible(x$projection)) 164 | 165 | } 166 | 167 | as.pop_projection <- function (x) { 168 | if (!is.pop_projection(x)) { 169 | class(x) <- c('pop_projection', class(x)) 170 | } 171 | return (x) 172 | } 173 | 174 | # functions to flatten and unflatten population 175 | pop2vec <- function (population) { 176 | # convert a population dataframe into a vector for deterministic analysis 177 | ans <- as.vector(t(as.matrix(population))) 178 | return (ans) 179 | } 180 | 181 | popvecNames <- function (population) { 182 | # get appropriate names for flattened version of population dataframe 183 | states <- colnames(population) 184 | patches <- as.character(seq_len(nrow(population))) 185 | if (length(patches) == 1) { 186 | # if only one patch, don't pollute the names 187 | names <- states 188 | } else { 189 | names <- apply(expand.grid(states, patches), 190 | 1, 191 | paste, 192 | sep = '', 193 | collapse = '_patch_') 194 | } 195 | return (names) 196 | } 197 | 198 | vec2pop <- function (vector, population) { 199 | n_state <- ncol(population) 200 | n_patch <- nrow(population) 201 | population[] <- matrix(vector, 202 | nrow = n_patch, 203 | ncol = n_state, 204 | byrow = TRUE) 205 | return (population) 206 | } 207 | -------------------------------------------------------------------------------- /R/simulation-class.R: -------------------------------------------------------------------------------- 1 | # simulation class 2 | 3 | #' @title Stochastic Simulation 4 | #' @name simulation 5 | #' @rdname simulation 6 | #' @description Simulate a population dynamic model in discrete time, recording 7 | #' the number of individuals in each state at each time point. 8 | #' @param dynamic a population dynamic model of class \code{\link{dynamic}} 9 | #' @param population a dataframe or named vector of positive integers, giving 10 | #' the number of individuals in each state of \code{dynamic}. If a dataframe, 11 | #' it should have only one row (as in the examples below), or as many rows as 12 | #' patches in the metapopulation if a multi-patch landscape has been defined 13 | #' for \code{dynamic} (using \code{\link{landscape}}). If a multi-patch 14 | #' landscape has been defined for \code{dynamic}, but \code{population} has 15 | #' only one row or is a vector, this population will be duplicated for all 16 | #' patches in the landscape. 17 | #' @param timesteps a positive integer giving the number of time steps 18 | #' (iterations) over which to simulate the model 19 | #' @param replicates a positive integer giving the number of independent time 20 | #' series to simulate 21 | #' @param ncores an optional positive integer giving the number of cpu cores to 22 | #' use when running simulations. By default (when \code{ncores = NULL}) all 23 | #' cores are used (or as many as \code{parallel::detectCores} can find). This 24 | #' argument is ignored is \code{replicates = 1} 25 | #' @return an object of class \code{simulation} 26 | #' @details The order of the dynamics in the simulation is defined by the order 27 | #' in which the transitions were passed to \code{dynamic}. I.e. if the stasis 28 | #' probability of a life stage (e.g. fraction surviving and remaining in the 29 | #' stage) was specified before the reproduction rate, then only those staying 30 | #' in the state will reproduce. Conversely, if reproduction was given first, 31 | #' individuals will reproduce before the stasis probability is applied. 32 | #' @export 33 | #' @import parallel 34 | #' @examples 35 | #' # set up a three-stage model 36 | #' stasis_egg <- tr(egg ~ egg, p(0.6)) 37 | #' stasis_larva <- tr(larva ~ larva, p(0.4)) 38 | #' stasis_adult <- tr(adult ~ adult, p(0.9)) 39 | #' hatching <- tr(larva ~ egg, p(0.35)) 40 | #' fecundity <- tr(egg ~ adult, r(20)) 41 | #' pupation <- tr(adult ~ larva, p(0.2)) 42 | #' 43 | #' pd <- dynamic(stasis_egg, 44 | #' stasis_larva, 45 | #' stasis_adult, 46 | #' hatching, 47 | #' pupation, 48 | #' fecundity) 49 | #' 50 | #' population <- data.frame(egg = 1200, larva = 250, adult = 50) 51 | #' 52 | #' # simulate for 50 timesteps, 30 times 53 | #' sim <- simulation(dynamic = pd, 54 | #' population = population, 55 | #' timesteps = 50, 56 | #' replicates = 30, 57 | #' ncores = 1) 58 | #' 59 | simulation <- function (dynamic, population, timesteps = 1, replicates = 1, ncores = NULL) { 60 | # given a dynamic and starting population, simulate the population for some 61 | # timesteps, and replicate a number of times, optionally in parallel 62 | 63 | # coerce the population to the correct format 64 | population <- expandPopulation(population, dynamic) 65 | 66 | # update the dynamic's landscape population with the requested starting population 67 | population(landscape(dynamic)) <- population 68 | 69 | # if the number of cores is not defined, assume they want all of them 70 | if (is.null(ncores)) { 71 | ncores <- parallel::detectCores() 72 | } 73 | 74 | # run the replicate simulations, in parallel or sequence 75 | if (ncores > 1 & replicates > 1) { 76 | # parallel case 77 | 78 | # set up the cluster 79 | on.exit(parallel::stopCluster(cl)) 80 | cl <- parallel::makeCluster(ncores) 81 | 82 | # export pop 83 | parallel::clusterEvalQ(cl = cl, 84 | library(pop)) 85 | 86 | # run simulations in parallel 87 | sims <- parallel::parLapply(cl = cl, 88 | seq_len(replicates), 89 | fun = popSimulate, 90 | dynamic = dynamic, 91 | population = population, 92 | timesteps = timesteps) 93 | 94 | } else { 95 | # sequence case 96 | 97 | # otherwise just lapply 98 | sims <- lapply(seq_len(replicates), 99 | FUN = popSimulate, 100 | dynamic = dynamic, 101 | population = population, 102 | timesteps = timesteps) 103 | 104 | } 105 | 106 | # return simulations ina pop_simulation object 107 | result <- list(dynamic = dynamic, 108 | simulations = sims) 109 | result <- as.simulation(result) 110 | return (result) 111 | 112 | } 113 | 114 | #' @rdname simulation 115 | #' @param x a \code{simulation} object, or an object to be tested as a \code{simulation} 116 | #' @export 117 | #' @examples 118 | #' is.simulation(sim) 119 | is.simulation <- function (x) { 120 | inherits(x, 'simulation') 121 | } 122 | 123 | #' @rdname simulation 124 | #' @param \dots further arguments passed to or from other methods. 125 | #' @param states a character vector naming the states in the \code{dynamic} 126 | #' object used to run the simulation that should be plotted. By default all of 127 | #' them are. 128 | #' @param patches vector of positive integers identifying the patches for which 129 | #' to plot the simulations. By default only projections for the first patch 130 | #' are plotted. 131 | #' @export 132 | #' @examples 133 | #' par(mfrow = c(3, 1)) 134 | #' plot(sim) 135 | plot.simulation <- function (x, states = NULL, patches = 1, ...) { 136 | # plot a pop simulation 137 | # state gives the name of the state to plot (by default all of them, in separate plots) 138 | 139 | # get states if they aren't specified 140 | if (is.null(states)) states <- states(x$dynamic) 141 | 142 | # check they're sane 143 | n_states <- length(states(x$dynamic)) 144 | n_patches <- nrow(landscape(x$dynamic)) 145 | stopifnot(states %in% states(x$dynamic)) 146 | stopifnot(all(patches %in% seq_len(n_patches))) 147 | 148 | # object to store the results in 149 | result <- list() 150 | 151 | # plot them one at a time 152 | for (patch in patches) { 153 | for (state in states) { 154 | 155 | if (n_patches == 1) { 156 | title <- state 157 | } else { 158 | title <- sprintf('%s in patch %i', 159 | state, 160 | patch) 161 | } 162 | 163 | # get column index & column 164 | idx <- (patch - 1) * n_states + match(state, states(x$dynamic)) 165 | 166 | # extract the simulations for this state 167 | sims <- lapply(x$simulations, 168 | function(x) x[, idx]) 169 | 170 | # if there are replicates, get CIs and medians of counts for each timepoint 171 | if (length(sims) > 1) { 172 | sims_mat <- do.call(cbind, sims) 173 | quants <- t(apply(sims_mat, 1, quantile, c(0.025, 0.5, 0.975))) 174 | } else { 175 | quants <- cbind(rep(NA, length(sims[[1]])), 176 | sims[[1]], 177 | rep(NA, length(sims[[1]]))) 178 | } 179 | 180 | colnames(quants) <- c('lower_95_CI', 181 | 'median', 182 | 'upper_95_CI') 183 | 184 | rownames(quants) <- names(sims[[1]]) 185 | 186 | # get y axis range 187 | ylim = range(quants, na.rm = TRUE) 188 | 189 | # get x axis 190 | xaxs <- as.numeric(names(sims[[1]])) 191 | 192 | # set up an empty plot 193 | plot(sims[[1]] ~ xaxs, 194 | type = 'n', 195 | ylim = ylim, 196 | ylab = 'population', 197 | xlab = 'time', 198 | main = title) 199 | 200 | # draw the 95% CI polygon (if available) and median line 201 | polygon(x = c(xaxs, rev(xaxs)), 202 | y = c(quants[, 1], rev(quants[, 3])), 203 | col = grey(0.9), 204 | border = NA) 205 | 206 | lines(quants[, 2] ~ xaxs, 207 | lwd = 2, 208 | col = grey(0.4)) 209 | 210 | result[[title]] <- quants 211 | 212 | } 213 | } 214 | 215 | # name and return result 216 | names(result) <- states 217 | return (invisible(result)) 218 | 219 | } 220 | 221 | update <- function (population, dynamic) { 222 | # stochastically update the population based on a dynamic. 223 | 224 | # get new population object to fill 225 | new_population <- population * 0 226 | 227 | # get landscape object 228 | landscape <- landscape(dynamic) 229 | 230 | # loop through transitions 231 | for (trans in dynamic) { 232 | 233 | # get the old and new N 234 | N <- population[, trans$from] 235 | N_new <- stoch(trans$transfun, N = N, landscape = landscape) 236 | 237 | if (trans$to == trans$from) { 238 | # if it's to the same state... 239 | 240 | if (contains(trans$transfun, 'rate')) { 241 | 242 | # if it's a rate (recruitment) add to new population 243 | new_population[, trans$to] <- new_population[, trans$to] + N_new 244 | 245 | } else { 246 | 247 | # if it's a (survival) probability (not recruitment), or dispersal to 248 | # same state, replace *old* population with the new one 249 | population[, trans$to] <- N_new 250 | 251 | } 252 | 253 | } else { 254 | # if it's to another state (can't be a dispersal) 255 | 256 | if (contains(trans$transfun, 'rate')) { 257 | 258 | # if it was a recruitment event add to the state in the new population 259 | new_population[, trans$to] <- new_population[, trans$to] + N_new 260 | 261 | } else { 262 | 263 | # if it *wasn't* a recruitment event, update in the new population 264 | new_population[, trans$to] <- new_population[, trans$to] + N_new 265 | 266 | # and remove the same number from the old population 267 | population[, trans$from] <- population[, trans$from] - N_new 268 | 269 | } 270 | 271 | } 272 | 273 | } 274 | 275 | # add surviving members of the old population to the new one & return 276 | new_population <- new_population + population 277 | return (new_population) 278 | 279 | } 280 | 281 | # stochastic updates for probabilities and rates 282 | stoch_prob <- function (expectation, N) { 283 | rbinom(n = length(N), size = N, prob = expectation) 284 | } 285 | stoch_rate <- function (expectation, N) { 286 | rpois(n = length(N), lambda = N * expectation) 287 | } 288 | stoch_disp <- function (expectation, N) { 289 | # random multinomial draws on a square matrix 290 | disp <- N * 0 291 | for (i in seq_along(N)) { 292 | disp <- disp + rmultinom(1, N[i], expectation[i, ]) 293 | } 294 | return (disp[, 1]) 295 | } 296 | 297 | stoch <- function (transfun, N, landscape) { 298 | # given a parameter value, a number of individuals in the *from* state, 299 | # stochastically generate the number of individuals in the *to* state 300 | 301 | # get type 302 | type <- transfunType(transfun) 303 | 304 | # if it's a dispersal 305 | if (contains(transfun, 'dispersal')) { 306 | 307 | # randomly them move across the landscape 308 | N <- stoch_disp(transfun(landscape), N) 309 | 310 | } else if (type == 'compound') { 311 | 312 | # if it's a (non-dispersal) compound transfun, call stoch recursively on each component 313 | tf_x <- environment(transfun)$x 314 | tf_y <- environment(transfun)$y 315 | N <- stoch(tf_x, N, landscape) 316 | N <- stoch(tf_y, N, landscape) 317 | 318 | } else { 319 | 320 | # otherwise execute the basis transition on its own 321 | N <- switch (type, 322 | probability = stoch_prob(transfun(landscape), N), 323 | rate = stoch_rate(transfun(landscape), N)) 324 | 325 | } 326 | 327 | return (N) 328 | 329 | } 330 | 331 | popSimulate <- function (iter, dynamic, population, timesteps) { 332 | # internal function to run simulations. First element is a dummy for use 333 | # with (par)lapply. 334 | 335 | # get the numbers of states and patches 336 | n_states <- length(states(dynamic)) 337 | n_patches <- nrow(landscape(dynamic)) 338 | 339 | # set up results matrix 340 | res <- matrix(0, 341 | nrow = timesteps + 1, 342 | ncol = n_states * n_patches) 343 | rownames(res) <- 0:timesteps 344 | colnames(res) <- popvecNames(population) 345 | 346 | # add population to first row 347 | popvec <- pop2vec(population) 348 | res[1, ] <- popvec 349 | 350 | 351 | for (time in seq_len(timesteps)) { 352 | 353 | # sample the population 354 | population <- update(population, dynamic) 355 | 356 | # update it in the landscape information 357 | population(landscape(dynamic)) <- population 358 | 359 | # store the result & call it quits if they're all gone 360 | res[time + 1, ] <- pop2vec(population) 361 | if (all(population == 0)) break() 362 | 363 | } 364 | 365 | return (res) 366 | 367 | } 368 | 369 | as.simulation <- function (x) { 370 | if (!is.simulation(x)) { 371 | class(x) <- c('simulation', class(x)) 372 | } 373 | return (x) 374 | } 375 | -------------------------------------------------------------------------------- /R/transfun-class.R: -------------------------------------------------------------------------------- 1 | # things related to the transfun class 2 | 3 | transfunClasses <- function () { 4 | # list all available classes of transfun 5 | c('probability', 'rate', 'dispersal', 'compound') 6 | } 7 | 8 | transfunType <- function (x) { 9 | # get the type of the transfun object 10 | stopifnot(is.transfun(x)) 11 | classes <- class(x) 12 | matches <- na.omit(match(transfunClasses(), classes)) 13 | if (length(matches) == 0) { 14 | stop ('this transfun object does not correspond to any known transfun types') 15 | } else if (length(matches) > 1) { 16 | stop ('this transfun object correspond to multiple transfun types') 17 | } else { 18 | type <- classes[matches] 19 | } 20 | return (type) 21 | } 22 | 23 | #' @title transfun objects 24 | #' @name transfun 25 | #' @rdname transfun 26 | #' @param x a transfun object to print or an object to test as a transfun object 27 | #' @description utility functions for the \code{transfun} class. \code{transfun} 28 | #' objects are created by functions such as \code{\link{probability}}. 29 | #' @export 30 | #' @examples 31 | #' prob <- p(0.3) 32 | #' is.transfun(prob) 33 | #' 34 | is.transfun <- function (x) inherits(x, 'transfun') 35 | 36 | #' @rdname transfun 37 | #' @param \dots further arguments passed to or from other methods. 38 | #' @export 39 | #' @examples 40 | #' prob 41 | print.transfun <- function(x, ...) { 42 | if (containsUserTransfun(x)) { 43 | text <- sprintf('user-specified %s transfun', 44 | transfunType(x)) 45 | } else { 46 | landscape <- as.landscape(NULL) 47 | text <- sprintf('%s transfun with expectation %s\n', 48 | transfunType(x), 49 | x(landscape)) 50 | } 51 | 52 | cat(text) 53 | } 54 | 55 | is.compound <- function (x) inherits(x, 'compound') 56 | 57 | as.compound <- function (x) { 58 | # define a compound transfun class 59 | if (!is.compound(x)) { 60 | class(x) <- c('compound', 'transfun', class(x)) 61 | } 62 | return (x) 63 | } 64 | 65 | #' @rdname transfun 66 | #' @param y a transfun object to be multiplied with another with the same 67 | #' pathway 68 | #' @details multiplication of transfun objects with the same pathway results in 69 | #' a compound transfun object (also of class \code{transfun}). When used in a 70 | #' stochastic model, the two stochastic transitions are evaluated one after 71 | #' another. When analysed deterministically, the expectation of the compound 72 | #' transition function is taken as the product of the expectations of the two 73 | #' basis transfuns. 74 | #' @export 75 | #' @examples 76 | #' (compound <- prob * r(4.3)) 77 | #' 78 | `*.transfun` <- function (x, y) { 79 | # given two transfun objects, combine them into a compound transfun 80 | stopifnot(is.transfun(x)) 81 | stopifnot(is.transfun(y)) 82 | 83 | # make sure a dispersal is not combined with a rate or another dispersal 84 | combineDispersalCheck(x, y) 85 | 86 | # if it contains a dispersal, the other must be only a probability 87 | if (contains(x, 'dispersal') | 88 | contains(y, 'dispersal')) { 89 | 90 | # if its a dispersal and probability 91 | z <- function (landscape) { 92 | probdisp(x, y, landscape) 93 | } 94 | 95 | } else { 96 | 97 | # if none are dispersals, just the product 98 | z <- function (landscape) { 99 | x(landscape) * y(landscape) 100 | } 101 | 102 | } 103 | 104 | # coerce class & return 105 | z <- as.compound(z) 106 | return (z) 107 | 108 | } 109 | 110 | #' @title create a transition function 111 | #' @name as.transfun 112 | #' @description A utility function to enable users to create bespoke transition 113 | #' functions (\code{transfun} objects) for use in \code{transition}s. 114 | #' @param fun an R function describing the transition. This must take only one 115 | #' argument: \code{landscape} and return a numeric vector (see 116 | #' \code{details}). 117 | #' @param param a named list of the parameters of \code{fun} (see 118 | #' \code{details}). 119 | #' @param type what type of transition this function represents, a probability 120 | #' or a rate 121 | #' @details \code{fun} must take only one argument, \code{landscape}, an object 122 | #' of class \code{\link{landscape}}. \code{landscape} objects contain three 123 | #' elements which may be used in the function: \code{population}, a dataframe 124 | #' giving the number of individuals of each stage (columns) in each patch 125 | #' (rows); \code{area}; a numeric vector giving the area of each patch in 126 | #' square kilometres; and \code{features}, a dataframe containing 127 | #' miscellaneous features (columns) of each habitat patch (rows), such as 128 | #' measures of patch quality or environmental variables. See examples for an 129 | #' illustration of how to these objects. Parameters of the transfun should be 130 | #' passed to \code{as.transfun} as a named list. These can then be used in 131 | #' \code{fun} by accessing them from this list. Note that \code{param} isn't 132 | #' an argument to \code{fun}, instead it's modified directly in the function's 133 | #' envirnment (because \emph{reasons}). 134 | #' @export 135 | #' @examples 136 | #' # a very simple (and unnecessary, see ?p) transfun 137 | #' fun <- function(landscape) param$prob 138 | #' prob <- as.transfun(fun, param = c(prob = 0.3), type = 'probability') 139 | #' 140 | #' # a density-dependent probability 141 | #' dd_fun <- function (landscape) { 142 | #' adult_density <- population(landscape, 'adult') / area(landscape) 143 | #' param$p * exp(- adult_density/param$range) 144 | #' } 145 | #' 146 | #' dd_prob <- as.transfun(dd_fun, 147 | #' param = list(p = 0.8, 148 | #' range = 10), 149 | #' type = 'probability') 150 | #' 151 | as.transfun <- function (fun, 152 | param, 153 | type = c('probability', 'rate', 'dispersal')) { 154 | 155 | # line up the transfun type 156 | type <- match.arg(type) 157 | 158 | # check it's a function 159 | stopifnot(is.function(fun)) 160 | 161 | # check landscape is the only argument 162 | args <- names(formals(fun)) 163 | if (length(args) != 1 || args != 'landscape') { 164 | stop ("transfun objects must only take the argument 'landscape' 165 | see ?as.transfun for details and examples") 166 | } 167 | 168 | # define parameters and fun here so fun can see param 169 | param <- param 170 | environment(fun) <- environment() 171 | 172 | # assign type and return 173 | fun <- switch(type, 174 | probability = as.probability(fun), 175 | rate = as.rate(fun), 176 | dispersal = as.dispersal(fun)) 177 | 178 | attr(fun, 'user-defined') <- TRUE 179 | 180 | return (fun) 181 | } 182 | 183 | containsUserTransfun <- function (transfun) { 184 | # test whether a transfun object contains a user-defined transfun 185 | 186 | # get transfun type, if it's a compound, call this function recursively 187 | type <- transfunType(transfun) 188 | 189 | if (type == 'compound') { 190 | # expand and test components 191 | tf_x <- environment(transfun)$x 192 | tf_y <- environment(transfun)$y 193 | ans <- containsUserTransfun(tf_x) | 194 | containsUserTransfun(tf_y) 195 | } else { 196 | # otherwise test this 197 | ans <- attr(transfun, 'user-defined') 198 | if (is.null(ans)){ 199 | ans <- FALSE 200 | } 201 | } 202 | 203 | return (ans) 204 | 205 | } 206 | 207 | #' @rdname transfun 208 | #' @export 209 | #' @examples 210 | #' # extract the transfun parameters 211 | #' (param_prob <- parameters(prob)) 212 | #' (param_compound <- parameters(compound)) 213 | #' 214 | parameters.transfun <- function (x) { 215 | if (is.compound(x)) { 216 | tf_x <- environment(x)$x 217 | tf_y <- environment(x)$y 218 | param <- c(parameters(tf_x), parameters(tf_y)) 219 | } else { 220 | param <- environment(x)$param 221 | } 222 | return (param) 223 | } 224 | 225 | #' @rdname transfun 226 | #' @export 227 | #' @param value a named list of parameters matching those currently defined for \code{x} 228 | #' @examples 229 | #' # update the parameters of these transfuns 230 | #' param_prob$p <- 0.6 231 | #' parameters(prob) <- param_prob 232 | #' parameters(prob) 233 | #' 234 | #' param_compound$r <- 15 235 | #' parameters(compound) <- param_compound 236 | #' parameters(compound) 237 | `parameters<-.transfun` <- function (x, value) { 238 | 239 | if (is.compound(x)) { 240 | 241 | # get components 242 | components <- list(environment(x)$x, environment(x)$y) 243 | 244 | # do components in turn 245 | for (i in 1:2) { 246 | new_param <- old_param <- parameters(components[[i]]) 247 | 248 | # loop through parameters in this component 249 | for (j in 1:length(new_param)) { 250 | 251 | # get first match 252 | which_value <- which(names(value) == names(old_param)[j])[1] 253 | 254 | # update in new_param 255 | new_param[j] <- value[which_value] 256 | 257 | # remove from value 258 | value <- value[-which_value] 259 | 260 | } 261 | 262 | # update transfun 263 | parameters(components[[i]]) <- new_param 264 | 265 | } 266 | 267 | # recombine the components 268 | x <- components[[1]] * components[[2]] 269 | 270 | } else { 271 | # otherwise update basis transfun 272 | 273 | # check new parameters 274 | parametersCheck(value, x) 275 | 276 | # if that worked, define param and fun here 277 | param <- value 278 | environment(x) <- environment() 279 | 280 | } 281 | 282 | return (x) 283 | 284 | } 285 | 286 | parametersCheck <- function (param, transfun = NULL) { 287 | 288 | # check incoming parameters make sense 289 | stopifnot(is.list(param)) 290 | stopifnot(all(sapply(param, is.finite))) 291 | stopifnot(all(sapply(param, is.numeric))) 292 | 293 | if (!is.null(transfun)) { 294 | # check they match the transfun 295 | old_param <- parameters(transfun) 296 | stopifnot(all.equal(names(param), names(old_param))) 297 | stopifnot(length(param) == length(old_param)) 298 | } 299 | 300 | } 301 | 302 | probdisp <- function (x, y, landscape) { 303 | # get expected dispersal fraction from a probability and a dispersal transfun. 304 | # dispersal should have diagonal giving probability of staying, off-diagonals 305 | # giving probability of moving to each other patch, w/ all rows summing to 1. 306 | # probability is probability of leaving (1-probability of staying). 307 | 308 | # work out which way round 309 | if (is.probability(x) & is.dispersal(y)) { 310 | prob <- x(landscape) 311 | disp <- y(landscape) 312 | } else { 313 | prob <- y(landscape) 314 | disp <- x(landscape) 315 | } 316 | 317 | # multiply each row by the dispersal probability 318 | disp <- sweep(disp, 1, prob, '*') 319 | 320 | # add fraction not attempting dispersal back onto diagonal 321 | diag(disp) <- diag(disp) + 1 - prob 322 | 323 | return (disp) 324 | 325 | } 326 | 327 | combineDispersalCheck <- function (x, y) { 328 | bad_thing1 <- contains(x, 'dispersal') & 329 | (contains(y, 'dispersal') | contains(y, 'rate')) 330 | bad_thing2 <- contains(y, 'dispersal') & 331 | (contains(x, 'dispersal') | contains(x, 'rate')) 332 | if (bad_thing1 | bad_thing2) { 333 | stop ('dispersal transfuns can only be combined with probability transfuns') 334 | } 335 | } 336 | -------------------------------------------------------------------------------- /R/transfun_dispersal.R: -------------------------------------------------------------------------------- 1 | # dispersal transition function 2 | 3 | #' @title dispersal transfun 4 | #' @name dispersal 5 | #' @rdname dispersal 6 | #' @description Create a transfun object representing a relative probability of 7 | #' dispersal between patches. Typically used inside a call to 8 | #' \code{\link{transition}} 9 | #' @param value the (positive) exponential rate of decay of dispersal 10 | #' probabilities. Large values imply shorter range dispersal. 11 | #' @details \code{d()} is a shorthand for \code{dispersal()}. The 12 | #' \code{transfun} object returned, when applied to a \code{landscape} object, 13 | #' produces a square symmetric matrix, with zero diagonal and off-diagonals 14 | #' giving the relative between patch dispersal probability. This implies that 15 | #' \emph{all} individuals in the state will \emph{try} to disperse. The 16 | #' fraction remaining in the patch depends on \code{value}. To have only some 17 | #' fraction try to disperse, a dispersal transfun can be multiplied by a 18 | #' probability transfun indicating the probability of attempting dispersal. 19 | #' 20 | #' The relative dispersal probability is given by \code{exp(-d * value)}, 21 | #' where \code{d} is the Euclidean distance between the origin and 22 | #' destination patch. 23 | #' @export 24 | #' @examples 25 | #' # these are equivalent 26 | #' disp <- dispersal(3) 27 | #' disp <- d(3) 28 | #' 29 | dispersal <- function (value) { 30 | # label a value as a probability 31 | stopifnot(is.numeric(value)) 32 | stopifnot(value >= 0) 33 | param = list(l = value) 34 | f <- function (landscape) { 35 | ans <- exp(param$l * -distance(landscape)) 36 | if (nrow(ans) > 1) { 37 | ans <- sweep(ans, 1, rowSums(ans), '/') 38 | } 39 | return (ans) 40 | } 41 | f <- as.dispersal(f) 42 | return (f) 43 | } 44 | 45 | #' @rdname dispersal 46 | #' @name d 47 | #' @export 48 | d <- dispersal 49 | 50 | #' @rdname dispersal 51 | #' @param x an object to be tested as a dispersal transfun object 52 | #' @export 53 | #' @examples 54 | #' is.dispersal(disp) 55 | is.dispersal <- function (x) inherits(x, 'dispersal') 56 | 57 | # unexported 58 | as.dispersal <- function (x) { 59 | if (!is.transfun(x)) { 60 | class(x) <- c('transfun', class(x)) 61 | } 62 | if (!is.dispersal(x)) { 63 | class(x) <- c('dispersal', class(x)) 64 | } 65 | return (x) 66 | } 67 | 68 | 69 | -------------------------------------------------------------------------------- /R/transfun_probability.R: -------------------------------------------------------------------------------- 1 | # probability transition function 2 | 3 | #' @title probability transfun 4 | #' @name probability 5 | #' @rdname probability 6 | #' @description Create a transfun object representing a probability of 7 | #' transition between states. Typically used inside a call to 8 | #' \code{\link{transition}} 9 | #' @param value a numeric between 0 and 1 representing a probability 10 | #' @details \code{p()} is a shorthand for \code{probability()}. 11 | #' @export 12 | #' @examples 13 | #' # these are equivalent 14 | #' prob <- probability(0.2) 15 | #' prob <- p(0.2) 16 | #' 17 | probability <- function (value) { 18 | # label a value as a probability 19 | stopifnot(is.numeric(value)) 20 | stopifnot(value > 0 & value < 1) 21 | param = list(p = value) 22 | f <- function (landscape) param$p 23 | f <- as.probability(f) 24 | return (f) 25 | } 26 | 27 | #' @rdname probability 28 | #' @name p 29 | #' @export 30 | p <- probability 31 | 32 | #' @rdname probability 33 | #' @param x an object to be tested as a probability transfun object 34 | #' @export 35 | #' @examples 36 | #' is.probability(prob) 37 | is.probability <- function (x) inherits(x, 'probability') 38 | 39 | # unexported 40 | as.probability <- function (x) { 41 | if (!is.transfun(x)) { 42 | class(x) <- c('transfun', class(x)) 43 | } 44 | if (!is.probability(x)) { 45 | class(x) <- c('probability', class(x)) 46 | } 47 | return (x) 48 | } 49 | 50 | 51 | -------------------------------------------------------------------------------- /R/transfun_rate.R: -------------------------------------------------------------------------------- 1 | # rate transition function 2 | 3 | #' @title rate transfun 4 | #' @name rate 5 | #' @rdname rate 6 | #' @description Create a transfun object representing a rate of transition 7 | #' between states - e.g. an expected number of offspring generated into one 8 | #' state from another. Typically used inside a call to 9 | #' \code{\link{transition}} 10 | #' @param value a numeric greater than 0 representing a rate 11 | #' @details \code{r()} is a shorthand for \code{rate()}. 12 | #' @export 13 | #' @examples 14 | #' # these are equivalent 15 | #' rate <- rate(0.2) 16 | #' rate <- r(0.2) 17 | #' 18 | rate <- function (value) { 19 | # label a value as a rate 20 | stopifnot(is.numeric(value)) 21 | stopifnot(value > 0) 22 | stopifnot(is.finite(value)) 23 | param = list(r = value) 24 | f <- function (landscape) param$r 25 | f <- as.rate(f) 26 | return (f) 27 | } 28 | 29 | #' @rdname rate 30 | #' @name r 31 | #' @export 32 | r <- rate 33 | 34 | #' @rdname rate 35 | #' @param x an object to be tested as a rate transfun object 36 | #' @export 37 | #' @examples 38 | #' is.rate(rate) 39 | is.rate <- function (x) inherits(x, 'rate') 40 | 41 | as.rate <- function (x) { 42 | if (!is.transfun(x)) { 43 | class(x) <- c('transfun', class(x)) 44 | } 45 | if (!is.rate(x)) { 46 | class(x) <- c('rate', class(x)) 47 | } 48 | return (x) 49 | } 50 | -------------------------------------------------------------------------------- /R/transition-class.R: -------------------------------------------------------------------------------- 1 | #' @title transition objects 2 | #' @name transition 3 | #' @rdname transition 4 | #' @param formula a two-sided formula identifying the states between which the 5 | #' transition occurs 6 | #' @param transfun a \code{\link{transfun}} object quantifying the transition. 7 | #' @description creates a \code{transition} object, encoding a transition 8 | #' between two states. E.g. the probability of a seed germinating, or of an 9 | #' individual surviving in each time step 10 | #' @details \code{tr} is just a shorthand for \code{transition} 11 | #' @export 12 | #' @examples 13 | #' # 50/50 chance of a larva emerging from an egg 14 | #' hatching <- tr(larva ~ egg, p(0.5)) 15 | #' 16 | #' # three eggs laid per adult per time step 17 | #' fecundity <- tr(egg ~ adult, r(3)) 18 | #' 19 | #' # 0.1 probability of a larva pupating into an adult 20 | #' pupa <- tr(adult ~ larva, p(0.1)) 21 | #' 22 | transition <- function (formula, transfun) { 23 | # given a formula describing a particular transition, 24 | # parse into an object & store the value 25 | 26 | stopifnot(inherits(formula, 'formula')) 27 | stopifnot(is.transfun(transfun)) 28 | 29 | to <- as.character(formula[[2]]) 30 | from <- as.character(formula[[3]]) 31 | 32 | # stop any cross-state dispersals 33 | if (to != from & contains(transfun, 'dispersal')) { 34 | stop ('dispersals can only occur between patches, within the same state') 35 | } 36 | 37 | object <- list(to = to, 38 | from = from, 39 | transfun = transfun) 40 | 41 | object <- as.transition(object) 42 | return (object) 43 | 44 | } 45 | 46 | #' @rdname transition 47 | #' @export 48 | #' @name tr 49 | tr <- transition 50 | 51 | #' @rdname transition 52 | #' @export 53 | is.transition <- function (x) inherits(x, 'transition') 54 | 55 | as.transition <- function (x) { 56 | if (!is.transition(x)) { 57 | class(x) <- c('transition', class(x)) 58 | } 59 | return (x) 60 | } 61 | 62 | #' @rdname transition 63 | #' @param x an object to print or test as a transition object 64 | #' @param \dots further arguments passed to or from other methods. 65 | #' @export 66 | #' @examples 67 | #' # print method 68 | #' print(pupa) 69 | #' 70 | print.transition <- function (x, ...) { 71 | if (containsUserTransfun(x$transfun)) { 72 | text <- sprintf('transition:\t%s -> %s with user-defined transfun\n', 73 | x$from, 74 | x$to) 75 | 76 | } else { 77 | landscape <- as.landscape(NULL) 78 | text <- sprintf('transition:\t%s -> %s with expectation %s\n', 79 | x$from, 80 | x$to, 81 | x$transfun(landscape)) 82 | } 83 | cat(text) 84 | } 85 | 86 | #' @rdname transition 87 | #' @param y a transition object to be multiplied with another with the same 88 | #' pathway 89 | #' @details multiplication of transition objects with the same pathway results 90 | #' in a transition object whose \code{transfun} object is a compound of the 91 | #' two transfuns in the transitions. See \code{\link{transfun}} for more 92 | #' details of compound transfuns. 93 | #' @export 94 | #' @examples 95 | #' # make a compound transition to include a probability of laying eggs 96 | #' prob_laying <- tr(egg ~ adult, p(0.6)) 97 | #' (recruitment <- prob_laying * fecundity) 98 | #' 99 | `*.transition` <- function (x, y) { 100 | # given two transition objects on the same pathway, combine their transfuns 101 | # into a compound transfun 102 | stopifnot(x$from == y$from & x$to == y$to) 103 | stopifnot(is.transition(x)) 104 | stopifnot(is.transition(y)) 105 | x$transfun <- x$transfun * y$transfun 106 | return (x) 107 | } 108 | 109 | #' @rdname transition 110 | #' @export 111 | #' @examples 112 | #' # extract the transfun parameters 113 | #' (param_pupa <- parameters(pupa)) 114 | #' (param_recruitment <- parameters(recruitment)) 115 | #' 116 | parameters.transition <- function (x) { 117 | parameters(x$transfun) 118 | } 119 | 120 | #' @rdname transition 121 | #' @export 122 | #' @param value a named list of parameters matching those currently defined for \code{x} 123 | #' @examples 124 | #' # update the parameters of these transfuns 125 | #' param_pupa$p <- 0.6 126 | #' parameters(pupa) <- param_pupa 127 | #' parameters(pupa) 128 | #' 129 | #' param_recruitment$r <- 15 130 | #' parameters(recruitment) <- param_recruitment 131 | #' parameters(recruitment) 132 | `parameters<-.transition` <- function (x, value) { 133 | parameters(x$transfun) <- value 134 | return (x) 135 | } 136 | -------------------------------------------------------------------------------- /man/as.transfun.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/transfun-class.R 3 | \name{as.transfun} 4 | \alias{as.transfun} 5 | \title{create a transition function} 6 | \usage{ 7 | as.transfun(fun, param, type = c("probability", "rate", "dispersal")) 8 | } 9 | \arguments{ 10 | \item{fun}{an R function describing the transition. This must take only one 11 | argument: \code{landscape} and return a numeric vector (see 12 | \code{details}).} 13 | 14 | \item{param}{a named list of the parameters of \code{fun} (see 15 | \code{details}).} 16 | 17 | \item{type}{what type of transition this function represents, a probability 18 | or a rate} 19 | } 20 | \description{ 21 | A utility function to enable users to create bespoke transition 22 | functions (\code{transfun} objects) for use in \code{transition}s. 23 | } 24 | \details{ 25 | \code{fun} must take only one argument, \code{landscape}, an object 26 | of class \code{\link{landscape}}. \code{landscape} objects contain three 27 | elements which may be used in the function: \code{population}, a dataframe 28 | giving the number of individuals of each stage (columns) in each patch 29 | (rows); \code{area}; a numeric vector giving the area of each patch in 30 | square kilometres; and \code{features}, a dataframe containing 31 | miscellaneous features (columns) of each habitat patch (rows), such as 32 | measures of patch quality or environmental variables. See examples for an 33 | illustration of how to these objects. Parameters of the transfun should be 34 | passed to \code{as.transfun} as a named list. These can then be used in 35 | \code{fun} by accessing them from this list. Note that \code{param} isn't 36 | an argument to \code{fun}, instead it's modified directly in the function's 37 | envirnment (because \emph{reasons}). 38 | } 39 | \examples{ 40 | # a very simple (and unnecessary, see ?p) transfun 41 | fun <- function(landscape) param$prob 42 | prob <- as.transfun(fun, param = c(prob = 0.3), type = 'probability') 43 | 44 | # a density-dependent probability 45 | dd_fun <- function (landscape) { 46 | adult_density <- population(landscape, 'adult') / area(landscape) 47 | param$p * exp(- adult_density/param$range) 48 | } 49 | 50 | dd_prob <- as.transfun(dd_fun, 51 | param = list(p = 0.8, 52 | range = 10), 53 | type = 'probability') 54 | 55 | } 56 | 57 | -------------------------------------------------------------------------------- /man/dispersal.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/transfun_dispersal.R 3 | \name{dispersal} 4 | \alias{d} 5 | \alias{dispersal} 6 | \alias{is.dispersal} 7 | \title{dispersal transfun} 8 | \usage{ 9 | dispersal(value) 10 | 11 | d(value) 12 | 13 | is.dispersal(x) 14 | } 15 | \arguments{ 16 | \item{value}{the (positive) exponential rate of decay of dispersal 17 | probabilities. Large values imply shorter range dispersal.} 18 | 19 | \item{x}{an object to be tested as a dispersal transfun object} 20 | } 21 | \description{ 22 | Create a transfun object representing a relative probability of 23 | dispersal between patches. Typically used inside a call to 24 | \code{\link{transition}} 25 | } 26 | \details{ 27 | \code{d()} is a shorthand for \code{dispersal()}. The 28 | \code{transfun} object returned, when applied to a \code{landscape} object, 29 | produces a square symmetric matrix, with zero diagonal and off-diagonals 30 | giving the relative between patch dispersal probability. This implies that 31 | \emph{all} individuals in the state will \emph{try} to disperse. The 32 | fraction remaining in the patch depends on \code{value}. To have only some 33 | fraction try to disperse, a dispersal transfun can be multiplied by a 34 | probability transfun indicating the probability of attempting dispersal. 35 | 36 | The relative dispersal probability is given by \code{exp(-d * value)}, 37 | where \code{d} is the Euclidean distance between the origin and 38 | destination patch. 39 | } 40 | \examples{ 41 | # these are equivalent 42 | disp <- dispersal(3) 43 | disp <- d(3) 44 | 45 | is.dispersal(disp) 46 | } 47 | 48 | -------------------------------------------------------------------------------- /man/dynamic.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dynamic-class.R 3 | \name{dynamic} 4 | \alias{as.matrix.dynamic} 5 | \alias{dynamic} 6 | \alias{is.dynamic} 7 | \alias{parameters.dynamic} 8 | \alias{parameters<-.dynamic} 9 | \alias{plot.dynamic} 10 | \alias{print.dynamic} 11 | \alias{states} 12 | \title{dynamic objects} 13 | \usage{ 14 | dynamic(...) 15 | 16 | is.dynamic(x) 17 | 18 | \method{plot}{dynamic}(x, ...) 19 | 20 | states(x) 21 | 22 | \method{print}{dynamic}(x, ...) 23 | 24 | \method{as.matrix}{dynamic}(x, which = c("A", "P", "F", "R"), ...) 25 | 26 | \method{parameters}{dynamic}(x) 27 | 28 | \method{parameters}{dynamic}(x) <- value 29 | } 30 | \arguments{ 31 | \item{x}{a dynamic object to print, plot, convert to a transition matrix, or 32 | an object to test as a dynamic object (for \code{is.dynamic}),} 33 | 34 | \item{which}{which type of matrix to build: the overall population growth 35 | matrix (\code{'A'}), the probabilistic progression matrix (\code{'P'}), the 36 | fecundity matrix (\code{'F'}) or the intrinsic reproduction matrix 37 | (\code{'R'})} 38 | 39 | \item{value}{a nested named list of parameters within each transition 40 | matching those currently defined for \code{x}} 41 | 42 | \item{\dots}{for \code{dynamic()}: one or more \code{transition} (or other 43 | \code{dynamic}) objects making up the dynamic. For \code{plot()} and 44 | \code{print()}: further arguments passed to or from other methods} 45 | } 46 | \description{ 47 | creates a \code{dynamic} object, comprising multiple 48 | \code{transition} objects to define a dynamical system. \code{dynamic} 49 | objects are the core of \code{pop}, since they can be created and updated 50 | using various methods (MPMs, IPMs etc.), combined (by addition of two 51 | \code{dynamic} objects to make another) and and analysed in various ways 52 | (deterministically to obtain demographic parameters, simulated to evaluate 53 | population viability etc.) 54 | } 55 | \examples{ 56 | # define transitions for a simple three-stage system (with implicit 57 | # mortality): 58 | stasis_egg <- tr(egg ~ egg, p(0.4)) 59 | stasis_larva <- tr(larva ~ larva, p(0.3)) 60 | stasis_adult <- tr(adult ~ adult, p(0.8)) 61 | hatching <- tr(larva ~ egg, p(0.5)) 62 | fecundity <- tr(egg ~ adult, r(3)) 63 | pupation <- tr(adult ~ larva, p(0.2)) 64 | 65 | # combine these into separate dynamics 66 | stasis <- dynamic(stasis_egg, 67 | stasis_larva, 68 | stasis_adult) 69 | growth <- dynamic(hatching, 70 | pupation) 71 | reproduction <- dynamic(fecundity) 72 | 73 | # combine these into one dynamic (the same as listing all the transitions 74 | # separately) 75 | all <- dynamic(stasis, growth, reproduction) 76 | 77 | # plot these 78 | plot(stasis) 79 | plot(growth) 80 | plot(all) 81 | 82 | # get component states 83 | states(all) 84 | 85 | # print method 86 | print(all) 87 | 88 | # convert to a transition matrix 89 | as.matrix(all) 90 | # extract the parameters 91 | (param_stasis <- parameters(stasis)) 92 | (param_all <- parameters(all)) 93 | 94 | # update the parameters of these transfuns 95 | param_stasis$stasis_egg$p <- 0.6 96 | parameters(stasis) <- param_stasis 97 | parameters(stasis) 98 | 99 | param_all$fecundity$r <- 15 100 | parameters(all) <- param_all 101 | parameters(all) 102 | } 103 | 104 | -------------------------------------------------------------------------------- /man/landscape.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/landscape-class.R 3 | \name{landscape} 4 | \alias{[[.landscape} 5 | \alias{area} 6 | \alias{area<-} 7 | \alias{as.landscape} 8 | \alias{distance} 9 | \alias{distance<-} 10 | \alias{features} 11 | \alias{features<-} 12 | \alias{is.landscape} 13 | \alias{landscape} 14 | \alias{landscape<-} 15 | \alias{population} 16 | \alias{population<-} 17 | \alias{print.landscape} 18 | \title{landscape objects} 19 | \usage{ 20 | landscape(dynamic) 21 | 22 | landscape(dynamic) <- value 23 | 24 | as.landscape(patches) 25 | 26 | is.landscape(x) 27 | 28 | \method{print}{landscape}(x, ...) 29 | 30 | area(landscape) 31 | 32 | area(landscape) <- value 33 | 34 | population(landscape) 35 | 36 | population(landscape) <- value 37 | 38 | features(landscape) 39 | 40 | features(landscape) <- value 41 | 42 | distance(landscape) 43 | 44 | distance(landscape) <- value 45 | 46 | \method{[[}{landscape}(x, i) 47 | } 48 | \arguments{ 49 | \item{dynamic}{an object of class \code{dynamic}} 50 | 51 | \item{value}{an object of class \code{landscape} (for 52 | \code{landscape(dynamic) <- value}) or the value to assign to the 53 | \code{distance}, \code{area}, \code{population}, or \code{features} 54 | elements of a \code{landscape} object} 55 | 56 | \item{patches}{an object to turn into a \code{landscape} object. Currently 57 | this can either be a dynamic, a list or \code{NULL} (see \code{details}), 58 | though more approaches will be added in the future} 59 | 60 | \item{x}{an object to print or test as a landscape object} 61 | 62 | \item{landscape}{an object of class \code{landscape}} 63 | 64 | \item{i}{index specifying the patches to include in the subset 65 | \code{landscape} object} 66 | 67 | \item{\dots}{further arguments passed to or from other methods.} 68 | } 69 | \value{ 70 | an object of class \code{landscape}, essentially a dataframe 71 | containing the coordinates, area, population and features (as columns) for 72 | each patch (rows) 73 | } 74 | \description{ 75 | \code{landscape} objects represent sets of patches forming a 76 | metapopulation, storing information (such as area, population and 77 | environmental features) that may impact on the dynamic transitions 78 | occurring in each component patch. \code{dynamic} objects all have a 79 | \code{landscape} object (by default a single-patch landscape) as a an 80 | attribute which can be accessed and set via the function \code{landscape}. 81 | \code{as.landscape} is used to create landscape objects, and the functions 82 | \code{population}, \code{area}, \code{distance} and \code{features} 83 | access and set each of the elements of a landscape. 84 | } 85 | \details{ 86 | The accessor function \code{landscape} either returns or sets the 87 | landscape structure of the dynamic, encoded as a \code{\link{landscape}} 88 | object 89 | 90 | \code{patches} can be a list containing the following elements: 91 | \code{population}, a dataframe giving the number of individuals of each 92 | stage (columns) within each patch (rows); \code{area}, a one-column 93 | dataframe giving the areas of the patches in square kilometres; 94 | \code{coordinates}, a dataframe giving the coordinates of the habitat 95 | patches; and \code{features}, a dataframe containing miscellaneous features 96 | (columns) of the patches (rows), such as measures of patch quality or 97 | environmental variables. Alternatively, \code{patches = NULL}, will set up 98 | a 'default' one-patch landscape with \code{area = data.frame(area =1)}, 99 | \code{coordinates = data.frame(x = 0, y = 0)} and blank \code{population} 100 | and \code{features} elements. The other option is to pass a \code{dynamic} 101 | object as \code{patches}, in which case the set up will be the same as for 102 | \code{patches = NULL} except that \code{population} will be a one-row 103 | dataframe of 0s, with columns corresponding to the states in the dynamic. 104 | This is what's used when analysing a \code{dynamic} object without 105 | user-specified metapopulation structure. 106 | 107 | the accessor functions \code{distance}, \code{area}, 108 | \code{population} and \code{features} either return or set corresponding 109 | sub-dataframes of the \code{landscape} object 110 | } 111 | \examples{ 112 | # create a default landscape 113 | landscape <- as.landscape(NULL) 114 | 115 | # create a marginally more interesting one-patch landscape 116 | landscape <- as.landscape(list(coordinates = data.frame(x = c(10, 11), 117 | y = c(11, 12)), 118 | area = data.frame(area = 10), 119 | population = data.frame(adult = 10, 120 | larva = 3, 121 | egg = 20), 122 | features = data.frame(temperature = 10))) 123 | # print method 124 | print(landscape) 125 | 126 | # get and set the area 127 | area(landscape) 128 | area(landscape) <- area(landscape) * 2 129 | area(landscape) 130 | 131 | # get and set the population 132 | population(landscape) 133 | population(landscape) <- population(landscape) * 2 134 | population(landscape) 135 | 136 | # get and set the features 137 | features(landscape) 138 | features(landscape) <- cbind(features(landscape), rainfall = 100) 139 | features(landscape) 140 | 141 | # get and set the distance matrix 142 | distance(landscape) 143 | distance(landscape) <- sqrt(distance(landscape)) 144 | distance(landscape) 145 | 146 | # landscapes can be subsetted to get sub-landscapes of patches with double 147 | # braces 148 | landscape 149 | landscape[[1]] 150 | landscape[[1:2]] 151 | 152 | } 153 | 154 | -------------------------------------------------------------------------------- /man/parameters.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/parameters-method.R 3 | \name{parameters} 4 | \alias{parameters} 5 | \alias{parameters<-} 6 | \title{get and set parameters} 7 | \usage{ 8 | parameters(x) 9 | 10 | parameters(x) <- value 11 | } 12 | \arguments{ 13 | \item{x}{an object from which to extract parameters, or in which to set them} 14 | 15 | \item{value}{an object to assign as the parameters of \code{x}} 16 | } 17 | \description{ 18 | this documents the S3 generic functions \code{parameters} to 19 | extract or assign parameter values from objects in the \code{pop} package. 20 | Methods of this function are defined for various object classes, including 21 | \code{transfun}, \code{transition} and \code{dynamic} objects. 22 | } 23 | \details{ 24 | each class-specific method will return parameters in a slightly 25 | different structure, and will require \code{value} to be provided in a 26 | different format (though the structures returned and required will 27 | generally be the same for all classes. See the helpfile for each class for 28 | the specific details and examples. 29 | } 30 | 31 | -------------------------------------------------------------------------------- /man/pop.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/pop.R 3 | \docType{package} 4 | \name{pop} 5 | \alias{pop} 6 | \alias{pop-package} 7 | \title{pop: A Flexible Syntax for Population Dynamic Modelling} 8 | \description{ 9 | Models of population dynamics underpin a range of analyses and 10 | applications in ecology and epidemiology. The various approaches for 11 | fitting and analysing these models (MPMs, IPMs, ODEs, POMPs, PVA, with and 12 | without metapopulation structure) are generally fitted using different 13 | software, each with a different interface. This makes it difficult to 14 | combine various modelling approaches and data types to solve a given 15 | problem. pop aims to provide a flexible and easy to use common interface 16 | for constructing population dynamic models and enabling to them to be 17 | fitted and analysed in various ways. 18 | } 19 | 20 | -------------------------------------------------------------------------------- /man/probability.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/transfun_probability.R 3 | \name{probability} 4 | \alias{is.probability} 5 | \alias{p} 6 | \alias{probability} 7 | \title{probability transfun} 8 | \usage{ 9 | probability(value) 10 | 11 | p(value) 12 | 13 | is.probability(x) 14 | } 15 | \arguments{ 16 | \item{value}{a numeric between 0 and 1 representing a probability} 17 | 18 | \item{x}{an object to be tested as a probability transfun object} 19 | } 20 | \description{ 21 | Create a transfun object representing a probability of 22 | transition between states. Typically used inside a call to 23 | \code{\link{transition}} 24 | } 25 | \details{ 26 | \code{p()} is a shorthand for \code{probability()}. 27 | } 28 | \examples{ 29 | # these are equivalent 30 | prob <- probability(0.2) 31 | prob <- p(0.2) 32 | 33 | is.probability(prob) 34 | } 35 | 36 | -------------------------------------------------------------------------------- /man/projection.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/projection-class.R 3 | \name{projection} 4 | \alias{is.pop_projection} 5 | \alias{plot.pop_projection} 6 | \alias{projection} 7 | \title{Deterministic projection} 8 | \usage{ 9 | projection(dynamic, population, timesteps = 1) 10 | 11 | is.pop_projection(x) 12 | 13 | \method{plot}{pop_projection}(x, states = NULL, patches = 1, ...) 14 | } 15 | \arguments{ 16 | \item{dynamic}{a population dynamic model of class \code{\link{dynamic}}} 17 | 18 | \item{population}{a dataframe or named vector of positive integers, giving 19 | the number of individuals in each state of \code{dynamic}. If a dataframe, 20 | it should have only one row (as in the examples below), or as many rows as 21 | patches in the metapopulation if a multi-patch landscape has been defined 22 | for \code{dynamic} (using \code{\link{landscape}}). If a multi-patch 23 | landscape has been defined for \code{dynamic}, but \code{population} has 24 | only one row or is a vector, this population will be duplicated for all 25 | patches in the landscape.} 26 | 27 | \item{timesteps}{a positive integer giving the number of time steps 28 | (iterations) over which to simulate the model} 29 | 30 | \item{x}{a \code{pop_projection} object, or an object to be tested as one} 31 | 32 | \item{states}{character vector naming the states in the \code{dynamic} object 33 | used to run the projection that should be plotted. By default all of them 34 | are plotted.} 35 | 36 | \item{patches}{vector of positive integers identifying the patches for which 37 | to plot the projections. By default only projections for the first patch 38 | are plotted.} 39 | 40 | \item{\dots}{further arguments passed to or from other methods.} 41 | } 42 | \value{ 43 | an object of class \code{pop_projection} 44 | } 45 | \description{ 46 | Project a population dynamic model in discrete time, recording 47 | the number of individuals in each state at each time point. 48 | } 49 | \examples{ 50 | # set up a three-stage model 51 | stasis_egg <- tr(egg ~ egg, p(0.6)) 52 | stasis_larva <- tr(larva ~ larva, p(0.4)) 53 | stasis_adult <- tr(adult ~ adult, p(0.9)) 54 | hatching <- tr(larva ~ egg, p(0.35)) 55 | fecundity <- tr(egg ~ adult, r(20)) 56 | pupation <- tr(adult ~ larva, p(0.2)) 57 | 58 | pd <- dynamic(stasis_egg, 59 | stasis_larva, 60 | stasis_adult, 61 | hatching, 62 | pupation, 63 | fecundity) 64 | 65 | population <- data.frame(egg = 1200, larva = 250, adult = 50) 66 | 67 | # simulate for 50 timesteps, 30 times 68 | proj <- projection(dynamic = pd, 69 | population = population, 70 | timesteps = 50) 71 | 72 | is.pop_projection(proj) 73 | 74 | par(mfrow = c(3, 1)) 75 | plot(proj) 76 | } 77 | 78 | -------------------------------------------------------------------------------- /man/rate.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/transfun_rate.R 3 | \name{rate} 4 | \alias{is.rate} 5 | \alias{r} 6 | \alias{rate} 7 | \title{rate transfun} 8 | \usage{ 9 | rate(value) 10 | 11 | r(value) 12 | 13 | is.rate(x) 14 | } 15 | \arguments{ 16 | \item{value}{a numeric greater than 0 representing a rate} 17 | 18 | \item{x}{an object to be tested as a rate transfun object} 19 | } 20 | \description{ 21 | Create a transfun object representing a rate of transition 22 | between states - e.g. an expected number of offspring generated into one 23 | state from another. Typically used inside a call to 24 | \code{\link{transition}} 25 | } 26 | \details{ 27 | \code{r()} is a shorthand for \code{rate()}. 28 | } 29 | \examples{ 30 | # these are equivalent 31 | rate <- rate(0.2) 32 | rate <- r(0.2) 33 | 34 | is.rate(rate) 35 | } 36 | 37 | -------------------------------------------------------------------------------- /man/simulation.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/simulation-class.R 3 | \name{simulation} 4 | \alias{is.simulation} 5 | \alias{plot.simulation} 6 | \alias{simulation} 7 | \title{Stochastic Simulation} 8 | \usage{ 9 | simulation(dynamic, population, timesteps = 1, replicates = 1, 10 | ncores = NULL) 11 | 12 | is.simulation(x) 13 | 14 | \method{plot}{simulation}(x, states = NULL, patches = 1, ...) 15 | } 16 | \arguments{ 17 | \item{dynamic}{a population dynamic model of class \code{\link{dynamic}}} 18 | 19 | \item{population}{a dataframe or named vector of positive integers, giving 20 | the number of individuals in each state of \code{dynamic}. If a dataframe, 21 | it should have only one row (as in the examples below), or as many rows as 22 | patches in the metapopulation if a multi-patch landscape has been defined 23 | for \code{dynamic} (using \code{\link{landscape}}). If a multi-patch 24 | landscape has been defined for \code{dynamic}, but \code{population} has 25 | only one row or is a vector, this population will be duplicated for all 26 | patches in the landscape.} 27 | 28 | \item{timesteps}{a positive integer giving the number of time steps 29 | (iterations) over which to simulate the model} 30 | 31 | \item{replicates}{a positive integer giving the number of independent time 32 | series to simulate} 33 | 34 | \item{ncores}{an optional positive integer giving the number of cpu cores to 35 | use when running simulations. By default (when \code{ncores = NULL}) all 36 | cores are used (or as many as \code{parallel::detectCores} can find). This 37 | argument is ignored is \code{replicates = 1}} 38 | 39 | \item{x}{a \code{simulation} object, or an object to be tested as a \code{simulation}} 40 | 41 | \item{states}{a character vector naming the states in the \code{dynamic} 42 | object used to run the simulation that should be plotted. By default all of 43 | them are.} 44 | 45 | \item{patches}{vector of positive integers identifying the patches for which 46 | to plot the simulations. By default only projections for the first patch 47 | are plotted.} 48 | 49 | \item{\dots}{further arguments passed to or from other methods.} 50 | } 51 | \value{ 52 | an object of class \code{simulation} 53 | } 54 | \description{ 55 | Simulate a population dynamic model in discrete time, recording 56 | the number of individuals in each state at each time point. 57 | } 58 | \details{ 59 | The order of the dynamics in the simulation is defined by the order 60 | in which the transitions were passed to \code{dynamic}. I.e. if the stasis 61 | probability of a life stage (e.g. fraction surviving and remaining in the 62 | stage) was specified before the reproduction rate, then only those staying 63 | in the state will reproduce. Conversely, if reproduction was given first, 64 | individuals will reproduce before the stasis probability is applied. 65 | } 66 | \examples{ 67 | # set up a three-stage model 68 | stasis_egg <- tr(egg ~ egg, p(0.6)) 69 | stasis_larva <- tr(larva ~ larva, p(0.4)) 70 | stasis_adult <- tr(adult ~ adult, p(0.9)) 71 | hatching <- tr(larva ~ egg, p(0.35)) 72 | fecundity <- tr(egg ~ adult, r(20)) 73 | pupation <- tr(adult ~ larva, p(0.2)) 74 | 75 | pd <- dynamic(stasis_egg, 76 | stasis_larva, 77 | stasis_adult, 78 | hatching, 79 | pupation, 80 | fecundity) 81 | 82 | population <- data.frame(egg = 1200, larva = 250, adult = 50) 83 | 84 | # simulate for 50 timesteps, 30 times 85 | sim <- simulation(dynamic = pd, 86 | population = population, 87 | timesteps = 50, 88 | replicates = 30, 89 | ncores = 1) 90 | 91 | is.simulation(sim) 92 | par(mfrow = c(3, 1)) 93 | plot(sim) 94 | } 95 | 96 | -------------------------------------------------------------------------------- /man/transfun.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/transfun-class.R 3 | \name{transfun} 4 | \alias{*.transfun} 5 | \alias{is.transfun} 6 | \alias{parameters.transfun} 7 | \alias{parameters<-.transfun} 8 | \alias{print.transfun} 9 | \alias{transfun} 10 | \title{transfun objects} 11 | \usage{ 12 | is.transfun(x) 13 | 14 | \method{print}{transfun}(x, ...) 15 | 16 | \method{*}{transfun}(x, y) 17 | 18 | \method{parameters}{transfun}(x) 19 | 20 | \method{parameters}{transfun}(x) <- value 21 | } 22 | \arguments{ 23 | \item{x}{a transfun object to print or an object to test as a transfun object} 24 | 25 | \item{y}{a transfun object to be multiplied with another with the same 26 | pathway} 27 | 28 | \item{value}{a named list of parameters matching those currently defined for \code{x}} 29 | 30 | \item{\dots}{further arguments passed to or from other methods.} 31 | } 32 | \description{ 33 | utility functions for the \code{transfun} class. \code{transfun} 34 | objects are created by functions such as \code{\link{probability}}. 35 | } 36 | \details{ 37 | multiplication of transfun objects with the same pathway results in 38 | a compound transfun object (also of class \code{transfun}). When used in a 39 | stochastic model, the two stochastic transitions are evaluated one after 40 | another. When analysed deterministically, the expectation of the compound 41 | transition function is taken as the product of the expectations of the two 42 | basis transfuns. 43 | } 44 | \examples{ 45 | prob <- p(0.3) 46 | is.transfun(prob) 47 | 48 | prob 49 | (compound <- prob * r(4.3)) 50 | 51 | # extract the transfun parameters 52 | (param_prob <- parameters(prob)) 53 | (param_compound <- parameters(compound)) 54 | 55 | # update the parameters of these transfuns 56 | param_prob$p <- 0.6 57 | parameters(prob) <- param_prob 58 | parameters(prob) 59 | 60 | param_compound$r <- 15 61 | parameters(compound) <- param_compound 62 | parameters(compound) 63 | } 64 | 65 | -------------------------------------------------------------------------------- /man/transition.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/transition-class.R 3 | \name{transition} 4 | \alias{*.transition} 5 | \alias{is.transition} 6 | \alias{parameters.transition} 7 | \alias{parameters<-.transition} 8 | \alias{print.transition} 9 | \alias{tr} 10 | \alias{transition} 11 | \title{transition objects} 12 | \usage{ 13 | transition(formula, transfun) 14 | 15 | tr(formula, transfun) 16 | 17 | is.transition(x) 18 | 19 | \method{print}{transition}(x, ...) 20 | 21 | \method{*}{transition}(x, y) 22 | 23 | \method{parameters}{transition}(x) 24 | 25 | \method{parameters}{transition}(x) <- value 26 | } 27 | \arguments{ 28 | \item{formula}{a two-sided formula identifying the states between which the 29 | transition occurs} 30 | 31 | \item{transfun}{a \code{\link{transfun}} object quantifying the transition.} 32 | 33 | \item{x}{an object to print or test as a transition object} 34 | 35 | \item{y}{a transition object to be multiplied with another with the same 36 | pathway} 37 | 38 | \item{value}{a named list of parameters matching those currently defined for \code{x}} 39 | 40 | \item{\dots}{further arguments passed to or from other methods.} 41 | } 42 | \description{ 43 | creates a \code{transition} object, encoding a transition 44 | between two states. E.g. the probability of a seed germinating, or of an 45 | individual surviving in each time step 46 | } 47 | \details{ 48 | \code{tr} is just a shorthand for \code{transition} 49 | 50 | multiplication of transition objects with the same pathway results 51 | in a transition object whose \code{transfun} object is a compound of the 52 | two transfuns in the transitions. See \code{\link{transfun}} for more 53 | details of compound transfuns. 54 | } 55 | \examples{ 56 | # 50/50 chance of a larva emerging from an egg 57 | hatching <- tr(larva ~ egg, p(0.5)) 58 | 59 | # three eggs laid per adult per time step 60 | fecundity <- tr(egg ~ adult, r(3)) 61 | 62 | # 0.1 probability of a larva pupating into an adult 63 | pupa <- tr(adult ~ larva, p(0.1)) 64 | 65 | # print method 66 | print(pupa) 67 | 68 | # make a compound transition to include a probability of laying eggs 69 | prob_laying <- tr(egg ~ adult, p(0.6)) 70 | (recruitment <- prob_laying * fecundity) 71 | 72 | # extract the transfun parameters 73 | (param_pupa <- parameters(pupa)) 74 | (param_recruitment <- parameters(recruitment)) 75 | 76 | # update the parameters of these transfuns 77 | param_pupa$p <- 0.6 78 | parameters(pupa) <- param_pupa 79 | parameters(pupa) 80 | 81 | param_recruitment$r <- 15 82 | parameters(recruitment) <- param_recruitment 83 | parameters(recruitment) 84 | } 85 | 86 | -------------------------------------------------------------------------------- /readme.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | output: 3 | md_document: 4 | variant: markdown_github 5 | --- 6 | 7 | # pop 8 | 9 | ### A Flexible Syntax for Population Dynamic Modelling 10 | 11 | [![Build Status](https://travis-ci.org/goldingn/pop.svg)](https://travis-ci.org/goldingn/pop) 12 | [![codecov.io](https://codecov.io/github/goldingn/pop/coverage.svg?branch=master)](https://codecov.io/github/goldingn/pop?branch=master) 13 | [![cran version](http://www.r-pkg.org/badges/version/pop)](https://cran.rstudio.com/web/packages/pop) 14 | 15 | Population dynamic models underpin a range of analyses and applications in 16 | ecology and epidemiology. The various approaches for analysing population dynamics 17 | models (MPMs, IPMs, ODEs, POMPs, PVA) each require the model to be defined in a different way. 18 | This makes it difficult to combine different modelling approaches and data types 19 | to solve a given problem. `pop` aims to provide a flexible and easy to use common 20 | interface for constructing population dynamic models and enabling to them to be 21 | fitted and analysed in lots of different ways. 22 | 23 | This package is a work in progress. So far you can create stage-structured dynamical models, add density dependence and metapopulation structure, convert them to transition matrices and project them into the future, both stochastically and deterministically. Future developments will add continuous traits (for e.g. age- and size-structured models) and support for fitting these models against various data types. 24 | 25 | #### Installation 26 | 27 | `pop` is now on [CRAN](https://cran.r-project.org/package=pop), so you can install the package with: 28 | 29 | ```{r install1, eval = FALSE} 30 | install.packages('pop') 31 | ``` 32 | 33 | You can also install the development version directly from GitHub using the `devtools` package: 34 | 35 | ```{r install, eval = FALSE} 36 | devtools::install_github('goldingn/pop') 37 | library(pop) 38 | ``` 39 | 40 | #### Creating a simple population dynamic model 41 | 42 | ```{r load, eval = TRUE, echo = FALSE} 43 | library(pop) 44 | set.seed(1) 45 | library(knitr) 46 | knit_hooks$set(set_xpd = function (before, options, envir) par(xpd = NA)) 47 | ``` 48 | 49 | `dynamic` objects (created with the function `dynamic()`) are the core of `pop` since they encode dynamical systems, can be updated by fitting to data, and can be analysed in a variety of ways. `dynamic` objects are composed of a series of `transitions` encoding the links between different states in the dynamic. That's all a bit generic, so here's an example for a simple ecological population with three life stages (states). 50 | 51 | First we define the different types of transitions between the states: 52 | 53 | ```{r transitions} 54 | # probability of staying in the same step between timesteps 55 | survival_egg <- tr(eggs ~ eggs, p(0.4)) 56 | survival_larva <- tr(larvae ~ larvae, p(0.3)) 57 | survival_adult <- tr(adults ~ adults, p(0.9)) 58 | 59 | # probability of moving to the next state 60 | hatching <- tr(larvae ~ eggs, p(0.5)) 61 | pupation <- tr(adults ~ larvae, p(0.2)) 62 | 63 | # probability and number of eggs laid 64 | prob_laying <- tr(eggs ~ adults, p(0.5)) 65 | fecundity <- tr(eggs ~ adults, r(30)) 66 | ``` 67 | 68 | Next we can combine these to create dynamics (systems of transitions). We'll make these three different dynamics to start with: 69 | 70 | ```{r dynamics} 71 | survival <- dynamic(survival_egg, 72 | survival_larva, 73 | survival_adult) 74 | 75 | growth <- dynamic(pupation, 76 | hatching) 77 | 78 | # we want the product of these two things, which we might estimate separately 79 | recruitment <- dynamic(prob_laying * fecundity) 80 | ``` 81 | 82 | We can plot each of these to see what they look like schematically: 83 | 84 | ```{r plot_dynamics, fig.width = 9, fig.height = 4, dpi = 300, set_xpd = TRUE} 85 | par(mfrow = c(1, 3)) 86 | plot(survival); title(main = 'survival') 87 | plot(growth); title(main = 'growth') 88 | plot(recruitment); title(main = 'recruitment') 89 | ``` 90 | 91 | These components aren't particularly useful on their own though, so we should combine them into one overall population dynamic: 92 | 93 | ```{r all_dynamics, fig.height = 4.5, fig.width = 9, dpi = 300, set_xpd = TRUE} 94 | # note that the order of transitions in the dynamic determines the order in 95 | # which transitions occur, and may influence the dynamics. 96 | all <- dynamic(survival, 97 | growth, 98 | recruitment) 99 | 100 | par(mfrow = c(1, 2)) 101 | plot(all) 102 | ``` 103 | 104 | #### Doing things with models 105 | 106 | We can convert any of these objects into transition matrices, and analyse them deterministically using functions from other matrix population model packages, like `popbio` and `popdemo`: 107 | 108 | ```{r popdemo, fig.height = 3, fig.width = 9, dpi = 300} 109 | (A <- as.matrix(all)) 110 | 111 | # estimate the intrinsic growth rate & stable stage distribution 112 | popbio::lambda(A) 113 | (ss <- popbio::stable.stage(A)) 114 | 115 | # get an initial population 116 | population <- round(ss * 100) 117 | 118 | # plot deterministic trajectory from this population 119 | par(mfrow = c(1, 3)) 120 | plot(popdemo::project(A, population, time = 50)) 121 | ``` 122 | 123 | We can also use the function `simulation` to carry out discrete-time stochastic simulations from dynamic objects: 124 | 125 | ```{r simulation, fig.height = 3, fig.width = 9, dpi = 300} 126 | # simulate 30 times for 50 generations each 127 | sim <- simulation(dynamic = all, 128 | population = population, 129 | timesteps = 50, 130 | replicates = 30) 131 | 132 | # plot abundance of the three life stages 133 | par(mfrow = c(1, 3)) 134 | plot(sim) 135 | ``` 136 | 137 | #### Density dependence 138 | 139 | `pop` supports user-defined transition functions that depend on aspects of the landscape, like the population size, patch area or other environmental drivers. 140 | We can use this functionality to update the above simulation analysis with density-dependent adult survival (see `?as.transfun` for details on how to define bespoke transition functions): 141 | 142 | ```{r dd_function, fig.height = 3, fig.width = 9, dpi = 300} 143 | # density-dependent adult survival function (patch is a required argument) 144 | ddfun <- function (landscape) { 145 | adult_density <- population(landscape)$adults / area(landscape)$area 146 | param$p * exp(-adult_density / param$area) 147 | } 148 | 149 | # turn it into a transfun object 150 | dd <- as.transfun(ddfun, 151 | param = list(p = 0.9, 152 | area = 100), 153 | type = 'probability') 154 | 155 | # use it in a transition and update the dynamic 156 | survival_adult_dd <- tr(adults ~ adults, dd) 157 | all_dd <- dynamic(survival_egg, 158 | survival_larva, 159 | survival_adult_dd, 160 | hatching, 161 | prob_laying * fecundity, 162 | pupation) 163 | 164 | # run the simulation (a little longer and with more simulations this time) 165 | sim_dd <- simulation(dynamic = all_dd, 166 | population = population, 167 | timesteps = 100, 168 | replicates = 100) 169 | 170 | # and plot it 171 | par(mfrow = c(1, 3)) 172 | plot(sim_dd) 173 | ``` 174 | 175 | While we used the `popdemo` function `project` to make deterministic projections from the earlier density-*independent* model, that approach can't account for the effect of density dependence. Instead, we can use `pop`'s `projection` function to make deterministic density-dependent projections: 176 | 177 | ```{r deterministic_dd, fig.height = 3, fig.width = 9, dpi = 300} 178 | # project for 100 time steps 179 | proj_dd <- projection(dynamic = all_dd, 180 | population = population, 181 | timesteps = 100) 182 | 183 | # and plot it 184 | par(mfrow = c(1, 3)) 185 | plot(proj_dd) 186 | ``` 187 | 188 | 189 | #### Metapopulation dynamics 190 | 191 | So far we have only looked at dynamics within a single population. `pop` also enables users to set up a metapopulation landscape on which to evaluate dynamics. Below we create a simple three-patch metapopulation and evaluate our density-dependent model on it. 192 | 193 | First we define and plot our metapopulation landscape. See `?landscape` for details for how to set up a landscape (more user-friendly methods will be available soon) 194 | 195 | ```{r define_metapop, fig.height = 4, fig.width = 9, dpi = 300} 196 | # set up the structure 197 | patches <- as.landscape(list(population = population(landscape(all_dd)), 198 | area = data.frame(area = c(0.2, 2, 5)), 199 | coordinates = data.frame(x = c(-3, 3, -2), 200 | y = c(-2, -1, 1)), 201 | features = features(landscape(all_dd)))) 202 | 203 | # plot it 204 | par(mfrow = c(1, 2)) 205 | symbols(x = patches[, 1], 206 | y = patches[, 2], 207 | circles = sqrt(patches[, 3] / pi), 208 | xlim = c(-4, 4), 209 | ylim = c(-3, 3), 210 | fg = grey(0.4), 211 | bg = grey(0.9), 212 | xlab = 'x', 213 | ylab = 'y', 214 | inches = FALSE, 215 | asp = 1) 216 | text(x = patches[, 1], 217 | y = patches[, 2], 218 | labels = 1:3) 219 | ``` 220 | 221 | Now we add an adult dispersal transition to the dynamic, add the landscape structure, and simulate starting with the same population of 100 individuals in all patches. 222 | 223 | ```{r simulate_metapop, fig.height = 3, fig.width = 9, dpi = 300} 224 | 225 | # 20% adults disperse & probability of moving to each patch decays exponentially 226 | adult_dispersal <- tr(adults ~ adults, p(0.4) * d(1)) 227 | 228 | # add this to the dynamic and assign the spatial structure 229 | all_dd_metapop <- dynamic(all_dd, adult_dispersal) 230 | landscape(all_dd_metapop) <- patches 231 | 232 | sim_dd_metapop <- simulation(dynamic = all_dd_metapop, 233 | population = population, 234 | timesteps = 100, 235 | replicates = 100) 236 | 237 | # and plot it 238 | par(mfrow = c(1, 3)) 239 | plot(sim_dd_metapop, 'adults', patches = 1:3) 240 | ``` 241 | 242 | We can also see what happens when we tweak the model's transition parameters, such as making dispersal between patches much less likely 243 | 244 | ```{r simulate_metapop2, fig.height = 3, fig.width = 9, dpi = 300} 245 | # set the dispersal probability low and see what happens 246 | param <- parameters(all_dd_metapop) 247 | param$adult_dispersal$p <- 0.001 248 | parameters(all_dd_metapop) <- param 249 | 250 | sim_dd_metapop2 <- simulation(dynamic = all_dd_metapop, 251 | population = population, 252 | timesteps = 100, 253 | replicates = 100) 254 | 255 | # and plot it 256 | par(mfrow = c(1, 3)) 257 | plot(sim_dd_metapop2, 'adults', patches = 1:3) 258 | 259 | ``` 260 | 261 | As before, we can also project this metapopulation deterministically, and extract transition matrices to use in other software. 262 | -------------------------------------------------------------------------------- /readme.md: -------------------------------------------------------------------------------- 1 | pop 2 | === 3 | 4 | ### A Flexible Syntax for Population Dynamic Modelling 5 | 6 | [![Build Status](https://travis-ci.org/goldingn/pop.svg)](https://travis-ci.org/goldingn/pop) [![codecov.io](https://codecov.io/github/goldingn/pop/coverage.svg?branch=master)](https://codecov.io/github/goldingn/pop?branch=master) [![cran version](http://www.r-pkg.org/badges/version/pop)](https://cran.rstudio.com/web/packages/pop) 7 | 8 | Population dynamic models underpin a range of analyses and applications in ecology and epidemiology. The various approaches for analysing population dynamics models (MPMs, IPMs, ODEs, POMPs, PVA) each require the model to be defined in a different way. This makes it difficult to combine different modelling approaches and data types to solve a given problem. `pop` aims to provide a flexible and easy to use common interface for constructing population dynamic models and enabling to them to be fitted and analysed in lots of different ways. 9 | 10 | This package is a work in progress. So far you can create stage-structured dynamical models, add density dependence and metapopulation structure, convert them to transition matrices and project them into the future, both stochastically and deterministically. Future developments will add continuous traits (for e.g. age- and size-structured models) and support for fitting these models against various data types. 11 | 12 | #### Installation 13 | 14 | `pop` is now on [CRAN](https://cran.r-project.org/package=pop), so you can install the package with: 15 | 16 | ``` r 17 | install.packages('pop') 18 | ``` 19 | 20 | You can also install the development version directly from GitHub using the `devtools` package: 21 | 22 | ``` r 23 | devtools::install_github('goldingn/pop') 24 | library(pop) 25 | ``` 26 | 27 | #### Creating a simple population dynamic model 28 | 29 | `dynamic` objects (created with the function `dynamic()`) are the core of `pop` since they encode dynamical systems, can be updated by fitting to data, and can be analysed in a variety of ways. `dynamic` objects are composed of a series of `transitions` encoding the links between different states in the dynamic. That's all a bit generic, so here's an example for a simple ecological population with three life stages (states). 30 | 31 | First we define the different types of transitions between the states: 32 | 33 | ``` r 34 | # probability of staying in the same step between timesteps 35 | survival_egg <- tr(eggs ~ eggs, p(0.4)) 36 | survival_larva <- tr(larvae ~ larvae, p(0.3)) 37 | survival_adult <- tr(adults ~ adults, p(0.9)) 38 | 39 | # probability of moving to the next state 40 | hatching <- tr(larvae ~ eggs, p(0.5)) 41 | pupation <- tr(adults ~ larvae, p(0.2)) 42 | 43 | # probability and number of eggs laid 44 | prob_laying <- tr(eggs ~ adults, p(0.5)) 45 | fecundity <- tr(eggs ~ adults, r(30)) 46 | ``` 47 | 48 | Next we can combine these to create dynamics (systems of transitions). We'll make these three different dynamics to start with: 49 | 50 | ``` r 51 | survival <- dynamic(survival_egg, 52 | survival_larva, 53 | survival_adult) 54 | 55 | growth <- dynamic(pupation, 56 | hatching) 57 | 58 | # we want the product of these two things, which we might estimate separately 59 | recruitment <- dynamic(prob_laying * fecundity) 60 | ``` 61 | 62 | We can plot each of these to see what they look like schematically: 63 | 64 | ``` r 65 | par(mfrow = c(1, 3)) 66 | plot(survival); title(main = 'survival') 67 | plot(growth); title(main = 'growth') 68 | plot(recruitment); title(main = 'recruitment') 69 | ``` 70 | 71 | ![](readme_files/figure-markdown_github/plot_dynamics-1.png) 72 | 73 | These components aren't particularly useful on their own though, so we should combine them into one overall population dynamic: 74 | 75 | ``` r 76 | # note that the order of transitions in the dynamic determines the order in 77 | # which transitions occur, and may influence the dynamics. 78 | all <- dynamic(survival, 79 | growth, 80 | recruitment) 81 | 82 | par(mfrow = c(1, 2)) 83 | plot(all) 84 | ``` 85 | 86 | ![](readme_files/figure-markdown_github/all_dynamics-1.png) 87 | 88 | #### Doing things with models 89 | 90 | We can convert any of these objects into transition matrices, and analyse them deterministically using functions from other matrix population model packages, like `popbio` and `popdemo`: 91 | 92 | ``` r 93 | (A <- as.matrix(all)) 94 | ``` 95 | 96 | ## eggs larvae adults 97 | ## eggs 0.2 0.00 13.5 98 | ## larvae 0.2 0.24 0.0 99 | ## adults 0.0 0.06 0.9 100 | ## attr(,"class") 101 | ## [1] "matrix" "transition_matrix" 102 | 103 | ``` r 104 | # estimate the intrinsic growth rate & stable stage distribution 105 | popbio::lambda(A) 106 | ``` 107 | 108 | ## [1] 1.106324 109 | 110 | ``` r 111 | (ss <- popbio::stable.stage(A)) 112 | ``` 113 | 114 | ## eggs larvae adults 115 | ## 0.77041868 0.17785915 0.05172217 116 | 117 | ``` r 118 | # get an initial population 119 | population <- round(ss * 100) 120 | 121 | # plot deterministic trajectory from this population 122 | par(mfrow = c(1, 3)) 123 | plot(popdemo::project(A, population, time = 50)) 124 | ``` 125 | 126 | ![](readme_files/figure-markdown_github/popdemo-1.png) 127 | 128 | We can also use the function `simulation` to carry out discrete-time stochastic simulations from dynamic objects: 129 | 130 | ``` r 131 | # simulate 30 times for 50 generations each 132 | sim <- simulation(dynamic = all, 133 | population = population, 134 | timesteps = 50, 135 | replicates = 30) 136 | 137 | # plot abundance of the three life stages 138 | par(mfrow = c(1, 3)) 139 | plot(sim) 140 | ``` 141 | 142 | ![](readme_files/figure-markdown_github/simulation-1.png) 143 | 144 | #### Density dependence 145 | 146 | `pop` supports user-defined transition functions that depend on aspects of the landscape, like the population size, patch area or other environmental drivers. We can use this functionality to update the above simulation analysis with density-dependent adult survival (see `?as.transfun` for details on how to define bespoke transition functions): 147 | 148 | ``` r 149 | # density-dependent adult survival function (patch is a required argument) 150 | ddfun <- function (landscape) { 151 | adult_density <- population(landscape)$adults / area(landscape)$area 152 | param$p * exp(-adult_density / param$area) 153 | } 154 | 155 | # turn it into a transfun object 156 | dd <- as.transfun(ddfun, 157 | param = list(p = 0.9, 158 | area = 100), 159 | type = 'probability') 160 | 161 | # use it in a transition and update the dynamic 162 | survival_adult_dd <- tr(adults ~ adults, dd) 163 | all_dd <- dynamic(survival_egg, 164 | survival_larva, 165 | survival_adult_dd, 166 | hatching, 167 | prob_laying * fecundity, 168 | pupation) 169 | 170 | # run the simulation (a little longer and with more simulations this time) 171 | sim_dd <- simulation(dynamic = all_dd, 172 | population = population, 173 | timesteps = 100, 174 | replicates = 100) 175 | 176 | # and plot it 177 | par(mfrow = c(1, 3)) 178 | plot(sim_dd) 179 | ``` 180 | 181 | ![](readme_files/figure-markdown_github/dd_function-1.png) 182 | 183 | While we used the `popdemo` function `project` to make deterministic projections from the earlier density-*independent* model, that approach can't account for the effect of density dependence. Instead, we can use `pop`'s `projection` function to make deterministic density-dependent projections: 184 | 185 | ``` r 186 | # project for 100 time steps 187 | proj_dd <- projection(dynamic = all_dd, 188 | population = population, 189 | timesteps = 100) 190 | 191 | # and plot it 192 | par(mfrow = c(1, 3)) 193 | plot(proj_dd) 194 | ``` 195 | 196 | ![](readme_files/figure-markdown_github/deterministic_dd-1.png) 197 | 198 | #### Metapopulation dynamics 199 | 200 | So far we have only looked at dynamics within a single population. `pop` also enables users to set up a metapopulation landscape on which to evaluate dynamics. Below we create a simple three-patch metapopulation and evaluate our density-dependent model on it. 201 | 202 | First we define and plot our metapopulation landscape. See `?landscape` for details for how to set up a landscape (more user-friendly methods will be available soon) 203 | 204 | ``` r 205 | # set up the structure 206 | patches <- as.landscape(list(population = population(landscape(all_dd)), 207 | area = data.frame(area = c(0.2, 2, 5)), 208 | coordinates = data.frame(x = c(-3, 3, -2), 209 | y = c(-2, -1, 1)), 210 | features = features(landscape(all_dd)))) 211 | 212 | # plot it 213 | par(mfrow = c(1, 2)) 214 | symbols(x = patches[, 1], 215 | y = patches[, 2], 216 | circles = sqrt(patches[, 3] / pi), 217 | xlim = c(-4, 4), 218 | ylim = c(-3, 3), 219 | fg = grey(0.4), 220 | bg = grey(0.9), 221 | xlab = 'x', 222 | ylab = 'y', 223 | inches = FALSE, 224 | asp = 1) 225 | text(x = patches[, 1], 226 | y = patches[, 2], 227 | labels = 1:3) 228 | ``` 229 | 230 | ![](readme_files/figure-markdown_github/define_metapop-1.png) 231 | 232 | Now we add an adult dispersal transition to the dynamic, add the landscape structure, and simulate starting with the same population of 100 individuals in all patches. 233 | 234 | ``` r 235 | # 20% adults disperse & probability of moving to each patch decays exponentially 236 | adult_dispersal <- tr(adults ~ adults, p(0.4) * d(1)) 237 | 238 | # add this to the dynamic and assign the spatial structure 239 | all_dd_metapop <- dynamic(all_dd, adult_dispersal) 240 | landscape(all_dd_metapop) <- patches 241 | 242 | sim_dd_metapop <- simulation(dynamic = all_dd_metapop, 243 | population = population, 244 | timesteps = 100, 245 | replicates = 100) 246 | 247 | # and plot it 248 | par(mfrow = c(1, 3)) 249 | plot(sim_dd_metapop, 'adults', patches = 1:3) 250 | ``` 251 | 252 | ![](readme_files/figure-markdown_github/simulate_metapop-1.png) 253 | 254 | We can also see what happens when we tweak the model's transition parameters, such as making dispersal between patches much less likely 255 | 256 | ``` r 257 | # set the dispersal probability low and see what happens 258 | param <- parameters(all_dd_metapop) 259 | param$adult_dispersal$p <- 0.001 260 | parameters(all_dd_metapop) <- param 261 | 262 | sim_dd_metapop2 <- simulation(dynamic = all_dd_metapop, 263 | population = population, 264 | timesteps = 100, 265 | replicates = 100) 266 | 267 | # and plot it 268 | par(mfrow = c(1, 3)) 269 | plot(sim_dd_metapop2, 'adults', patches = 1:3) 270 | ``` 271 | 272 | ![](readme_files/figure-markdown_github/simulate_metapop2-1.png) 273 | 274 | As before, we can also project this metapopulation deterministically, and extract transition matrices to use in other software. 275 | -------------------------------------------------------------------------------- /readme_files/figure-markdown_github/all_dynamics-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/goldingn/pop/b722cb0246ef2af61e49b8fa27e8a67c153385c6/readme_files/figure-markdown_github/all_dynamics-1.png -------------------------------------------------------------------------------- /readme_files/figure-markdown_github/dd_function-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/goldingn/pop/b722cb0246ef2af61e49b8fa27e8a67c153385c6/readme_files/figure-markdown_github/dd_function-1.png -------------------------------------------------------------------------------- /readme_files/figure-markdown_github/define_metapop-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/goldingn/pop/b722cb0246ef2af61e49b8fa27e8a67c153385c6/readme_files/figure-markdown_github/define_metapop-1.png -------------------------------------------------------------------------------- /readme_files/figure-markdown_github/deterministic_dd-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/goldingn/pop/b722cb0246ef2af61e49b8fa27e8a67c153385c6/readme_files/figure-markdown_github/deterministic_dd-1.png -------------------------------------------------------------------------------- /readme_files/figure-markdown_github/plot_dynamics-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/goldingn/pop/b722cb0246ef2af61e49b8fa27e8a67c153385c6/readme_files/figure-markdown_github/plot_dynamics-1.png -------------------------------------------------------------------------------- /readme_files/figure-markdown_github/popdemo-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/goldingn/pop/b722cb0246ef2af61e49b8fa27e8a67c153385c6/readme_files/figure-markdown_github/popdemo-1.png -------------------------------------------------------------------------------- /readme_files/figure-markdown_github/simulate_metapop-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/goldingn/pop/b722cb0246ef2af61e49b8fa27e8a67c153385c6/readme_files/figure-markdown_github/simulate_metapop-1.png -------------------------------------------------------------------------------- /readme_files/figure-markdown_github/simulate_metapop2-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/goldingn/pop/b722cb0246ef2af61e49b8fa27e8a67c153385c6/readme_files/figure-markdown_github/simulate_metapop2-1.png -------------------------------------------------------------------------------- /readme_files/figure-markdown_github/simulation-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/goldingn/pop/b722cb0246ef2af61e49b8fa27e8a67c153385c6/readme_files/figure-markdown_github/simulation-1.png -------------------------------------------------------------------------------- /tests/test-all.R: -------------------------------------------------------------------------------- 1 | Sys.setenv("R_TESTS" = "") 2 | library(testthat) 3 | test_check("pop") 4 | -------------------------------------------------------------------------------- /tests/testthat/test_deterministic_analyses.R: -------------------------------------------------------------------------------- 1 | context('deterministic-analysis') 2 | 3 | test_that('deterministic analyses work', { 4 | 5 | # set up a simple model and initial population 6 | # generate four types of dynamic 7 | stasis_egg <- tr(eggs ~ eggs, p(0.4)) 8 | stasis_larva <- tr(larvae ~ larvae, p(0.3)) 9 | stasis_adult <- tr(adults ~ adults, p(0.8)) 10 | hatching <- tr(larvae ~ eggs, p(0.5)) 11 | fecundity <- tr(eggs ~ adults, p(0.2) * r(3)) 12 | pupation <- tr(adults ~ larvae, p(0.2)) 13 | clonal <- tr(larvae ~ larvae, r(1.4)) 14 | 15 | all <- dynamic(stasis_egg, 16 | stasis_larva, 17 | stasis_adult, 18 | hatching, 19 | pupation, 20 | clonal, 21 | fecundity) 22 | 23 | population <- data.frame(eggs = 1000, 24 | larvae = 200, 25 | adults = 50) 26 | 27 | # project for some timesteps 28 | proj <- projection(dynamic = all, 29 | population = population, 30 | timesteps = 100) 31 | 32 | # check you can also do this with a vector 33 | proj <- projection(dynamic = all, 34 | population = unlist(population), 35 | timesteps = 100) 36 | 37 | # check it has the right class and structure 38 | expect_s3_class(proj, 'pop_projection') 39 | expect_s3_class(proj$dynamic, 'dynamic') 40 | expect_true(is.matrix(proj$projection)) 41 | 42 | # 30 replicates of 101 timepoints 43 | expect_equal(dim(proj$projection), c(101, 3)) 44 | 45 | # check there are no NAs in there 46 | expect_false(anyNA(proj$projection)) 47 | 48 | # each should have the right number of states 49 | expect_true(ncol(proj$projection) == length(states(all))) 50 | 51 | # check we get errors for dodgy inputs 52 | 53 | # for a transition instead of a dynamic 54 | expect_error(projection(dynamic = all[[1]], 55 | population = population, 56 | timesteps = 50)) 57 | 58 | # for the wrong size of population 59 | expect_error(projection(dynamic = all, 60 | population = population[1:2], 61 | timesteps = 50)) 62 | 63 | # for the wrong population names 64 | population2 <- population 65 | names(population2) <- paste0(names(population2), '_blaaaargh') 66 | expect_error(projection(dynamic = all, 67 | population = population2, 68 | timesteps = 50)) 69 | 70 | # nagative populations 71 | expect_error(projection(dynamic = all, 72 | population = population * -1, 73 | timesteps = 50)) 74 | 75 | # non-finite populations 76 | expect_error(projection(dynamic = all, 77 | population = population * Inf, 78 | timesteps = 50)) 79 | 80 | # NA populations 81 | expect_error(projection(dynamic = all, 82 | population = population * NA, 83 | timesteps = 50)) 84 | 85 | # check is.pop_projection 86 | expect_true(is.pop_projection(proj)) 87 | expect_false(is.pop_projection(proj$dynamic)) 88 | 89 | # check projection plotting 90 | 91 | # check output structure for one state 92 | plot_out_egg <- plot(proj, state = 'eggs') 93 | 94 | # list 95 | expect_true(is.matrix(plot_out_egg)) 96 | 97 | # first element as 3 columns and right no. rows 98 | expect_equal(dim(plot_out_egg), c(101,3)) 99 | # no NAs 100 | expect_false(anyNA(plot_out_egg)) 101 | 102 | # check output structure for all state 103 | plot_out_all <- plot(proj) 104 | # list 105 | expect_true(is.matrix(plot_out_all)) 106 | # first element as 3 columns and right no. rows 107 | expect_equal(dim(plot_out_all), c(101,3)) 108 | # no NAs 109 | expect_false(anyNA(plot_out_all)) 110 | 111 | # error on bad states 112 | expect_error(plot(proj, state = 'bee')) 113 | expect_error(plot(proj, state = NA)) 114 | 115 | # ~~~~~~~~~~ 116 | # test multi-patch models run and can be analysed in the same way 117 | 118 | # pick a dynamic and give it lots of patches 119 | ls <- landscape(all) 120 | n <- 10 121 | ls_new <- as.landscape(list(coordinates = data.frame(x = runif(n), 122 | y = runif(n)), 123 | area = area(ls), 124 | population = population(ls), 125 | features = features(ls))) 126 | landscape(all) <- ls_new 127 | 128 | # add dispersal into the dynamic 129 | adult_dispersal <- tr(adults ~ adults, p(0.5) * d(3)) 130 | all <- dynamic(all, adult_dispersal) 131 | landscape(all) <- ls_new 132 | 133 | # do projection 134 | proj <- projection(dynamic = all, 135 | population = population, 136 | timesteps = 10) 137 | 138 | # check it has the right class and structure 139 | expect_s3_class(proj, 'pop_projection') 140 | expect_s3_class(proj$dynamic, 'dynamic') 141 | expect_true(is.matrix(proj$projection)) 142 | 143 | # 30 replicates of 101 timepoints 144 | expect_equal(dim(proj$projection), c(11, 30)) 145 | 146 | # check there are no NAs in there 147 | expect_false(anyNA(proj$projection)) 148 | 149 | # plotting with specific states/patches 150 | proj_plot1 <- plot(proj) 151 | proj_plot2 <- plot(proj, states = 'eggs') 152 | proj_plot3 <- plot(proj, patches = 2) 153 | proj_plot4 <- plot(proj, states = 'larvae', patches = 2) 154 | 155 | # should be the same 156 | expect_equal(proj_plot1, proj_plot2) 157 | expect_equal(proj_plot1, proj_plot3) 158 | expect_equal(proj_plot1, proj_plot4) 159 | 160 | expect_error(plot(proj, states = 'larvae', patches = 11)) 161 | expect_error(plot(proj, states = 'larvae', patches = -1)) 162 | expect_error(plot(proj, states = 'bees', patches = 11)) 163 | expect_error(plot(proj, states = 'bees', patches = -1)) 164 | 165 | }) 166 | -------------------------------------------------------------------------------- /tests/testthat/test_dynamic_class.R: -------------------------------------------------------------------------------- 1 | context('dynamic-class') 2 | 3 | test_that('dynamic classes work', { 4 | 5 | # generate four types of dynamic 6 | stasis_egg <- tr(egg ~ egg, p(0.4)) 7 | stasis_larva <- tr(larva ~ larva, p(0.3)) 8 | stasis_adult <- tr(adult ~ adult, p(0.8)) 9 | hatching <- tr(larva ~ egg, p(0.5)) 10 | fecundity <- tr(egg ~ adult, p(0.2) * r(3)) 11 | pupation <- tr(adult ~ larva, p(0.2)) 12 | clonal <- tr(larva ~ larva, r(1.4)) 13 | 14 | stasis <- dynamic(stasis_egg, 15 | stasis_larva, 16 | stasis_adult) 17 | growth <- dynamic(hatching, 18 | pupation) 19 | reproduction <- dynamic(fecundity, 20 | clonal) 21 | all1 <- dynamic(stasis_egg, 22 | stasis_larva, 23 | stasis_adult, 24 | hatching, 25 | pupation, 26 | fecundity, 27 | clonal) 28 | 29 | # make sure adding dynamics is the same as compiling their transitions in 30 | # one go 31 | all2 <- dynamic(stasis, growth, reproduction) 32 | expect_equal(all2, all1) 33 | 34 | # check 3 trs, then two dynamics 35 | all3 <- dynamic(stasis_egg, 36 | stasis_larva, 37 | stasis_adult, 38 | growth, 39 | reproduction) 40 | expect_equal(all3, all1) 41 | 42 | # check dynamic sandwich 43 | all4 <- dynamic(stasis_egg, 44 | stasis_larva, 45 | stasis_adult, 46 | growth, 47 | fecundity, 48 | clonal) 49 | expect_equal(all4, all1) 50 | 51 | # check only one dynamic 52 | growth2 <- dynamic(growth) 53 | expect_equal(growth2, growth) 54 | 55 | 56 | # check they have the right class 57 | expect_s3_class(stasis, 'dynamic') 58 | expect_s3_class(growth, 'dynamic') 59 | expect_s3_class(reproduction, 'dynamic') 60 | expect_s3_class(all1, 'dynamic') 61 | expect_s3_class(all2, 'dynamic') 62 | 63 | # check is.dynamic works on dynamics 64 | expect_true(is.dynamic(stasis)) 65 | expect_true(is.dynamic(growth)) 66 | expect_true(is.dynamic(reproduction)) 67 | expect_true(is.dynamic(all1)) 68 | expect_true(is.dynamic(all2)) 69 | 70 | # check is.dynamic works on non-dynamics 71 | expect_false(is.dynamic(list())) 72 | expect_false(is.dynamic(NA)) 73 | expect_false(is.dynamic(NULL)) 74 | 75 | # check is.dynamic works on transitions 76 | expect_false(is.dynamic(stasis_egg)) 77 | expect_false(is.dynamic(fecundity)) 78 | 79 | # check as.dynamic works 80 | obj1 <- pop:::as.dynamic(list()) 81 | obj2 <- pop:::as.dynamic(NA) 82 | obj3 <- pop:::as.dynamic(Inf) 83 | expect_s3_class(obj1, 'dynamic') 84 | expect_s3_class(obj2, 'dynamic') 85 | expect_s3_class(obj3, 'dynamic') 86 | 87 | # check print.dynamic works 88 | expect_equal(capture.output(print(all1)), 89 | 'dynamic: transitions between: egg, larva, adult') 90 | expect_equal(capture.output(print(reproduction)), 91 | 'dynamic: transitions between: egg, adult, larva') 92 | 93 | # check as.matrix 94 | mat_stasis <- as.matrix(stasis) 95 | mat_growth <- as.matrix(growth) 96 | mat_reproduction <- as.matrix(reproduction) 97 | mat_all1 <- as.matrix(all1) 98 | mat_all2 <- as.matrix(all2) 99 | 100 | # check classes 101 | expect_s3_class(mat_stasis, c('matrix', 'transition_matrix')) 102 | expect_s3_class(mat_growth, c('matrix', 'transition_matrix')) 103 | expect_s3_class(mat_reproduction, c('matrix', 'transition_matrix')) 104 | expect_s3_class(mat_all1, c('matrix', 'transition_matrix')) 105 | expect_s3_class(mat_all2, c('matrix', 'transition_matrix')) 106 | 107 | # check dimensions are correct 108 | expect_equal(dim(mat_stasis), c(3, 3)) 109 | expect_equal(dim(mat_growth), c(3, 3)) 110 | expect_equal(dim(mat_reproduction), c(3, 3)) 111 | expect_equal(dim(mat_all1), c(3, 3)) 112 | expect_equal(dim(mat_all2), c(3, 3)) 113 | 114 | # check all1 and all2 are still the same even as matrices 115 | expect_equal(mat_all1, mat_all2) 116 | 117 | # compute F, P and R matrics and make sure they return something sensible 118 | mat_all1_F <- as.matrix(all1, which = 'F') 119 | mat_all2_F <- as.matrix(all2, which = 'F') 120 | mat_all1_P <- as.matrix(all1, which = 'P') 121 | mat_all2_P <- as.matrix(all2, which = 'P') 122 | mat_all1_R <- as.matrix(all1, which = 'R') 123 | mat_all2_R <- as.matrix(all2, which = 'R') 124 | 125 | # check classes 126 | expect_s3_class(mat_all1_F, c('matrix', 'transition_matrix')) 127 | expect_s3_class(mat_all2_F, c('matrix', 'transition_matrix')) 128 | expect_s3_class(mat_all1_P, c('matrix', 'transition_matrix')) 129 | expect_s3_class(mat_all2_P, c('matrix', 'transition_matrix')) 130 | expect_s3_class(mat_all1_R, c('matrix', 'transition_matrix')) 131 | expect_s3_class(mat_all2_R, c('matrix', 'transition_matrix')) 132 | 133 | # check dimensions are correct 134 | expect_equal(dim(mat_all1_F), c(3, 3)) 135 | expect_equal(dim(mat_all2_F), c(3, 3)) 136 | expect_equal(dim(mat_all1_P), c(3, 3)) 137 | expect_equal(dim(mat_all2_P), c(3, 3)) 138 | expect_equal(dim(mat_all1_R), c(3, 3)) 139 | expect_equal(dim(mat_all2_R), c(3, 3)) 140 | 141 | 142 | # check that plot returns an igraph object 143 | plot_stasis <- plot(stasis) 144 | plot_growth <- plot(growth) 145 | plot_reproduction <- plot(reproduction) 146 | plot_all1 <- plot(all1) 147 | plot_all2 <- plot(all2) 148 | expect_s3_class(plot_stasis, 'igraph') 149 | expect_s3_class(plot_growth, 'igraph') 150 | expect_s3_class(plot_reproduction, 'igraph') 151 | expect_s3_class(plot_all1, 'igraph') 152 | expect_s3_class(plot_all2, 'igraph') 153 | 154 | # get parameters of a dynamic 155 | expected_param_all <- list(stasis_egg = list(p = 0.4), 156 | stasis_larva = list(p = 0.3), 157 | stasis_adult = list(p = 0.8), 158 | hatching = list(p = 0.5), 159 | pupation = list(p = 0.2), 160 | fecundity = list(p = 0.2, r = 3), 161 | clonal = list(r = 1.4)) 162 | 163 | # check they're as expected in both dynamic creation methods 164 | expect_equal(parameters(all1), expected_param_all) 165 | expect_equal(parameters(all2), expected_param_all) 166 | 167 | # update them & check it comes through 168 | expected_param_all_updated <- expected_param_all 169 | expected_param_all_updated$fecundity$p <- 0.5 170 | parameters(all1) <- expected_param_all_updated 171 | expect_equal(parameters(all1), expected_param_all_updated) 172 | 173 | # ~~~~~~~~~~ 174 | # test multi-patch models run and can be analysed in the same way 175 | 176 | # pick a dynamic and give it lots of patches 177 | all <- all1 178 | ls <- landscape(all) 179 | n <- 10 180 | ls_new <- as.landscape(list(coordinates = data.frame(x = runif(n), 181 | y = runif(n)), 182 | area = area(ls), 183 | population = population(ls), 184 | features = features(ls))) 185 | landscape(all) <- ls_new 186 | 187 | # see what happens when we make a matrix 188 | mat <- as.matrix(all) 189 | expect_true(is.matrix(mat)) 190 | expect_equal(dim(mat), rep(n * 3, 2)) 191 | 192 | # add dispersal into the dynamic 193 | adult_dispersal <- tr(adult ~ adult, p(0.5) * d(3)) 194 | all_disp <- dynamic(all, 195 | adult_dispersal) 196 | landscape(all_disp) <- ls_new 197 | 198 | 199 | # check plotting 200 | plot_all_disp <- plot(all_disp) 201 | 202 | # convert to matrices 203 | mat_disp <- as.matrix(all_disp) 204 | matA_disp <- as.matrix(all_disp, which = 'A') 205 | matP_disp <- as.matrix(all_disp, which = 'P') 206 | matF_disp <- as.matrix(all_disp, which = 'F') 207 | matR_disp <- as.matrix(all_disp, which = 'R') 208 | 209 | # check classes 210 | expect_s3_class(mat_disp, c('matrix', 'transition_matrix')) 211 | expect_s3_class(matA_disp, c('matrix', 'transition_matrix')) 212 | expect_s3_class(matP_disp, c('matrix', 'transition_matrix')) 213 | expect_s3_class(matF_disp, c('matrix', 'transition_matrix')) 214 | expect_s3_class(matR_disp, c('matrix', 'transition_matrix')) 215 | 216 | # check dimensions are correct 217 | expect_equal(dim(mat_disp), c(30, 30)) 218 | expect_equal(dim(matA_disp), c(30, 30)) 219 | expect_equal(dim(matP_disp), c(30, 30)) 220 | expect_equal(dim(matF_disp), c(30, 30)) 221 | expect_equal(dim(matR_disp), c(30, 30)) 222 | 223 | # check there are/aren't 0s where there should/shouldn't be 224 | idx <- seq(0, 30, by = 3)[-1] 225 | cells <- as.matrix(expand.grid(idx, idx)) 226 | expect_true(all(matA_disp[cells] > 0)) 227 | expect_true(all(matP_disp[cells] > 0)) 228 | expect_true(all(matF_disp[cells] == 0)) 229 | 230 | # # make sure projection works for dispersals 231 | # proj <- projection(all_disp, 232 | # population = c(egg = 500, larva = 200, adult = 500), 233 | # timesteps = 100) 234 | 235 | }) 236 | -------------------------------------------------------------------------------- /tests/testthat/test_landscape_class.R: -------------------------------------------------------------------------------- 1 | context('landscape-class') 2 | 3 | test_that('landscape classes work', { 4 | 5 | # create a dummy dynamic to get at its landscape 6 | # set up a simple model and initial population 7 | # generate four types of dynamic 8 | stasis_egg <- tr(eggs ~ eggs, p(0.4)) 9 | stasis_larva <- tr(larvae ~ larvae, p(0.3)) 10 | stasis_adult <- tr(adults ~ adults, p(0.8)) 11 | hatching <- tr(larvae ~ eggs, p(0.5)) 12 | fecundity <- tr(eggs ~ adults, p(0.2) * r(3)) 13 | pupation <- tr(adults ~ larvae, p(0.2)) 14 | clonal <- tr(larvae ~ larvae, r(1.4)) 15 | 16 | all <- dynamic(stasis_egg, 17 | stasis_larva, 18 | stasis_adult, 19 | hatching, 20 | pupation, 21 | clonal, 22 | fecundity) 23 | 24 | ls_all <- landscape(all) 25 | ls_null <- as.landscape(NULL) 26 | ls_list <- as.landscape(list(coordinates = data.frame(x = runif(3), y = runif(3)), 27 | area = data.frame(area = c(10, 15, 12)), 28 | population = data.frame(eggs = 1, 29 | larvae = 3, 30 | adults = 12), 31 | features = data.frame()[1, ])) 32 | 33 | # class we're expecting 34 | expect_s3_class(ls_all, 'landscape') 35 | expect_s3_class(ls_null, 'landscape') 36 | expect_s3_class(ls_list, 'landscape') 37 | 38 | # is.landscape 39 | expect_true(is.landscape(ls_all)) 40 | expect_true(is.landscape(ls_null)) 41 | expect_true(is.landscape(ls_list)) 42 | expect_false(is.landscape(NA)) 43 | expect_false(is.landscape(list())) 44 | expect_false(is.landscape(NULL)) 45 | 46 | # expected print method output 47 | expect_equal(capture.output(print(ls_all)), 48 | 'landscape with 1 patches') 49 | expect_equal(capture.output(print(ls_null)), 50 | 'landscape with 1 patches') 51 | expect_equal(capture.output(print(ls_list)), 52 | 'landscape with 3 patches') 53 | 54 | # getting and setting areas 55 | expect_equal(area(ls_all)$area, 1) 56 | area(ls_all) <- data.frame(area = 3) 57 | expect_equal(area(ls_all)$area, 3) 58 | 59 | expect_equal(area(ls_null)$area, 1) 60 | area(ls_null) <- data.frame(area = 3) 61 | expect_equal(area(ls_null)$area, 3) 62 | 63 | expect_equal(area(ls_list)$area, c(10, 15, 12)) 64 | area(ls_list) <- data.frame(area = 3:1) 65 | expect_equal(area(ls_list)$area, 3:1) 66 | 67 | # wrong length 68 | expect_error(area(ls_list) <- 3) 69 | 70 | # getting and setting populations 71 | expect_equal(population(ls_all), 72 | data.frame(eggs = 0, larvae = 0, adults = 0)) 73 | population(ls_all) <- population(ls_all) + 3 74 | expect_equal(population(ls_all), 75 | data.frame(eggs = 3, larvae = 3, adults = 3)) 76 | 77 | # wrong lengths 78 | expect_error(population(ls_all) <- 3) 79 | 80 | # getting and setting features 81 | expect_equal(dim(features(ls_all)), c(1, 0)) 82 | features(ls_all) <- data.frame(temp = 10, rainfall = 11) 83 | expect_equal(features(ls_all), 84 | data.frame(temp = 10, rainfall = 11)) 85 | features(ls_all) <- data.frame(aridity = -1) 86 | expect_equal(features(ls_all), 87 | data.frame(aridity = -1)) 88 | 89 | # wrong dimension 90 | expect_error(features(ls_all) <- 3) 91 | 92 | # getting and setting distance matrices 93 | distance_list <- distance(ls_list) 94 | expect_true(is.matrix(distance_list)) 95 | expect_true(all(diag(distance_list) == 0)) 96 | expect_equal(dim(distance_list), c(3, 3)) 97 | 98 | distance(ls_list) <- as.matrix(dist(runif(3))) 99 | 100 | expect_true(is.matrix(distance(ls_list))) 101 | expect_true(all(diag(distance(ls_list)) == 0)) 102 | expect_equal(dim(distance(ls_list)), c(3, 3)) 103 | 104 | # wrong dimension 105 | expect_error(distance(ls_all) <- 3) 106 | expect_error(distance(ls_all) <- data.frame(x = 10)) 107 | expect_error(distance(ls_all) <- as.matrix(dist(runif(4)))) 108 | 109 | # test subsetting 110 | ls <- as.landscape(list(coordinates = data.frame(x = 1:3, y = 1:3), 111 | area = data.frame(area = 1), 112 | population = data.frame(eggs = 1, 113 | larvae = 3, 114 | adults = 12), 115 | features = data.frame()[1, ])) 116 | 117 | ls_sub <- as.landscape(list(coordinates = data.frame(x = 1:2, y = 1:2), 118 | area = data.frame(area = 1), 119 | population = data.frame(eggs = 1, 120 | larvae = 3, 121 | adults = 12), 122 | features = data.frame()[1, ])) 123 | 124 | expect_equal(ls[[1:2]], ls_sub) 125 | expect_equal(capture.output(print(ls)), 126 | 'landscape with 3 patches') 127 | expect_equal(capture.output(print(ls_sub)), 128 | 'landscape with 2 patches') 129 | expect_equal(distance(ls)[1:2, 1:2], 130 | distance(ls_sub)) 131 | 132 | }) 133 | -------------------------------------------------------------------------------- /tests/testthat/test_stochastic_analyses.R: -------------------------------------------------------------------------------- 1 | context('stochastic-analysis') 2 | 3 | test_that('stochastic analyses work', { 4 | 5 | skip_on_cran() 6 | 7 | # generate four types of dynamic 8 | stasis_egg <- tr(eggs ~ eggs, p(0.4)) 9 | stasis_larva <- tr(larvae ~ larvae, p(0.3)) 10 | stasis_adult <- tr(adults ~ adults, p(0.8)) 11 | hatching <- tr(larvae ~ eggs, p(0.5)) 12 | fecundity <- tr(eggs ~ adults, p(0.2) * r(3)) 13 | pupation <- tr(adults ~ larvae, p(0.2)) 14 | clonal <- tr(larvae ~ larvae, r(1.4)) 15 | 16 | stasis <- dynamic(stasis_egg, 17 | stasis_larva, 18 | stasis_adult) 19 | growth <- dynamic(hatching, 20 | pupation) 21 | reproduction <- dynamic(fecundity, 22 | clonal) 23 | all <- dynamic(stasis_egg, 24 | stasis_larva, 25 | stasis_adult, 26 | hatching, 27 | pupation, 28 | clonal, 29 | fecundity) 30 | 31 | population <- data.frame(eggs = 1000, 32 | larvae = 200, 33 | adults = 50) 34 | 35 | 36 | # set the RNG seed and simulate 30 times for 50 generations each 37 | set.seed(1) 38 | 39 | # run with 1 core 40 | sim <- simulation(dynamic = all, 41 | population = population, 42 | timesteps = 10, 43 | replicates = 3, 44 | ncores = 1) 45 | 46 | # check you can also do this with a vector 47 | sim <- simulation(dynamic = all, 48 | population = unlist(population), 49 | timesteps = 10, 50 | replicates = 3, 51 | ncores = 1) 52 | 53 | # get a single simulationt oo, for testing plotting 54 | sim1 <- simulation(dynamic = all, 55 | population = unlist(population), 56 | timesteps = 10, 57 | replicates = 1, 58 | ncores = 1) 59 | 60 | # check it has the right class and structure 61 | expect_s3_class(sim, 'simulation') 62 | expect_s3_class(sim$dynamic, 'dynamic') 63 | expect_true(is.list(sim$simulations)) 64 | 65 | # 3 replicates of 11 snapshots 66 | expect_equal(length(sim$simulations), 3) 67 | maxt <- sapply(sim$simulations, nrow) 68 | expect_true(all(maxt == 11)) 69 | 70 | # check there are no NAs in there 71 | NAs <- sapply(sim$simulations, anyNA) 72 | expect_false(any(NAs)) 73 | 74 | # each should have the right number of states 75 | cols <- sapply(sim$simulations, ncol) 76 | expect_true(all(cols == length(states(all)))) 77 | 78 | # check we get errors for dodgy inputs 79 | 80 | # for a transition instead of a dynamic 81 | expect_error(simulation(dynamic = all[[1]], 82 | population = population, 83 | timesteps = 10, 84 | replicates = 3)) 85 | 86 | # for the wrong size of population 87 | expect_error(simulation(dynamic = all, 88 | population = population[1:2], 89 | timesteps = 10, 90 | replicates = 3)) 91 | 92 | # for the wrong population names 93 | population2 <- population 94 | names(population2) <- paste0(names(population2), '_blaaaargh') 95 | expect_error(simulation(dynamic = all, 96 | population = population2, 97 | timesteps = 10, 98 | replicates = 3)) 99 | 100 | # nagative populations 101 | expect_error(simulation(dynamic = all, 102 | population = population * -1, 103 | timesteps = 10, 104 | replicates = 3)) 105 | 106 | # non-finite populations 107 | expect_error(simulation(dynamic = all, 108 | population = population * Inf, 109 | timesteps = 10, 110 | replicates = 3)) 111 | 112 | # non-finite populations 113 | expect_error(simulation(dynamic = all, 114 | population = population * NA, 115 | timesteps = 10, 116 | replicates = 3)) 117 | 118 | # negative timesteps 119 | expect_error(simulation(dynamic = all, 120 | population = population, 121 | timesteps = -1, 122 | replicates = 3)) 123 | 124 | # negative replicates 125 | expect_error(simulation(dynamic = all, 126 | population = population, 127 | timesteps = 10, 128 | replicates = -1)) 129 | 130 | # check is.simulation 131 | expect_true(is.simulation(sim)) 132 | expect_false(is.simulation(sim$dynamic)) 133 | 134 | # check as.simulation 135 | expect_true(is.simulation(pop:::as.simulation(NA))) 136 | expect_false(is.simulation(pop:::as.dynamic(NA))) 137 | 138 | # check simulation plotting 139 | 140 | # check output structure for one state 141 | plot_out_egg <- plot(sim, state = 'eggs') 142 | # list 143 | expect_true(is.list(plot_out_egg)) 144 | # first element as 3 columns and right no. rows 145 | expect_equal(dim(plot_out_egg[[1]]), c(11,3)) 146 | # no NAs 147 | expect_true(!any(is.na(plot_out_egg[[1]]))) 148 | 149 | # for single simulation 150 | plot_out_egg1 <- plot(sim1, state = 'eggs') 151 | # list 152 | expect_true(is.list(plot_out_egg1)) 153 | # first element as 3 columns and right no. rows 154 | expect_equal(dim(plot_out_egg1[[1]]), c(11,3)) 155 | # NAs for CIs, not median 156 | expect_false(anyNA(plot_out_egg1[[1]][, 2])) 157 | expect_true(all(is.na(plot_out_egg1[[1]][, -2]))) 158 | 159 | # check output structure for all states 160 | plot_out_all1 <- plot(sim1) 161 | # list 162 | expect_true(is.list(plot_out_all1)) 163 | # first element as 3 columns and right no. rows 164 | expect_equal(dim(plot_out_all1[[1]]), c(11,3)) 165 | # NAs for CIs, not median 166 | expect_false(anyNA(plot_out_all1[[1]][, 2])) 167 | expect_true(all(is.na(plot_out_all1[[1]][, -2]))) 168 | 169 | # error on bad states 170 | expect_error(plot(sim, state = 'bee')) 171 | expect_error(plot(sim, state = NA)) 172 | expect_error(plot(sim1, state = 'bee')) 173 | expect_error(plot(sim1, state = NA)) 174 | 175 | 176 | # ~~~~~~~~~~ 177 | # test multi-patch models run and can be analysed in the same way 178 | 179 | # pick a dynamic and give it lots of patches 180 | ls <- landscape(all) 181 | n <- 10 182 | ls_new <- as.landscape(list(coordinates = data.frame(x = runif(n), 183 | y = runif(n)), 184 | area = area(ls), 185 | population = population(ls), 186 | features = features(ls))) 187 | 188 | # add dispersal into the dynamic 189 | adult_dispersal <- tr(adults ~ adults, p(0.5) * d(3)) 190 | all <- dynamic(all, adult_dispersal) 191 | landscape(all) <- ls_new 192 | 193 | # try to do simulation 194 | sim <- simulation(dynamic = all, 195 | population = population, 196 | timesteps = 10, 197 | replicates = 3, 198 | ncores = 1) 199 | 200 | # check it has the right class and structure 201 | expect_s3_class(sim, 'simulation') 202 | expect_s3_class(sim$dynamic, 'dynamic') 203 | expect_true(is.list(sim$simulations)) 204 | 205 | # 3 replicates of 11 snapshots 206 | expect_equal(length(sim$simulations), 3) 207 | maxt <- sapply(sim$simulations, nrow) 208 | expect_true(all(maxt == 11)) 209 | 210 | # check there are no NAs in there 211 | NAs <- sapply(sim$simulations, anyNA) 212 | expect_false(any(NAs)) 213 | 214 | # each should have the right number of states 215 | cols <- sapply(sim$simulations, ncol) 216 | expect_true(all(cols == length(states(all)) * nrow(landscape(all)))) 217 | 218 | # plotting with specific states/patches 219 | sim_plot1 <- plot(sim) 220 | sim_plot2 <- plot(sim, states = 'eggs') 221 | sim_plot3 <- plot(sim, patches = 2) 222 | sim_plot4 <- plot(sim, states = 'larvae', patches = 2) 223 | 224 | expect_error(plot(sim, states = 'larvae', patches = 11)) 225 | expect_error(plot(sim, states = 'larvae', patches = -1)) 226 | expect_error(plot(sim, states = 'bees', patches = 11)) 227 | expect_error(plot(sim, states = 'bees', patches = -1)) 228 | 229 | }) 230 | -------------------------------------------------------------------------------- /tests/testthat/test_transfun_class.R: -------------------------------------------------------------------------------- 1 | context('transfun-class') 2 | 3 | test_that('transfun classes work', { 4 | 5 | # the types of transfun 6 | prob <- p(0.5) 7 | rate <- r(3) 8 | disp <- d(3) 9 | 10 | # a user-specified transfun 11 | ddfun <- function (landscape) { 12 | adult_density <- population(landscape, 'adults') / area(landscape) 13 | param$p * exp(-adult_density / param$area) 14 | } 15 | dd <- as.transfun(ddfun, 16 | param = list(p = 0.9, 17 | area = 1000), 18 | type = 'probability') 19 | 20 | # check as.transfun won't handle a silly function 21 | expect_error(as.transfun(function() x, 22 | param = list(p = 0.5))) 23 | expect_error(as.transfun(function(x) x, 24 | param = list(p = 0.5))) 25 | expect_error(as.transfun(function(x, y) x, 26 | param = list(p = 0.5))) 27 | 28 | # compound transfuns 29 | compound <- prob * rate 30 | compound_disp <- prob * disp 31 | compound_user <- prob * dd 32 | 33 | # check they have the right class 34 | expect_s3_class(prob, 'transfun') 35 | expect_s3_class(rate, 'transfun') 36 | expect_s3_class(disp, 'transfun') 37 | expect_s3_class(dd, 'transfun') 38 | expect_s3_class(compound, 'transfun') 39 | expect_s3_class(compound_disp, 'transfun') 40 | expect_s3_class(compound_user, 'transfun') 41 | 42 | # check is.transfun works on transfuns 43 | expect_true(is.transfun(prob)) 44 | expect_true(is.transfun(rate)) 45 | expect_true(is.transfun(disp)) 46 | expect_true(is.transfun(dd)) 47 | expect_true(is.transfun(compound)) 48 | expect_true(is.transfun(compound_disp)) 49 | expect_true(is.transfun(compound_user)) 50 | 51 | # check is.transfun works on non-transfuns 52 | expect_false(is.transfun(list())) 53 | expect_false(is.transfun(NA)) 54 | expect_false(is.transfun(NULL)) 55 | 56 | # check print.transfun works on boring transfuns 57 | expect_equal(capture.output(print(prob)), 58 | 'probability transfun with expectation 0.5') 59 | expect_equal(capture.output(print(rate)), 60 | 'rate transfun with expectation 3') 61 | expect_equal(capture.output(print(disp)), 62 | 'dispersal transfun with expectation 1') 63 | expect_equal(capture.output(print(dd)), 64 | 'user-specified probability transfun') 65 | expect_equal(capture.output(print(compound)), 66 | 'compound transfun with expectation 1.5') 67 | expect_equal(capture.output(print(compound_disp)), 68 | 'compound transfun with expectation 1') 69 | expect_equal(capture.output(print(compound_user)), 70 | 'user-specified compound transfun') 71 | 72 | # screw with some transfuns and expect an error 73 | bad_prob2 <- bad_prob <- prob 74 | class(bad_prob) <- c('flooflah', 'transfun', 'function') 75 | class(bad_prob2) <- c('probability', 'rate', 'transfun', 'function') 76 | 77 | # they're still transfuns, but the internal checks should error 78 | expect_true(is.transfun(bad_prob)) 79 | expect_true(is.transfun(bad_prob2)) 80 | expect_error(pop:::transfunType(bad_prob)) 81 | expect_error(pop:::transfunType(bad_prob2)) 82 | 83 | # check that dispersals and rates are combined in the right way 84 | landscape <- as.landscape(list(coordinates = data.frame(x = runif(5), 85 | y = runif(5)), 86 | area = data.frame(area = 1), 87 | population = data.frame(bees = 1), 88 | features = data.frame()[1, ])) 89 | 90 | disp <- d(3) 91 | p_disp1 <- p(0.5) * disp 92 | p_disp2 <- disp * p(0.2) 93 | 94 | # evaluate 95 | disp_mat <- disp(landscape) 96 | p_disp1_mat <- p_disp1(landscape) 97 | p_disp2_mat <- p_disp2(landscape) 98 | 99 | # check rowSums are (nearly) all 1, or the rate 100 | eps <- sqrt(.Machine$double.eps) 101 | expect_true(all((abs(rowSums(disp_mat) - 1)) < eps)) 102 | expect_true(all((abs(rowSums(p_disp1_mat) - 1)) < eps)) 103 | expect_true(all((abs(rowSums(p_disp2_mat) - 1)) < eps)) 104 | 105 | # check that it errors when doing illegal things with dispersal transfuns 106 | expect_error(r(3) * disp) 107 | expect_error(tr(bee ~ bull, disp)) 108 | 109 | }) 110 | -------------------------------------------------------------------------------- /tests/testthat/test_transfun_constructors.R: -------------------------------------------------------------------------------- 1 | context('transfun-constructors') 2 | 3 | test_that('transfun constructors work', { 4 | 5 | # ~~~~~~~~~~ 6 | # probability 7 | 8 | # alias works 9 | expect_equal(p, probability) 10 | 11 | # invalid values 12 | expect_error(p(0)) 13 | expect_error(p(1)) 14 | expect_error(p(1.1)) 15 | expect_error(p(-0.1)) 16 | expect_error(p(NA)) 17 | expect_error(p(NULL)) 18 | expect_error(p(-Inf)) 19 | expect_error(p(Inf)) 20 | 21 | # valid values 22 | expect_error(p(.Machine$double.eps), NA) 23 | expect_error(p(1 - .Machine$double.eps), NA) 24 | 25 | prob <- p(0.5) 26 | 27 | # check they have the right class 28 | expect_s3_class(prob, c('transfun', 'probability', 'function')) 29 | 30 | # check is.probability works 31 | expect_true(is.probability(prob)) 32 | expect_false(is.probability(list())) 33 | expect_false(is.probability(NA)) 34 | expect_false(is.probability(NULL)) 35 | expect_false(is.probability(r(3))) 36 | 37 | # check as.probability works 38 | obj1 <- pop:::as.probability(list()) 39 | obj2 <- pop:::as.probability(NA) 40 | obj3 <- pop:::as.probability(Inf) 41 | expect_s3_class(obj1, 'probability') 42 | expect_s3_class(obj2, 'probability') 43 | expect_s3_class(obj3, 'probability') 44 | 45 | # ~~~~~~~~~~ 46 | # rate 47 | 48 | # alias works 49 | expect_equal(r, rate) 50 | 51 | # invalid values 52 | expect_error(r(0)) 53 | expect_error(r(-0.1)) 54 | expect_error(r(-Inf)) 55 | expect_error(r(Inf)) 56 | expect_error(r(NA)) 57 | expect_error(r(NULL)) 58 | 59 | # valid values 60 | expect_error(r(.Machine$double.eps), NA) 61 | 62 | ra <- r(3) 63 | 64 | # check they have the right class 65 | expect_s3_class(ra, c('transfun', 'rate', 'function')) 66 | 67 | # check is.probability works 68 | expect_true(is.rate(ra)) 69 | expect_false(is.rate(list())) 70 | expect_false(is.rate(NA)) 71 | expect_false(is.rate(NULL)) 72 | expect_false(is.rate(p(0.5))) 73 | 74 | # check as.rate works 75 | obj1 <- pop:::as.rate(list()) 76 | obj2 <- pop:::as.rate(NA) 77 | obj3 <- pop:::as.rate(Inf) 78 | expect_s3_class(obj1, 'rate') 79 | expect_s3_class(obj2, 'rate') 80 | expect_s3_class(obj3, 'rate') 81 | 82 | 83 | }) 84 | -------------------------------------------------------------------------------- /tests/testthat/test_transition_class.R: -------------------------------------------------------------------------------- 1 | context('transition-class') 2 | 3 | test_that('transition classes work', { 4 | 5 | # a user-specified transfun 6 | ddfun <- function (landscape) { 7 | adult_density <- population(landscape, 'adults') / area(landscape) 8 | param$p * exp(-adult_density / param$area) 9 | } 10 | dd <- as.transfun(ddfun, 11 | param = list(p = 0.9, 12 | area = 1000), 13 | type = 'probability') 14 | 15 | # alias works 16 | expect_equal(tr, transition) 17 | 18 | # two types of transfun 19 | tr1 <- transition(larva ~ egg, p(0.5)) 20 | tr2 <- transition(egg ~ adult, r(10)) 21 | tr3 <- transition(adult ~ adult, dd) 22 | tr4 <- transition(adult ~ adult, p(0.5)) * tr3 23 | 24 | # check they have the right class 25 | expect_s3_class(tr1, 'transition') 26 | expect_s3_class(tr2, 'transition') 27 | expect_s3_class(tr3, 'transition') 28 | expect_s3_class(tr4, 'transition') 29 | 30 | # check is.transition works on transitions 31 | expect_true(is.transition(tr1)) 32 | expect_true(is.transition(tr2)) 33 | expect_true(is.transition(tr3)) 34 | expect_true(is.transition(tr4)) 35 | 36 | # check is.transition works on non-transitions 37 | expect_false(is.transition(list())) 38 | expect_false(is.transition(NA)) 39 | expect_false(is.transition(NULL)) 40 | 41 | # check as.transition works 42 | obj1 <- pop:::as.transition(list()) 43 | obj2 <- pop:::as.transition(NA) 44 | obj3 <- pop:::as.transition(Inf) 45 | expect_s3_class(obj1, 'transition') 46 | expect_s3_class(obj2, 'transition') 47 | expect_s3_class(obj3, 'transition') 48 | 49 | # check print.transition works 50 | expect_equal(capture.output(print(tr1)), 51 | 'transition: egg -> larva with expectation 0.5') 52 | expect_equal(capture.output(print(tr2)), 53 | 'transition: adult -> egg with expectation 10') 54 | expect_equal(capture.output(print(tr3)), 55 | 'transition: adult -> adult with user-defined transfun') 56 | expect_equal(capture.output(print(tr4)), 57 | 'transition: adult -> adult with user-defined transfun') 58 | 59 | }) 60 | --------------------------------------------------------------------------------