Conceptually, this is expected to occur when on the left side of the curve, increasing habitat heterogeneity opens up new regions in niche space, facilitating colonization by new species. However, as heterogeneity continues to increase, each species has fewer habitat patches to utilize, population sizes decrease, and local extinction risk increases due to demographic stochasticity. To explore this idea theoretically, Allouche et al. (2012) developed an individually based model using a continuous time Markov process. The details of their modeling approach can be found in the supplementary material to their article, which I recommend. In this post, I’ll demonstrate how to implement a discrete time version of their model in R. Thanks to the agent-based modeling working group at the University of Colorado for providing motivation to code up model in R.

Model structure

This model is spatially implicit, with A equally connected sites. Each site falls on an environmental condition axis, receiving some value E that characterizes local conditions. The environmental conditions for each site are uniformly distributed between two values that dictate the range of environmental conditions in a focal area. The local range of environmental conditions is a subset of some global range. There are N species in the regional pool that can colonize habitat patches. Each species has some environmental optimum $\mu_i$, and some niche width $\sigma_i$, which together define a Gaussian function for the probability of establishment given a colonization attempt and a habitat patch environmental condition E.

The image above illustrates the probability of establishing for five species across the global range of environmental conditions possible. For any focal area, the realized range of environmental conditions is some subset of this global range.

It is assumed that all individuals that occupy a patch have the same per-timestep probabilities of death and reproduction. If an individual reproduces, the number of offspring it produces is a Poisson distributed random variable, and each individual offspring attempts to colonize one randomly selected site. At each time-step, every site has an equal probability of a colonization attempt by an individual from each species in the regional pool. Every habitat patch holds only one individual.

Offspring and immigrants from the regional pool do not displace individuals from habitat patches when they attempt to colonize. In empty sites, offspring receive colonization priority, with regional colonization occurring after breeding. When multiple offspring or immigrants from the regional pool could establish in an empty site, one successful individual is randomly chosen to establish regardless of species identity.

Parameters

The following parameters are supplied to the function alloucheIBM():

A = number of sites; N = number of species in the regional pool; ERmin = global environmental conditions minimum; ERmax = global environmental conditions maximum; Emin = local environmental minimum; Emax = local environmental maximum; sig = niche width standard deviation for all species; pM = per timestep probability of mortality; pR = per timestep probability of reproduction; R = per capita expected number of offspring; and I = per timestep probability of attempted colonization by an immigrant from the regional pool for each patch.

Implementation in R

The function alloucheIBM() does the majority of work for this model:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127

