Introduction

For many species, count data is very skewly distributed. This is especially the case for species which tend to flock or cluster together at one or more resting places, that may or may not change from year to year. Especially when these places do change, it will become difficult for rtrim (or any GLM) to model this correctly, because the episodic high counts are not captured well in a site factor, nor in a time-point factor. The result is that model deviations for these place/time combinations are large, which for serveral resons may affect the computed overdispersion. To some extent, this effect will be true (because of the larger-than-expected variance), but there is also the risk of methodologival artefacts, which we would like to avoid.

This vigenette aims as understanding the nature of huge overdispersion for these cases, and presents a number of mitigating approaches implemented in rtrim.

Let’s look at an example for Oystercatcher data that comes with RTRIM. First we plot the sorted raw counts.

library(rtrim)
data(oystercatcher)

# Collect all raw count data
ok <- is.finite(oystercatcher$count) & oystercatcher$count > 0
count <- oystercatcher$count[ok]
plot(count, type='p', pch=16, col="red", cex=0.4)

Of course, sorting does help to see the big picture.

count <- sort(count)
plot(count/1000, type='p', pch=16, col="red", cex=0.4, las=TRUE, ylab="count (x1000)")

So it appears that a few site/year/month combinations have the majority of all individuals. We can plot exactly this:

cum_count <- cumsum(sort(count, decreasing = TRUE)) # cumulative counts, largest first
cum_pct <- 100 * cum_count / sum(count)             # express as percentage of total
n <- length(count)
obs_pct <- 100 * (1:n)/n
plot(obs_pct, cum_pct, type='n', xlab="Observations (%)", ylab="Cum. counts (%)", las=1)
points(obs_pct, cum_pct, pch=16, cex=0.3, col="red")
abline(a=100, b=-1, lty="dashed")
grid()

In this case, we see the typical “Pareto-principle”: 20% of the data points represent 80% of the total counts. This is likely to have a strong impact on estimated overdispersion.

Overdispersion for clustered observations: the problem

Let’s see how large overdispersion actually is. Because using the full dataset may be a bit slow for use within a vignette, we create a second dataset using only the last 10 year, and the sites that have the best coverage (percentage of years and months that have positive counts).

oystercatcher2 <- subset(oystercatcher, year>=2005)

calc_coverage <- function(x) 100*mean(is.finite(x) & x>0)
coverage <- aggregate(count ~ site, data=oystercatcher2, calc_coverage, na.action=na.pass)
coverage <- coverage[order(coverage$count, decreasing=TRUE), ]
plot(coverage$count, ylab="coverage (%)", pch=16, col=gray(0,0.5), las=1)
abline(a=50, b=0, col="red")

Based on above figure, we decide to use a threshold of 50% coverage, which is about 20 sites.

ok <- subset(coverage, count > 45)
oystercatcher3 <- subset(oystercatcher2, site %in% ok$site)

z <- trim(count ~ site + (year+month), data=oystercatcher3, model=3, overdisp=TRUE)
summary(z)
#> Call:
#> tools::buildVignettes(dir = ".", tangle = TRUE)
#> 
#> Model  : 3
#> Method : GEE (Convergence reached after 8 iterations)
#> 
#> Coefficients:
#>     what which         add     se_add       mul     se_mul
#> 1   year     1  0.00000000 0.00000000 1.0000000 0.00000000
#> 2   year     2 -0.12910821 0.10412101 0.8788789 0.09150975
#> 3   year     3 -0.26286715 0.10480722 0.7688440 0.08058041
#> 4   year     4 -0.34053864 0.10443466 0.7113870 0.07429346
#> 5   year     5 -0.40775682 0.11236331 0.6651406 0.07473740
#> 6   year     6 -0.23146611 0.10398967 0.7933696 0.08250224
#> 7   year     7 -0.45102143 0.10950416 0.6369772 0.06975165
#> 8   year     8 -0.05673496 0.09844313 0.9448445 0.09301345
#> 9   year     9 -0.31097791 0.10313944 0.7327301 0.07557337
#> 10  year    10 -0.23289935 0.10190991 0.7922333 0.08073643
#> 11 month     1  0.00000000 0.00000000 1.0000000 0.00000000
#> 12 month     2  0.05336631 0.09636071 1.0548160 0.10164281
#> 13 month     3 -0.62159914 0.11900349 0.5370849 0.06391497
#> 14 month     4 -1.15666563 0.14573389 0.3145332 0.04583815
#> 15 month     5 -1.59739827 0.16395820 0.2024225 0.03318883
#> 16 month     6 -1.45125447 0.16571737 0.2342762 0.03882364
#> 17 month     7 -0.66394637 0.12149335 0.5148157 0.06254668
#> 18 month     8  0.03478200 0.10172791 1.0353940 0.10532846
#> 19 month     9  0.09859027 0.09225028 1.1036140 0.10180870
#> 20 month    10 -0.12836654 0.10233123 0.8795309 0.09000348
#> 21 month    11  0.07262761 0.09633538 1.0753300 0.10359232
#> 22 month    12  0.03298819 0.10082010 1.0335383 0.10420144
#> 
#>  Overdispersion     : 1213.0781
#> 
#> Goodness of fit:
#>               Chi-square = 2549890.26, df=2102, p=0.0000
#>         Likelihood Ratio = 1613397.34, df=2102, p=0.0000
#>   AIC (up to a constant) = 1609193.34

