├── .github ├── .gitignore ├── workflows │ ├── R-CMD-check.yaml │ └── pkgdown.yaml ├── CONTRIBUTING.md └── CODE_OF_CONDUCT.md ├── tests ├── testthat.R └── testthat │ ├── test-linear-trend.R │ └── test-step-trend.R ├── .Rbuildignore ├── NEWS.md ├── man ├── abr_fit.rpart.Rd ├── rickerfit.Rd ├── linear_trend.Rd ├── seed_rng.Rd ├── abr_breaks.hgam.Rd ├── step_trend.Rd ├── sim_troph_triangle.Rd ├── simulate_linear_trend.Rd ├── abr_fit.hgam.Rd └── simulate_step_trend.Rd ├── abrupt.Rproj ├── _pkgdown.yml ├── NAMESPACE ├── README.md ├── .gitignore ├── R ├── model_tree.R ├── utilities.R ├── ricker-model.R ├── skeleton.R ├── parameterize.R ├── trend_linear.R ├── trend_step.R ├── sim_troph_triangle.R ├── HGAM.R └── simulate_abrupt_change.R ├── DESCRIPTION ├── LICENSE ├── LICENSE.md └── code-for-inclusion ├── dynamic_shift_detector.R ├── simulations_weight_analysis.R └── simulations.R /.github/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(abrupt) 3 | 4 | test_check("abrupt") 5 | -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^LICENSE\.md$ 2 | ^\.github$ 3 | ^\code-for-inclusion$ 4 | ^_pkgdown\.yml$ 5 | ^docs$ 6 | ^pkgdown$ 7 | ^.*\.Rproj$ 8 | ^\.Rproj\.user$ 9 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | # abrupt 0.0.0.9000 2 | 3 | * Added `step_trend()` and `linear_trend()` as example driver functions. 4 | 5 | * Added `simulate_step_trend()` and `simulate_linear_trend()` functions to 6 | simulate from the example drievr functions. 7 | 8 | * Added a `NEWS.md` file to track changes to the package. 9 | -------------------------------------------------------------------------------- /man/abr_fit.rpart.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/model_tree.R 3 | \name{abr_fit.rpart} 4 | \alias{abr_fit.rpart} 5 | \title{Estimate change points using a regression tree} 6 | \usage{ 7 | abr_fit.rpart(data, ...) 8 | } 9 | \description{ 10 | Estimate change points using a regression tree 11 | } 12 | -------------------------------------------------------------------------------- /man/rickerfit.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ricker-model.R 3 | \name{rickerfit} 4 | \alias{rickerfit} 5 | \title{Function that fits the Ricker model} 6 | \usage{ 7 | rickerfit(data) 8 | } 9 | \arguments{ 10 | \item{data}{ToDo} 11 | } 12 | \description{ 13 | Function that fits the Ricker model 14 | } 15 | -------------------------------------------------------------------------------- /abrupt.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | BuildType: Package 16 | PackageUseDevtools: Yes 17 | PackageInstallArgs: --no-multiarch --with-keep.source 18 | -------------------------------------------------------------------------------- /_pkgdown.yml: -------------------------------------------------------------------------------- 1 | url: https://regime-shifts.github.io/abrupt/ 2 | 3 | home: 4 | title: Methods for detecting abrupt change in temporal, spatial, and spatiotemporal data series 5 | description: A consistent tidy interface to methods and models for detecting aburpt change and regime shifts in temporal, spatial, and spatiotemporal data series. 6 | 7 | template: 8 | params: 9 | bootswatch: simplex 10 | -------------------------------------------------------------------------------- /man/linear_trend.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/trend_linear.R 3 | \name{linear_trend} 4 | \alias{linear_trend} 5 | \title{Linear trend response model} 6 | \usage{ 7 | linear_trend(t, start_value = 0, end_value = 1, ...) 8 | } 9 | \arguments{ 10 | \item{t}{numeric; vector of time points.} 11 | 12 | \item{start_value, end_value}{numeric vectors of length 1; the start and end 13 | values for the linear trend.} 14 | 15 | \item{...}{other arguments. Ignored here.} 16 | } 17 | \description{ 18 | Linear trend response model 19 | } 20 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | export(sim_troph_triangle) 4 | export(simulate_step_trend) 5 | export(step_trend) 6 | importFrom(deSolve,ode) 7 | importFrom(dplyr,group_by) 8 | importFrom(dplyr,left_join) 9 | importFrom(dplyr,mutate) 10 | importFrom(dplyr,summarize) 11 | importFrom(glue,glue_collapse) 12 | importFrom(minpack.lm,nlsLM) 13 | importFrom(purrr,map_lgl) 14 | importFrom(stats,AIC) 15 | importFrom(stats,approx) 16 | importFrom(stats,rlnorm) 17 | importFrom(stats,rnorm) 18 | importFrom(stats,runif) 19 | importFrom(tibble,add_column) 20 | importFrom(tibble,tibble) 21 | importFrom(tidyr,gather) 22 | -------------------------------------------------------------------------------- /.github/workflows/R-CMD-check.yaml: -------------------------------------------------------------------------------- 1 | on: 2 | push: 3 | branches: 4 | - main 5 | pull_request: 6 | branches: 7 | - main 8 | 9 | name: R-CMD-check 10 | 11 | jobs: 12 | R-CMD-check: 13 | runs-on: macOS-latest 14 | steps: 15 | - uses: actions/checkout@v2 16 | - uses: r-lib/actions/setup-r@master 17 | - name: Install dependencies 18 | run: | 19 | install.packages(c("remotes", "rcmdcheck")) 20 | remotes::install_deps(dependencies = TRUE) 21 | shell: Rscript {0} 22 | - name: Check 23 | run: rcmdcheck::rcmdcheck(args = "--no-manual", error_on = "error") 24 | shell: Rscript {0} 25 | -------------------------------------------------------------------------------- /tests/testthat/test-linear-trend.R: -------------------------------------------------------------------------------- 1 | ## Tests for linear_trend() & related 2 | 3 | ## load packages 4 | library("testthat") 5 | 6 | context("Test linear_trend() & related") 7 | 8 | test_that("linear_trend() returns a tibble", { 9 | expect_silent(df <- linear_trend(t = 1:20)) 10 | expect_s3_class(df, "linear_trend") 11 | expect_named(df, c("t", "trend")) 12 | expect_identical(nrow(df), 20L) 13 | }) 14 | 15 | test_that("simulate_linear_trend() returns a tibble", { 16 | expect_silent(df <- simulate_linear_trend(t = 1:20, seed = 42)) 17 | expect_s3_class(df, "simulate_linear_trend") 18 | expect_named(df, c("t", "trend", "y")) 19 | expect_identical(nrow(df), 20L) 20 | }) 21 | -------------------------------------------------------------------------------- /man/seed_rng.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/utilities.R 3 | \name{seed_rng} 4 | \alias{seed_rng} 5 | \title{Seed the RNG state possibly with a user supplied seed} 6 | \usage{ 7 | seed_rng(seed = NULL) 8 | } 9 | \arguments{ 10 | \item{seed}{numeric seed for RNG. See \code{\link[base:Random]{base::set.seed()}}.} 11 | } 12 | \value{ 13 | A list containing \code{seed}, the supplied seed, \code{initial_state}, 14 | the initial state of the RNG before the seed was set, and 15 | \code{kind}, the type of RNG used, as returned by \code{\link[base:Random]{base::RNGkind()}}. 16 | } 17 | \description{ 18 | Seed the RNG state possibly with a user supplied seed 19 | } 20 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # abrupt 2 | 3 | 4 | [![R build status](https://github.com/regime-shifts/abrupt/workflows/R-CMD-check/badge.svg)](https://github.com/regime-shifts/abrupt/actions) 5 | 6 | 7 | Methods for detecting abrupt change in temporal, spatial, and spatiotemporal data series. 8 | 9 | ## Installation 10 | 11 | You can install the in-development version of abrupt from GitHub with: 12 | 13 | ``` r 14 | remotes::install_github("regime-shifts/abrupt") 15 | ``` 16 | 17 | ## Code of Conduct 18 | 19 | Please note that the abrupt project is released with a [Contributor Code of Conduct](https://contributor-covenant.org/version/2/0/CODE_OF_CONDUCT.html). By contributing to this project, you agree to abide by its terms. 20 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # History files 2 | .Rhistory 3 | .Rapp.history 4 | 5 | # Session Data files 6 | .RData 7 | 8 | # User-specific files 9 | .Ruserdata 10 | 11 | # Example code in package build process 12 | *-Ex.R 13 | 14 | # Output files from R CMD build 15 | /*.tar.gz 16 | 17 | # Output files from R CMD check 18 | /*.Rcheck/ 19 | 20 | # RStudio files 21 | .Rproj.user/ 22 | 23 | # produced vignettes 24 | vignettes/*.html 25 | vignettes/*.pdf 26 | 27 | # OAuth2 token, see https://github.com/hadley/httr/releases/tag/v0.3 28 | .httr-oauth 29 | 30 | # knitr and R markdown default cache directories 31 | *_cache/ 32 | /cache/ 33 | 34 | # Temporary files created by R markdown 35 | *.utf8.md 36 | *.knit.md 37 | 38 | # R Environment Variables 39 | .Renviron 40 | .Rproj.user 41 | 42 | # No Emacs backup files 43 | *~ 44 | 45 | docs 46 | -------------------------------------------------------------------------------- /man/abr_breaks.hgam.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/HGAM.R 3 | \name{abr_breaks.hgam} 4 | \alias{abr_breaks.hgam} 5 | \title{Extracts breakpoints from an HGAM model} 6 | \usage{ 7 | abr_breaks.hgam( 8 | abr_fitobj, 9 | breaktype = NULL, 10 | stepsize = NULL, 11 | delta = NULL, 12 | nsims = NULL, 13 | transform = NULL, 14 | aggregate = NULL, 15 | CI = FALSE 16 | ) 17 | } 18 | \arguments{ 19 | \item{abr_fitobj}{A previously fitted} 20 | } 21 | \value{ 22 | A list containing \code{seed}, the supplied seed, \code{initial_state}, the 23 | initial state of the RNG before the seed was set, and \code{kind}, the type of 24 | RNG used, as returned by \code{\link[base:Random]{base::RNGkind()}}. 25 | } 26 | \description{ 27 | Extracts breakpoints from an HGAM model 28 | } 29 | -------------------------------------------------------------------------------- /tests/testthat/test-step-trend.R: -------------------------------------------------------------------------------- 1 | ## Tests for step_trend() & related 2 | 3 | ## load packages 4 | library("testthat") 5 | 6 | context("Test step_trend() & related") 7 | 8 | test_that("step_trend() returns a tibble", { 9 | expect_silent(df <- step_trend(t = 1:20, change_points = c(5, 15), 10 | means = c(1, 2, 3))) 11 | expect_s3_class(df, "step_trend") 12 | expect_named(df, c("t", "trend")) 13 | expect_identical(nrow(df), 20L) 14 | }) 15 | 16 | test_that("simulate_step_trend() returns a tibble", { 17 | expect_silent(df <- simulate_step_trend(t = 1:20, change_points = c(5, 15), 18 | means = c(1, 2, 3), seed = 42)) 19 | expect_s3_class(df, "simulate_step_trend") 20 | expect_named(df, c("t", "trend", "y")) 21 | expect_identical(nrow(df), 20L) 22 | }) 23 | -------------------------------------------------------------------------------- /man/step_trend.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/trend_step.R 3 | \name{step_trend} 4 | \alias{step_trend} 5 | \title{Step change trend response model} 6 | \usage{ 7 | step_trend(t, change_points, means, ...) 8 | } 9 | \arguments{ 10 | \item{t}{numeric; vector of time points.} 11 | 12 | \item{change_points}{numeric; vector of change points, within \code{t}} 13 | 14 | \item{means}{numeric; vector of means for the regimes implied by 15 | \code{change_points}. Must be of length \code{length(change_points) + 1}.} 16 | 17 | \item{...}{other arguments. Ignored here.} 18 | } 19 | \description{ 20 | Step change trend response model 21 | } 22 | \examples{ 23 | \dontshow{ 24 | set.seed(1) 25 | op <- options(digits = 3, cli.unicode = FALSE) 26 | } 27 | sims <- step_trend(1:100, change_points = c(25, 75), means = c(2, 8, 4)) 28 | sims 29 | 30 | library("ggplot2") 31 | ggplot(sims, aes(x = t, y = trend)) + 32 | geom_step() 33 | \dontshow{options(op)} 34 | } 35 | -------------------------------------------------------------------------------- /man/sim_troph_triangle.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/sim_troph_triangle.R 3 | \name{sim_troph_triangle} 4 | \alias{sim_troph_triangle} 5 | \title{Trophic triangle model} 6 | \usage{ 7 | sim_troph_triangle( 8 | time_out = 100, 9 | n_steps = c(100), 10 | measurement_sigma = c(0, 0, 0), 11 | harvest_rates = create_driver_function(change_times = 50, parm_values = c(0, 0.25), 12 | interpolation = "constant"), 13 | pred_overlap = create_driver_function(change_times = 50, parm_values = c(1, 1), 14 | interpolation = "constant") 15 | ) 16 | } 17 | \arguments{ 18 | \item{time_out}{ToDo} 19 | 20 | \item{n_steps}{ToDo} 21 | 22 | \item{measurement_sigma}{ToDo} 23 | 24 | \item{harvest_start}{ToDo} 25 | 26 | \item{harvest_end}{ToDo} 27 | 28 | \item{harvest_shape}{ToDo} 29 | 30 | \item{pred_overlap_start}{ToDo} 31 | 32 | \item{pred_overlap_end}{ToDo} 33 | 34 | \item{pred_overlap_shape}{ToDo} 35 | } 36 | \description{ 37 | Trophic triangle model 38 | } 39 | \author{ 40 | Eric J. Pedersen 41 | } 42 | -------------------------------------------------------------------------------- /R/model_tree.R: -------------------------------------------------------------------------------- 1 | #' Estimate change points using a regression tree 2 | #' 3 | `abr_fit.rpart` <- function(data, ...) { 4 | # fail early if rpart and partykit are not avilable 5 | pkgs <- c("rpart", "partykit") 6 | load_required_packages(pkgs) 7 | fit <- rpart::rpart(y ~ t, data = data, model = TRUE) 8 | fit <- partykit::as.party(fit) 9 | fit 10 | } 11 | 12 | #' @importFrom purrr map_lgl 13 | #' @importFrom glue glue glue_collapse 14 | `load_required_packages` <- function(packages, quietly = TRUE, ...) { 15 | loaded <- map_lgl(packages, load_required_package, quietly = quietly, ...) 16 | # report which failed 17 | if (any(!loaded)) { 18 | pkgs <- packages[!loaded] 19 | msg <- glue::glue_collapse(glue::glue("{pkgs}"), sep = ", ") 20 | msg <- glue::glue("Failed to load packages: {tmp}. 21 | 22 | Install the missing packages and try again.") 23 | stop(msg, call. = FALSE) 24 | } 25 | } 26 | 27 | `load_required_package` <- function(package, quietly = TRUE, ...) { 28 | requireNamespace(package, quietly = quietly, ...) 29 | } -------------------------------------------------------------------------------- /man/simulate_linear_trend.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/trend_linear.R 3 | \name{simulate_linear_trend} 4 | \alias{simulate_linear_trend} 5 | \title{Simulate data from a linear trend model} 6 | \usage{ 7 | simulate_linear_trend( 8 | t, 9 | start_value = 0, 10 | end_value = 1, 11 | sampling_distribution = NULL, 12 | seed = NULL, 13 | ... 14 | ) 15 | } 16 | \arguments{ 17 | \item{t}{numeric; vector of time points.} 18 | 19 | \item{start_value, end_value}{numeric vectors of length 1; the start and end 20 | values for the linear trend.} 21 | 22 | \item{sampling_distribution}{function; a random number generating function, 23 | which takes as it's first argument the number of observations to sample. 24 | The second argument should be the expected value. The default, if nothing 25 | is supplied, is \code{\link[stats:Normal]{stats::rnorm()}}.} 26 | 27 | \item{seed}{numeric; a seed for the simulation.} 28 | 29 | \item{...}{additional arguments that will be passed to 30 | \code{sampling_distribution}.} 31 | } 32 | \description{ 33 | Simulate data from a linear trend model 34 | } 35 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: abrupt 2 | Title: Methods for detecting abrupt change in temporal, spatial, and spatiotemporal data series 3 | Version: 0.0.0.9000 4 | Authors@R: 5 | c(person(given = "Gavin", 6 | family = "Simpson", 7 | role = c("aut", "cre"), 8 | email = "ucfagls@gmail.com", 9 | comment = c(ORCID = "0000-0002-9084-8413")), 10 | person(given = "Eric", 11 | family = "Pedersen", 12 | role = c("aut"), 13 | email = "eric@example.com", # FIXME 14 | comment = c(ORCID = "0000-0000-0000-0000"))) 15 | Description: A consistent tidy interface to methods and models for detecting aburpt change and regime shifts in temporal, spatial, and spatiotemporal data series. 16 | License: MIT + file LICENSE 17 | Encoding: UTF-8 18 | LazyData: true 19 | Roxygen: list(markdown = TRUE) 20 | RoxygenNote: 7.1.1 21 | Imports: 22 | stats, 23 | tibble, 24 | Formula, 25 | tidyr, 26 | dplyr, 27 | purrr, 28 | deSolve, 29 | minpack.lm 30 | Suggests: 31 | testthat, 32 | ggplot2, 33 | glue, 34 | rpart, 35 | partykit 36 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2020 CIEE Regime Shift Working Group 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | # MIT License 2 | 3 | Copyright (c) 2020 CIEE Regime Shift Working Group 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /man/abr_fit.hgam.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/HGAM.R 3 | \name{abr_fit.hgam} 4 | \alias{abr_fit.hgam} 5 | \title{Fits an HGAM model} 6 | \usage{ 7 | abr_fit.hgam( 8 | data, 9 | type = "t", 10 | bs_t = "tp", 11 | bs_s = "gp", 12 | bs_g = "re", 13 | k_t = 20, 14 | k_s = 20, 15 | k_g = NA, 16 | func = "gam", 17 | family = "gaussian", 18 | calc_breaks = FALSE, 19 | break_args = list(), 20 | ... 21 | ) 22 | } 23 | \arguments{ 24 | \item{data}{Data frame used for fitting. Should be constructed by the 25 | abr_data function} 26 | 27 | \item{type}{The type of regime detection model. One of "t", "st","s", "gt", 28 | "gst","gs". "t" indicates a temporal smoother, "s" indicates a spatial 29 | smoother, and "g" indicates a grouped (HGAM) smoother} 30 | 31 | \item{family}{The family mgcv or brms will use to fit the model.} 32 | 33 | \item{bs_t/bs_s/bs_g}{basis types to be used for the temporal, spatial, and 34 | group-level smoothers} 35 | 36 | \item{k_t/k_s/k_g}{number of basis functions to use for temporal, spatial, 37 | and group-level smoothers} 38 | } 39 | \value{ 40 | A fitted object of class 'abrupt_model' and 'HGAM'. 41 | } 42 | \description{ 43 | Fits an HGAM model 44 | } 45 | -------------------------------------------------------------------------------- /R/utilities.R: -------------------------------------------------------------------------------- 1 | ##' Seed the RNG state possibly with a user supplied seed 2 | ##' 3 | ##' @param seed numeric seed for RNG. See [base::set.seed()]. 4 | ##' 5 | ##' @return A list containing `seed`, the supplied seed, `initial_state`, 6 | ##' the initial state of the RNG before the seed was set, and 7 | ##' `kind`, the type of RNG used, as returned by [base::RNGkind()]. 8 | ##' 9 | ##' @importFrom stats runif 10 | `seed_rng` <- function(seed = NULL) { 11 | ## initialise seed if not set in session 12 | if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) { 13 | runif(1) 14 | } 15 | rnd_kind <- as.list(RNGkind()) # need kind to be reproducible 16 | 17 | ## grab the current state of the RNG system 18 | ## want to return this so it can be reset on exit from 19 | ## calling function 20 | initial_state <- get(".Random.seed", envir = .GlobalEnv) 21 | 22 | ## if user provided a seed, set the seed now 23 | if (!is.null(seed)) { 24 | set.seed(seed) 25 | } 26 | 27 | ## return the seed and other info as a list 28 | list(seed = seed, initial_state = initial_state, kind = rnd_kind) 29 | } 30 | 31 | 32 | `calc_1st_deriv` <- function(fit_before, fit_after,delta) { 33 | (fit_after-fit_before)/(2*delta) 34 | 35 | } 36 | 37 | `calc_2nd_deriv` <- function(fit, fit_before, fit_after,delta) { 38 | (fit_before + fit_after-2*fit)/delta^2 39 | } 40 | 41 | 42 | -------------------------------------------------------------------------------- /.github/workflows/pkgdown.yaml: -------------------------------------------------------------------------------- 1 | on: 2 | push: 3 | branches: main 4 | 5 | name: pkgdown 6 | 7 | jobs: 8 | pkgdown: 9 | runs-on: macOS-latest 10 | env: 11 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 12 | steps: 13 | - uses: actions/checkout@v2 14 | 15 | - uses: r-lib/actions/setup-r@master 16 | 17 | - uses: r-lib/actions/setup-pandoc@master 18 | 19 | - name: Query dependencies 20 | run: | 21 | install.packages('remotes') 22 | saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2) 23 | writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version") 24 | shell: Rscript {0} 25 | 26 | - name: Cache R packages 27 | uses: actions/cache@v1 28 | with: 29 | path: ${{ env.R_LIBS_USER }} 30 | key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }} 31 | restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1- 32 | 33 | - name: Install dependencies 34 | run: | 35 | install.packages("remotes") 36 | remotes::install_deps(dependencies = TRUE) 37 | remotes::install_dev("pkgdown") 38 | shell: Rscript {0} 39 | 40 | - name: Install package 41 | run: R CMD INSTALL . 42 | 43 | - name: Deploy package 44 | run: pkgdown::deploy_to_branch(new_process = FALSE) 45 | shell: Rscript {0} 46 | -------------------------------------------------------------------------------- /R/ricker-model.R: -------------------------------------------------------------------------------- 1 | ##' Function that fits the Ricker model 2 | ##' 3 | ##' @param data ToDo 4 | ##' 5 | ##' @importFrom minpack.lm nlsLM 6 | ##' @importFrom stats AIC 7 | `rickerfit` <- function (data){ 8 | ## create an initial estimate of k to aide model convergence 9 | kest <- mean(data$Nt) 10 | 11 | ## supress warnings about failed convergence in oddball fits 12 | ## - these models won't be favoured by AIC anyway 13 | op <- options(warn=-1) 14 | on.exit(options(op)) # reverse this on exit of function 15 | 16 | ## fit the model 17 | ricker.model <- tryCatch(nlsLM(Nt1 ~ Nt * exp(r * (1 - Nt/k)), 18 | start = list(r = 1.5, k = kest), data = data), 19 | error = function(e) NULL) 20 | ## What outputs do we need from each run? AIC, r and k, and their resepective 21 | ## errors. Want to create a vector with this information in it so we can use 22 | ## this information later 23 | if(is.list(ricker.model)) { 24 | output <- c(AIC(ricker.model), #AIC 25 | summary(ricker.model)$coefficients[1,1], # r 26 | summary(ricker.model)$coefficients[1,2], # se for r 27 | summary(ricker.model)$coefficients[2,1], # k 28 | summary(ricker.model)$coefficients[2,2]) # se for k 29 | } else { 30 | ## if the model fails to converge, give it an an arbitrarily high but finite AIC 31 | output < -c(100000000, 0, 0, 0, 0) 32 | } 33 | 34 | output # return 35 | } 36 | -------------------------------------------------------------------------------- /man/simulate_step_trend.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/trend_step.R 3 | \name{simulate_step_trend} 4 | \alias{simulate_step_trend} 5 | \title{Simulate data from a linear trend model} 6 | \usage{ 7 | simulate_step_trend( 8 | t, 9 | change_points, 10 | means, 11 | sampling_distribution = NULL, 12 | seed = NULL, 13 | ... 14 | ) 15 | } 16 | \arguments{ 17 | \item{t}{numeric; vector of time points.} 18 | 19 | \item{change_points}{numeric; vector of change points, within \code{t}} 20 | 21 | \item{means}{numeric; vector of means for the regimes implied by 22 | \code{change_points}. Must be of length \code{length(change_points) + 1}.} 23 | 24 | \item{sampling_distribution}{function; a random number generating function, 25 | which takes as it's first argument the number of observations to sample. 26 | The second argument should be the expected value. The default, if nothing 27 | is supplied, is \code{\link[stats:Normal]{stats::rnorm()}}.} 28 | 29 | \item{seed}{numeric; a seed for the simulation.} 30 | 31 | \item{...}{additional arguments that will be passed to 32 | \code{sampling_distribution}.} 33 | } 34 | \description{ 35 | Simulate data from a linear trend model 36 | } 37 | \examples{ 38 | \dontshow{ 39 | set.seed(1) 40 | op <- options(digits = 3, cli.unicode = FALSE) 41 | } 42 | sims <- simulate_step_trend(1:100, change_points = c(25, 75), 43 | means = c(2, 8, 4)) 44 | sims 45 | 46 | library("ggplot2") 47 | ggplot(sims, aes(x = t, y = y)) + 48 | geom_point() + 49 | geom_step(aes(y = trend)) 50 | \dontshow{options(op)} 51 | } 52 | -------------------------------------------------------------------------------- /R/skeleton.R: -------------------------------------------------------------------------------- 1 | #' Generate a deterministic skeleton for a abrupt change driver 2 | #' 3 | #' @param t numeric; either a length 1 vector indicating the number ot time 4 | #' points in the skeleton, or a vector of time points in the interval [0,1]. 5 | #' @param scenario 6 | #' @param breaks 7 | #' @param mean 8 | #' @param ... 9 | #' 10 | #' @export 11 | #' 12 | #' @examples 13 | #' 14 | #' skeleton(t = 10, scenario = "constant", mean = 0.5) 15 | #' 16 | #' skeleton(t = 10, scenario = "stepped", breaks = c(0.3, 0.75), 17 | #' mean = c(2, 4, 6)) 18 | `skeleton` <- function(t = 100, 19 | scenario = c("constant", "linear", "segmented", "stepped", "unimodal", 20 | "cyclic", "auto_regressive"), 21 | breaks = 0.5, 22 | mean = 0.5, 23 | ... 24 | ) { 25 | # handle scalar t 26 | if (length(t) == 1L) { 27 | if (t < 3L || isFALSE(t %% 1 == 0)) { 28 | stop("If scalar 't', must be an integer > 2") 29 | } 30 | t <- seq(0, 1, length.out = t) 31 | } 32 | 33 | # handle scenario 34 | scenario <- match.arg(scenario) 35 | fun <- paste0(scenario, "_skeleton") 36 | fun <- match.fun(fun) 37 | 38 | # call the actual skeleton function 39 | skeleton <- fun(t, breaks = breaks, mean = mean, ...) 40 | 41 | skeleton 42 | } 43 | 44 | #' @importFrom tibble tibble 45 | #' @importFrom dplyr arrange 46 | `constant_skeleton` <- function(t, mean, ...) { 47 | if (length(mean) > 1L) { 48 | stop("Single mean only") 49 | } 50 | skeleton <- tibble(t = t, value = rep_len(mean, length(t))) |> 51 | arrange(t) 52 | class(skeleton) <- append("skeleton", class(skeleton)) 53 | skeleton 54 | } 55 | 56 | #' @importFrom tibble tibble 57 | #' @importFrom dplyr arrange 58 | `stepped_skeleton` <- function(t, breaks, mean, ...) { 59 | n_breaks <- length(breaks) 60 | n_means <- length(mean) 61 | if (isFALSE(n_breaks == (n_means - 1))) { 62 | stop("Number of breaks must be 1 fewer than the number of means") 63 | } 64 | cuts <- cut(t, c(0L, breaks, 1L), include.lowest = TRUE, right = FALSE) 65 | skeleton <- tibble(t = t, value = mean[cuts]) |> 66 | arrange(t) 67 | class(skeleton) <- append("skeleton", class(skeleton)) 68 | skeleton 69 | } 70 | -------------------------------------------------------------------------------- /.github/CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing to abrupt 2 | 3 | This outlines how to propose a change to abrupt. 4 | 5 | ## Fixing typos 6 | 7 | You can fix typos, spelling mistakes, or grammatical errors in the documentation directly using the GitHub web interface, as long as the changes are made in the _source_ file. 8 | This generally means you'll need to edit [roxygen2 comments](https://roxygen2.r-lib.org/articles/roxygen2.html) in an `.R`, not a `.Rd` file. 9 | You can find the `.R` file that generates the `.Rd` by reading the comment in the first line. 10 | 11 | ## Bigger changes 12 | 13 | If you want to make a bigger change, it's a good idea to first file an issue and make sure someone from the team agrees that it’s needed. 14 | If you’ve found a bug, please file an issue that illustrates the bug with a minimal 15 | [reprex](https://www.tidyverse.org/help/#reprex) (this will also help you write a unit test, if needed). 16 | 17 | ### Pull request process 18 | 19 | * Fork the package and clone onto your computer. If you haven't done this before, we recommend using `usethis::create_from_github("regime-shifts/abrupt", fork = TRUE)`. 20 | 21 | * Install all development dependences with `devtools::install_dev_deps()`, and then make sure the package passes R CMD check by running `devtools::check()`. 22 | If R CMD check doesn't pass cleanly, it's a good idea to ask for help before continuing. 23 | * Create a Git branch for your pull request (PR). We recommend using `usethis::pr_init("brief-description-of-change")`. 24 | 25 | * Make your changes, commit to git, and then create a PR by running `usethis::pr_push()`, and following the prompts in your browser. 26 | The title of your PR should briefly describe the change. 27 | The body of your PR should contain `Fixes #issue-number`. 28 | 29 | * For user-facing changes, add a bullet to the top of `NEWS.md` (i.e. just below the first header). Follow the style described in . 30 | 31 | ### Code style 32 | 33 | * We use [roxygen2](https://cran.r-project.org/package=roxygen2), with [Markdown syntax](https://cran.r-project.org/web/packages/roxygen2/vignettes/rd-formatting.html), for documentation. 34 | 35 | * We use [testthat](https://cran.r-project.org/package=testthat) for unit tests. 36 | Contributions with test cases included are easier to accept. 37 | 38 | ## Code of Conduct 39 | 40 | Please note that the abrupt project is released with a 41 | [Contributor Code of Conduct](CODE_OF_CONDUCT.md). By contributing to this 42 | project you agree to abide by its terms. 43 | -------------------------------------------------------------------------------- /R/parameterize.R: -------------------------------------------------------------------------------- 1 | `parameterize` <- function(t = 100, 2 | model = c("mean_plus_noise", "lottery", "ricker", 3 | "trophic_triangle"), 4 | scenario = c("constant", "linear", "segmented", 5 | "stepped", "unimodal", 6 | "cyclic", "auto_regressive"), 7 | observation_dist = NULL, 8 | parameters = NULL, 9 | n_spp = 1, 10 | ...) { 11 | 12 | model <- match.arg(model) 13 | scenario <- match.arg(scenario) 14 | 15 | par_fun <- paste("parameterize", model, sep = "_") 16 | par_fun <- match.fun(par_fun) 17 | 18 | pars <- par_fun(t = t, scenario = scenario, n_spp = n_spp, ...) 19 | } 20 | 21 | # vary noise, survival (u), density dependence (s), birth rate sd (sd) 22 | `parameterize_lottery` <- function(t, 23 | scenario = "constant", 24 | n_spp = 2, 25 | breaks = NULL, 26 | survival = 0.95, 27 | density_dependence = 0.01, 28 | birth_sd = 0.8, ...) { 29 | birth <- 20 # this is parameter b, hard coded 30 | # birth needs to be in data frame of parameters 31 | 32 | # survival can be a list of length n_spp, each element is the mean for the 33 | # skeleton, each species follows the same skeleton/scenario 34 | 35 | # genearate data frame of parameters with length(t) rows 36 | 37 | # scenario affects survival *only* 38 | # survival gets passed to the mean argument of the skeleton fun 39 | 40 | # parameters is a data frame with columns: 41 | # t, spp, birth, survival, density_dependence, birth_sd 42 | 43 | # after generated parameters do parameter checks 44 | } 45 | 46 | # constant - mean 47 | # linear - start and end values, linearlly interpolate 48 | # segmented - specify internal breaks, mean = breaks = 2 (start and end) values 49 | # - linearlly interpolate between the start, breaks, end 50 | # stepped - breaks and mean (length(mean) == length(breaks) + 1) 51 | # unimdal - optima, tolerance assume a gaussian curve 52 | # cyclic - mean, amplitude, freq: output mean + (amplitude * sin(freq*t*2*pi)), 53 | # - min freq is 2 54 | # auto_regressive mean rho t_1 sigma 55 | # 56 | # Details for autoregressive: 57 | # t <- 1:100 58 | # t_1 <- 0 59 | # mean <- 10 60 | # rho <- 0.99 61 | # sd <- 2 62 | # x <- rnorm(length(t), mean = 0, sd = sd) 63 | # x[1] <- t_1 - mean # (init) 64 | # f <- stats::filter(x, filter = rho, method = "recursive", sides = 1) 65 | # f + mean 66 | # plot(f + mean) 67 | -------------------------------------------------------------------------------- /R/trend_linear.R: -------------------------------------------------------------------------------- 1 | ##' Linear trend response model 2 | ##' 3 | ##' @param t numeric; vector of time points. 4 | ##' @param start_value,end_value numeric vectors of length 1; the start and end 5 | ##' values for the linear trend. 6 | ##' @param ... other arguments. Ignored here. 7 | ##' 8 | ##' @importFrom tibble tibble 9 | ##' @importFrom stats approx 10 | ##' 11 | `linear_trend` <- function(t, start_value = 0, end_value = 1, ...) { 12 | ## is t in order? 13 | if (is.unsorted(t)) { 14 | stop("'t' must be in increasing order.") 15 | } 16 | 17 | nt <- length(t) # length of series 18 | 19 | ## linear sequence from start to end of the length of t 20 | trend <- seq(start_value, end_value, length.out = nt) 21 | 22 | ## if t is irregular, interpolate truth to the irregular t points 23 | irregular <- length(unique(diff(t))) > 1L 24 | if (irregular) { 25 | ## use approx to interpolate 26 | trend <- approx(x = seq(t[1], t[nt], length.out = nt), 27 | y = trend, xout = t)$y 28 | } 29 | 30 | ## arrange in a tibble 31 | out <- tibble(t = t, trend = trend) 32 | class(out) <- c("linear_trend", "abrupt_driver", class(out)) 33 | out 34 | } 35 | 36 | ##' Simulate data from a linear trend model 37 | ##' 38 | ##' @param t numeric; vector of time points. 39 | ##' @param start_value,end_value numeric vectors of length 1; the start and end 40 | ##' values for the linear trend. 41 | ##' @param sampling_distribution function; a random number generating function, 42 | ##' which takes as it's first argument the number of observations to sample. 43 | ##' The second argument should be the expected value. The default, if nothing 44 | ##' is supplied, is [stats::rnorm()]. 45 | ##' @param seed numeric; a seed for the simulation. 46 | ##' @param ... additional arguments that will be passed to 47 | ##' `sampling_distribution`. 48 | ##' 49 | ##' @importFrom stats approx rnorm 50 | ##' @importFrom tibble add_column 51 | `simulate_linear_trend` <- function(t, start_value = 0, end_value = 1, 52 | sampling_distribution = NULL, seed = NULL, 53 | ...) { 54 | ## initialise the RNG, possibly with the user-supplied seed 55 | rng_state <- seed_rng(seed = seed) 56 | ## arrange for RNG state to be reset upon exit from function 57 | on.exit(assign(".Random.seed", rng_state$initial_state, envir = .GlobalEnv)) 58 | 59 | ## match the sampling_distribution to a function 60 | fun <- if (is.null(sampling_distribution)) { 61 | stats::rnorm # use rnorm() for the default 62 | } else { 63 | match.fun(sampling_distribution) 64 | } 65 | 66 | nt <- length(t) # length of series 67 | 68 | ## generate linear trend 69 | out <- linear_trend(t = t, start_value = start_value, end_value = end_value) 70 | 71 | ## generate noisy values from trend 72 | out <- add_column(out, y = fun(nt, out$trend)) 73 | class(out) <- c("simulate_linear_trend", "simulate_driver", 74 | "linear_trend", "abrupt_driver", class(out)) 75 | attr(out, "rng_state") <- rng_state 76 | out 77 | } 78 | 79 | `linear_trend_fun` <- function(t, start_value = 0, end_value = 1, 80 | sampling_distribution = NULL, ...) { 81 | .NotYetImplemented() 82 | } 83 | -------------------------------------------------------------------------------- /R/trend_step.R: -------------------------------------------------------------------------------- 1 | #' Step change trend response model 2 | #' 3 | #' @param t numeric; vector of time points. 4 | #' @param change_points numeric; vector of change points, within `t` 5 | #' @param means numeric; vector of means for the regimes implied by 6 | #' `change_points`. Must be of length `length(change_points) + 1`. 7 | #' @param ... other arguments. Ignored here. 8 | #' 9 | #' @importFrom tibble tibble 10 | #' @importFrom stats approx 11 | #' 12 | #' @export 13 | #' 14 | #' @examples 15 | #' \dontshow{ 16 | #' set.seed(1) 17 | #' op <- options(digits = 3, cli.unicode = FALSE) 18 | #' } 19 | #' sims <- step_trend(1:100, change_points = c(25, 75), means = c(2, 8, 4)) 20 | #' sims 21 | #' 22 | #' library("ggplot2") 23 | #' ggplot(sims, aes(x = t, y = trend)) + 24 | #' geom_step() 25 | #' \dontshow{options(op)} 26 | `step_trend` <- function(t, change_points, means, ...) { 27 | ## is t in order? 28 | if (is.unsorted(t)) { 29 | stop("'t' must be in increasing order.") 30 | } 31 | 32 | nt <- length(t) # length of series 33 | n_pts <- length(change_points) 34 | n_mns <- length(means) 35 | if (!identical(n_pts, n_mns - 1L)) { 36 | stop("Number of change points must be one fewer than number of means.") 37 | } 38 | 39 | ## set trend vector to last mean 40 | trend <- rep(means[n_mns], nt) 41 | ## loop over the change points, repeat mean[i] for t < change_point[i] 42 | start <- t[1] 43 | for (i in seq_along(change_points)) { 44 | ind <- (t >= start) & (t < change_points[i]) 45 | trend[ind] <- means[i] 46 | start <- change_points[i] 47 | } 48 | 49 | ## linear sequence from start to end of the length of t 50 | ## i.e. `trend <- seq(start_value, end_value, length.out = nt)` 51 | 52 | ## if t is irregular, interpolate truth to the irregular t points 53 | irregular <- length(unique(diff(t))) > 1L 54 | if (irregular) { 55 | ## use approx to interpolate 56 | trend <- approx(x = seq(t[1], t[nt], length.out = nt), 57 | y = trend, xout = t)$y 58 | } 59 | 60 | ## arrange in a tibble 61 | out <- tibble(t = t, trend = trend) 62 | class(out) <- c("step_trend", "abrupt_driver", class(out)) 63 | out 64 | } 65 | 66 | #' Simulate data from a linear trend model 67 | #' 68 | #' @param sampling_distribution function; a random number generating function, 69 | #' which takes as it's first argument the number of observations to sample. 70 | #' The second argument should be the expected value. The default, if nothing 71 | #' is supplied, is [stats::rnorm()]. 72 | #' @param seed numeric; a seed for the simulation. 73 | #' @param ... additional arguments that will be passed to 74 | #' `sampling_distribution`. 75 | #' 76 | #' @inheritParams step_trend 77 | #' 78 | #' @importFrom stats approx 79 | #' @importFrom tibble add_column 80 | #' @importFrom stats rnorm 81 | #' 82 | #' @export 83 | #' 84 | #' @examples 85 | #' \dontshow{ 86 | #' set.seed(1) 87 | #' op <- options(digits = 3, cli.unicode = FALSE) 88 | #' } 89 | #' sims <- simulate_step_trend(1:100, change_points = c(25, 75), 90 | #' means = c(2, 8, 4)) 91 | #' sims 92 | #' 93 | #' library("ggplot2") 94 | #' ggplot(sims, aes(x = t, y = y)) + 95 | #' geom_point() + 96 | #' geom_step(aes(y = trend)) 97 | #' \dontshow{options(op)} 98 | `simulate_step_trend` <- function(t, change_points, means, 99 | sampling_distribution = NULL, seed = NULL, 100 | ...) { 101 | ## initialise the RNG, possibly with the user-supplied seed 102 | rng_state <- seed_rng(seed = seed) 103 | ## arrange for RNG state to be reset upon exit from function 104 | on.exit(assign(".Random.seed", rng_state$initial_state, envir = .GlobalEnv)) 105 | 106 | ## match the sampling_distribution to a function 107 | fun <- if (is.null(sampling_distribution)) { 108 | stats::rnorm # use rnorm() for the default 109 | } else { 110 | match.fun(sampling_distribution) 111 | } 112 | 113 | nt <- length(t) # length of series 114 | 115 | ## generate linear trend 116 | out <- step_trend(t = t, change_points = change_points, means = means) 117 | 118 | ## generate noisy values from trend 119 | out <- add_column(out, y = fun(nt, out$trend)) 120 | class(out) <- c("simulate_step_trend", "simulate_driver", 121 | "step_trend", "abrupt_driver", class(out)) 122 | attr(out, "rng_state") <- rng_state 123 | out 124 | } 125 | -------------------------------------------------------------------------------- /R/sim_troph_triangle.R: -------------------------------------------------------------------------------- 1 | ##' Trophic triangle model 2 | ##' 3 | ##' @param time_out ToDo 4 | ##' @param n_steps ToDo 5 | ##' @param measurement_sigma ToDo 6 | ##' @param harvest_start ToDo 7 | ##' @param harvest_end ToDo 8 | ##' @param harvest_shape ToDo 9 | ##' @param pred_overlap_start ToDo 10 | ##' @param pred_overlap_end ToDo 11 | ##' @param pred_overlap_shape ToDo 12 | ##' 13 | ##' @author Eric J. Pedersen 14 | ##' 15 | ##' @export 16 | ##' 17 | ##' @importFrom deSolve ode 18 | ##' @importFrom dplyr mutate left_join 19 | ##' @importFrom tidyr gather 20 | ##' @importFrom stats rlnorm 21 | sim_troph_triangle <- function(time_out, 22 | n_steps, 23 | measurement_sigma = c(0,0,0), 24 | harvest_start = 0, 25 | harvest_end = 0.25, 26 | harvest_shape = 0, 27 | pred_overlap_start = 1, 28 | pred_overlap_end = 1, 29 | pred_overlap_shape = 0) { 30 | 31 | ## Describes the basic dynamic system 32 | model_parameters <- list( 33 | T_mat = 5, #length of time it takes a juvenile predator to mature to an adult 34 | m = 0.025, #mortality rate of adult and juvenile fish 35 | s = 0.05, #The stocking rate (amount of new fish being added from outside) for adult predators 36 | 37 | e_start = harvest_start, 38 | e_end = harvest_end, 39 | 40 | a_PF_start = pred_overlap_start, 41 | a_PF_end = pred_overlap_end, 42 | 43 | 44 | f = 0.5, #amount of new offspring for each adult predator per unit time 45 | a_PJ = 0.05, #Cannibalism rate of adult predators on juveniles 46 | a_FJ = 0.1, #attack rate of forage fish on juvenile predators 47 | 48 | r = 0.25, #population growth rate of forage fish at low densities 49 | b = 0.005, #density-dependence term for the forage fish 50 | a_PF_start = 0.1, #attack rate of adult predators on forage fish when species fully overlap 51 | d = 0.5, #Stocking rate for forage fish 52 | 53 | max_time = time_out 54 | ) 55 | 56 | init_cond <- c(adult = 77, forage = 0.067, juv = 9.37) 57 | 58 | troph_tri_static <- function(t,y, parms){ 59 | ## make the current model state variables also available to refer to by name 60 | adult = y["adult"] 61 | forage = y["forage"] 62 | juv = y["juv"] 63 | 64 | e <- parms[["e_start"]] + (parms[["e_end"]]-parms[["e_start"]])*t/parms[["max_time"]] 65 | a_PF <- parms[["a_PF_start"]] + (parms[["a_PF_end"]]-parms[["a_PF_start"]])*t/parms[["max_time"]] 66 | 67 | ## This next code calculates the derivatives at each point in time. 68 | ## the with(x,...) function here make the model parameters available by name 69 | ## without having to type parms$e*adult + parms$s... 70 | d_adult <- with(parms, juv/T_mat - m*adult - e*adult + s) 71 | d_forage <- with(parms, r*forage - b*forage^2 - a_PF*adult*forage + d) 72 | d_juv <- with(parms, f*adult - juv/T_mat - m*juv - a_PJ*adult*juv - a_FJ*forage*juv) 73 | 74 | list(c(adult=d_adult, forage=d_forage, juv=d_juv)) 75 | } 76 | 77 | 78 | simulation <- ode(y = init_cond, 79 | times = seq(0,time_out,length.out = n_steps), 80 | func = troph_tri_static, 81 | parms = model_parameters) 82 | 83 | simulation <- as.data.frame(simulation) 84 | 85 | noisy_obs <- mutate(simulation, 86 | adult = adult*rlnorm(n_steps,0, measurement_sigma[1]), 87 | juv = juv*rlnorm(n_steps,0, measurement_sigma[2]), 88 | forage = forage*rlnorm(n_steps,0, measurement_sigma[3]), 89 | ) 90 | noisy_obs <- gather(noisy_obs,key = species, value = abundance_obs, adult, juv,forage) 91 | 92 | 93 | simulation <- gather(simulation, key = species, value = abundance_true, adult, juv, forage) 94 | simulation <- left_join(simulation, noisy_obs) 95 | simulation <- mutate(simulation, 96 | exploitation_rate = harvest_start + (harvest_end-harvest_start)*time/time_out, 97 | predator_prey_attack = pred_overlap_start + 98 | (pred_overlap_end-pred_overlap_start)*time/time_out 99 | ) 100 | 101 | simulation 102 | } 103 | -------------------------------------------------------------------------------- /.github/CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Contributor Covenant Code of Conduct 2 | 3 | ## Our Pledge 4 | 5 | We as members, contributors, and leaders pledge to make participation in our 6 | community a harassment-free experience for everyone, regardless of age, body 7 | size, visible or invisible disability, ethnicity, sex characteristics, gender 8 | identity and expression, level of experience, education, socio-economic status, 9 | nationality, personal appearance, race, religion, or sexual identity and 10 | orientation. 11 | 12 | We pledge to act and interact in ways that contribute to an open, welcoming, 13 | diverse, inclusive, and healthy community. 14 | 15 | ## Our Standards 16 | 17 | Examples of behavior that contributes to a positive environment for our 18 | community include: 19 | 20 | * Demonstrating empathy and kindness toward other people 21 | * Being respectful of differing opinions, viewpoints, and experiences 22 | * Giving and gracefully accepting constructive feedback 23 | * Accepting responsibility and apologizing to those affected by our mistakes, 24 | and learning from the experience 25 | * Focusing on what is best not just for us as individuals, but for the overall 26 | community 27 | 28 | Examples of unacceptable behavior include: 29 | 30 | * The use of sexualized language or imagery, and sexual attention or 31 | advances of any kind 32 | * Trolling, insulting or derogatory comments, and personal or political attacks 33 | * Public or private harassment 34 | * Publishing others' private information, such as a physical or email 35 | address, without their explicit permission 36 | * Other conduct which could reasonably be considered inappropriate in a 37 | professional setting 38 | 39 | ## Enforcement Responsibilities 40 | 41 | Community leaders are responsible for clarifying and enforcing our standards 42 | of acceptable behavior and will take appropriate and fair corrective action in 43 | response to any behavior that they deem inappropriate, threatening, offensive, 44 | or harmful. 45 | 46 | Community leaders have the right and responsibility to remove, edit, or reject 47 | comments, commits, code, wiki edits, issues, and other contributions that are 48 | not aligned to this Code of Conduct, and will communicate reasons for moderation 49 | decisions when appropriate. 50 | 51 | ## Scope 52 | 53 | This Code of Conduct applies within all community spaces, and also applies 54 | when an individual is officially representing the community in public spaces. 55 | Examples of representing our community include using an official e-mail 56 | address, posting via an official social media account, or acting as an appointed 57 | representative at an online or offline event. 58 | 59 | ## Enforcement 60 | 61 | Instances of abusive, harassing, or otherwise unacceptable behavior may be 62 | reported to the community leaders responsible for enforcement at [INSERT CONTACT 63 | METHOD]. All complaints will be reviewed and investigated promptly and fairly. 64 | 65 | All community leaders are obligated to respect the privacy and security of the 66 | reporter of any incident. 67 | 68 | ## Enforcement Guidelines 69 | 70 | Community leaders will follow these Community Impact Guidelines in determining 71 | the consequences for any action they deem in violation of this Code of Conduct: 72 | 73 | ### 1. Correction 74 | 75 | **Community Impact**: Use of inappropriate language or other behavior deemed 76 | unprofessional or unwelcome in the community. 77 | 78 | **Consequence**: A private, written warning from community leaders, providing 79 | clarity around the nature of the violation and an explanation of why the 80 | behavior was inappropriate. A public apology may be requested. 81 | 82 | ### 2. Warning 83 | 84 | **Community Impact**: A violation through a single incident or series of 85 | actions. 86 | 87 | **Consequence**: A warning with consequences for continued behavior. No 88 | interaction with the people involved, including unsolicited interaction with 89 | those enforcing the Code of Conduct, for a specified period of time. This 90 | includes avoiding interactions in community spaces as well as external channels 91 | like social media. Violating these terms may lead to a temporary or permanent 92 | ban. 93 | 94 | ### 3. Temporary Ban 95 | 96 | **Community Impact**: A serious violation of community standards, including 97 | sustained inappropriate behavior. 98 | 99 | **Consequence**: A temporary ban from any sort of interaction or public 100 | communication with the community for a specified period of time. No public or 101 | private interaction with the people involved, including unsolicited interaction 102 | with those enforcing the Code of Conduct, is allowed during this period. 103 | Violating these terms may lead to a permanent ban. 104 | 105 | ### 4. Permanent Ban 106 | 107 | **Community Impact**: Demonstrating a pattern of violation of community 108 | standards, including sustained inappropriate behavior, harassment of an 109 | individual, or aggression toward or disparagement of classes of individuals. 110 | 111 | **Consequence**: A permanent ban from any sort of public interaction within the 112 | community. 113 | 114 | ## Attribution 115 | 116 | This Code of Conduct is adapted from the [Contributor Covenant][homepage], 117 | version 2.0, 118 | available at https://www.contributor-covenant.org/version/2/0/ 119 | code_of_conduct.html. 120 | 121 | Community Impact Guidelines were inspired by [Mozilla's code of conduct 122 | enforcement ladder](https://github.com/mozilla/diversity). 123 | 124 | [homepage]: https://www.contributor-covenant.org 125 | 126 | For answers to common questions about this code of conduct, see the FAQ at 127 | https://www.contributor-covenant.org/faq. Translations are available at https:// 128 | www.contributor-covenant.org/translations. 129 | -------------------------------------------------------------------------------- /R/HGAM.R: -------------------------------------------------------------------------------- 1 | ##' Fits an HGAM model 2 | ##' 3 | ##' @param data Data frame used for fitting. Should be constructed by the 4 | ##' abr_data function 5 | ##' @param type The type of regime detection model. One of "t", "st","s", "gt", 6 | ##' "gst","gs". "t" indicates a temporal smoother, "s" indicates a spatial 7 | ##' smoother, and "g" indicates a grouped (HGAM) smoother 8 | ##' @param bs_t/bs_s/bs_g basis types to be used for the temporal, spatial, and 9 | ##' group-level smoothers 10 | ##' @param k_t/k_s/k_g number of basis functions to use for temporal, spatial, 11 | ##' and group-level smoothers 12 | ##' @param family The family mgcv or brms will use to fit the model. 13 | ##' 14 | ##' 15 | ##' @return A fitted object of class 'abrupt_model' and 'HGAM'. 16 | ##' 17 | ##' @depend mgcv 18 | ##' @suggest brms 19 | `abr_fit.hgam` <- function(data,type = "t", 20 | bs_t = "tp", bs_s = "gp", bs_g = "re", 21 | k_t = 20,k_s=20, k_g=NA, 22 | func = "gam", 23 | family = "gaussian", 24 | calc_breaks = FALSE, 25 | break_args = list(), 26 | ... ) { 27 | 28 | #Currently, just loading the gam function via mgcv::gam does not work, 29 | #as it is unable to find other associated functions from the mgcv namespace 30 | #like ldTweedie 31 | library(mgcv) 32 | 33 | #is the data of the right type? 34 | if (!inherits(data,"abdata")) { 35 | stop("'data' must be constructed by the the 'abr_data' function.") 36 | } 37 | 38 | if(grepl("s", type,fixed = TRUE)){ 39 | #Add code turning spatial column into either coordinates (for point-like 40 | #data) or an adjacency matrix (for polygon-like data) 41 | } 42 | 43 | ## To do: add checks to ensure that basis types, families provided are valid 44 | 45 | if(type=="t"){ 46 | model <- mgcv::gam(value~s(time, bs=bs_t), 47 | family = family, 48 | method = "REML", 49 | data =data) 50 | } 51 | if(type=="gt"){ 52 | model <- mgcv::gam(formula = value~t2(time, variable, 53 | bs= c(bs_t,bs_g), 54 | k=c(k_t,k_g)), 55 | family = family, 56 | method = "REML", 57 | data =data) 58 | } 59 | out <- list() 60 | out$data <- data 61 | out$type <- type 62 | out$model <- model 63 | out$break_args <- break_args 64 | class(out) <- c("abrupt_model","hgam", class(model)) 65 | 66 | if(calc_breaks){ 67 | out$breaks <- abr_breaks.hgam(out) 68 | }else{ 69 | out$breaks <- NULL 70 | } 71 | 72 | out 73 | } 74 | 75 | 76 | 77 | ##' Extracts breakpoints from an HGAM model 78 | ##' 79 | ##' @param abr_fitobj A previously fitted 80 | ##' 81 | ##' @return A list containing `seed`, the supplied seed, `initial_state`, the 82 | ##' initial state of the RNG before the seed was set, and `kind`, the type of 83 | ##' RNG used, as returned by [base::RNGkind()]. 84 | ##' 85 | ##' @depend mgcv 86 | ##' @suggest brms 87 | ##' @importFrom dplyr mutate group_by summarize 88 | `abr_breaks.hgam` <- function(abr_fitobj, 89 | breaktype = NULL, 90 | stepsize = NULL, 91 | delta = NULL, 92 | nsims = NULL, 93 | transform = NULL, 94 | aggregate = NULL, 95 | CI = FALSE){ 96 | 97 | 98 | t_range <- range(abr_fitobj$data$time) 99 | 100 | if(is.null(stepsize)){ 101 | if(is.null(abr_fitobj$break_args$stepsize)){ 102 | #this is currently pretty ugly; it would be nicer with pipes but 103 | #I need to figure out whether it's reasonable to import pipes into the 104 | #function 105 | stepsize <- group_by(abr_fitobj$data, variable) 106 | stepsize <- summarize(stepsize, tdiff = min(diff(time))) 107 | stepsize <- min(stepsize$tdiff) 108 | if(stepsize ==0){ 109 | stepsize <- (t_range[2] -t_range[1]) /100 110 | } 111 | } else{ 112 | stepsize <- abr_fitobj$break_args$stepsize 113 | } 114 | } 115 | 116 | if(is.null(nsims)){ 117 | if(is.null(abr_fitobj$break_args$nsims)){ 118 | nsims <- 100 119 | } else nsims <- abr_fitobj$break_args$nsims 120 | } 121 | 122 | 123 | if(is.null(delta)){ 124 | if(is.null(abr_fitobj$break_args$delta)){ 125 | delta <- 1e-6 126 | } else delta <- abr_fitobj$break_args$delta 127 | } 128 | 129 | 130 | if(is.null(transform)){ 131 | if(is.null(abr_fitobj$break_args$transform)){ 132 | transform <- identity 133 | } else nsims <- abr_fitobj$break_args$transform 134 | } 135 | 136 | type <- abr_fitobj$type 137 | 138 | if(grepl("g", type,fixed = TRUE)){ 139 | variable <- unique(abr_fitobj$data$variable) 140 | } else{ 141 | variable <- NA 142 | } 143 | 144 | #Creating synthetic prediction data to 145 | pred_at <- expand.grid(time = seq(t_range[1],t_range[2], by= stepsize), 146 | variable = variable,stringsAsFactors = FALSE) 147 | 148 | pred_before <- pred_at 149 | pred_before$time <- pred_before$time - delta 150 | 151 | pred_after <- pred_at 152 | pred_after$time <- pred_after$time + delta 153 | 154 | lp_at <- mgcv::predict.gam(abr_fitobj$model, 155 | newdata = pred_at, 156 | type = "lpmatrix") 157 | lp_before <- mgcv::predict.gam(abr_fitobj$model, 158 | newdata = pred_before, 159 | type = "lpmatrix") 160 | lp_after <- mgcv::predict.gam(abr_fitobj$model, 161 | newdata = pred_after, 162 | type = "lpmatrix") 163 | 164 | #taking advantage of the linearity of the derivative to just 165 | #calculate one lp matrix. Note that this won't work for nonlinear 166 | #transformations of the data, but we can post-multiply the 167 | #derivative by the derivative of the transformation w.r.t. 168 | #x to get the new derivative. 169 | lp_deriv <- calc_1st_deriv(lp_before, lp_after,delta) 170 | 171 | vcv <- abr_fitobj$model$Vc 172 | coef_means <- abr_fitobj$model$coefficients 173 | 174 | coef_sims <- t(mgcv::rmvn(n = nsims,mu = coef_means, V = vcv)) 175 | deriv_fit <- lp_deriv%*%coef_sims 176 | 177 | breaks_ci <- t(apply(deriv_fit,MARGIN = 1,FUN = quantile,probs = c(0.025,0.975)) ) 178 | breaks_ci <- as.data.frame(breaks_ci) 179 | names(breaks_ci) <- c("ci_lower","ci_upper") 180 | breaks_ci <- cbind(pred_at, breaks_ci) 181 | # breaks <- list() 182 | # 183 | # is_break <- FALSE 184 | # sign <- "zero" 185 | # for(i in 1:nrow(pred_at)){ 186 | # if(breaks_ci[i,1]>0){ 187 | # if(!is_break){ 188 | # break_start <- pred_at$time[i] 189 | # sign <- "pos" 190 | # is_break <- TRUE 191 | # } 192 | # if(is_break&sign=="neg"){ 193 | # 194 | # breaks 195 | breaks_ci 196 | } 197 | 198 | 199 | 200 | 201 | 202 | -------------------------------------------------------------------------------- /R/simulate_abrupt_change.R: -------------------------------------------------------------------------------- 1 | create_driver_function <- function(change_times, 2 | parm_values, 3 | interpolation = c("linear","constant","spline")){ 4 | interpolation <- match.arg(interpolation) 5 | if(length(change_times)+1 != length(parm_values)){ 6 | stop("parm_values should be a vector 1 longer than change_times to account for the initial regime") 7 | } 8 | stopifnot(is.numeric(change_times)) 9 | stopifnot(is.numeric(parm_values)) 10 | 11 | interp_values = c(0, change_times) 12 | 13 | if(interpolation=="spline"){ 14 | fun <- stats::splinefun(x= interp_values, 15 | y = parm_values, 16 | method = "natural") 17 | }else{ 18 | fun <- stats::approxfun(x = interp_values, 19 | y= parm_values, 20 | rule = 2, 21 | method = interpolation) 22 | } 23 | 24 | fun 25 | } 26 | 27 | random_var_matrix <- function(n_sp,diag_min = 0, diag_max =1, off_diag_min = -1, 28 | frac_connected = 0.25, 29 | off_diag_max = 1, check_eigen = TRUE){ 30 | 31 | if(!check_eigen){ 32 | n_iter = 1 33 | mat <- matrix(runif(n_sp^2, 34 | min = off_diag_min, 35 | max = off_diag_max) * 36 | rbinom(n_sp^2,size = 1,prob = frac_connected), 37 | nrow = n_sp) 38 | diag(mat) = runif(n_sp,diag_min,diag_max) 39 | } else{ 40 | n_iter = 0 41 | while(check_eigen){ 42 | n_iter = n_iter + 1 43 | mat <- matrix(runif(n_sp^2, 44 | min = off_diag_min, 45 | max = off_diag_max) * 46 | rbinom(n_sp^2,size = 1,prob = frac_connected), 47 | nrow = n_sp) 48 | diag(mat) = runif(n_sp,diag_min,diag_max) 49 | 50 | if(max(abs(eigen(mat)$value))<1) check_eigen = FALSE 51 | } 52 | } 53 | attr(mat, "n_iter") = n_iter 54 | return(mat) 55 | } 56 | 57 | 58 | sim_troph_triangle <- function(time_out = 100, 59 | n_steps = c(100), 60 | measurement_sigma = c(0,0,0), 61 | harvest_rates = create_driver_function(change_times = 50, 62 | parm_values = c(0,0.25), 63 | interpolation = "constant"), 64 | pred_overlap = create_driver_function(change_times = 50, 65 | parm_values = c(1,1), 66 | interpolation = "constant") 67 | ) { 68 | 69 | #Describes the basic dynamic system 70 | 71 | library(deSolve) 72 | library(dplyr) 73 | library(tidyr) 74 | 75 | model_parameters <- list( 76 | T_mat = 5, #length of time it takes a juvenile predator to mature to an adult 77 | m = 0.025, #mortality rate of adult and juvenile fish 78 | s = 0.1, #The stocking rate (amount of new fish being added from outside) for adult predators 79 | 80 | harvest_rates = harvest_rates, 81 | pred_overlap = pred_overlap, 82 | 83 | a_PF_base = 0.1, 84 | 85 | f = 0.5, #amount of new offspring for each adult predator per unit time 86 | a_PJ = 0.05, #Cannibalism rate of adult predators on juveniles 87 | a_FJ = 0.1, #attack rate of forage fish on juvenile predators 88 | 89 | r = 0.25, #population growth rate of forage fish at low densities 90 | b = 0.005, #density-dependence term for the forage fish 91 | a_PF_start = 0.1, #attack rate of adult predators on forage fish when species fully overlap 92 | d = 1, #Stocking rate for forage fish 93 | 94 | max_time = time_out 95 | ) 96 | 97 | 98 | 99 | init_cond <- c(adult = 77, forage = 0.067, juv = 9.37) 100 | 101 | troph_tri_static <- function(t,y, parms){ 102 | #make the current model state variables also available to refer to by name 103 | adult = y["adult"] 104 | forage = y["forage"] 105 | juv = y["juv"] 106 | 107 | e <- parms$harvest_rates(t) 108 | a_PF <- parms$pred_overlap(t)*parms[["a_PF_base"]] 109 | 110 | #This next code calculates the derivatives at each point in time. 111 | #the with(x,...) function here make the model parameters available by name 112 | #without having to type parms$e*adult + parms$s... 113 | d_adult <- with(parms, juv/T_mat - m*adult - e*adult + s) 114 | d_forage <- with(parms, r*forage - b*forage^2 - a_PF*adult*forage + d) 115 | d_juv <- with(parms, f*adult - juv/T_mat - m*juv - a_PJ*adult*juv - a_FJ*forage*juv) 116 | return(list(c(adult=d_adult,forage=d_forage, juv=d_juv))) 117 | } 118 | 119 | 120 | simulation <- ode(y=init_cond, 121 | times = seq(0,time_out,length.out = n_steps), 122 | func = troph_tri_static, 123 | parms = model_parameters) 124 | 125 | simulation <- as.data.frame(simulation) 126 | 127 | noisy_obs <- mutate(simulation, 128 | adult = adult*rlnorm(n_steps,0, measurement_sigma[1]), 129 | juv = juv*rlnorm(n_steps,0, measurement_sigma[2]), 130 | forage = forage*rlnorm(n_steps,0, measurement_sigma[3]), 131 | ) 132 | noisy_obs <- gather(noisy_obs,key = species, value = abundance_obs, adult, juv,forage) 133 | 134 | 135 | simulation <- gather(simulation,key = species, value = abundance_true, adult, juv,forage) 136 | simulation <- left_join(simulation, noisy_obs) 137 | simulation <- mutate(simulation, 138 | exploitation_rate = harvest_rates(time), 139 | predator_prey_attack = model_parameters[["a_PF_base"]]*pred_overlap(time) 140 | ) 141 | 142 | return(simulation) 143 | 144 | } 145 | 146 | 147 | sim_var <- function(n_steps = 50, 148 | n_species = 10, 149 | regime_change_points = c(), 150 | regime_means = "random", 151 | regime_coefs = "random", 152 | regime_vars = 1 153 | ) { 154 | 155 | n_regimes <- length(regime_change_points)+1 156 | if(!(regime_means[[1]][[1]]=="random" |(is.list(regime_means)&length(regime_means) == n_regimes)|length(regime_means)==1|length(regime_means)==n_species)){ 157 | stop("regime_means should be one of: 'random', a list of vectors equal to the number of regime change points plus 1, a single number, or a vector of length n_species") 158 | } 159 | 160 | if(!(regime_coefs[[1]][[1]]=="random" |(is.list(regime_coefs)&length(regime_coefs) == n_regimes)|length(regime_coefs)==1|length(regime_coefs)==n_species^2)){ 161 | stop("regime_coefs should be one of: 'random', a list of matrices equal to the number of regime change points plus 1, a single number, or a matrix of length n_species") 162 | } 163 | 164 | if(!((is.list(regime_vars)&length(regime_vars) == n_regimes)|length(regime_vars)==1|length(regime_vars)==n_species)){ 165 | stop("regime_vars should be one of: a list of vectors equal to the number of regime change points plus 1, a single number, or a vector of length n_species") 166 | } 167 | 168 | regime_change_points <- c(0, sort(regime_change_points), n_steps+1) 169 | 170 | if(regime_means[1]=="random"){ 171 | regime_means <- list() 172 | for(i in 1:n_regimes){ 173 | regime_means[[i]] <- runif(n_species) 174 | } 175 | } else if(!is.list(regime_means)){ 176 | new_means <- list() 177 | for(i in 1:n_regimes){ 178 | new_means[[i]] <- regime_means 179 | } 180 | regime_means <- new_means 181 | } 182 | 183 | if(regime_coefs[1]=="random"){ 184 | regime_coefs <- list() 185 | for(i in 1:n_regimes){ 186 | regime_coefs[[i]] <- random_var_matrix(n_species) 187 | } 188 | } else if(!is.list(regime_coefs)){ 189 | new_coefs <- list() 190 | for(i in 1:n_regimes){ 191 | new_coefs[[i]] <- regime_coefs 192 | } 193 | regime_coefs <- new_coefs 194 | } 195 | 196 | if(!is.list(regime_vars)){ 197 | new_vars <- list() 198 | for(i in 1:n_regimes){ 199 | new_vars[[i]] <- regime_vars 200 | } 201 | regime_vars <- new_vars 202 | } 203 | 204 | 205 | 206 | 207 | 208 | out_data <- matrix(nrow = n_steps, ncol = n_species) 209 | out_data[1,] <- regime_means[[1]] 210 | regime <- 1 211 | 212 | for(i in 2:n_steps){ 213 | if(i>regime_change_points[regime+1]) regime = regime +1 214 | out_data[i,] <- regime_means[[regime]] + regime_coefs[[regime]]%*%(out_data[i-1,]-regime_means[[regime]]) + rnorm(n_species) 215 | } 216 | 217 | out_data <- as.data.frame(out_data) 218 | out_data <- dplyr::mutate(out_data, 219 | time = 1:n_steps) 220 | out_data <- tidyr::gather(out_data,species,abundance,-time) 221 | 222 | out_list <- list(simulation = out_data, 223 | n_regimes = n_regimes, 224 | regime_change_points = regime_change_points, 225 | regime_means = regime_means, 226 | regime_coefs = regime_coefs) 227 | out_list 228 | } 229 | -------------------------------------------------------------------------------- /code-for-inclusion/dynamic_shift_detector.R: -------------------------------------------------------------------------------- 1 | #script to analyse time series data to determine break points 2 | 3 | #assume data is in form of data frame where first column is year, second is abundance (Nt) 4 | 5 | #create function that makes an additional response variable Nt1 6 | #where Nt1 is the abundance in the next year 7 | 8 | addNt1<-function(data){ 9 | #create empty vector to feed 'next year' abundance into 10 | Nt1 = c() 11 | #pull out values from the abundance column- 12 | #for each year, go to the NEXT year's abundance, put that in the vector 13 | for (i in 1:(length(data[,2])-1)) { 14 | Nt1 = c(Nt1,(data[,2])[i+1]) 15 | } 16 | #cut out last sampling year, because there is no Nt+1 for that year 17 | data<-data[which(data[,1](Break1-1)),] 108 | if(nrow(part1)>3 & nrow(part2)>3){ #constrain model to run only when 4 or more points are present 109 | fit1<-rickerfit(part1) #fit the model to part 1 110 | fit2<-rickerfit(part2) #fit the model to part 2 111 | breaks.1<-c(breaks, max(part1$year), max(part2$year)) #breaks for one break 112 | fit.1<-c(fit, fit1[1], fit2[1]) #fit for one break 113 | out[1]<-list(breaks.1)#create output vector of two lists 114 | out[2]<-list(fit.1) 115 | out.frame<-rbind(out.frame, out) #bind it to previous results 116 | } 117 | Break1<-Break1+1 #move the break to next year 118 | } 119 | #rename columns in output for some reason 120 | colnames(out.frame)<- c("Breaks", "AICs") 121 | return(out.frame) 122 | } 123 | 124 | 125 | #lets take our results frame from splitnfit and test each break combinaton for the 126 | # the ability to be broken up more. This situation will occur when the last two years 127 | # in the breaks list are more than 5 years apart 128 | 129 | findbreakable<-function(data){ #create a function that finds if the last subset of the data is still breakable 130 | breakable<-c() #create vector to put results in 131 | for (i in 1:nrow(data)){ #for each row in the data frame 132 | if (length(unlist(data$Breaks[i]))>1){ #if the data has been subset 133 | breakvector<-unlist(data$Breaks[i]) #create a vector of the breaks 134 | L<-length(breakvector) # find out how long breakvector is 135 | difference<-breakvector[L]-breakvector[L-1] #find out how big the last subset is 136 | if(difference>5){ #we can break it down more if the last subset has more than 5 points in it 137 | breakable.i<-TRUE 138 | }else{ 139 | breakable.i<-FALSE #don't break more if the subset is 5 or smaller 140 | } 141 | }else{ 142 | breakable.i<-FALSE # don't break it down more if the data is frm the zero breaks model 143 | } 144 | breakable<-c(breakable, breakable.i) 145 | } 146 | return(breakable) 147 | 148 | } 149 | 150 | 151 | #create a function that uses findbreakable to apply splitntfit to the datasets that are still breakble 152 | out.frame<-data.frame(matrix(vector(), 0, 2, #create an empty data frame we can add to later 153 | dimnames=list(c(), c("Breaks", "AICs"))), 154 | stringsAsFactors=F) 155 | 156 | subsequentsplit<-function(fitdata, rawdata){ 157 | keepers<-findbreakable(fitdata) #find subsets that are still breakable 158 | newfitdata<-fitdata[which(keepers==TRUE),] #create new data frame with only these data in it 159 | breaklist<-newfitdata$Breaks #pull out our two operational objects out of data frame 160 | fitlist<-newfitdata$AICs 161 | result<-data.frame(matrix(vector(), 0, 2, 162 | dimnames=list(c(), c("Breaks", "AICs"))), 163 | stringsAsFactors=F) 164 | if(nrow(newfitdata)>0){ #if there are subsets with still breakable data 165 | for(i in 1:nrow(newfitdata)){ #for each row in the new frame we need to break down 166 | breakvector<-unlist(breaklist[i]) #turn the list element back into a vector 167 | fitvector<-unlist(fitlist[i]) 168 | breakvector<-breakvector[-length(breakvector)]#remove the last element from each 169 | fitvector<-fitvector[-length(fitvector)] 170 | cullpoint<-max(breakvector) #find point of last break 171 | testdata<-rawdata[which(rawdata$year>cullpoint),] 172 | out<-splitnfit(testdata, breakvector, fitvector, out.frame) 173 | out<-out[-1,] #remove the no-break fit, we don't need that 174 | result<-rbind(result, out) 175 | } 176 | }else{ #if there is no more room for breaks in any of the fits 177 | result<-result #leave result empty 178 | } 179 | return(result) 180 | } 181 | 182 | 183 | #okay, now let's put this all together into a function that will fit all the breaks 184 | 185 | nbreaker<-function(data){ 186 | breaks<-list() #create empty LIST for storing breaks 187 | fit<-list() #create empty LIST for storing associated AICs 188 | out.frame<-data.frame(matrix(vector(), 0, 2, 189 | dimnames=list(c(), c("Breaks", "AICs"))), 190 | stringsAsFactors=F) 191 | onebreak<-splitnfit(data, breaks, fit, out.frame)#get fits for zero and one break 192 | feed<-onebreak #create derrived data to feed into the fit 193 | out<-onebreak #prepare these data to be output 194 | 195 | keepers<-findbreakable(onebreak) #find subsets that are still breakable 196 | newfitdata<-onebreak[which(keepers==TRUE),] #create new data frame with only these data in it 197 | stillbreakable<-nrow(newfitdata) 198 | while(stillbreakable>0){ #if there is data that can still be broken up 199 | feed<-subsequentsplit(feed, data) #fit the subsequent split using data fed from last breaks 200 | out<-rbind(out, feed) #attach this break iteration to the data frame 201 | #see if there's more breaks to be had 202 | keepers<-findbreakable(feed) #find subsets that are still breakable 203 | newfitdata<-feed[which(keepers==TRUE),] #create new data frame with only these data in it 204 | stillbreakable<-nrow(newfitdata) 205 | 206 | } 207 | return(out) 208 | } 209 | 210 | 211 | #victory! now we need to extract the data we've produced from this data frame, sum up AICs and add 212 | # the corrections, and identify the best models 213 | 214 | #function to tally up AICs 215 | AICtally<-function(data){ #create a function that adds up the AICs in the list 216 | fitdata<-nbreaker(data) 217 | AICtots<-c() #create vector to put results in 218 | N_AIC<-c() #create a vector to put counts of AICs in 219 | for (i in 1:nrow(fitdata)){ #for each row in the data frame 220 | AICsvector<-unlist(fitdata$AICs[i]) #create a vector of the AICs for the fit 221 | total<-sum(AICsvector)#add up the AICs 222 | N<-length(AICsvector)#count the AICs 223 | AICtots<-c(AICtots, total)# add the total for each cell to the vector 224 | N_AIC<-c(N_AIC, N) #add the count of AICs 225 | } 226 | out<-as.data.frame(cbind(AICtots, N_AIC)) #bind the outputs into a data frame 227 | colnames(out)<- c("AICtot", "Nfits") #name the columns 228 | 229 | #now we want to calculate the AICc correction for each 230 | out$Nbreaks<-out$Nfits-1 231 | out$AICc<-out$AICtot+AICcorrection(data, out$Nbreaks) #n breaks = n fits-1, add correction to AIC 232 | 233 | return(out) 234 | 235 | } 236 | 237 | 238 | #see if AICtally outputs will stick to nbreaker outputs- and create a function that does this 239 | allfits<-function(data){ 240 | out<-as.data.frame(cbind(nbreaker(data), AICtally(data))) #stick output from two functions into a df 241 | return(out) 242 | } 243 | 244 | 245 | 246 | 247 | #create a function that finds equivalent fits in n breakpoint data 248 | #add functionality for switching between AIC and AICc, with AIC as default 249 | 250 | equivalentfit<-function(data, criterion){ 251 | breakset<-allfits(data) #generate matrix of fits by breakpoints 252 | if(missing(criterion)){ #set AIC as the default criterion 253 | criterion<-"AIC" 254 | } 255 | if(criterion=="AIC"){ 256 | AICbest<-min(breakset$AICtot) #find best AIC in the set 257 | deltaAIC<-AICbest+2 # create rule for equivalent models 258 | out.frame<-breakset[which(breakset$AICtotbreakvector[i]),] 311 | fit1<-rickerfit(part1) #fit first segment 312 | output<-c(min(part1$year), max(part1$year), fit1)#save results of fitting segment in vector 313 | out.frame<-rbind(out.frame, output)#put output for segment in a data frame 314 | data<-part2 #update data to cull out already fitted segments 315 | } 316 | 317 | } 318 | colnames(out.frame)<- c("Year1", "Year2", "AIC", "r", "rse", "k", "kse") 319 | return(out.frame) 320 | } 321 | 322 | #adapt this function to provide specs of any fit information, as output in the format of the bestfit function 323 | 324 | modelspecification<-function(specs, data){ 325 | modelspecs<-specs #get the particulars of the best model 326 | out.frame<-data.frame(matrix(vector(), 0, 7, 327 | dimnames=list(c(), 328 | c("Year1", "Year2", "AIC", "r", "rse", "k", "kse"))), 329 | stringsAsFactors=F)#Create a place to put our data 330 | breakvector<-unlist(modelspecs$Breaks[1])#pull out a vector of the max year in each fit 331 | 332 | if (modelspecs$Nbreaks[1]==0){ #if there's no breaks 333 | fit<-rickerfit(data) 334 | output<-c(min(data$year), max(data$year), fit) #fit whole data series + output results 335 | out.frame<-rbind(out.frame, output) 336 | 337 | } else { 338 | for (i in 1:(length(breakvector))){ #for all breakpoints, including the end of the time series, in order 339 | part1<-data[which(data$yearbreakvector[i]),] 341 | fit1<-rickerfit(part1) #fit first segment 342 | output<-c(min(part1$year), max(part1$year), fit1)#save results of fitting segment in vector 343 | out.frame<-rbind(out.frame, output)#put output for segment in a data frame 344 | data<-part2 #update data to cull out already fitted segments 345 | } 346 | 347 | } 348 | colnames(out.frame)<- c("Year1", "Year2", "AIC", "r", "rse", "k", "kse") 349 | return(out.frame) 350 | } 351 | 352 | 353 | #looks like that works! Okay! put it all together like we did for the 2 break model 354 | 355 | DSdetector<-function(data, criterion){ #use raw time series data 356 | #plot the data 357 | plot(data) 358 | data1<-addNt1(data) 359 | plot(data1$Nt, data1$Nt1) 360 | #give an output of all possible break point combinations tested 361 | writeLines(paste("Here are the break points for all models tested")) 362 | print(allfits(data1)) 363 | #output models with equivalent performance 364 | writeLines(paste("Here is the set of best performing models")) 365 | print(equivalentfit(data1, criterion)) 366 | #output model with best performance 367 | writeLines(paste("Here is the best model- the one with the lowest AIC/AICc, or fewest parameters, in case of a tie")) 368 | print(bestfit(data1, criterion)) 369 | # output regression parameters of best model 370 | writeLines(paste("Here is the set of regression parameters")) 371 | print(bestmodel(data1, criterion)) 372 | } 373 | 374 | 375 | 376 | #looks like we have a working model! Boom! 377 | 378 | #Okay, but what about 'break weights'- how 'strong' are the given breaks? Let's take some inspiration 379 | #from multimodel interference and calculate the weight of a given break that the model finds 380 | #first, we need to calculate the model weights for all of the fits 381 | 382 | allweights<-function(data, criterion){ 383 | breakset<-allfits(data) #generate matrix of fits by breakpoints 384 | if(missing(criterion)){ #set AIC as the default criterion 385 | criterion<-"AIC" 386 | } 387 | if(criterion=="AIC"){ 388 | AICbest<-min(breakset$AICtot) #find best AIC in the set 389 | deltaAIC<-breakset$AICtot-AICbest 390 | sumdeltaAIC<-sum(exp(-deltaAIC/2)) 391 | } 392 | if (criterion=="AICc"){ 393 | AICbest<-min(breakset$AICc) #find best AIC in the set 394 | deltaAIC<-breakset$AICc-AICbest 395 | sumdeltaAIC<-sum(exp(-deltaAIC/2)) 396 | } 397 | breakset$modelweights<-(exp(-deltaAIC/2))/sumdeltaAIC 398 | 399 | out.frame<-breakset[which(breakset$modelweights>0.001),] #cut out all models with weight less than 0.01, just to speed things up 400 | return(out.frame) 401 | } 402 | 403 | #now we need a function that calculates parameter weights for the breaks 404 | breakweights<-function(data, criterion){ 405 | modelset<-allweights(data, criterion)#find all models with weights over 0.001 406 | breaksfound<-sort(unique(unlist(modelset$Breaks))) #get a list of unique breaks, sort it in numerical order 407 | breakweights<-c() #blank vector to put the breaks in 408 | for(i in 1:length(breaksfound)){ 409 | weightcounter<-0 410 | for (j in 1:length(modelset$modelweights)){ 411 | if(breaksfound[i] %in% unlist(modelset$Breaks[j])){ 412 | weightcounter<-weightcounter+modelset$modelweights[j] #add model weight of parameter where that break appears 413 | }else{ 414 | weightcounter<-weightcounter+0 415 | } 416 | } 417 | breakweights<-c(breakweights, weightcounter) 418 | } 419 | correctedweights<-breakweights/max(breakweights) #breakweights is based on best model set- correct to normalize by break at the end of time series 420 | out.frame<-as.data.frame(cbind(breaksfound, breakweights, correctedweights)) 421 | return(out.frame) 422 | } 423 | 424 | -------------------------------------------------------------------------------- /code-for-inclusion/simulations_weight_analysis.R: -------------------------------------------------------------------------------- 1 | #script for creating simulated data under a variety of parameters 2 | #and then determining if breakweights function correctly determines these parameters 3 | 4 | #get the regime shift detector functions into memory 5 | ## source("dynamic_shift_detector.R") 6 | 7 | #create a function that will make fake data based on specified parameters 8 | #assume change, noise is given in percent (0-100) scale, as is change to r, k 9 | 10 | fakedata<-function(startyear, Nyears, startPop, noise, startK, startR, breaks, changeK, changeR){ 11 | if(missing(startyear)){ #set default values for all paremeters 12 | startyear<-1900 13 | } 14 | if(missing(Nyears)){ 15 | Nyears<-20 16 | } 17 | #in order to set the default breaks, I need to know what the last year in the time range is 18 | #so let's create a vector of years going into the time series now 19 | year<-seq(startyear, (startyear+Nyears-1)) #-1 because time range is inclusive of year 0 20 | lastyear<-max(year)-1# max is second last year because we don't have Nt1 for last year 21 | 22 | if(missing(startPop)){#let's make popultion size default to 1000 23 | startPop<-1000 24 | } 25 | if(missing(noise)){#no noise by default 26 | noise<-0 27 | } 28 | if(missing(startK)){ #so start population can grow by default 29 | startK<-1500 30 | } 31 | if(missing(startR)){ 32 | startR<-1.5 33 | } 34 | if(missing(breaks)){ 35 | breaks<-list()#no break model, null list 36 | } 37 | if(missing(changeK)){ # by default, don't change K after a break 38 | changeK<-0 39 | } 40 | if(missing(changeR)){ #same with r 41 | changeR<-0 42 | } 43 | 44 | #create a vector for noise for each year- it will be random, normally distributed error 45 | noisevector<-c()# make an empty vector 46 | for (i in 1:(length(year))){ 47 | randomnoise<-rnorm(1, mean=0, sd=noise)#choose a random value with a sd of our % noise 48 | instant.buzz<-1+(randomnoise)/100 #generate an instantaneous buzz :) 49 | noisevector<-c(noisevector, instant.buzz) #add that to the vector 50 | } 51 | 52 | #create a vector of when regime shifts will occur 53 | change<-c(FALSE)# make a vector with first value false- cannot have a change in first year 54 | for (i in 1:(length(year)-1)){ 55 | if(any(breaks==year[i])){ 56 | switch<-TRUE 57 | }else{ 58 | switch<-FALSE 59 | } 60 | change<-c(change, switch) #add that to the vector 61 | } 62 | 63 | #create a vector of changes to k 64 | k<-c(startK)# initiate vector with start value at k 65 | for (i in 1:length(year)-1){ 66 | if (change[i+1]){ 67 | changesetK<-c(changeK, -changeK) 68 | nextk<-k[i]*(100+(sample(changesetK, 1)))/100 #randomly chose an increase or decrease in % change 69 | } else{ 70 | nextk<-k[i] # or if it's not a break year, don't change k 71 | } 72 | k<-c(k, nextk) 73 | } 74 | 75 | # #create a vector of changes to r 76 | r<-c(startR)# initiate vector with start value at r 77 | for (i in 1:length(year)-1){ 78 | if (change[i+1]){ 79 | changesetR<-c(changeR, -changeR) 80 | nextr<-r[i]*(100+(sample(changesetR, 1)))/100 #randomly chose an increase or decrease in % change 81 | } else{ 82 | nextr<-r[i] # or if it's not a break year, don't change r 83 | } 84 | r<-c(r, nextr) 85 | } 86 | #calculate Nt vector 87 | Nt<-c(startPop) #create population vector with starting population as entry 1 88 | for(i in 1:length(year)){ 89 | Nt1<-Nt[i]*exp(r[i]*(1- Nt[i]/k[i]))*noisevector[i] 90 | Nt<-c(Nt, Nt1) 91 | 92 | } 93 | #now we need to make the simulated data into a data frame which would look like 94 | #one fed into the analysis 95 | addyear<-max(year)+1 96 | year<-c(year, addyear) 97 | simdata<-as.data.frame(cbind(year, Nt)) 98 | 99 | return(simdata) 100 | } 101 | fakedata(noise=5, changeK=25, changeR=25, breaks=list("1905", "1910")) 102 | 103 | #now we need to create a function that will take the simulated data, find the best break combination 104 | #and compare the ones it finds to the ones the data was built with 105 | 106 | '%ni%' <- Negate('%in%') 107 | 108 | 109 | weight.fake.shifts<-function(startyear, Nyears, startPop, noise, startK, 110 | startR, breaks, changeK, changeR, criterion){ 111 | #create simulated data based on input parameters 112 | test<-fakedata(startyear, Nyears, startPop, noise, startK, startR, breaks, changeK, changeR) 113 | endbreak<-startyear+Nyears-1 #add the end break to the break list so it's more comparable to output 114 | breaksin<-c(unlist(breaks), endbreak) #and make it a vector 115 | nbreaksin<-length(breaks) 116 | output<-breakweights(addNt1(test), criterion) 117 | options(warn=-1) #turn off warnings, we'll handle special cases directly 118 | rightbreaks<-output[which(output$breaksfound %in% breaksin),] 119 | wrongbreaks<-output[which(output$breaksfound %ni% breaksin),] 120 | wrongweight<-mean(as.numeric(wrongbreaks$correctedweights)) #mean weight of incorrect breaks 121 | wrongmax<-max(wrongbreaks$correctedweights)# maximum weight of incorrect break 122 | #if there are no wrong breaks, we need to set a zero weight 123 | if (is.nan(wrongweight)){ 124 | wrongweight<-0 125 | wrongmax<-0 126 | } 127 | #right breaks need two cases- for no breaks and any breaks scenarios 128 | if(nbreaksin>0){ 129 | weights<-rightbreaks$correctedweights[1:(length(rightbreaks$correctedweights)-1)] 130 | rightweight<-mean(weights) 131 | rightmin<-min(weights) #minimum weight of correct break 132 | #mean weight of correct breaks minus end of series 133 | }else{ 134 | rightweight<-1 #end of series break has a weight of 1 by definition 135 | rightmin<-1 #only break is at the end of the series 136 | } 137 | 138 | #output needed information 139 | testconditions<-unlist(c(Nyears, startPop, noise, nbreaksin, startK, 140 | startR, changeK, changeR, rightweight, wrongweight, rightmin, wrongmax)) 141 | return(testconditions) 142 | 143 | } 144 | 145 | 146 | #create a function that compiles sucesses and failures for iterations of fitting the model 147 | # on simulated data produced under given conditions 148 | 149 | break.it.down.2<-function(startyear, Nyears, startPop, noise, 150 | startK, startR, breaks, changeK, changeR, nIter, criterion){ 151 | out.frame<-data.frame(matrix(vector(), 0, 12, 152 | dimnames=list(c(), 153 | c("Nyears", "startPop", "noise", "nbreaksin", 154 | "startK", "startR", "changeK", "changeR", "rightweight", 155 | "wrongweight", "rightmin", "wrongmax"))), 156 | stringsAsFactors=FALSE)#Create a place to put our data 157 | for (i in 1:nIter){ 158 | test<-weight.fake.shifts(startyear, Nyears, startPop, noise, startK, 159 | startR, breaks, changeK, changeR, criterion) 160 | out.frame<-rbind(out.frame, test)#put output for segment in a data frame 161 | } 162 | colnames(out.frame)<- c("Nyears", "startPop", "noise", "nbreaksin", 163 | "startK", "startR", "changeK", "changeR", "rightweight", 164 | "wrongweight", "rightmin", "wrongmax") 165 | return(out.frame) 166 | 167 | } 168 | 169 | ## Some of this won't be needed in a package 170 | 171 | ## #okay, now that we've got it all working, it's time to build out the tests. To prevent the permutations 172 | ## # of possible tests from going to infinity, let's create a 'base scenario' that we modify one parameter 173 | ## # at a time, and let's choose 1,2,3,4 break point scenarios in which to test these 174 | 175 | ## #choose base parameters 176 | 177 | ## startyear<-1 #should not affect output at all 178 | ## Nyears<-25 #processing time goes up considerably with length of time series, so make this the base scenario 179 | ## startPop<-3000 # arbtrary start point, but r, K need to be chosen in reasonable scale with this 180 | ## noise<-1 #base scenario should have very little %noise, but needs some so there's a wee bit of error in the fit 181 | ## startK<-2000 #seems reasonable for a startpop of 1500 182 | ## startR<-2 #also reasonable r 183 | ## changeK<-50# start with big, easily detected shifts 184 | ## changeR<-0 # as with changeK 185 | ## nIter<-5 # keep this low while we build the code 186 | 187 | ## # create some script that randomly chooses the breaks, given certain rules 188 | ## # recall that the model assumes breaks cannot occur less than three years apart 189 | ## # or from the start or end of the time series because of overfitting issues 190 | 191 | 192 | #create a function that generates a list of breaks randomly from the available set of breaks 193 | 194 | breaklist<-function(possibleBreaks, howmany){ #we'll cap it at 3 breaks for the simulations 195 | if (howmany>3){ #no cheating, we're capping this at 3 breaks for the simulations 196 | howmany<-3 197 | } 198 | if (howmany<1){ #seriously, don't try to break this here 199 | howmany<-1 200 | } 201 | firstbreak<-sample(possibleBreaks, 1) 202 | eliminatedSecondBreaks<-seq(firstbreak-3, firstbreak+3) 203 | possibleSecondBreaks<-possibleBreaks[!is.element(possibleBreaks, eliminatedSecondBreaks)] 204 | secondbreak<-tryCatch(sample(possibleSecondBreaks, 1), error=function(e) NULL) 205 | eliminatedThirdBreaks<-tryCatch(seq(secondbreak-3, secondbreak+3), error=function(e) NULL) 206 | possibleThirdBreaks<-possibleSecondBreaks[!is.element(possibleSecondBreaks, eliminatedThirdBreaks)] 207 | thirdbreak<-tryCatch(sample(possibleThirdBreaks, 1), error=function(e) NULL) 208 | 209 | if (howmany==1){ 210 | #for one break, this is simple 211 | breaks=sample(possibleBreaks, 1) 212 | }else if (howmany==2){ 213 | #for two breaks 214 | breaks<-sort(c(firstbreak, secondbreak)) 215 | }else if (howmany==3){ 216 | #for three breaks, follow from 2 217 | breaks<-sort(c(firstbreak, secondbreak, thirdbreak)) 218 | } 219 | return(breaks) 220 | } 221 | 222 | 223 | #create a function that uses break.it.down to test the function in four break point scenarios 224 | 225 | iterate.breakitdown.2<-function(startyear, Nyears, startPop, 226 | noise, startK, startR, 227 | changeK, changeR, nIter, numLoops, criterion){ 228 | #figure out possible breaks 229 | #minumum break must be four years in or later 230 | minbreak<-startyear+4 231 | #maximum break must be four years prior to the end of the series or before, plus we lose the last year 232 | maxbreak<-startyear+Nyears-5 233 | #create a sequence of all posible breaks 234 | possibleBreaks<-seq(minbreak, maxbreak) 235 | #Create a place to put our data 236 | results.matrix<-data.frame(matrix(vector(), 0, 12, 237 | dimnames=list(c(), c("Nyears", "startPop", "noise", "nbreaksin", 238 | "startK", "startR", "changeK", "changeR", "rightweight", 239 | "wrongweight", "rightmin", "wrongmax"))), 240 | stringsAsFactors=F) 241 | 242 | while (numLoops>0){ 243 | #we want to test each scenario with 0-3 breaks 244 | breaks0<-list() #empty list for no break scenario 245 | breaks1<-breaklist(possibleBreaks, 1) 246 | breaks2<-breaklist(possibleBreaks, 2) 247 | breaks3<-breaklist(possibleBreaks, 3) 248 | result.matrix0<-break.it.down.2(startyear=startyear, Nyears=Nyears, startPop=startPop, 249 | noise=noise, startK=startK, startR=startR, 250 | breaks=breaks0, changeK=changeK, changeR=changeR, nIter=nIter, criterion=criterion) 251 | result.matrix1<-break.it.down.2(startyear=startyear, Nyears=Nyears, startPop=startPop, 252 | noise=noise, startK=startK, startR=startR, 253 | breaks=breaks1, changeK=changeK, changeR=changeR, nIter=nIter, criterion=criterion) 254 | result.matrix2<-break.it.down.2(startyear=startyear, Nyears=Nyears, startPop=startPop, 255 | noise=noise, startK=startK, startR=startR, 256 | breaks=breaks2, changeK=changeK, changeR=changeR, nIter=nIter, criterion=criterion) 257 | result.matrix3<-break.it.down.2(startyear=startyear, Nyears=Nyears, startPop=startPop, 258 | noise=noise, startK=startK, startR=startR, 259 | breaks=breaks3, changeK=changeK, changeR=changeR, nIter=nIter, criterion=criterion) 260 | 261 | results.matrix<-rbind(results.matrix, result.matrix0, result.matrix1, result.matrix2, result.matrix3) 262 | numLoops<-numLoops-1 263 | } 264 | return(results.matrix) 265 | } 266 | 267 | 268 | ## FIXME: Commented this out for the package; clean up eventually 269 | 270 | ## ########################################################## 271 | 272 | ## #Okay, now we're ready to generate some data on how well the RS detector works 273 | ## #rerun from this point and alter parts here to fiddle with simulations 274 | 275 | ## #first, create a frame to put the data in as we change the scenarios 276 | ## simulation.results<-data.frame(matrix(vector(), 0, 12, 277 | ## dimnames=list(c(), c("Nyears", "startPop", "noise", "nbreaksin", 278 | ## "startK", "startR", "changeK", "changeR", "rightweight", 279 | ## "wrongweight", "rightmin", "wrongmax"))), 280 | ## stringsAsFactors=F)#Create a place to put our data 281 | ## clearsims<-simulation.results 282 | ## test.iter<-data.frame(matrix(vector(), 0, 12, 283 | ## dimnames=list(c(), c("Nyears", "startPop", "noise", "nbreaksin", 284 | ## "startK", "startR", "changeK", "changeR", "rightweight", 285 | ## "wrongweight", "rightmin", "wrongmax"))), 286 | ## stringsAsFactors=F)#Create a place to put our data 287 | 288 | ## #create base simulation 289 | ## #we will be holding these values completely constant for comparisons' sake 290 | ## startyear<-1 291 | ## startPop<-3000 292 | ## nIter<-1 293 | ## numLoops<-1 294 | ## startK<-2000 295 | ## criterion<-"AIC" 296 | 297 | ## #we also want to keep track of how long this takes to run, so 298 | ## # Start the clock! 299 | ## ptm <- proc.time() 300 | 301 | ## #things we want to vary 302 | ## Nyearslist<-c(15,20,25,30) 303 | ## noiselist<-c(1,2,5,10,15) 304 | ## startRlist<-c(-0.5, 0.5, 1, 1.5, 2) 305 | ## changeRlist<-c(0,10,25,50,75) 306 | ## changeKlist<-c(0,10,25,50,75) 307 | 308 | ## ############## 309 | ## #base scenario 310 | ## #variables with = should be altered to see how results change 311 | ## test.iter<-iterate.breakitdown.2(startyear=startyear, startPop=startPop, 312 | ## Nyears=Nyearslist[2], 313 | ## startK=startK, noise=noiselist[2], 314 | ## startR=startRlist[5], 315 | ## changeK=changeKlist[5], changeR=changeRlist[3], 316 | ## nIter, numLoops, criterion) 317 | 318 | 319 | ## # Stop the clock 320 | ## proc.time() - ptm 321 | 322 | 323 | ## #okay, let's do this as one iteration on a complete set, repeated x times 324 | ## #################################################################### 325 | ## ### Start runnng here if it breaks 326 | 327 | ## simnumber<-250 328 | ## nIter<-1 329 | ## numLoops<-1 330 | ## simulation.results<-clearsims 331 | ## criterion="AICc" 332 | 333 | 334 | ## ###### replace number before :simnuber with last sucessful sim number 335 | ## for (f in 1:simnumber){ 336 | ## ptm <- proc.time() 337 | 338 | ## #first number of years on base scenario 339 | ## for (i in 1:length(Nyearslist)){ 340 | ## test.iter<-iterate.breakitdown.2(startyear=startyear, startPop=startPop, 341 | ## Nyears=Nyearslist[i], 342 | ## startK=startK, noise=noiselist[2], 343 | ## startR=startRlist[5], 344 | ## changeK=changeKlist[5], changeR=changeRlist[3], 345 | ## nIter, numLoops, criterion) 346 | 347 | ## #add these results to the data frame 348 | ## simulation.results<-rbind(simulation.results, test.iter) 349 | ## writeLines(paste("finished", Nyearslist[i], " years")) 350 | ## } 351 | 352 | ## #### starting values of r 353 | 354 | ## for(q in 1:length(startRlist)){ 355 | ## #next changeR on base scenario 356 | ## for (i in 1:length(changeRlist)){ 357 | ## test.iter<-iterate.breakitdown.2(startyear=startyear, startPop=startPop, 358 | ## Nyears=Nyearslist[2], 359 | ## startK=startK, noise=noiselist[2], 360 | ## startR=startRlist[q], 361 | ## changeK=changeKlist[5], changeR=changeRlist[i], 362 | ## nIter, numLoops, criterion) 363 | ## #add these results to the data frame 364 | ## writeLines(paste("finished changeR ", changeRlist[i])) 365 | ## simulation.results<-rbind(simulation.results, test.iter) 366 | ## } 367 | 368 | ## #next changeK on base scenario 369 | ## for (i in 1:length(changeKlist)){ 370 | ## test.iter<-iterate.breakitdown.2(startyear=startyear, startPop=startPop, 371 | ## Nyears=Nyearslist[2], 372 | ## startK=startK, noise=noiselist[2], 373 | ## startR=startRlist[q], 374 | ## changeK=changeKlist[i], changeR=changeRlist[3], 375 | ## nIter, numLoops, criterion) 376 | ## writeLines(paste("finished changeK ", changeKlist[i])) 377 | ## #add these results to the data frame 378 | ## simulation.results<-rbind(simulation.results, test.iter) 379 | ## } 380 | ## writeLines(paste("finished startR ", startRlist[q])) 381 | 382 | ## } 383 | 384 | 385 | ## #noise 386 | ## for (j in 1:length(noiselist)){ 387 | ## #next changeR on base scenario 388 | ## for (i in 1:length(changeRlist)){ 389 | ## test.iter<-iterate.breakitdown.2(startyear=startyear, startPop=startPop, 390 | ## Nyears=Nyearslist[2], 391 | ## startK=startK, noise=noiselist[j], 392 | ## startR=startRlist[5], 393 | ## changeK=changeKlist[5], changeR=changeRlist[i], 394 | ## nIter, numLoops, criterion) 395 | ## #add these results to the data frame 396 | ## writeLines(paste("finished changeR ", changeRlist[i])) 397 | ## simulation.results<-rbind(simulation.results, test.iter) 398 | ## } 399 | 400 | ## #next changeK on base scenario 401 | ## for (i in 1:length(changeKlist)){ 402 | ## test.iter<-iterate.breakitdown.2(startyear=startyear, startPop=startPop, 403 | ## Nyears=Nyearslist[2], 404 | ## startK=startK, noise=noiselist[j], 405 | ## startR=startRlist[5], 406 | ## changeK=changeKlist[i], changeR=changeRlist[3], 407 | ## nIter, numLoops, criterion) 408 | ## writeLines(paste("finished changeK ", changeKlist[i])) 409 | ## #add these results to the data frame 410 | ## simulation.results<-rbind(simulation.results, test.iter) 411 | ## } 412 | 413 | ## writeLines(paste("finished noise ", noiselist[j])) 414 | ## #save the simulation results 415 | 416 | ## } 417 | 418 | ## write.csv(simulation.results, file=paste0("simresults/Break_weights_AICc/simresultsweightsAICc_", f,".csv")) 419 | ## simulation.results<-clearsims 420 | 421 | ## # Stop the clock 422 | ## proc.time() - ptm 423 | ## writeLines(paste(proc.time() - ptm)) 424 | ## } 425 | 426 | 427 | -------------------------------------------------------------------------------- /code-for-inclusion/simulations.R: -------------------------------------------------------------------------------- 1 | #script for creating simulated data under a variety of parameters 2 | #and then determining if DSdetector function correctly determines these parameters 3 | 4 | #to-do list 5 | 6 | #create simulations to test robustness of picking up regime shifts at different break point spacings 7 | #Create simulations to test robustness of picking up regime shifts of different sizes 8 | #create simulations to test robustness of picking up regime shifts in different noise scenarios 9 | #and while we're at it, simulations to test how this all works given different lengths of time series 10 | 11 | #get the regime shift detector functions into memory 12 | source("dynamic_shift_detector.R") 13 | 14 | #create a function that will make fake data based on specified parameters 15 | #assume change, noise is given in percent (0-100) scale, as is change to r, k 16 | 17 | fakedata<-function(startyear, Nyears, startPop, noise, startK, startR, breaks, changeK, changeR){ 18 | if(missing(startyear)){ #set default values for all paremeters 19 | startyear<-1900 20 | } 21 | if(missing(Nyears)){ 22 | Nyears<-20 23 | } 24 | #in order to set the default breaks, I need to know what the last year in the time range is 25 | #so let's create a vector of years going into the time series now 26 | year<-seq(startyear, (startyear+Nyears-1)) #-1 because time range is inclusive of year 0 27 | lastyear<-max(year)-1# max is second last year because we don't have Nt1 for last year 28 | 29 | if(missing(startPop)){#let's make popultion size default to 1000 30 | startPop<-1000 31 | } 32 | if(missing(noise)){#no noise by default 33 | noise<-0 34 | } 35 | if(missing(startK)){ #so start population can grow by default 36 | startK<-1500 37 | } 38 | if(missing(startR)){ 39 | startR<-1.5 40 | } 41 | if(missing(breaks)){ 42 | breaks<-list()#no break model, null list 43 | } 44 | if(missing(changeK)){ # by default, don't change K after a break 45 | changeK<-0 46 | } 47 | if(missing(changeR)){ #same with r 48 | changeR<-0 49 | } 50 | 51 | #create a vector for noise for each year- it will be random, normally distributed error 52 | noisevector<-c()# make an empty vector 53 | for (i in 1:(length(year))){ 54 | randomnoise<-rnorm(1, mean=0, sd=noise)#choose a random value with a sd of our % noise 55 | instant.buzz<-1+(randomnoise)/100 #generate an instantaneous buzz :) 56 | noisevector<-c(noisevector, instant.buzz) #add that to the vector 57 | } 58 | 59 | #create a vector of when regime shifts will occur 60 | change<-c(FALSE)# make a vector with first value false- cannot have a change in first year 61 | for (i in 1:(length(year)-1)){ 62 | if(any(breaks==year[i])){ 63 | switch<-TRUE 64 | }else{ 65 | switch<-FALSE 66 | } 67 | change<-c(change, switch) #add that to the vector 68 | } 69 | 70 | #create a vector of changes to k 71 | k<-c(startK)# initiate vector with start value at k 72 | for (i in 1:length(year)-1){ 73 | if (change[i+1]){ 74 | changesetK<-c(changeK, -changeK) 75 | nextk<-k[i]*(100+(sample(changesetK, 1)))/100 #randomly chose an increase or decrease in % change 76 | } else{ 77 | nextk<-k[i] # or if it's not a break year, don't change k 78 | } 79 | k<-c(k, nextk) 80 | } 81 | 82 | # #create a vector of changes to r 83 | r<-c(startR)# initiate vector with start value at r 84 | for (i in 1:length(year)-1){ 85 | if (change[i+1]){ 86 | changesetR<-c(changeR, -changeR) 87 | nextr<-r[i]*(100+(sample(changesetR, 1)))/100 #randomly chose an increase or decrease in % change 88 | } else{ 89 | nextr<-r[i] # or if it's not a break year, don't change r 90 | } 91 | r<-c(r, nextr) 92 | } 93 | #calculate Nt vector 94 | Nt<-c(startPop) #create population vector with starting population as entry 1 95 | for(i in 1:length(year)){ 96 | Nt1<-Nt[i]*exp(r[i]*(1- Nt[i]/k[i]))*noisevector[i] 97 | Nt<-c(Nt, Nt1) 98 | 99 | } 100 | #now we need to make the simulated data into a data frame which would look like 101 | #one fed into the analysis 102 | addyear<-max(year)+1 103 | year<-c(year, addyear) 104 | simdata<-as.data.frame(cbind(year, Nt)) 105 | 106 | return(simdata) 107 | } 108 | test<-fakedata(noise=5, changeK=25, changeR=25, breaks=list("1905", "1910")) 109 | 110 | #now we need to create a function that will take the simulated data, find the best break combination 111 | #and compare the ones it finds to the ones the data was built with 112 | 113 | 114 | detect.fake.shifts<-function(startyear, Nyears, startPop, noise, startK, startR, breaks, changeK, changeR, criterion){ 115 | #create simulated data based on input parameters 116 | test<-fakedata(startyear, Nyears, startPop, noise, startK, startR, breaks, changeK, changeR) 117 | #run the data thtrough the script that finds the best model 118 | #and pull out a list of the breaks it found 119 | breaksfound<-bestmodel(addNt1(test), criterion)$Year2 120 | #also want to output number of breaks input (deal with output in conditionals) 121 | nbreaksin<-length(breaks) 122 | #need to deal with the case that no breaks are found 123 | #model will find a 'break' at the end of the sequence, leading to a of length 1 124 | if (length(breaksfound)==1){ 125 | #first, if we found no breaks 126 | if (nbreaksin == 0){ #if there's no breaks in the sim data, great! 127 | victory<-1 128 | nbreaksout<-0 129 | }else{ #if we found no breaks, but there was breaks to find 130 | victory<-0 131 | nbreaksout<-0 132 | } 133 | 134 | }else{ # test if we found the right breaks 135 | #cull out the 'break' at the end of the data 136 | breaksfound<-breaksfound[-length(breaksfound)] 137 | #and for output purposes 138 | nbreaksout<-length(breaksfound) 139 | #obviously- if the breaks are all found, bam, the breaks are all found 140 | if(all(breaksfound %in% breaks)){ 141 | victory<-1 142 | }else{ 143 | if(any(breaksfound %in% breaks)){ #if we find some breaks 144 | #to deal with a data type issue, encode partial matches numerically 145 | #extra breaks found = 2 146 | #missing breaks (when more than one break in sim data) =3 147 | #right number of breaks but not all match =4 148 | if(length(breaksfound)>length(breaks)){ 149 | victory<-2 150 | }else if(length(breaksfound)0)){ 181 | inSet<-1 182 | }else{ 183 | inSet<-0 184 | } 185 | }else { #we already know the best model is in the equivalent model set 186 | inSet<-1 187 | } 188 | 189 | #output needed information 190 | testconditions<-unlist(c(Nyears, startPop, noise, nbreaksin, nbreaksout, startK, startR, changeK, changeR, victory, inSet)) 191 | return(testconditions) 192 | 193 | } 194 | 195 | 196 | #create a function that compiles sucesses and failures for iterations of fitting the model 197 | # on simulated data produced under given conditions 198 | 199 | break.it.down<-function(startyear, Nyears, startPop, noise, 200 | startK, startR, breaks, changeK, changeR, nIter, criterion){ 201 | out.frame<-data.frame(matrix(vector(), 0, 11, 202 | dimnames=list(c(), 203 | c("Nyears", "startPop", "noise", "nbreaksin","nbreaksout", 204 | "startK", "startR", "changeK", "changeR", "victory", "inSet"))), 205 | stringsAsFactors=FALSE)#Create a place to put our data 206 | for (i in 1:nIter){ 207 | test<-detect.fake.shifts(startyear, Nyears, startPop, noise, startK, 208 | startR, breaks, changeK, changeR, criterion) 209 | out.frame<-rbind(out.frame, test)#put output for segment in a data frame 210 | } 211 | colnames(out.frame)<- c("Nyears", "startPop", "noise", "nbreaksin","nbreaksout", 212 | "startK", "startR", "changeK", "changeR", "victory", "inSet") 213 | return(out.frame) 214 | 215 | } 216 | 217 | 218 | 219 | #okay, now that we've got it all working, it's time to build out the tests. To prevent the permutations 220 | # of possible tests from going to infinity, let's create a 'base scenario' that we modify one parameter 221 | # at a time, and let's choose 1,2,3,4 break point scenarios in which to test these 222 | 223 | #choose base parameters 224 | 225 | startyear<-1 #should not affect output at all 226 | Nyears<-25 #processing time goes up considerably with length of time series, so make this the base scenario 227 | startPop<-3000 # arbtrary start point, but r, K need to be chosen in reasonable scale with this 228 | noise<-1 #base scenario should have very little %noise, but needs some so there's a wee bit of error in the fit 229 | startK<-2000 #seems reasonable for a startpop of 1500 230 | startR<-2 #also reasonable r 231 | changeK<-50# start with big, easily detected shifts 232 | changeR<-0 # as with changeK 233 | nIter<-5 # keep this low while we build the code 234 | criterion="AIC" 235 | 236 | # create some script that randomly chooses the breaks, given certain rules 237 | # recall that the model assumes breaks cannot occur less than three years apart 238 | # or from the start or end of the time series because of overfitting issues 239 | 240 | 241 | #create a function that generates a list of breaks randomly from the available set of breaks 242 | 243 | breaklist<-function(possibleBreaks, howmany){ #we'll cap it at 3 breaks for the simulations 244 | if (howmany>3){ #no cheating, we're capping this at 3 breaks for the simulations 245 | howmany<-3 246 | } 247 | if (howmany<1){ #seriously, don't try to break this here 248 | howmany<-1 249 | } 250 | firstbreak<-sample(possibleBreaks, 1) 251 | eliminatedSecondBreaks<-seq(firstbreak-3, firstbreak+3) 252 | possibleSecondBreaks<-possibleBreaks[!is.element(possibleBreaks, eliminatedSecondBreaks)] 253 | secondbreak<-tryCatch(sample(possibleSecondBreaks, 1), error=function(e) NULL) 254 | eliminatedThirdBreaks<-tryCatch(seq(secondbreak-3, secondbreak+3), error=function(e) NULL) 255 | possibleThirdBreaks<-possibleSecondBreaks[!is.element(possibleSecondBreaks, eliminatedThirdBreaks)] 256 | thirdbreak<-tryCatch(sample(possibleThirdBreaks, 1), error=function(e) NULL) 257 | 258 | if (howmany==1){ 259 | #for one break, this is simple 260 | breaks=sample(possibleBreaks, 1) 261 | }else if (howmany==2){ 262 | #for two breaks 263 | breaks<-sort(c(firstbreak, secondbreak)) 264 | }else if (howmany==3){ 265 | #for three breaks, follow from 2 266 | breaks<-sort(c(firstbreak, secondbreak, thirdbreak)) 267 | } 268 | return(breaks) 269 | } 270 | 271 | 272 | #create a function that uses break.it.down to test the function in four break point scenarios 273 | 274 | iterate.breakitdown<-function(startyear, Nyears, startPop, 275 | noise, startK, startR, 276 | changeK, changeR, nIter, numLoops, criterion){ 277 | #figure out possible breaks 278 | #minumum break must be four years in or later 279 | minbreak<-startyear+4 280 | #maximum break must be four years prior to the end of the series or before, plus we lose the last year 281 | maxbreak<-startyear+Nyears-5 282 | #create a sequence of all posible breaks 283 | possibleBreaks<-seq(minbreak, maxbreak) 284 | #Create a place to put our data 285 | results.matrix<-data.frame(matrix(vector(), 0, 11, 286 | dimnames=list(c(), c("Nyears", "startPop", "noise", "nbreaksin","nbreaksout", 287 | "startK", "startR", "changeK", "changeR", 288 | "victory", "inSet"))), 289 | stringsAsFactors=F) 290 | 291 | while (numLoops>0){ 292 | #we want to test each scenario with 0-3 breaks 293 | breaks0<-list() #empty list for no break scenario 294 | breaks1<-breaklist(possibleBreaks, 1) 295 | breaks2<-breaklist(possibleBreaks, 2) 296 | breaks3<-breaklist(possibleBreaks, 3) 297 | result.matrix0<-break.it.down(startyear=startyear, Nyears=Nyears, startPop=startPop, 298 | noise=noise, startK=startK, startR=startR, 299 | breaks=breaks0, changeK=changeK, changeR=changeR, nIter=nIter, criterion=criterion) 300 | result.matrix1<-break.it.down(startyear=startyear, Nyears=Nyears, startPop=startPop, 301 | noise=noise, startK=startK, startR=startR, 302 | breaks=breaks1, changeK=changeK, changeR=changeR, nIter=nIter, criterion=criterion) 303 | result.matrix2<-break.it.down(startyear=startyear, Nyears=Nyears, startPop=startPop, 304 | noise=noise, startK=startK, startR=startR, 305 | breaks=breaks2, changeK=changeK, changeR=changeR, nIter=nIter, criterion=criterion) 306 | result.matrix3<-break.it.down(startyear=startyear, Nyears=Nyears, startPop=startPop, 307 | noise=noise, startK=startK, startR=startR, 308 | breaks=breaks3, changeK=changeK, changeR=changeR, nIter=nIter, criterion=criterion) 309 | 310 | results.matrix<-rbind(results.matrix, result.matrix0, result.matrix1, result.matrix2, result.matrix3) 311 | numLoops<-numLoops-1 312 | } 313 | return(results.matrix) 314 | } 315 | 316 | 317 | 318 | 319 | ########################################################## 320 | 321 | #Okay, now we're ready to generate some data on how well the RS detector works 322 | #rerun from this point and alter parts here to fiddle with simulations 323 | 324 | #first, create a frame to put the data in as we change the scenarios 325 | simulation.results<-data.frame(matrix(vector(), 0, 11, 326 | dimnames=list(c(), c("Nyears", "startPop", "noise", "nbreaksin","nbreaksout", 327 | "startK", "startR", "changeK", "changeR", 328 | "victory", "inSet"))), 329 | stringsAsFactors=F)#Create a place to put our data 330 | clearsims<-simulation.results 331 | test.iter<-data.frame(matrix(vector(), 0, 11, 332 | dimnames=list(c(), c("Nyears", "startPop", "noise", "nbreaksin","nbreaksout", 333 | "startK", "startR", "changeK", "changeR", 334 | "victory", "inSet"))), 335 | stringsAsFactors=F)#Create a place to put our data 336 | 337 | #create base simulation 338 | #we will be holding these values completely constant for comparisons' sake 339 | startyear<-1 340 | startPop<-3000 341 | nIter<-1 342 | numLoops<-1 343 | startK<-2000 344 | 345 | 346 | 347 | #things we want to vary 348 | Nyearslist<-c(15,20,25,30) 349 | noiselist<-c(1,2,5,10,15) 350 | startRlist<-c(-0.5, 0.5, 1, 1.5, 2) 351 | changeRlist<-c(0,10,25,50,75) 352 | changeKlist<-c(0,10,25,50,75) 353 | criterion="AICc" 354 | 355 | ############## 356 | #base scenario 357 | #variables with = should be altered to see how results change 358 | test.iter<-iterate.breakitdown(startyear=startyear, startPop=startPop, 359 | Nyears=Nyearslist[2], 360 | startK=startK, noise=noiselist[2], 361 | startR=startRlist[5], 362 | changeK=changeKlist[5], changeR=changeRlist[3], 363 | nIter, numLoops, criterion) 364 | 365 | 366 | 367 | 368 | #okay, let's do this as one iteration on a complete set, repeated x times 369 | #################################################################### 370 | ### Start runnng here if it breaks 371 | 372 | simnumber<-250 373 | nIter<-1 374 | numLoops<-1 375 | simulation.results<-clearsims 376 | criterion="AICc" 377 | 378 | 379 | ###### replace number before :simnuber with last sucessful sim number 380 | for (f in 1:simnumber){ 381 | ptm <- proc.time() 382 | 383 | #first number of years on base scenario 384 | for (i in 1:length(Nyearslist)){ 385 | test.iter<-iterate.breakitdown(startyear=startyear, startPop=startPop, 386 | Nyears=Nyearslist[i], 387 | startK=startK, noise=noiselist[2], 388 | startR=startRlist[5], 389 | changeK=changeKlist[5], changeR=changeRlist[3], 390 | nIter, numLoops, criterion) 391 | 392 | #add these results to the data frame 393 | simulation.results<-rbind(simulation.results, test.iter) 394 | writeLines(paste("finished", Nyearslist[i], " years")) 395 | } 396 | 397 | #### starting values of r 398 | 399 | for(q in 1:length(startRlist)){ 400 | #next changeR on base scenario 401 | for (i in 1:length(changeRlist)){ 402 | test.iter<-iterate.breakitdown(startyear=startyear, startPop=startPop, 403 | Nyears=Nyearslist[2], 404 | startK=startK, noise=noiselist[2], 405 | startR=startRlist[q], 406 | changeK=changeKlist[5], changeR=changeRlist[i], 407 | nIter, numLoops, criterion) 408 | #add these results to the data frame 409 | writeLines(paste("finished changeR ", changeRlist[i])) 410 | simulation.results<-rbind(simulation.results, test.iter) 411 | } 412 | 413 | #next changeK on base scenario 414 | for (i in 1:length(changeKlist)){ 415 | test.iter<-iterate.breakitdown(startyear=startyear, startPop=startPop, 416 | Nyears=Nyearslist[2], 417 | startK=startK, noise=noiselist[2], 418 | startR=startRlist[q], 419 | changeK=changeKlist[i], changeR=changeRlist[3], 420 | nIter, numLoops, criterion) 421 | writeLines(paste("finished changeK ", changeKlist[i])) 422 | #add these results to the data frame 423 | simulation.results<-rbind(simulation.results, test.iter) 424 | } 425 | writeLines(paste("finished startR ", startRlist[q])) 426 | 427 | } 428 | 429 | 430 | #noise 431 | for (j in 1:length(noiselist)){ 432 | #next changeR on base scenario 433 | for (i in 1:length(changeRlist)){ 434 | test.iter<-iterate.breakitdown(startyear=startyear, startPop=startPop, 435 | Nyears=Nyearslist[2], 436 | startK=startK, noise=noiselist[j], 437 | startR=startRlist[5], 438 | changeK=changeKlist[5], changeR=changeRlist[i], 439 | nIter, numLoops, criterion) 440 | #add these results to the data frame 441 | writeLines(paste("finished changeR ", changeRlist[i])) 442 | simulation.results<-rbind(simulation.results, test.iter) 443 | } 444 | 445 | #next changeK on base scenario 446 | for (i in 1:length(changeKlist)){ 447 | test.iter<-iterate.breakitdown(startyear=startyear, startPop=startPop, 448 | Nyears=Nyearslist[2], 449 | startK=startK, noise=noiselist[j], 450 | startR=startRlist[5], 451 | changeK=changeKlist[i], changeR=changeRlist[3], 452 | nIter, numLoops, criterion) 453 | writeLines(paste("finished changeK ", changeKlist[i])) 454 | #add these results to the data frame 455 | simulation.results<-rbind(simulation.results, test.iter) 456 | } 457 | 458 | writeLines(paste("finished noise ", noiselist[j])) 459 | #save the simulation results 460 | 461 | } 462 | 463 | write.csv(simulation.results, file=paste0("simresults/Best_model_AICc/simresultsbestmodelAICc_", f,".csv")) 464 | simulation.results<-clearsims 465 | 466 | # Stop the clock 467 | proc.time() - ptm 468 | writeLines(paste(proc.time() - ptm)) 469 | } 470 | 471 | 472 | --------------------------------------------------------------------------------