alloucheIBM <- function(A=100, N=100, ERmin=-30, ERmax=30, Emin=-30, Emax=30,
                    sig=5, timesteps=1000, pM=.1, pR=1, R=2, I=0.1){
  E <- runif(A, Emin, Emax) # habitat patch environment type
  mu.i <- runif(N, ERmin, ERmax) # optimum environment
  sigma <- rep(sig, N) # niche width
  Z <- array(dim=c(N)) # normalization constant

  # Z ensures all species have equal Pr(establishment) in regional pool
  for (i in 1:N){
    integrand <- function(E) {
      exp(-((E - mu.i[i]) ^ 2) / (2 * sigma[i] ^ 2))
    }
    res <- integrate(integrand, lower=ERmin, upper=ERmax)
    Z[i] <- 1 / res$value
  }

  # probability of establishment|colonization attempt
  Pcol <- array(dim=c(A, N))
  for (i in 1:A){
    for (j in 1:N){
      Pcol[i, j] <- Z[j] * exp(-((E[i] - mu.i[j]) ^ 2) / (2*sigma[j] ^ 2))
    }
  }

  # store niche data
  species <- rep(1:N, each=A)
  E <- rep(E, N)
  Pr.estab <- c(Pcol)
  niche.d <- data.frame(species, E, Pr.estab)
  niche.d <- niche.d[with(niche.d, order(species, E)),]

  # initialize output
  state <- array(0, dim=c(timesteps, A, N))
  richness <- rep(NA, timesteps)
  richness[1] <- 0
  p.occ <- rep(NA, timesteps)
  p.occ[1] <- 0

  for (t in 2:timesteps){
    state[t,,] <- state[t-1,,]

    ## DEATHS ##
    deaths <- array(rbinom(A*N, 1, c(state[t,,])*pM), dim=c(A, N))
    state[t,,] <- state[t,,] - deaths

    ## BIRTHS ##
    pot.fecundity <- array(rpois(A * N, lambda = c(state[t,,] * R)), dim=c(A, N))
    repro <- array(rbinom(A*N, 1, pR), dim=c(A, N))
    fecundity <- repro * pot.fecundity
    sum.fec <- apply(fecundity, 2, sum) # number of offspring per species

    ## OFFSPRING COLONIZE ##
    occupancy <- apply(state[t,,], 1, max)
    if (sum(occupancy) < A & sum(sum.fec) > 0){ # if empty sites & new offspring
      empty.sites <- which(occupancy == 0)
      occ.sites <- which(occupancy == 1)
      # randomly assign sites (empty & filled) to each offspring individual
      col.sites <- sample(1:A, sum(sum.fec), replace=T)
      col.spec <- rep(1:N, times=sum.fec) # how many of each species colonizing
      colonizing.offspring <- array(0, dim=c(A, N))
      for(i in 1:length(col.sites)){
        colonizing.offspring[col.sites[i], col.spec[i]] <-
          colonizing.offspring[col.sites[i], col.spec[i]] + 1
      }
      # offspring attempting to colonize occupied sites fail to displace
      colonizing.offspring[occ.sites,] <- 0

      # which colonizing offspring can actually establish?
      binom.mat <- ifelse(colonizing.offspring > 0, 1, 0)
      colonists <- array(rbinom(n = A * N,
                                size = c(colonizing.offspring),
                                prob = c(binom.mat * Pcol)),
                         dim=c(A, N))

      # are there colonization conflicts (> 1 individual trying to colonize each site?)
      attempting <- apply(colonists, 1, sum)
      if (any(attempting > 1)){
        # resolve colonization conflicts
        conflicts <- which(attempting > 1) # which sites have conflicts
        for (k in conflicts){ # for each conflict
          # how many indiv's of each spp attempting to simultaneously colonize?
          n.attempting <- rep(1:N, times = colonists[k,])
          # randomly select one successful from those attempting
          successful <- sample(n.attempting, size=1)
          new.row <- rep(0, length.out=N)
          new.row[successful] <- 1
          colonists[k,] <- new.row # individual becomes the only colonist
        }
      }
      # add successful colonists
      state[t,,] <- state[t,,] + colonists
    }

    ## IMMIGRANTS COLONIZE ##
    occupancy <- apply(state[t,,], 1, max)
    if(sum(occupancy) < A){
      empty.sites <- which(occupancy == 0)
      # which species immigrate to each site?
      immigration <- array(rbinom(length(empty.sites)*N,
                                  1, I), dim=c(length(empty.sites), N))
      # which immigrants establish?
      Pest <- immigration * Pcol[empty.sites, ]
      establishment <- array(rbinom(length(Pest), 1, c(Pest)),
                             dim=c(length(empty.sites), N))

      # resolve conflicts arising from simultaneous colonization
      col.attempts <- apply(establishment, 1, sum)
      if (any(col.attempts > 1)){ # if individuals are trying to simultaneously colonize
        conflicts <- which(col.attempts > 1) # which empty sites have conflicts
        for (k in conflicts){ # for each conflict
          # how many of individuals of each species are attempting to simultaneously colonize?
          attempting <- rep(1:N, times = establishment[k,])
          # successful individual randomly selected from those attempting
          successful <- sample(attempting, size=1)
          new.row <- rep(0, length.out=N)
          new.row[successful] <- 1
          establishment[k,] <- new.row
        }
      }
      # add successful immigrants
      state[t, empty.sites, ] <- state[t, empty.sites,] + establishment
    }
    richness[t] <- sum(apply(state[t,,], 2, max))
    p.occ[t] <- length(which(state[t,,] == 1)) / A
  }
  return(list(richness=richness, p.occ = p.occ, state=state, niche.d=niche.d))
}