So overdispersion is indeed huge!

You may recall from TRIM_methods_v2.pdf that the formula for overdispersion is given by \[ \sigma^2 = \frac{1}{n-p} \sum_{ijm} r^2_{ijm}\] with \(n\) the number of observations, \(p\) the number of model parameters and \(r\) Pearson residuals, given by \[ r = \frac{f_{ijm} -\mu_{ijm}}{\sqrt{\mu_{ijm}}}. \]

Species like Oystercatcher are known to cluster in winter: many individuals may appear at one monitoring site at one time, and at another site at another time. This clustering behaviour is unlikely to be captured in full by the TRIM model. Therefore, residuals (i.e. \(f-\mu\)) may be large, and more than proportionally affect overdispersion \(\sigma^2\) because the nonlinearity involved (i.e. the squaring process). So, while overdispersion may be high, it is also very likely to be overestimated.

We can see the effect of large deviations on the computed overdispersion by skipping the 0,1,2,etc largest values from the computation.

# Retrieve raw observed and modelled counts
out <- results(z)
ok  <- is.finite(out$observed)
f   <- out$observed[ok]
mu  <- out$fitted[ok]

# Compute Pearson residuals, and sort
r <- (f - mu) / sqrt(mu)
idx <- order(r^2, decreasing=TRUE)
r <- r[idx]

# How many obervations and parameters?
n <- length(f)
p <- z$nsite + z$nyear-1 + z$nmonth-1

# Set up
skips <- 0 : (n %/% 2) # skip none to approx 50% of all residuals
sig2 <- numeric(length(skips)) # Allocate a vector with the computed overdispersion
for (i in seq_along(skips)) {
  r2 <- r[skips[i] : n]^2
  df <- n - p - skips[i] # correct for skipped
  sig2[i] <- sum(r2) / df
}
plot(skips, sig2, type='l', col="red", las=1)
abline(h=0.0, lty="dashed", col="red")

Indeed, overdispersion appears to be very sensitive for the largest residuals, suggesting that the actual value is not very robust against the contingent observations.

The question now is, how to compute a more robust and realistic estimate of overdispersion, which may be (much) larger than 1, but not affected by artefacts resulting from the estimation procedure?

Approach #1: average first, square later.

The formal approach to compute overdispersion is to first square the residuals, and then do the averaging, which is very sensitive for outliers. Let’s see what happens if we reverse this order: first we do the averaging (using the absolute values of the residuals), then the squaring. Again, formally this is not correct, but at least if gives us some hint whether this phenomenon is the cause of the problem.

sig2_alt1 <- numeric(length(skips))
for (i in seq_along(skips)) {
  rr <- r[skips[i] : n]
  df <- n - p - skips[i] # correct for skipped
  sig2_alt1[i] <- (sum(abs(rr))/df)^2
}
plot(skips, sig2, type='l', col="red", las=1)
lines(skips, sig2_alt1, col="blue")

Indeed, it appears that the effect is strongly mitigated reducing \(\sigma^2\) from about 850 to about 200, and converges to about the same value once all outliers have beem removed. But again, this approach is formally incorrect.

Approach #2: remove outliers (nonparametric)

