IUCN Classification
2025-09-24
Classification
There are some subtleties around the interpreting the posterior probabilities of the population change classification as the uncertainty in the population change increases.
The following simulations illustrate the issue by using the simplest ACAPT model to estimate the iucn threat level as surveys become increasingly less frequent and precise. The true log growth rate is chosen to give an expected decline of 25% over 60 years, and so in principle the population should be classified as “Near Threatened”.
When the surveys are frequent and precise (Simulation 1), the model estimates there is a high probability the population is “Vulnerable” (48%) or “Near Threatened” (46%), with a low probability of “Least Concern” (6%).
As the surveys become less frequent and precise, the probability of the population being classified as “Critically Endangered” or “Least Concern” increases - as the uncertainty increases it becomes harder to rule these categories out.
Very high levels of uncertainty favour the “Least Concern” category. As the estimated population change becomes more variable, it is more likely to fall into the “Least Concern” category which has no upper limit. In the extreme (Simulation 8), the most likely change is approximately 0.175, but the most likely category is “Least Concern”.
library(ACAPT)
library(ggplot2)Survey Data
Set the prior mean and precision for the initial subpopulation sizes for both simulation and parameter estimation
x1.mu <- log(c(10000,3000,8000))
x1.tau <- c(0.01,0.01,0.01)Set a mean growth rate that would result in a 25% decline over 60 years
q <- log(0.75)/60Simulation 1
Assume the population consists of three subpopulations, each subpopulation is surveyed every three years and a survey occurs every year, and the survey precision is extremely high
d.se2 <- data.frame(Year=1946:2025,S1=0,S2=0,S3=0)
d.se2$S1[seq(1,nrow(d.se2),3)] <- 0.001^2
d.se2$S2[seq(2,nrow(d.se2),3)] <- 0.001^2
d.se2$S3[seq(3,nrow(d.se2),3)] <- 0.001^2Simulate survey estimates from the first model variant
set.seed(23)
sim <- ACAPTsimulate1(d.se2,x1=x1.mu,q=q,y.sigma=0.0,r.sigma=0.03)
d.est <- sim$d.estand convert the data to long format for plotting
d <- mergeSurveyDF(d.est,d.se2)
ggplot(d,aes(x=Year,y=Est,group=Sub,colour=Sub)) +
geom_point()
Sample from the model
model <- ACAPTmodel1(d.est,d.se2,x1.mu=x1.mu, x1.tau=x1.tau)
s <- JAGSsample(model)
summary(as.coda(s[c("y.tau","r.tau")]))##
## Iterations = 1:5000
## Thinning interval = 1
## Number of chains = 4
## Sample size per chain = 5000
##
## 1. Empirical mean and standard deviation for each variable,
## plus standard error of the mean:
##
## Mean SD Naive SE Time-series SE
## y.tau 3190 1314.5 9.295 37.952
## r.tau 1216 225.9 1.597 4.227
##
## 2. Quantiles for each variable:
##
## 2.5% 25% 50% 75% 97.5%
## y.tau 1385.0 2249 2933 3830 6542
## r.tau 831.2 1054 1197 1357 1711Plot the posterior distribution of the mean log growth \(q\) with the true value (red)
hist(s$q,50,xlab="q",main="Mean Log Growth")
abline(v=sim$q,col="red")
Plot the posterior median and 95% credible intervals for the annual subpopulation sizes (colour) together with the true values (grey) and the observed survey estimates (black)
d.s <- cbind(annualSummary(exp(s$x)),Sim=as.vector(exp(sim$x)))
ggplot(d.s,
aes(x=Year,y=`Q.50%`,ymin=`Q.2.5%`,ymax=`Q.97.5%`,group=Sub,color=Sub,fill=Sub))+
geom_ribbon(alpha=0.2,color=NA)+
geom_point(mapping=aes(x=Year,y=Est,group=Sub),inherit.aes=FALSE,data=d)+
geom_line(mapping=aes(x=Year,y=Sim),color="grey50")+
geom_line()+
facet_wrap(~Sub,ncol=3,scales="free")+
guides(color = "none", fill="none")+
ylab("N")+
ggtitle("Population Size")+
theme_minimal()
Plot the posterior distribution of the population change over 60 years extrapolated from the 20 year change estimated from the population size in the period 2016 to 2025, coded by IUCN threat categories.
r <- populationChange(s$N,2016:2025,20,60)
d.s <- iucnHistogram(r)
ggplot(d.s, aes(x = Change, y = Density, fill = Label)) +
geom_col(width = 0.05, color = "grey60") +
scale_fill_manual(values = hcl.colors(6,"YlOrRd"), name = "Threat") +
labs(x = "Population change", y = "Density") +
theme_minimal()
Simulation 2
Assume each subpopulation is surveyed every three years and a survey occurs every year, and the survey precision is high
d.se2 <- data.frame(Year=1946:2025,S1=0,S2=0,S3=0)
d.se2$S1[seq(1,nrow(d.se2),3)] <- 0.05^2
d.se2$S2[seq(2,nrow(d.se2),3)] <- 0.05^2
d.se2$S3[seq(3,nrow(d.se2),3)] <- 0.05^2Simulate survey estimates from the first model variant
set.seed(23)
sim <- ACAPTsimulate1(d.se2,x1=x1.mu,q=q,y.sigma=0.0,r.sigma=0.03)
d.est <- sim$d.estand convert the data to long format for plotting
d <- mergeSurveyDF(d.est,d.se2)
ggplot(d,aes(x=Year,y=Est,group=Sub,colour=Sub)) +
geom_point()
Sample from the model
model <- ACAPTmodel1(d.est,d.se2,x1.mu=x1.mu, x1.tau=x1.tau)
s <- JAGSsample(model)
summary(as.coda(s[c("y.tau","r.tau")]))##
## Iterations = 1:5000
## Thinning interval = 1
## Number of chains = 4
## Sample size per chain = 5000
##
## 1. Empirical mean and standard deviation for each variable,
## plus standard error of the mean:
##
## Mean SD Naive SE Time-series SE
## y.tau 1342.7 833.7 5.895 14.647
## r.tau 777.3 199.3 1.409 4.557
##
## 2. Quantiles for each variable:
##
## 2.5% 25% 50% 75% 97.5%
## y.tau 403.6 772.5 1126.5 1670.5 3482
## r.tau 453.1 633.7 755.3 896.3 1225Plot the posterior distribution of the mean log growth \(q\) with the true value (red)
hist(s$q,50,xlab="q",main="Mean Log Growth")
abline(v=sim$q,col="red")
Plot the posterior median and 95% credible intervals for the annual subpopulation sizes (colour) together with the true values (grey) and the observed survey estimates (black)
d.s <- cbind(annualSummary(exp(s$x)),Sim=as.vector(exp(sim$x)))
ggplot(d.s,
aes(x=Year,y=`Q.50%`,ymin=`Q.2.5%`,ymax=`Q.97.5%`,group=Sub,color=Sub,fill=Sub))+
geom_ribbon(alpha=0.2,color=NA)+
geom_point(mapping=aes(x=Year,y=Est,group=Sub),inherit.aes=FALSE,data=d)+
geom_line(mapping=aes(x=Year,y=Sim),color="grey50")+
geom_line()+
facet_wrap(~Sub,ncol=3,scales="free")+
guides(color = "none", fill="none")+
ylab("N")+
ggtitle("Population Size")+
theme_minimal()
Plot the posterior distribution of the population change over 60 years extrapolated from the 20 year change estimated from the population size in the period 2016 to 2025, coded by IUCN threat categories.
r <- populationChange(s$N,2016:2025,20,60)
d.s <- iucnHistogram(r)
ggplot(d.s, aes(x = Change, y = Density, fill = Label)) +
geom_col(width = 0.05, color = "grey60") +
scale_fill_manual(values = hcl.colors(6,"YlOrRd"), name = "Threat") +
labs(x = "Population change", y = "Density") +
theme_minimal()
Simulation 3
Assume each subpopulation is surveyed every six years and a survey occurs every second year, and the survey precision is high
d.se2 <- data.frame(Year=1946:2025,S1=0,S2=0,S3=0)
d.se2$S1[seq(1,nrow(d.se2),6)] <- 0.05^2
d.se2$S2[seq(3,nrow(d.se2),6)] <- 0.05^2
d.se2$S3[seq(5,nrow(d.se2),6)] <- 0.05^2Simulate survey estimates from the first model variant
set.seed(23)
sim <- ACAPTsimulate1(d.se2,x1=x1.mu,q=q,y.sigma=0.0,r.sigma=0.03)
d.est <- sim$d.estand convert the data to long format for plotting
d <- mergeSurveyDF(d.est,d.se2)
ggplot(d,aes(x=Year,y=Est,group=Sub,colour=Sub)) +
geom_point()
Sample from the model
model <- ACAPTmodel1(d.est,d.se2,x1.mu=x1.mu, x1.tau=x1.tau)
s <- JAGSsample(model)
summary(as.coda(s[c("y.tau","r.tau")]))##
## Iterations = 1:5000
## Thinning interval = 1
## Number of chains = 4
## Sample size per chain = 5000
##
## 1. Empirical mean and standard deviation for each variable,
## plus standard error of the mean:
##
## Mean SD Naive SE Time-series SE
## y.tau 1186.6 833.8 5.896 13.726
## r.tau 671.2 192.9 1.364 4.213
##
## 2. Quantiles for each variable:
##
## 2.5% 25% 50% 75% 97.5%
## y.tau 266.9 598.3 964.5 1516.0 3388
## r.tau 357.4 531.1 648.9 787.6 1108Plot the posterior distribution of the mean log growth \(q\) with the true value (red)
hist(s$q,50,xlab="q",main="Mean Log Growth")
abline(v=sim$q,col="red")
Plot the posterior median and 95% credible intervals for the annual subpopulation sizes (colour) together with the true values (grey) and the observed survey estimates (black)
d.s <- cbind(annualSummary(exp(s$x)),Sim=as.vector(exp(sim$x)))
ggplot(d.s,
aes(x=Year,y=`Q.50%`,ymin=`Q.2.5%`,ymax=`Q.97.5%`,group=Sub,color=Sub,fill=Sub))+
geom_ribbon(alpha=0.2,color=NA)+
geom_point(mapping=aes(x=Year,y=Est,group=Sub),inherit.aes=FALSE,data=d)+
geom_line(mapping=aes(x=Year,y=Sim),color="grey50")+
geom_line()+
facet_wrap(~Sub,ncol=3,scales="free")+
guides(color = "none", fill="none")+
ylab("N")+
ggtitle("Population Size")+
theme_minimal()
Plot the posterior distribution of the population change over 60 years extrapolated from the 20 year change estimated from the population size in the period 2016 to 2025, coded by IUCN threat categories.
r <- populationChange(s$N,2016:2025,20,60)
d.s <- iucnHistogram(r)
ggplot(d.s, aes(x = Change, y = Density, fill = Label)) +
geom_col(width = 0.05, color = "grey60") +
scale_fill_manual(values = hcl.colors(6,"YlOrRd"), name = "Threat") +
labs(x = "Population change", y = "Density") +
theme_minimal()
Simulation 4
Assume each subpopulation is surveyed every nine years and a survey occurs every third year, and the survey precision is good
d.se2 <- data.frame(Year=1946:2025,S1=0,S2=0,S3=0)
d.se2$S1[seq(1,nrow(d.se2),9)] <- 0.08^2
d.se2$S2[seq(4,nrow(d.se2),9)] <- 0.08^2
d.se2$S3[seq(7,nrow(d.se2),9)] <- 0.08^2Simulate survey estimates from the first model variant
set.seed(23)
sim <- ACAPTsimulate1(d.se2,x1=x1.mu,q=q,y.sigma=0.0,r.sigma=0.03)
d.est <- sim$d.estand convert the data to long format for plotting
d <- mergeSurveyDF(d.est,d.se2)
ggplot(d,aes(x=Year,y=Est,group=Sub,colour=Sub)) +
geom_point()
Sample from the model
model <- ACAPTmodel1(d.est,d.se2,x1.mu=x1.mu, x1.tau=x1.tau)
s <- JAGSsample(model)
summary(as.coda(s[c("y.tau","r.tau")]))##
## Iterations = 1:5000
## Thinning interval = 1
## Number of chains = 4
## Sample size per chain = 5000
##
## 1. Empirical mean and standard deviation for each variable,
## plus standard error of the mean:
##
## Mean SD Naive SE Time-series SE
## y.tau 718.1 655.4 4.634 13.220
## r.tau 486.8 174.2 1.232 3.495
##
## 2. Quantiles for each variable:
##
## 2.5% 25% 50% 75% 97.5%
## y.tau 95.38 280.8 510.4 931.4 2526.1
## r.tau 216.60 362.0 462.8 583.6 897.4Plot the posterior distribution of the mean log growth \(q\) with the true value (red)
hist(s$q,50,xlab="q",main="Mean Log Growth")
abline(v=sim$q,col="red")
Plot the posterior median and 95% credible intervals for the annual subpopulation sizes (colour) together with the true values (grey) and the observed survey estimates (black)
d.s <- cbind(annualSummary(exp(s$x)),Sim=as.vector(exp(sim$x)))
ggplot(d.s,
aes(x=Year,y=`Q.50%`,ymin=`Q.2.5%`,ymax=`Q.97.5%`,group=Sub,color=Sub,fill=Sub))+
geom_ribbon(alpha=0.2,color=NA)+
geom_point(mapping=aes(x=Year,y=Est,group=Sub),inherit.aes=FALSE,data=d)+
geom_line(mapping=aes(x=Year,y=Sim),color="grey50")+
geom_line()+
facet_wrap(~Sub,ncol=3,scales="free")+
guides(color = "none", fill="none")+
ylab("N")+
ggtitle("Population Size")+
theme_minimal()
Plot the posterior distribution of the population change over 60 years extrapolated from the 20 year change estimated from the population size in the period 2016 to 2025, coded by IUCN threat categories.
r <- populationChange(s$N,2016:2025,20,60)
d.s <- iucnHistogram(r)
ggplot(d.s, aes(x = Change, y = Density, fill = Label)) +
geom_col(width = 0.05, color = "grey60") +
scale_fill_manual(values = hcl.colors(6,"YlOrRd"), name = "Threat") +
labs(x = "Population change", y = "Density") +
theme_minimal()
Simulation 5
Assume each subpopulation is surveyed every 12 years and a survey occurs every fourth year, and the survey precision is good
d.se2 <- data.frame(Year=1946:2025,S1=0,S2=0,S3=0)
d.se2$S1[seq(1,nrow(d.se2),12)] <- 0.08^2
d.se2$S2[seq(5,nrow(d.se2),12)] <- 0.08^2
d.se2$S3[seq(9,nrow(d.se2),12)] <- 0.08^2Simulate survey estimates from the first model variant
set.seed(23)
sim <- ACAPTsimulate1(d.se2,x1=x1.mu,q=q,y.sigma=0.0,r.sigma=0.03)
d.est <- sim$d.estand convert the data to long format for plotting
d <- mergeSurveyDF(d.est,d.se2)
ggplot(d,aes(x=Year,y=Est,group=Sub,colour=Sub)) +
geom_point()
Sample from the model
model <- ACAPTmodel1(d.est,d.se2,x1.mu=x1.mu, x1.tau=x1.tau)
s <- JAGSsample(model)
summary(as.coda(s[c("y.tau","r.tau")]))##
## Iterations = 1:5000
## Thinning interval = 1
## Number of chains = 4
## Sample size per chain = 5000
##
## 1. Empirical mean and standard deviation for each variable,
## plus standard error of the mean:
##
## Mean SD Naive SE Time-series SE
## y.tau 700.1 686.2 4.852 14.218
## r.tau 478.8 183.5 1.297 3.218
##
## 2. Quantiles for each variable:
##
## 2.5% 25% 50% 75% 97.5%
## y.tau 79.34 260.5 487.4 893.1 2531.1
## r.tau 199.13 345.4 453.1 582.6 910.7Plot the posterior distribution of the mean log growth \(q\) with the true value (red)
hist(s$q,50,xlab="q",main="Mean Log Growth")
abline(v=sim$q,col="red")
Plot the posterior median and 95% credible intervals for the annual subpopulation sizes (colour) together with the true values (grey) and the observed survey estimates (black)
d.s <- cbind(annualSummary(exp(s$x)),Sim=as.vector(exp(sim$x)))
ggplot(d.s,
aes(x=Year,y=`Q.50%`,ymin=`Q.2.5%`,ymax=`Q.97.5%`,group=Sub,color=Sub,fill=Sub))+
geom_ribbon(alpha=0.2,color=NA)+
geom_point(mapping=aes(x=Year,y=Est,group=Sub),inherit.aes=FALSE,data=d)+
geom_line(mapping=aes(x=Year,y=Sim),color="grey50")+
geom_line()+
facet_wrap(~Sub,ncol=3,scales="free")+
guides(color = "none", fill="none")+
ylab("N")+
ggtitle("Population Size")+
theme_minimal()
Plot the posterior distribution of the population change over 60 years extrapolated from the 20 year change estimated from the population size in the period 2016 to 2025, coded by IUCN threat categories.
r <- populationChange(s$N,2016:2025,20,60)
d.s <- iucnHistogram(r)
ggplot(d.s, aes(x = Change, y = Density, fill = Label)) +
geom_col(width = 0.05, color = "grey60") +
scale_fill_manual(values = hcl.colors(6,"YlOrRd"), name = "Threat") +
labs(x = "Population change", y = "Density") +
theme_minimal()
Simulation 6
Assume each subpopulation is surveyed every 12 years and a survey occurs every fourth year, and the survey precision is moderate
d.se2 <- data.frame(Year=1946:2025,S1=0,S2=0,S3=0)
d.se2$S1[seq(1,nrow(d.se2),12)] <- 0.2^2
d.se2$S2[seq(5,nrow(d.se2),12)] <- 0.2^2
d.se2$S3[seq(9,nrow(d.se2),12)] <- 0.2^2Simulate survey estimates from the first model variant
set.seed(23)
sim <- ACAPTsimulate1(d.se2,x1=x1.mu,q=q,y.sigma=0.0,r.sigma=0.03)
d.est <- sim$d.estand convert the data to long format for plotting
d <- mergeSurveyDF(d.est,d.se2)
ggplot(d,aes(x=Year,y=Est,group=Sub,colour=Sub)) +
geom_point()
Sample from the model
model <- ACAPTmodel1(d.est,d.se2,x1.mu=x1.mu, x1.tau=x1.tau)
s <- JAGSsample(model)
summary(as.coda(s[c("y.tau","r.tau")]))##
## Iterations = 1:5000
## Thinning interval = 1
## Number of chains = 4
## Sample size per chain = 5000
##
## 1. Empirical mean and standard deviation for each variable,
## plus standard error of the mean:
##
## Mean SD Naive SE Time-series SE
## y.tau 420.2 513.7 3.632 13.241
## r.tau 306.4 146.6 1.036 2.224
##
## 2. Quantiles for each variable:
##
## 2.5% 25% 50% 75% 97.5%
## y.tau 25.36 101.7 232.6 529.2 1922.6
## r.tau 100.28 199.5 280.4 383.3 666.8Plot the posterior distribution of the mean log growth \(q\) with the true value (red)
hist(s$q,50,xlab="q",main="Mean Log Growth")
abline(v=sim$q,col="red")
Plot the posterior median and 95% credible intervals for the annual subpopulation sizes (colour) together with the true values (grey) and the observed survey estimates (black)
d.s <- cbind(annualSummary(exp(s$x)),Sim=as.vector(exp(sim$x)))
ggplot(d.s,
aes(x=Year,y=`Q.50%`,ymin=`Q.2.5%`,ymax=`Q.97.5%`,group=Sub,color=Sub,fill=Sub))+
geom_ribbon(alpha=0.2,color=NA)+
geom_point(mapping=aes(x=Year,y=Est,group=Sub),inherit.aes=FALSE,data=d)+
geom_line(mapping=aes(x=Year,y=Sim),color="grey50")+
geom_line()+
facet_wrap(~Sub,ncol=3,scales="free")+
guides(color = "none", fill="none")+
ylab("N")+
ggtitle("Population Size")+
theme_minimal()
Plot the posterior distribution of the population change over 60 years extrapolated from the 20 year change estimated from the population size in the period 2016 to 2025, coded by IUCN threat categories.
r <- populationChange(s$N,2016:2025,20,60)
d.s <- iucnHistogram(r)
ggplot(d.s, aes(x = Change, y = Density, fill = Label)) +
geom_col(width = 0.05, color = "grey60") +
scale_fill_manual(values = hcl.colors(6,"YlOrRd"), name = "Threat") +
labs(x = "Population change", y = "Density") +
theme_minimal()
Simulation 7
Assume each subpopulation is surveyed every 15 years and a survey occurs every fifth year, and the survey precision is poor
d.se2 <- data.frame(Year=1946:2025,S1=0,S2=0,S3=0)
d.se2$S1[seq(1,nrow(d.se2),15)] <- 0.5^2
d.se2$S2[seq(6,nrow(d.se2),15)] <- 0.5^2
d.se2$S3[seq(11,nrow(d.se2),15)] <- 0.5^2Simulate survey estimates from the first model variant
set.seed(23)
sim <- ACAPTsimulate1(d.se2,x1=x1.mu,q=q,y.sigma=0.0,r.sigma=0.03)
d.est <- sim$d.estand convert the data to long format for plotting
d <- mergeSurveyDF(d.est,d.se2)
ggplot(d,aes(x=Year,y=Est,group=Sub,colour=Sub)) +
geom_point()
Sample from the model
model <- ACAPTmodel1(d.est,d.se2,x1.mu=x1.mu, x1.tau=x1.tau)
s <- JAGSsample(model)
summary(as.coda(s[c("y.tau","r.tau")]))##
## Iterations = 1:5000
## Thinning interval = 1
## Number of chains = 4
## Sample size per chain = 5000
##
## 1. Empirical mean and standard deviation for each variable,
## plus standard error of the mean:
##
## Mean SD Naive SE Time-series SE
## y.tau 217.1 353.2 2.497 19.714
## r.tau 163.8 111.3 0.787 1.584
##
## 2. Quantiles for each variable:
##
## 2.5% 25% 50% 75% 97.5%
## y.tau 3.883 22.07 77.07 250.4 1260.7
## r.tau 29.576 83.11 137.27 215.0 453.1Plot the posterior distribution of the mean log growth \(q\) with the true value (red)
hist(s$q,50,xlab="q",main="Mean Log Growth")
abline(v=sim$q,col="red")
Plot the posterior median and 95% credible intervals for the annual subpopulation sizes (colour) together with the true values (grey) and the observed survey estimates (black)
d.s <- cbind(annualSummary(exp(s$x)),Sim=as.vector(exp(sim$x)))
ggplot(d.s,
aes(x=Year,y=`Q.50%`,ymin=`Q.2.5%`,ymax=`Q.97.5%`,group=Sub,color=Sub,fill=Sub))+
geom_ribbon(alpha=0.2,color=NA)+
geom_point(mapping=aes(x=Year,y=Est,group=Sub),inherit.aes=FALSE,data=d)+
geom_line(mapping=aes(x=Year,y=Sim),color="grey50")+
geom_line()+
facet_wrap(~Sub,ncol=3,scales="free")+
guides(color = "none", fill="none")+
ylab("N")+
ggtitle("Population Size")+
theme_minimal()
Plot the posterior distribution of the population change over 60 years extrapolated from the 20 year change estimated from the population size in the period 2016 to 2025, coded by IUCN threat categories.
r <- populationChange(s$N,2016:2025,20,60)
d.s <- iucnHistogram(r)
ggplot(d.s, aes(x = Change, y = Density, fill = Label)) +
geom_col(width = 0.05, color = "grey60") +
scale_fill_manual(values = hcl.colors(6,"YlOrRd"), name = "Threat") +
labs(x = "Population change", y = "Density") +
theme_minimal()
Simulation 8
Assume each subpopulation is surveyed every 15 years and a survey occurs every fifth year, and the survey precision is very poor
d.se2 <- data.frame(Year=1946:2025,S1=0,S2=0,S3=0)
d.se2$S1[seq(1,nrow(d.se2),15)] <- 0.8^2
d.se2$S2[seq(6,nrow(d.se2),15)] <- 0.8^2
d.se2$S3[seq(11,nrow(d.se2),15)] <- 0.8^2Simulate survey estimates from the first model variant
set.seed(23)
sim <- ACAPTsimulate1(d.se2,x1=x1.mu,q=q,y.sigma=0.0,r.sigma=0.03)
d.est <- sim$d.estand convert the data to long format for plotting
d <- mergeSurveyDF(d.est,d.se2)
ggplot(d,aes(x=Year,y=Est,group=Sub,colour=Sub)) +
geom_point()
Sample from the model
model <- ACAPTmodel1(d.est,d.se2,x1.mu=x1.mu, x1.tau=x1.tau)
s <- JAGSsample(model)
summary(as.coda(s[c("y.tau","r.tau")]))##
## Iterations = 1:5000
## Thinning interval = 1
## Number of chains = 4
## Sample size per chain = 5000
##
## 1. Empirical mean and standard deviation for each variable,
## plus standard error of the mean:
##
## Mean SD Naive SE Time-series SE
## y.tau 348.7 691.1 4.8868 117.088
## r.tau 131.8 102.9 0.7277 1.366
##
## 2. Quantiles for each variable:
##
## 2.5% 25% 50% 75% 97.5%
## y.tau 1.728 12.46 57.96 283.8 2492.1
## r.tau 18.918 58.94 103.62 172.8 404.7Plot the posterior distribution of the mean log growth \(q\) with the true value (red)
hist(s$q,50,xlab="q",main="Mean Log Growth")
abline(v=sim$q,col="red")
Plot the posterior median and 95% credible intervals for the annual subpopulation sizes (colour) together with the true values (grey) and the observed survey estimates (black)
d.s <- cbind(annualSummary(exp(s$x)),Sim=as.vector(exp(sim$x)))
ggplot(d.s,
aes(x=Year,y=`Q.50%`,ymin=`Q.2.5%`,ymax=`Q.97.5%`,group=Sub,color=Sub,fill=Sub))+
geom_ribbon(alpha=0.2,color=NA)+
geom_point(mapping=aes(x=Year,y=Est,group=Sub),inherit.aes=FALSE,data=d)+
geom_line(mapping=aes(x=Year,y=Sim),color="grey50")+
geom_line()+
facet_wrap(~Sub,ncol=3,scales="free")+
guides(color = "none", fill="none")+
ylab("N")+
ggtitle("Population Size")+
theme_minimal()
Plot the posterior distribution of the population change over 60 years extrapolated from the 20 year change estimated from the population size in the period 2016 to 2025, coded by IUCN threat categories.
r <- populationChange(s$N,2016:2025,20,60)
d.s <- iucnHistogram(r)
ggplot(d.s, aes(x = Change, y = Density, fill = Label)) +
geom_col(width = 0.05, color = "grey60") +
scale_fill_manual(values = hcl.colors(6,"YlOrRd"), name = "Threat") +
labs(x = "Population change", y = "Density") +
theme_minimal()