The function returns a list containing a vector of species richness at each timestep, the proportion of sites occupied at each timestep, a state array containing all occupancy information for each patch, species, and timestep, and lastly a dataframe containing information on the niches of each species in the regional pool.

Using this function we can begin to explore the dynamics of the model through time:

1
2

out <- alloucheIBM(pM=.1, Emin=-30, Emax=30, sig=8, R=8, N=100, A=300, I=.01, timesteps=1000)
plot(out$richness, type="l", xlab="Timestep", ylab="Species richness")

Repeating this process a few times, we can get a picture of the expected species richness and it’s variance for some set of parameters.

Finally, we can address the issue of habitat heterogeneity and its effect on species richness. There are many ways to approach this issue, and many parameter combinations to consider. Allouche et al. (2012) provides a thorough treatment of the subject; I’ll demonstrate just one result: that under certain conditions, species richness peaks at intermediate levels of habitat heterogeneity.

To construct a range of habitat heterogeneity values, let’s construct an interval and take subsequently narrower intervals centered around the middle of the original interval.

1
2
3
4
5
6
7

ERmin <- -50
ERmax <- 50
global.median <- median(c(ERmin, ERmax))
n.intervals <- 30
lower.limits <- seq(ERmin, global.median-.5, length.out=n.intervals)
upper.limits <- seq(ERmax, global.median, length.out=n.intervals)
hab.het <- upper.limits - lower.limits # habitat heterogeneity

Here are the intervals:

Now, for each interval, we can iteratively run the model and track species richness. Because species richness tends to vary through time, let’s take the mean of the final 100 timesteps as a measure of species richness for each model run, and record the standard deviation to track variability.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27

n.iter <- 3 # number of iterations per interval
sd.rich <- array(NA, dim=c(n.intervals, n.iter))
end.rich <- array(NA, dim=c(n.intervals, n.iter))
for (i in 1:n.intervals){
  for (iter in 1:n.iter){
    Emin <- lower.limits[i]
    Emax <- upper.limits[i]
    out <- alloucheIBM(pM=.9, Emin=Emin, Emax=Emax, sig=10, pR=1, R=1,
                   N=100, A=100, I=.9, timesteps=300)
    timesteps <- length(out$richness)
    end.rich[i, iter] <- mean(out$richness[timesteps-100:timesteps])
    sd.rich[i, iter] <- sd(out$richness[timesteps-100:timesteps])
  }
}

end.richness <- c(t(end.rich))
end.sd <- c(t(sd.rich))
interval <- rep(hab.het, each=n.iter)
plot.d <- data.frame(interval, end.richness, end.sd)

# visualize the results
require(ggplot2)
range <- aes(ymax=end.richness + end.sd, ymin=end.richness - end.sd)
ggplot(plot.d, aes(x=interval, y=end.richness)) +
  geom_point(shape=1, size=2) + geom_errorbar(range) +
  theme_classic() +
  xlab("Habitat heterogeneity") + ylab("Species richness")

Of course, the shape of this relationship is sensitive to the parameters. As an example, changing niche width to increase or decrease niche overlap will mediate the strength of interspecific competition for space. Also, increasing reproductive rates may buffer each species from stochastic extinction so that the relationship between environmental heterogeneity and richness is monotonically increasing. Furthermore, here I centered all intervals around the same value, but the exact position of the environmental heterogeneity interval will affect the net establishment probability for each site, depending on how the interval relates to species niches. The parameter space is yours to explore.

These types of stochastic simulation models are fairly straightforward to implement in R. Indeed there’s a package dedicated to facilitating the implementation of such models: simecol. There’s even a book: A Practical Guide to Ecological Modelling: Using R as a Simulation Platform.

Full reference

Allouche O, Kalyuzhny M, Moreno-Rueda G, Pizarro M, & Kadmon R. (2012) Area-heterogeneity tradeoff and the diversity of ecological communities. Proceedings of the National Academy of Sciences of the United States of America, 109 (43): 17495-17500.

Before getting started, we can define two convenience functions:

1
2
3
4
5
6
7

logit <- function(x) {
    log(x/(1 - x))
}

antilogit <- function(x) {
    exp(x)/(1 + exp(x))
}