A second approach is to just remove the outliers. One way to do this is to use a nonparametric methods, such as based on the interquantile interval (`Tuckey’s Fence’)

# residuals, and their square
r <- (f - mu) / sqrt(mu)
r2 <- r^2

# classic overdispersion
n <- length(f)
p <- z$nsite + z$nyear-1 + z$nmonth-1
sig2_std <- sum(r^2) / (n-p)

# Compute interquantile distance and outlier limits
Q <- quantile(r2, c(0.25, 0.50, 0.75)) # such that Q[3] is what you expect
IQR <- (Q[3]-Q[1]) # Interquartile range
k <- 3 # Tuckey's criterion for "far out"
lo <- Q[1] - k * IQR # low threshold value added for completeless only
hi <- Q[3] + k * IQR
cat(sprintf("Using r2 limit %f -- %f\n", lo, hi))
#> Using r2 limit -1463.172751 -- 2039.455264
nlo <- sum(r2<lo)
cat(sprintf("  removing %d lower outliers (%.1f%%)\n", nlo, 100*nlo/length(f)))
#>   removing 0 lower outliers (0.0%)
nhi <- sum(r2>hi)
cat(sprintf("  removing %d upper outliers (%.1f%%)\n", nhi, 100*nhi/length(f)))
#>   removing 165 upper outliers (7.7%)
ok <- (r2>lo) & (r2<hi)
df <- length(r2) - p
sig2_alt2 <- sum(r2[ok]) / df
cat(sprintf("Reduced sig2 from %.1f to %.1f\n", sig2_std, sig2_alt2))
#> Reduced sig2 from 1213.1 to 272.9

So, this approach appears to work. It is implemented in R-TRIM using the constrain_overdisp argument, where values (\(>1\)) represents the IQR multiplier (defaulting to 3, for `far out’, in above example)

z <- trim(..., overdisp=TRUE, constrain_overdisp=3, ...)

Approach #3: remove outliers (parametric)

One of the assumptions behind TRIM is that the residuals are approximately \(\chi^2\)-distributed. Thus, it makes sense to fit such a distribution to find the, say, 99% percentile, using an estimate of \(\sigma^2\) as a scaling parameter, to obtain a threshold value to identify outliers. Since the value of \(\sigma^2\) will depend on the outliers removed, an iterative approach is required.

level <- 0.99
niter <- 10
sig2_alt3 <- numeric(niter)
ok <- !logical(length(r2)) # all TRUE
for (i in 1:niter) {
  # Compute current overdispersion
  df <- sum(ok) - p
  sig2_alt3[i] <- sum(r2[ok]) / df
  # Compute new cutoff value
  cutoff <- sig2_alt3[i] * qchisq(level, 1) 
  ok <- r2 < cutoff
}
ntotal <- length(r2)
noutlier <- ntotal - sum(ok)
cat(sprintf("Removed %d outliers (%.1f%%)\n", noutlier, 100*noutlier/ntotal))
#> Removed 166 outliers (7.7%)
plot(sig2_alt3, type='l', col="red", ylim=range(0,range(sig2_alt3)), las=1)
points(sig2_alt3, pch=16, col="red")
text(25,400, sprintf("Convergence at %.1f", sig2_alt3[niter]))

Again, this method works well, and is implemented in R-TRIM using the constrain_overdisp option, for values in the range \(0\ldots1\), e.g.

z <- trim(..., overdisp=TRUE, constrain_overdisp=0.99, ...)

Note that constrain_overdisp has 3 possible values:

• \(0 \ldots 1\) : Using Chi-squared outlier detection, with the specified level.
• \(1\) : No constraints.
• \(>1\) : Using Tuckey’s Fence, with the specified IQR multiplier.

Application

Here is an example where we compare unconstrained / constrained overdispersion, using the 3th approach.

z1 <- trim(count ~ site + (year+month), data=oystercatcher3, model=3,
           overdisp=TRUE, constrain_overdisp=0.99)
z2 <- trim(count ~ site + (year+month), data=oystercatcher3, model=3,
           overdisp=TRUE, constrain_overdisp=1)
idx1 <- index(z1)
#>  [1] 320343.7 281543.3 246294.3 227888.3 213073.6 254150.9 204051.6
#>  [8] 302674.9 234725.4 253786.9
#>              [,1]        [,2]       [,3]       [,4]       [,5]       [,6]
#>  [1,] 128525483.4    702505.4   640485.9   323086.9   544703.6   977262.3
#>  [2,]    702505.4 111152518.0   651367.2   202800.1   234790.1   245866.3
#>  [3,]    640485.9    651367.2 87219429.9   218165.3   250692.6   239338.9
#>  [4,]    323086.9    202800.1   218165.3 73301406.5   308497.1   378797.2
#>  [5,]    544703.6    234790.1   250692.6   308497.1 83400984.4   335732.5
#>  [6,]    977262.3    245866.3   239338.9   378797.2   335732.5 90690470.8
#>  [7,]    513821.9    253793.2   126164.3   349513.9   349703.7   619779.0
#>  [8,]    730902.6    273917.0   271673.4   508313.3   462283.0   858915.7
#>  [9,]    391974.2    120752.7   204075.2   342303.6   277414.0   268319.3
#> [10,]    418305.6    392656.0   269403.0   459794.3   328602.5   388609.5
#>             [,7]        [,8]       [,9]      [,10]
#>  [1,]   513821.9    730902.6   391974.2   418305.6
#>  [2,]   253793.2    273917.0   120752.7   392656.0
#>  [3,]   126164.3    271673.4   204075.2   269403.0
#>  [4,]   349513.9    508313.3   342303.6   459794.3
#>  [5,]   349703.7    462283.0   277414.0   328602.5
#>  [6,]   619779.0    858915.7   268319.3   388609.5
#>  [7,] 70048053.6    769248.7   232239.8   386812.2
#>  [8,]   769248.7 102768338.4   384988.2   613045.5
#>  [9,]   232239.8    384988.2 74246551.9   407908.0
#> [10,]   386812.2    613045.5   407908.0 82833323.4
#>  [1] 0.000000000 0.002038533 0.001580672 0.001343644 0.001359750
#>  [6] 0.001656969 0.001184382 0.002106078 0.001390338 0.001586799
idx2 <- index(z2)
#>  [1] 320343.7 281543.3 246294.3 227888.3 213073.6 254150.9 204051.6
#>  [8] 302674.9 234725.4 253786.9
#>            [,1]        [,2]        [,3]        [,4]        [,5]      [,6]
#>  [1,] 527966414   2885803.3   2631034.9   1327200.0   2237573.3   4014470
#>  [2,]   2885803 456600470.2   2675733.8    833077.1    964487.8   1009988
#>  [3,]   2631035   2675733.8 358286374.8    896195.4   1029813.3    983174
#>  [4,]   1327200    833077.1    896195.4 301112897.3   1267267.1   1556051
#>  [5,]   2237573    964487.8   1029813.3   1267267.1 342600685.4   1379147
#>  [6,]   4014470   1009987.6    983174.0   1556051.0   1379146.7 372544972
#>  [7,]   2110715   1042550.3    518267.1   1435758.8   1436538.5   2545974
#>  [8,]   3002455   1125216.4   1116000.1   2088086.6   1899000.1   3528317
#>  [9,]   1610180    496036.8    838314.9   1406139.9   1139581.6   1102222
#> [10,]   1718346   1612981.2   1106673.5   1888777.0   1349857.6   1596359
#>              [,7]      [,8]        [,9]     [,10]
#>  [1,]   2110715.3   3002455   1610180.5   1718346
#>  [2,]   1042550.3   1125216    496036.8   1612981
#>  [3,]    518267.1   1116000    838314.9   1106674
#>  [4,]   1435758.8   2088087   1406139.9   1888777
#>  [5,]   1436538.5   1899000   1139581.6   1349858
#>  [6,]   2545973.5   3528317   1102221.8   1596359
#>  [7,] 287748535.3   3159977    954011.8   1588976
#>  [8,]   3159976.5 422159323   1581482.9   2518313
#>  [9,]    954011.8   1581483 304995434.8   1675635
#> [10,]   1588975.5   2518313   1675634.6 340268805
#>  [1] 0.000000000 0.008374035 0.006493202 0.005519519 0.005585679
#>  [6] 0.006806620 0.004865293 0.008651501 0.005711334 0.006518371
plot(idx1, idx2, names=c("constrained","unconstrained"))

Where it is clear that the standard errors for the constrained overdispersion run are considerable smaller.