Then, initializing the number of sites, species, years, and repeat surveys (i.e. surveys within years, where the occupancy status of a site is assumed to be constant),

1
2
3
4

nsite <- 150
nspec <- 6
nyear <- 4
nrep <- 3

we can begin to consider occupancy. We’re interested in making inferences about the rates of colonization and population persistence for each species in a community, while estimating and accounting for imperfect detection.

Occupancy status at site $j$, by species $i$, in year $t$ is represented by $z(j, i, t)$. For occupied sites $z=1$; for unoccupied sites $z=0$. However, $z$ is incompletely observed: it is possible that a species $i$ is present at a site $j$ in some year $t$ ($z(j, i, t) = 1$) but species $i$ was never seen at at site $j$ in year $t$ across all $k$ repeat surveys because of imperfect detection. These observations are represented by $x(j, i, t, k)$. Here we assume that there are no “false positive” observations. In other words, if $\sum_{1}^{k}x(j, i, t, k) >0\$, then $z(j, i, t) = 1$. If a site is occupied, the probability that $x(j, i, t, k) = 1$ is represented as a Bernoulli trial with probability of detection $p(j, i, t, k)$, such that

The occupancy status $z$ of species $i$ at site $j$ in year $t$ is modeled as a Markov Bernoulli trial. In other words whether a species is present at a site in year $t$ is influenced by whether it was present at year $t-1$.

where for $t > 1$

and in year one $(t = 1)$

where the occupancy status in year 0, $z_{0}(i, j) \sim Bernoulli(\rho_{0i})$, and $\rho_{0i} \sim Uniform(0, 1)$. $\beta_i$ and $\rho_i$ are parameters that control the probabilities of colonization and persistence. If a site was unoccupied by species $i$ in a previous year $z(i, j, t-1) = 0$, then the probability of colonization is given by the antilogit of $\beta_i$. If a site was previously occupied $z(i, j, t-1) = 1$, the probability of population persistence is given by the anitlogit of $\beta_i + \rho_i$. We assume that the distributions of species specific parameters are defined by community level hyperparameters such that $\beta_i \sim Normal(\mu_{\beta}, \sigma_\beta^2)$ and $\rho_i \sim Normal(\mu_{\rho}, \sigma_\rho^2)$. We can generate occupancy data as follows:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42

# community level hyperparameters
p_beta = 0.7
mubeta <- logit(p_beta)
sdbeta <- 2

p_rho <- 0.8
murho <- logit(p_rho)
sdrho <- 1

# species specific random effects
set.seed(1)  # for reproducibility
beta <- rnorm(nspec, mubeta, sdbeta)
set.seed(1008)
rho <- rnorm(nspec, murho, sdrho)

# initial occupancy states
set.seed(237)
rho0 <- runif(nspec, 0, 1)
z0 <- array(dim = c(nsite, nspec))
for (i in 1:nspec) {
    z0[, i] <- rbinom(nsite, 1, rho0[i])
}

# subsequent occupancy
z <- array(dim = c(nsite, nspec, nyear))
lpsi <- array(dim = c(nsite, nspec, nyear))
psi <- array(dim = c(nsite, nspec, nyear))
for (j in 1:nsite) {
    for (i in 1:nspec) {
        for (t in 1:nyear) {
            if (t == 1) {
                lpsi[j, i, t] <- beta[i] + rho[i] * z0[j, i]
                psi[j, i, t] <- antilogit(lpsi[j, i, t])
                z[j, i, t] <- rbinom(1, 1, psi[j, i, t])
            } else {
                lpsi[j, i, t] <- beta[i] + rho[i] * z[j, i, t - 1]
                psi[j, i, t] <- antilogit(lpsi[j, i, t])
                z[j, i, t] <- rbinom(1, 1, psi[j, i, t])
            }
        }
    }
}

For simplicity, we’ll assume that there are no differences in species detectability among sites, years, or repeat surveys, but that detectability varies among species. We’ll again use hyperparameters to specify a distribution of detection probabilities in our community, such that $logit(p_i) \sim Normal(\mu_p, \sigma_p^2)$.

1
2
3
4
5
6

p_p <- 0.7
mup <- logit(p_p)
sdp <- 1.5
set.seed(222)
lp <- rnorm(nspec, mup, sdp)
p <- antilogit(lp)

We can now generate our observations based on occupancy states and detection probabilities. Although this could be vectorized for speed, let’s stick with nested for loops in the interest of clarity.

1
2
3
4
5
6
7
8
9
10

x <- array(dim = c(nsite, nspec, nyear, nrep))
for (j in 1:nsite) {
    for (i in 1:nspec) {
        for (t in 1:nyear) {
            for (k in 1:nrep) {
                x[j, i, t, k] <- rbinom(1, 1, p[i] * z[j, i, t])
            }
        }
    }
}

Now that we’ve collected some data, we can specify our model:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61

cat("
model{
  #### priors
  # beta hyperparameters
  p_beta ~ dbeta(1, 1)
	mubeta <- log(p_beta / (1 - p_beta))
  sigmabeta ~ dunif(0, 10)
  taubeta <- (1 / (sigmabeta * sigmabeta))

  # rho hyperparameters
  p_rho ~ dbeta(1, 1)
	murho <- log(p_rho / (1 - p_rho))
	sigmarho~dunif(0,10)
	taurho<-1/(sigmarho*sigmarho)

  # p hyperparameters
  p_p ~ dbeta(1, 1)
  mup <- log(p_p / (1 - p_p))
  sigmap ~ dunif(0,10)
  taup <- (1 / (sigmap * sigmap))

  #### occupancy model
  # species specific random effects
  for (i in 1:(nspec)) {
    rho0[i] ~ dbeta(1, 1)
    beta[i] ~ dnorm(mubeta, taubeta)
    rho[i] ~ dnorm(murho, taurho)
  }
  
  # occupancy states
  for (j in 1:nsite) {
    for (i in 1:nspec) {
      z0[j, i] ~ dbern(rho0[i])
      logit(psi[j, i, 1]) <- beta[i] + rho[i] * z0[j, i] 
      z[j, i, 1] ~ dbern(psi[j, i, 1]) 
      for (t in 2:nyear) {
        logit(psi[j, i, t]) <- beta[i] + rho[i] * z[j, i, t-1]
        z[j, i, t] ~ dbern(psi[j, i, t])
      }
    }
  }

  #### detection model
	for(i in 1:nspec){ 
		lp[i] ~ dnorm(mup, taup)
		p[i] <- (exp(lp[i])) / (1 + exp(lp[i]))
	}
	
  #### observation model
  for (j in 1:nsite){
    for (i in 1:nspec){
      for (t in 1:nyear){
        mu[j, i, t] <- z[j, i, t] * p[i] 
        for (k in 1:nrep){
          x[j, i, t, k] ~ dbern(mu[j, i, t])
        }
      }
    }
  }
}
", fill=TRUE, file="com_occ.txt")

Next, bundle up the data.

1

data <- list(x = x, nrep = nrep, nsite = nsite, nspec = nspec, nyear = nyear)

Provide initial values.

1
2
3
4
5
6
7
8
9
10
11
12
13

zinit <- array(dim = c(nsite, nspec, nyear))
for (j in 1:nsite) {
    for (i in 1:nspec) {
        for (t in 1:nyear) {
            zinit[j, i, t] <- max(x[j, i, t, ])
        }
    }
}

inits <- function() {
    list(p_beta = runif(1, 0, 1), p_rho = runif(1, 0, 1), sigmarho = runif(1,
        0, 1), sigmap = runif(1, 0, 10), sigmabeta = runif(1, 0, 10), z = zinit)
}

As a side note, it is helpful in JAGS to provide initial values for the incompletely observed occupancy state $z$ that are consistent with observed presences, as provided in this example with zinit. In other words if $x(j, i, t, k)=1$, provide an intial value of $1$ for $z(j, i, t)$. Unlike WinBUGS and OpenBUGS, if you do not do this, you’ll often (but not always) encounter an error message such as:

1
2
3

# Error in jags.model(file = 'com_occ.txt', data = data, n.chains = 3) :
# Error in node x[1,1,2,3] Observed node inconsistent with unobserved
# parents at initialization

Now we’re ready to monitor and make inferences about some parameters of interest using JAGS.

1
2
3
4

params <- c("lp", "beta", "rho")

require(rjags)
ocmod <- jags.model(file = "com_occ.txt", inits = inits, data = data, n.chains = 3)

1
2
3
4

nburn <- 2000
update(ocmod, n.iter = nburn)
out <- coda.samples(ocmod, n.iter = 17000, variable.names = params)
summary(out)

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50

## 
## Iterations = 3001:20000
## Thinning interval = 1 
## Number of chains = 3 
## Sample size per chain = 17000 
## 
## 1. Empirical mean and standard deviation for each variable,
##    plus standard error of the mean:
## 
##            Mean     SD Naive SE Time-series SE
## beta[1] -0.4539 0.1629 0.000721       0.002140
## beta[2]  0.9986 0.4274 0.001893       0.011038
## beta[3] -0.9036 0.1157 0.000513       0.001006
## beta[4]  4.7439 2.5492 0.011288       0.050756
## beta[5]  1.5512 0.3251 0.001440       0.007095
## beta[6] -0.8833 0.3021 0.001338       0.005858
## lp[1]    3.0660 0.1400 0.000620       0.000782
## lp[2]    0.8533 0.0580 0.000257       0.000409
## lp[3]    2.9045 0.2007 0.000889       0.001160
## lp[4]    0.3773 0.0491 0.000217       0.000315
## lp[5]    1.2224 0.0635 0.000281       0.000407
## lp[6]    0.4881 0.0615 0.000272       0.000551
## rho[1]   1.8640 0.2200 0.000974       0.002691
## rho[2]   2.6201 0.6009 0.002661       0.011576
## rho[3]  -0.0766 0.2229 0.000987       0.002010
## rho[4]   2.6567 2.2459 0.009945       0.035121
## rho[5]   1.1056 0.4091 0.001812       0.007679
## rho[6]   3.4425 0.4591 0.002033       0.009132
## 
## 2. Quantiles for each variable:
## 
##           2.5%    25%     50%    75%  97.5%
## beta[1] -0.777 -0.564 -0.4515 -0.343 -0.139
## beta[2]  0.168  0.707  0.9975  1.288  1.833
## beta[3] -1.132 -0.981 -0.9028 -0.826 -0.679
## beta[4]  1.117  3.206  4.3157  5.732 11.010
## beta[5]  0.896  1.338  1.5590  1.770  2.174
## beta[6] -1.509 -1.077 -0.8699 -0.675 -0.327
## lp[1]    2.803  2.970  3.0630  3.159  3.348
## lp[2]    0.740  0.814  0.8535  0.892  0.967
## lp[3]    2.528  2.766  2.8992  3.035  3.316
## lp[4]    0.282  0.344  0.3771  0.410  0.474
## lp[5]    1.100  1.179  1.2216  1.265  1.348
## lp[6]    0.369  0.446  0.4877  0.529  0.610
## rho[1]   1.439  1.714  1.8611  2.011  2.301
## rho[2]   1.504  2.205  2.5972  3.013  3.843
## rho[3]  -0.516 -0.226 -0.0747  0.074  0.359
## rho[4]  -0.928  1.270  2.3693  3.688  8.060
## rho[5]   0.319  0.831  1.1003  1.380  1.920
## rho[6]   2.601  3.123  3.4209  3.741  4.390

1

plot(out)

At this point, you’ll want to run through the usual MCMC diagnostics to check for convergence and adjust the burn-in or number of iterations accordingly. Once satisfied, we can check to see how well our model performed based on our known parameter values.

1
2
3

require(mcmcplots)
caterplot(out, "beta", style = "plain")
caterpoints(beta)

1
2

caterplot(out, "lp", style = "plain")
caterpoints(lp)

1
2

caterplot(out, "rho", style = "plain")
caterpoints(rho)

The model tracks the number of susceptible, infectious, and recovered individuals in two co-occuring host species. The rates of change for each class are represented as a system of differential equations:

Where $S_{i}$, $I_{i}$, and $R_{i}$ represent the density of susceptible, infectious, and recovered individuals respectively of species $i$. The total number of individuals of each species is $N_{i}$. Per capita birth and death rates are represented by $b_{i}$ and $d_{i}$, and the strength of density dependence in population growth is $\delta_{i}$. Transmission rates from species $j$ to species $i$ are given by $\beta_{ij}$. The pathogen imposes additional mortality for infected individuals at rate $\alpha_{i}$, and infected individuals recover at rate $\sigma_{i}$ so that the average infectious period is $\frac{1}{\sigma_{i}}$. Here, it is assumed that the pathogen does not castrate its hosts. Thus, susceptible, infectious, and recovered individuals reproduce at the same rate.

Epidemiological models often differentiate between two transmission dynamics. With density-dependent transmission, the number of host contacts and transmission events increases with the density of individuals (as shown in the above system of equations). In contrast, with frequency-dependent transmission, hosts have a constant contact rate so that the transmission rate depends on the relative proportion of infectious individuals. As an example, models of sexually transmitted infections often assume frequency dependent transmission, implying that the number of sexual partners one has is independent of population density. To incorporate frequency dependent transmission into the above model, it is necessary to divide the transmission term $S\sum(\beta I)$ by $N$.

Based on this system of equations, a criterion for pathogen invasion called $R_{0}$ can be derived based on the dominant eigenvalue of the next generation matrix (Dobson 2004). If $% &lt;![CDATA[ R_{0} < 1 %]]&gt;$, the pathogen does not invade; if $R_{0} > 1$, the pathogen invades.

Building the R shiny app

Shiny requires two files to run: a file containing all of the calculations, plotting functionality, etc., and a file defining a user interface.

Here is the file defining what you want the server to do. Note the use of ifelse() to have either density- or frequency-dependent transmission.

Here is the file defining the user interface.

Here is the resulting graphical user interface for the model.

Feel free to clone the repository or alter the code to suit your own needs. Shiny seems like a tool with great potential to make some mathematical models more accessible (at some level). For instance, something like this could be used in an ecology class to demonstrate the different ways that pathogens can regulate host populations.

The population at time $t$ is represented by a vector $\bar{x}_{t}$, where each element of the vector represents the number of individulas in each age class (e.g. if a population has $n$ age classes, then $\bar{x}_{t}$ has $n$ elements). Time is considered discrete and we assume that the population is censused prior to breeding. We assume that individuals within each age class are identical, and that each has some probability of maturing to the next age class, surviving (staying in the same age class), and reproduction. Changes in the population from one timestep to another are represented as:

where $L$ is an $n$ x $n$ Leslie matrix (or more generally, a projection matrix) that describes the contribution of each age class to the population at time $t + 1$.

Suppose we are tasked with modeling the annual dynamics of a population with four age classes, and $t$ represents years. For simplicity, we model only females and assume that plenty of males are available for breeding. Individuals in the first age class survive to class 2 with probability 0.1, class 2 individuals survive to class 3 with probability 0.5, class 3 individuals survive to class 4 with probability 0.9, and class four individuals survive each year with probability 0.7. Only the fourth age class is reproductive, with individuals producing 100 class 1 individuals per year. We can represent this population graphically as:

Equivalently, as a Leslie matrix:

The long term population growth rate is related to the dominant eigenvalue $\lambda_{1}$ of $L$. If $% &lt;![CDATA[ \lambda_{1} < 1 %]]&gt;$ the population eventually declines to extinction, and if $\lambda_{1} > 1$, the population increases.

From a management perspective, it is often useful to know how limited resources may be allocated to increase population growth or prevent extinction. In other words, if an element $l_{ij}$ such as fecundity or survival could be manipulated by managers, how much would the long term population growth rate change? To this end, one can calculate the sensitivity of the dominant eigenvalue ($\lambda_{1}$) to small changes in $l_{ij}$:

where $\bar{w}_{1}$ and $\bar{v}_{1}$ are left and right eigenvectors, respectively, associated with the dominant eigenvalue. Because survival and fecundity are on different scales, sensitivity is often scaled by a factor of $\frac{L_{ij}}{\lambda_{1}}$ for a measure of elasticity.

Building the R shiny app

Files are accessible in this repository. Please feel free to clone for your own use and/or contribute.

Here is the resulting graphical user interface for the model.