aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorKen Kellner <ken@kenkellner.com>2023-03-07 09:21:28 -0500
committerKen Kellner <ken@kenkellner.com>2023-03-07 09:21:28 -0500
commitaf3942cfdc289b8dedc3df176549b13c36dab23d (patch)
treec61faac56c983038018220426641d48feda1f0d2
parent267f82f8735bb3a73a9a5be0402484da0b59daf3 (diff)
parent8bf6bf43ca45808a5839e091534c6b4a4b494741 (diff)
Merge remote-tracking branch 'upstream/master' into plotMarginal
-rw-r--r--.Rbuildignore5
-rw-r--r--.github/workflows/build-mac-binary.yaml51
-rw-r--r--DESCRIPTION28
-rw-r--r--NAMESPACE17
-rw-r--r--NEWS162
-rw-r--r--NEWS.md121
-rw-r--r--R/boot.R149
-rw-r--r--R/distsampOpen.R14
-rw-r--r--R/gdistremoval.R77
-rw-r--r--R/getDesign.R11
-rw-r--r--R/mixedModelTools.R83
-rw-r--r--R/multinomPois.R5
-rw-r--r--R/multmixOpen.R5
-rw-r--r--R/nmixTTD.R9
-rw-r--r--R/occu.R5
-rw-r--r--R/occuMS.R4
-rw-r--r--R/occuMulti.R10
-rw-r--r--R/pcount.R5
-rw-r--r--R/power.R438
-rw-r--r--R/predict.R948
-rw-r--r--R/ranef.R32
-rw-r--r--R/simulate.R558
-rw-r--r--R/unmarkedCrossVal.R10
-rw-r--r--R/unmarkedFit.R2060
-rw-r--r--R/unmarkedFitList.R6
-rw-r--r--R/unmarkedFrame.R79
-rw-r--r--R/utils.R25
-rw-r--r--R/zzz.R1
-rw-r--r--README.Rmd86
-rw-r--r--README.md168
-rw-r--r--_pkgdown.yml61
-rw-r--r--data/MesoCarnivores.rdabin0 -> 28948 bytes
-rw-r--r--inst/shinyPower/server.R141
-rw-r--r--inst/shinyPower/ui.R51
-rw-r--r--inst/unitTests/runTests.R99
-rw-r--r--inst/unitTests/runit.colext.R105
-rw-r--r--inst/unitTests/runit.crossVal.R86
-rw-r--r--inst/unitTests/runit.distsamp.r201
-rw-r--r--inst/unitTests/runit.format.R43
-rw-r--r--inst/unitTests/runit.gmultmix.R88
-rw-r--r--inst/unitTests/runit.gpcount.R30
-rw-r--r--inst/unitTests/runit.modSel.R62
-rw-r--r--inst/unitTests/runit.multinomPois.R140
-rw-r--r--inst/unitTests/runit.occu.R326
-rw-r--r--inst/unitTests/runit.occuPEN.R160
-rw-r--r--inst/unitTests/runit.occuRN.R77
-rw-r--r--inst/unitTests/runit.parboot.R266
-rw-r--r--inst/unitTests/runit.pcount.R137
-rw-r--r--inst/unitTests/runit.pifun.R123
-rw-r--r--inst/unitTests/runit.predict.R193
-rw-r--r--inst/unitTests/runit.ranef.R618
-rw-r--r--inst/unitTests/runit.simulate.R52
-rw-r--r--inst/unitTests/runit.unmarkedFrame.R197
-rw-r--r--inst/unitTests/runit.unmarkedMultFrame.R294
-rw-r--r--inst/unitTests/sim.colext.R253
-rw-r--r--inst/unitTests/sim.distsamp.R383
-rw-r--r--inst/unitTests/sim.distsampOpen.R129
-rw-r--r--inst/unitTests/sim.gdistsamp.R404
-rw-r--r--inst/unitTests/sim.gmultmix.R375
-rw-r--r--inst/unitTests/sim.gpcount.R149
-rw-r--r--inst/unitTests/sim.pcount.R58
-rw-r--r--inst/unitTests/sim.pcountOpen.r987
-rw-r--r--inst/unitTests/sim.ranef.R518
-rw-r--r--man/MesoCarnivores.Rd41
-rw-r--r--man/Switzerland.Rd1
-rw-r--r--man/crossVal.Rd5
-rw-r--r--man/cruz.Rd3
-rw-r--r--man/fitted-methods.Rd3
-rw-r--r--man/formatDistData.Rd2
-rw-r--r--man/gdistremoval.Rd7
-rw-r--r--man/nonparboot-methods.Rd2
-rw-r--r--man/parboot.Rd12
-rw-r--r--man/powerAnalysis.Rd105
-rw-r--r--man/ranef-methods.Rd3
-rw-r--r--man/shinyPower.Rd16
-rw-r--r--man/simulate-methods.Rd91
-rw-r--r--man/unmarkedFit-class.Rd2
-rw-r--r--man/unmarkedFrame-class.Rd2
-rw-r--r--man/unmarkedFrameGDR.Rd6
-rw-r--r--man/unmarkedPower-class.Rd63
-rw-r--r--man/unmarkedPowerList.Rd95
-rw-r--r--src/RcppExports.cpp4
-rw-r--r--src/TMB/compile.R1
-rw-r--r--src/TMB/tmb_distsamp.hpp3
-rw-r--r--src/TMB/tmb_gdistremoval.hpp4
-rw-r--r--src/TMB/tmb_keyfun.hpp22
-rw-r--r--src/TMB/tmb_multinomPois.hpp2
-rw-r--r--src/TMB/tmb_occu.hpp3
-rw-r--r--src/TMB/tmb_pcount.hpp4
-rw-r--r--src/TMB/tmb_utils.hpp2
-rw-r--r--src/TMB/unmarked_TMBExports.cpp2
-rw-r--r--src/distprob.cpp36
-rw-r--r--src/nll_distsamp.cpp4
-rw-r--r--src/nll_gdistremoval.cpp2
-rw-r--r--src/nll_multmixOpen.cpp5
-rw-r--r--src/nll_multmixOpen.h2
-rw-r--r--tests/testthat.R3
-rw-r--r--tests/testthat/test_colext.R140
-rw-r--r--tests/testthat/test_crossVal.R90
-rw-r--r--tests/testthat/test_distsamp.R311
-rw-r--r--tests/testthat/test_distsampOpen.R (renamed from inst/unitTests/runit.distsampOpen.R)215
-rw-r--r--tests/testthat/test_fitList.R41
-rw-r--r--tests/testthat/test_formatInputs.R (renamed from inst/unitTests/runit.utils.R)153
-rw-r--r--tests/testthat/test_gdistremoval.R (renamed from inst/unitTests/runit.gdistremoval.R)198
-rw-r--r--tests/testthat/test_gdistsamp.R (renamed from inst/unitTests/runit.gdistsamp.R)400
-rw-r--r--tests/testthat/test_gmultmix.R289
-rw-r--r--tests/testthat/test_gpcount.R119
-rw-r--r--tests/testthat/test_linearComb.R35
-rw-r--r--tests/testthat/test_makePiFun.R69
-rw-r--r--tests/testthat/test_modSel.R65
-rw-r--r--tests/testthat/test_multinomPois.R262
-rw-r--r--tests/testthat/test_multmixOpen.R (renamed from inst/unitTests/runit.multmixOpen.R)92
-rw-r--r--tests/testthat/test_nmixTTD.R (renamed from inst/unitTests/runit.nmixTTD.R)126
-rw-r--r--tests/testthat/test_nonparboot.R (renamed from inst/unitTests/runit.nonparboot.R)45
-rw-r--r--tests/testthat/test_occu.R404
-rw-r--r--tests/testthat/test_occuFP.R (renamed from inst/unitTests/runit.occuFP.R)19
-rw-r--r--tests/testthat/test_occuMS.R (renamed from inst/unitTests/runit.occuMS.R)342
-rw-r--r--tests/testthat/test_occuMulti.R (renamed from inst/unitTests/runit.occuMulti.R)374
-rw-r--r--tests/testthat/test_occuPEN.R164
-rw-r--r--tests/testthat/test_occuRN.R93
-rw-r--r--tests/testthat/test_occuTTD.R (renamed from inst/unitTests/runit.occuTTD.R)266
-rw-r--r--tests/testthat/test_parboot.R102
-rw-r--r--tests/testthat/test_pcount.R212
-rw-r--r--tests/testthat/test_pcount.spHDS.R (renamed from inst/unitTests/runit.pcount.spHDS.R)13
-rw-r--r--tests/testthat/test_pcountOpen.R (renamed from inst/unitTests/runit.pcountOpen.R)250
-rw-r--r--tests/testthat/test_plotMarginal.R (renamed from inst/unitTests/runit.plotMarginal.R)21
-rw-r--r--tests/testthat/test_powerAnalysis.R127
-rw-r--r--tests/testthat/test_predict.R140
-rw-r--r--tests/testthat/test_ranef_predict.R89
-rw-r--r--tests/testthat/test_simulate.R199
-rw-r--r--tests/testthat/test_unmarkedFrame.R217
-rw-r--r--tests/testthat/test_utils.R32
-rw-r--r--tests/testthat/test_vif.R (renamed from inst/unitTests/runit.vif.R)33
-rw-r--r--vignettes/README.txt13
-rw-r--r--vignettes/cap-recap.Rmd (renamed from vignettes/cap-recap.Rnw)565
-rw-r--r--vignettes/colext-cov.pdfbin6443 -> 0 bytes
-rw-r--r--vignettes/colext-data-1.pngbin0 -> 15926 bytes
-rw-r--r--vignettes/colext-est-1.pngbin0 -> 20660 bytes
-rw-r--r--vignettes/colext-gof-1.pngbin0 -> 3713 bytes
-rw-r--r--vignettes/colext-gof.pdfbin4378 -> 0 bytes
-rw-r--r--vignettes/colext-pred-1.pngbin0 -> 6248 bytes
-rw-r--r--vignettes/colext-sim.pdfbin5084 -> 0 bytes
-rw-r--r--vignettes/colext-yearlysim.pdfbin6829 -> 0 bytes
-rw-r--r--vignettes/colext.Rmd (renamed from vignettes/colext.Rnw)1220
-rw-r--r--vignettes/colext.Rmd.orig873
-rw-r--r--vignettes/distsamp.Rmd (renamed from vignettes/distsamp.Rnw)317
-rw-r--r--vignettes/ecology.bst1460
-rw-r--r--vignettes/ecology.csl188
-rw-r--r--vignettes/figures/poweranalysis-acfl-1.pngbin0 -> 15254 bytes
-rw-r--r--vignettes/figures/poweranalysis-acfl-2.pngbin0 -> 15030 bytes
-rwxr-xr-xvignettes/figures/poweranalysis-alpha.pngbin0 -> 5565 bytes
-rw-r--r--vignettes/figures/poweranalysis-effectsizes.pngbin0 -> 13945 bytes
-rw-r--r--vignettes/figures/poweranalysis-list-1.pngbin0 -> 17491 bytes
-rwxr-xr-xvignettes/figures/poweranalysis-modinfo.pngbin0 -> 5269 bytes
-rwxr-xr-xvignettes/figures/poweranalysis-nulls.pngbin0 -> 11175 bytes
-rwxr-xr-xvignettes/figures/poweranalysis-run.pngbin0 -> 1913 bytes
-rwxr-xr-xvignettes/figures/poweranalysis-scenarios.pngbin0 -> 9995 bytes
-rwxr-xr-xvignettes/figures/poweranalysis-summaryplot.pngbin0 -> 23021 bytes
-rwxr-xr-xvignettes/figures/poweranalysis-summarytable.pngbin0 -> 43549 bytes
-rw-r--r--vignettes/occuMulti.Rmd521
-rw-r--r--vignettes/powerAnalysis.Rmd928
-rw-r--r--vignettes/powerAnalysis.Rmd.orig618
-rw-r--r--vignettes/simulate.Rmd274
-rw-r--r--vignettes/spp-dist-psi2.pdfbin82492 -> 0 bytes
-rw-r--r--vignettes/spp-dist.Rmd (renamed from vignettes/spp-dist.Rnw)336
-rw-r--r--vignettes/unmarked.Rmd (renamed from vignettes/unmarked.Rnw)245
-rw-r--r--vignettes/unmarked.bib154
167 files changed, 12755 insertions, 13240 deletions
diff --git a/.Rbuildignore b/.Rbuildignore
index 5bb2f1a..70e8958 100644
--- a/.Rbuildignore
+++ b/.Rbuildignore
@@ -7,5 +7,8 @@
.Rhistory
[.].Rhistory
README.md
-
+README.Rmd
+^tests/testthat/_snaps$
^\.github$
+^_pkgdown\.yml$
+^vignettes/colext.Rmd.orig
diff --git a/.github/workflows/build-mac-binary.yaml b/.github/workflows/build-mac-binary.yaml
new file mode 100644
index 0000000..bfab295
--- /dev/null
+++ b/.github/workflows/build-mac-binary.yaml
@@ -0,0 +1,51 @@
+on:
+ workflow_dispatch:
+
+name: build-mac-binary
+
+jobs:
+ build-mac-binary:
+ runs-on: macOS-latest
+ env:
+ GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
+ steps:
+ - uses: actions/checkout@v2
+
+ - uses: r-lib/actions/setup-r@v1
+
+ - uses: r-lib/actions/setup-pandoc@v1
+
+ - name: Query dependencies
+ run: |
+ install.packages('remotes')
+ saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2)
+ writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version")
+ shell: Rscript {0}
+
+ - name: Cache R packages
+ uses: actions/cache@v2
+ with:
+ path: ${{ env.R_LIBS_USER }}
+ key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }}
+ restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-
+
+ - name: Install dependencies
+ run: |
+ install.packages(c("remotes"))
+ remotes::install_deps(dependencies = TRUE)
+ remotes::install_cran("pkgbuild")
+ shell: Rscript {0}
+
+ - name: Build Mac binary
+ run: pkgbuild::build(binary=TRUE, dest_path=".")
+ shell: Rscript {0}
+
+ - name: Get binary name
+ id: getfilename
+ run: echo "::set-output name=file::$(ls *.tgz)"
+
+ - name: Upload binary
+ uses: actions/upload-artifact@v1
+ with:
+ name: ${{ steps.getfilename.outputs.file }}
+ path: ${{ steps.getfilename.outputs.file }}
diff --git a/DESCRIPTION b/DESCRIPTION
index 02f2d79..cabf60b 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,14 +1,14 @@
Package: unmarked
-Version: 1.1.1.9008
-Date: 2021-08-20
+Version: 1.2.5.9010
+Date: 2022-12-29
Type: Package
Title: Models for Data from Unmarked Animals
Authors@R: c(
person("Richard", "Chandler", role="aut"),
- person("Ken", "Kellner", role="aut"),
+ person("Ken", "Kellner", email="contact@kenkellner.com", role=c("cre", "aut")),
person("Ian", "Fiske", role="aut"),
person("David", "Miller", role="aut"),
- person("Andy", "Royle", email="aroyle@usgs.gov", role=c("cre", "aut")),
+ person("Andy", "Royle", role="aut"),
person("Jeff", "Hostetler", role="aut"),
person("Rebecca", "Hutchinson", role="aut"),
person("Adam", "Smith", role="aut"),
@@ -18,21 +18,22 @@ Authors@R: c(
person("Ariel", "Muldoon", role="ctb"),
person("Chris", "Baker", role="ctb")
)
-Depends: R (>= 2.12.0), methods, lattice
+Depends: R (>= 2.12.0)
Imports:
graphics,
+ lattice,
lme4,
MASS,
Matrix,
+ methods,
parallel,
pbapply,
- plyr,
- raster,
Rcpp (>= 0.8.0),
stats,
TMB (>= 1.7.18),
utils
-Description: Fits hierarchical models of animal abundance and occurrence to data collected using survey methods such as point counts, site occupancy sampling, distance sampling, removal sampling, and double observer sampling. Parameters governing the state and observation processes can be modeled as functions of covariates.
+Suggests: knitr, rmarkdown, pkgdown, raster, shiny, testthat
+Description: Fits hierarchical models of animal abundance and occurrence to data collected using survey methods such as point counts, site occupancy sampling, distance sampling, removal sampling, and double observer sampling. Parameters governing the state and observation processes can be modeled as functions of covariates. Reference: Fiske and Chandler (2011) <doi:10.18637/jss.v043.i10>.
License: GPL (>=3)
LazyLoad: yes
LazyData: yes
@@ -44,18 +45,23 @@ Collate: 'classes.R' 'unmarkedEstimate.R' 'mapInfo.R' 'unmarkedFrame.R'
'occuMS.R' 'occuTTD.R' 'distsampOpen.R' 'multmixOpen.R'
'unmarkedCrossVal.R' 'piFun.R' 'vif.R' 'makePiFun.R' 'posteriorSamples.R'
'nmixTTD.R'
- 'mixedModelTools.R'
'gdistremoval.R'
'plotMarginal.R'
+ 'mixedModelTools.R'
+ 'power.R'
+ 'simulate.R'
+ 'predict.R'
'RcppExports.R'
+ 'zzz.R'
LinkingTo:
Rcpp,
RcppArmadillo,
TMB,
RcppEigen
SystemRequirements: GNU make
-URL: http://groups.google.com/d/forum/unmarked,
- https://sites.google.com/site/unmarkedinfo/home,
+URL: https://groups.google.com/d/forum/unmarked,
+ https://rbchan.github.io/unmarked/,
https://github.com/ianfiske/unmarked,
https://github.com/rbchan/unmarked
BugReports: https://github.com/rbchan/unmarked/issues
+VignetteBuilder: knitr
diff --git a/NAMESPACE b/NAMESPACE
index 57dbaa9..34a99c6 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -9,18 +9,17 @@ importFrom(stats, confint, fitted, coef, vcov, predict, update, profile,
update.formula, sigma)
importFrom(graphics, plot, hist, abline, axis, lines, points, polygon, segments)
importFrom(utils, head, read.csv)
-importFrom(plyr, ldply, alply, ddply)
-importFrom(grDevices, devAskNewPage, dev.interactive)
-importFrom(raster, raster, stack, extent, "extent<-", getValues)
+importFrom(grDevices, devAskNewPage, dev.interactive, palette.colors)
importFrom(MASS, mvrnorm)
importFrom(parallel, detectCores, makeCluster, stopCluster, clusterExport,
clusterEvalQ)
importFrom(methods, is, as, new, show, slot, .hasSlot, callGeneric,
- callNextMethod)
+ callNextMethod, setMethod)
importFrom(lattice, xyplot, levelplot)
importFrom(Rcpp, evalCpp)
importFrom(pbapply, pbsapply, pblapply)
+
# Fitting functions
export(occu, occuFP, occuRN, pcount, pcountOpen, multinomPois, distsamp,
colext, gmultmix, gdistsamp, gpcount, occuPEN, occuPEN_CV, occuMulti,
@@ -41,7 +40,7 @@ exportClasses(unmarkedFit, unmarkedFitOccu, unmarkedFitOccuFP, unmarkedFitDS,
unmarkedFrameGPC, unmarkedEstimate, unmarkedFitList,
unmarkedModSel, unmarkedRanef, unmarkedFrameOccuMulti,
unmarkedFrameOccuMS, unmarkedFrameGDR, unmarkedCrossVal,
- unmarkedPostSamples)
+ unmarkedPostSamples, unmarkedPower, unmarkedPowerList)
# Methods
exportMethods(backTransform, coef, confint, coordinates, fitted, getData,
@@ -51,9 +50,8 @@ exportMethods(backTransform, coef, confint, coordinates, fitted, getData,
projection, residuals, sampleSize, SE, show, simulate, siteCovs,
"siteCovs<-", summary, update, vcov, yearlySiteCovs,
"yearlySiteCovs<-", "[", smoothed, projected, nonparboot, logLik,
- LRT, ranef, bup, crossVal, posteriorSamples, sigma, randomTerms,
- optimizePenalty, plotMarginalData, plotMarginal)
-
+ LRT, ranef, bup, crossVal, posteriorSamples, sigma, randomTerms,
+ optimizePenalty, unmarkedPowerList, plotMarginalData, plotMarginal)
S3method("print", "unmarkedPostSamples")
@@ -70,7 +68,8 @@ export(csvToUMF, formatLong, formatWide, formatMult, formatDistData)
# Misc
export(imputeMissing, gxhn, gxexp, gxhaz, dxhn, dxexp, dxhaz, drhn, drexp,
- drhaz, grhn, grexp, grhaz, sight2perpdist, lambda2psi, SSE, vif)
+ drhaz, grhn, grexp, grhaz, sight2perpdist, lambda2psi, SSE, vif, powerAnalysis,
+ shinyPower)
useDynLib("unmarked", .registration=TRUE)
useDynLib(unmarked_TMBExports)
diff --git a/NEWS b/NEWS
deleted file mode 100644
index 2846ca6..0000000
--- a/NEWS
+++ /dev/null
@@ -1,162 +0,0 @@
-All changes can be found here:
-https://github.com/rbchan/unmarked/commits/master.
-The following is just a summary.
-
-Version 1.1.1
- o Fix address sanitizer problems with multmixOpen
-
-Version 1.1.0
- o Add nmixTTD fitting function
- o Add experimental random effects support and TMB engine to occu and pcount
- o Add openMP support to some fitting functions (occuRN, gdistsamp, gmultmix, gpcount) for calculating likelihood in parallel
- o Define STRICT_R_HEADERS in C++ code for compatibility with future Rcpp update
- o Many bugfixes mainly related to predict()
-
-Version 1.0.1
- o Fix LTO mismatches
- o Automatically convert characters to factors in unmarkedFrames
- o Many bugfixes, mainly related to predict()
-
-Version 1.0.0
-
- o New functions 'distsampOpen' and 'multmixOpen' - open population versions of distsamp/gdistsamp and multinomPois/gmultmix
- o Add 'predict' method for output from 'ranef', for generating posterior samples of the random effects and running a function on them
- o Predict now correctly handles formulas containing functions and newdata with invalid factor levels
- o Remove reshape2 dependency
- o Bugfixes
-
-Version 0.13-1.9000
-
- o New 'makePiFun' function factories added to generate piFuns with required defaults
-
- o 'plot' method for parboot now only "ask"s for new page when screen device is in use; restores former "ask" setting on exit.
-
-Version 0.13-1
-
- o Fixes for compatibility with R 4.0
-
-
-Version 0.13-0
-
- o New 'occuMS' function added for fitting multi-state occupancy models (single-season and dynamic)
- o New 'occuTTD' function for fitting continuous time-to-detection occupancy models (single season and dynamic). Thanks to Jonathan Cohen for help with this
- o New 'crossVal' function for doing cross-validation on fitted unmarked models and fitLists
- o New 'vif' function for calculating variance inflation factors for fitted unmarked models
- o Add ability to use complimentary-log-log link function in occu
- o Add built-in dependent double observer pi function
- o New C++ engines for gmultmix, gdistsamp, multinomPois, occuRN
- o Approximate integrals in C++ engines with trapezoidal rule function instead of using Rdqags
- o Misc minor bugfixes
-
-
-Version 0.12-3
-
- o New 'occuMulti' function added by Ken Kellner
-
-
-Version 0.12-0
-
- o Fixed mistake in turnover calculations in colext vignette (thanks
- to Giacomo Tavecchia)
-
- o added pcount.spHDS from AHM book.
-
- o updated predict method for pcount to include ZIP model
-
- o Adam Smith added some parallel capabilities to the parboot functionality
-
- o Adam Smith fixed formatMult conversion of julian date to factor
-
- o Auriel Fournier fixed formatDistData to pad data with NA
-
- o fixed error in obsToY for custom pi function
-
-
-Version 0.11-0
-
- o Andy Royle is the new maintainer
-
- o Added Rebecca Hutchinson's penalized likelihood function occuPEN
- (experimental)
-
- o fixed bug in gmultmix to accommodate mixed sampling protocols (NA
- in count frequency vector is not counted in the constraint that
- multinomial cell probabilities sum to 1)
-
- o Changed variable 'ufp' to 'ufc' in ovenbird data and related functions.
-
- o Removed constraint in pcountOpen that lambdaformula==omegaformula
-
- o Fixed bug in gdistsamp that caused error when NAs were present in
- half-normal model
-
- o Fixed bug in ranef (it was giving an error message for pcountOpen with the
- new dynamics options (Ricker and Gompertz) and working incorrectly for
- pcountOpen with immigration)
-
- o Fixed bug in pcountOpen that occurred when covariates were time
- varying but not varying among sites
-
-
-Version 0.10-6
-
- o Fixed bug in C++ code that was causing problems on Solaris
-
-
-Version 0.10-5
-
- o Added new models of population dynamics to pcountOpen. Most
- changes contributed by Jeff Hostetler.
-
-
-Version 0.10-4
-
- o Added importFrom("plyr", "ldply") to NAMESPACE because "reshape" no longer
- depends on "plyr"
-
-
-Version 0.10-3
-
- o RcppArmadillo was moved from "Depends" section of DESCRIPTION file to
- "LinkingTo"
-
-
-Version 0.10-2
-
- Bug fixes
-
- o Thanks for Dirk Eddelbuettel for patch to deal with change in Armadillo's
- in-place reshape function. Serious problems might occur if you use a recent
- version of RcppArmadillo and an old version of unmarked.
-
- o Dave Miller added another NA handling fix in occuFP(). I forgot to add
- this one in the previous version.
-
-
-Version 0.10-1
-
- o Doc fixes requested by CRAN
-
-
-Version 0.10-0
-
- Bug fixes
-
- o Fixed NA handling in occuFP()
-
- o Fixed integration setting in C++ code that were causing segfaults
- when calling distsamp
-
- o Replace raster:::layerNames() with raster:::names()
-
-
- New features
-
- o distsamp() and gdistsamp() should be faster and more stable for
- some keyfun/survey combinations
-
-
-
-Version 0.12-0
-
-
diff --git a/NEWS.md b/NEWS.md
new file mode 100644
index 0000000..314f645
--- /dev/null
+++ b/NEWS.md
@@ -0,0 +1,121 @@
+# unmarked 1.2.4
+
+* Convert vignettes to use rmarkdown
+* Handle suggested packages in vignettes
+* Remove occuMulti vignette due to AHMbook being temporarily off CRAN
+
+# unmarked 1.2.3
+
+* Add gdistremoval function to fit distance/removal models, see Amundson et al. 2014
+* Add power analysis tools (powerAnalysis)
+* Simulate datasets from scratch for any model type using simulate()
+* Add penalized likelihood option to occuMulti, see Clipp et al. 2021
+* Experimental random effects support for distsamp, multinomPois, and gdistremoval using TMB
+* Improvements to predict() speed and better error messages
+* Add vignettes for occuMulti, power analysis, simulation, and random effects
+* Overhaul package tests and move to testthat
+* New package website using pkgdown
+* Move raster package from imports to suggests
+* Fix assorted compilation warnings with newer versions of compilers on CRAN
+* Remove call in TMB code to deprecated DOUBLE_XMIN
+* Many bugfixes
+
+# unmarked 1.1.1
+
+* Fix address sanitizer problems with multmixOpen
+
+# unmarked 1.1.0
+
+* Add nmixTTD fitting function
+* Add experimental random effects support and TMB engine to occu and pcount
+* Add openMP support to some fitting functions (occuRN, gdistsamp, gmultmix, gpcount) for calculating likelihood in parallel
+* Define STRICT_R_HEADERS in C++ code for compatibility with future Rcpp update
+* Many bugfixes mainly related to predict()
+
+# unmarked 1.0.1
+
+* Fix LTO mismatches
+* Automatically convert characters to factors in unmarkedFrames
+* Many bugfixes, mainly related to predict()
+
+# unmarked 1.0.0
+
+* New functions 'distsampOpen' and 'multmixOpen' - open population versions of distsamp/gdistsamp and multinomPois/gmultmix
+* Add 'predict' method for output from 'ranef', for generating posterior samples of the random effects and running a function on them
+* Predict now correctly handles formulas containing functions and newdata with invalid factor levels
+* Remove reshape2 dependency
+* Bugfixes
+
+# unmarked 0.13-1
+
+* Fixes for compatibility with R 4.0
+
+# unmarked 0.13-0
+
+* New 'occuMS' function added for fitting multi-state occupancy models (single-season and dynamic)
+* New 'occuTTD' function for fitting continuous time-to-detection occupancy models (single season and dynamic). Thanks to Jonathan Cohen for help with this
+* New 'crossVal' function for doing cross-validation on fitted unmarked models and fitLists
+* New 'vif' function for calculating variance inflation factors for fitted unmarked models
+* Add ability to use complimentary-log-log link function in occu
+* Add built-in dependent double observer pi function
+* New C++ engines for gmultmix, gdistsamp, multinomPois, occuRN
+* Approximate integrals in C++ engines with trapezoidal rule function instead of using Rdqags
+* Misc minor bugfixes
+
+
+# unmarked 0.12-3
+
+* New 'occuMulti' function added by Ken Kellner
+
+# unmarked 0.12-0
+
+* Fixed mistake in turnover calculations in colext vignette (thanks to Giacomo Tavecchia)
+* added pcount.spHDS from AHM book.
+* updated predict method for pcount to include ZIP model
+* Adam Smith added some parallel capabilities to the parboot functionality
+* Adam Smith fixed formatMult conversion of julian date to factor
+* Auriel Fournier fixed formatDistData to pad data with NA
+* fixed error in obsToY for custom pi function
+
+# unmarked 0.11-0
+
+* Andy Royle is the new maintainer
+* Added Rebecca Hutchinson's penalized likelihood function occuPEN (experimental)
+* fixed bug in gmultmix to accommodate mixed sampling protocols (NA in count frequency vector is not counted in the constraint that multinomial cell probabilities sum to 1)
+* Changed variable 'ufp' to 'ufc' in ovenbird data and related functions.
+* Removed constraint in pcountOpen that lambdaformula==omegaformula
+* Fixed bug in gdistsamp that caused error when NAs were present in half-normal model
+* Fixed bug in ranef (it was giving an error message for pcountOpen with the new dynamics options (Ricker and Gompertz) and working incorrectly for pcountOpen with immigration)
+* Fixed bug in pcountOpen that occurred when covariates were time varying but not varying among sites
+
+# unmarked 0.10-6
+
+* Fixed bug in C++ code that was causing problems on Solaris
+
+# unmarked 0.10-5
+
+* Added new models of population dynamics to pcountOpen. Most changes contributed by Jeff Hostetler.
+
+# unmarked 0.10-4
+
+* Added importFrom("plyr", "ldply") to NAMESPACE because "reshape" no longer depends on "plyr"
+
+# unmarked 0.10-3
+
+* RcppArmadillo was moved from "Depends" section of DESCRIPTION file to "LinkingTo"
+
+# unmarked 0.10-2
+
+* Thanks for Dirk Eddelbuettel for patch to deal with change in Armadillo's in-place reshape function. Serious problems might occur if you use a recent version of RcppArmadillo and an old version of unmarked.
+* Dave Miller added another NA handling fix in occuFP(). I forgot to add this one in the previous version.
+
+# unmarked 0.10-1
+
+* Doc fixes requested by CRAN
+
+# unmarked 0.10-0
+
+* Fixed NA handling in occuFP()
+* Fixed integration setting in C++ code that were causing segfaults when calling distsamp
+* Replace raster:::layerNames() with raster:::names()
+* distsamp() and gdistsamp() should be faster and more stable for some keyfun/survey combinations
diff --git a/R/boot.R b/R/boot.R
index d6c9862..2f8cffc 100644
--- a/R/boot.R
+++ b/R/boot.R
@@ -30,81 +30,66 @@ setMethod("replaceY", "unmarkedFrameOccuMulti",
object
})
-setMethod("parboot", "unmarkedFit",
- function(object, statistic=SSE, nsim=10, report, seed = NULL, parallel = TRUE, ncores, ...)
-{
- dots <- list(...)
- statistic <- match.fun(statistic)
- call <- match.call(call = sys.call(-1))
- formula <- object@formula
- umf <- getData(object)
- y <- getY(object)
- ests <- as.numeric(coef(object))
- starts <- ests
- if(methods::.hasSlot(object, "TMB") && !is.null(object@TMB)) starts <- NULL
- t0 <- statistic(object, ...)
- lt0 <- length(t0)
- t.star <- matrix(NA, nsim, lt0)
- if(!missing(report))
- cat("t0 =", t0, "\n")
- simdata <- umf
- if (!is.null(seed)) set.seed(seed)
- simList <- simulate(object, nsim = nsim, na.rm = FALSE)
- availcores <- detectCores()
- if(missing(ncores)) ncores <- availcores - 1
- if(ncores > availcores) ncores <- availcores
-
- no_par <- ncores < 2 || nsim < 100 || !parallel
-
- if (no_par) {
- if (!missing(report)) {
- for(i in 1:nsim) {
- simdata <- replaceY(simdata, simList[[i]])
- fit <- update(object, data=simdata, starts=starts, se=FALSE)
- t.star[i,] <- statistic(fit, ...)
- if(!missing(report)) {
- if (nsim > report && i %in% seq(report, nsim, by=report))
- cat("iter", i, ": ", t.star[i, ], "\n")
- }
- }
- } else {
- t.star <- pbsapply(1:nsim, function(i) {
- simdata <- replaceY(simdata, simList[[i]])
- fit <- update(object, data=simdata, starts=starts, se=FALSE)
- t.star.tmp <- statistic(fit, ...)
- })
- if (lt0 > 1)
- t.star <- t(t.star)
- else
- t.star <- matrix(t.star, ncol = lt0)
- }
- } else {
- message("Running parametric bootstrap in parallel on ", ncores, " cores.")
- if (!missing(report)) message("Bootstrapped statistics not reported during parallel processing.")
- cl <- makeCluster(ncores)
- if (!is.null(seed)) parallel::clusterSetRNGStream(cl, iseed = seed)
- on.exit(stopCluster(cl))
- varList <- c("simList", "y", "object", "simdata", "starts", "statistic", "dots")
- # If call formula is an object, include it too
- fm.nms <- all.names(object@call)
- if (!any(grepl("~", fm.nms))) varList <- c(varList, fm.nms[2])
- ## Hack to get piFun for unmarkedFitGMM and unmarkedFitMPois
- if(.hasSlot(umf, "piFun")) varList <- c(varList, umf@piFun)
- clusterExport(cl, varList, envir = environment())
- clusterEvalQ(cl, library(unmarked))
- clusterEvalQ(cl, list2env(dots))
- t.star.parallel <- pblapply(1:nsim, function(i) {
- simdata <- replaceY(simdata, simList[[i]])
- fit <- update(object, data = simdata, starts = starts, se = FALSE)
- t.star <- statistic(fit, ...)
- }, cl = cl)
- t.star <- matrix(unlist(t.star.parallel), nrow = length(t.star.parallel), byrow = TRUE)
- }
- if (!is.null(names(t0)))
- colnames(t.star) <- names(t0)
- else colnames(t.star) <- paste("t*", 1:lt0, sep="")
- out <- new("parboot", call = call, t0 = t0, t.star = t.star)
- return(out)
+
+setMethod("parboot", "unmarkedFit", function(object, statistic=SSE, nsim=10,
+ report, seed = NULL, parallel = FALSE, ncores, ...){
+
+ if(!missing(report)){
+ warning("report argument is non-functional and will be deprecated in the next version", call.=FALSE)
+ }
+
+ dots <- list(...)
+ call <- match.call(call = sys.call(-1))
+ stopifnot(is.function(statistic))
+ starts <- as.numeric(coef(object))
+ # Get rid of starting values if model was fit with TMB
+ if(methods::.hasSlot(object, "TMB") && !is.null(object@TMB)) starts <- NULL
+
+ t0 <- statistic(object, ...)
+
+ simList <- simulate(object, nsim = nsim, na.rm = FALSE)
+
+ availcores <- parallel::detectCores() - 1
+ if(missing(ncores) || ncores > availcores) ncores <- availcores
+
+ cl <- NULL
+ if(parallel){
+ cl <- parallel::makeCluster(ncores)
+ on.exit(parallel::stopCluster(cl))
+ parallel::clusterEvalQ(cl, library(unmarked))
+ env_vars <- c("dots", "replaceY")
+ fm.nms <- all.names(object@call)
+ if (!any(grepl("~", fm.nms))) env_vars <- c(env_vars, fm.nms[2])
+ if(.hasSlot(object@data, "piFun")) env_vars <- c(env_vars, object@data@piFun)
+ parallel::clusterExport(cl, env_vars, envir = environment())
+ parallel::clusterEvalQ(cl, list2env(dots))
+ }
+
+ run_sim <- function(x, object, statistic, starts, t0, ...){
+ simdata <- replaceY(object@data, x)
+ tryCatch({
+ #if(runif(1,0,1) < 0.5) stop("fail") # for testing error trapping
+ fit <- update(object, data=simdata, starts=starts, se=FALSE)
+ statistic(fit, ...)
+ }, error=function(e){
+ t0[] <- NA
+ t0
+ })
+ }
+
+ t.star <- t(pbapply::pbsapply(simList, run_sim, object=object,
+ statistic=statistic, starts=starts, t0=t0,
+ cl=cl, ...))
+ if(length(t0) == 1) t.star <- matrix(t.star, ncol=1)
+
+ failed <- apply(t.star, 1, function(x) any(is.na(x)))
+ if(sum(failed) > 0){
+ warning(paste0("Model fitting failed in ",sum(failed), " sims."), call.=FALSE)
+ t.star <- t.star[!failed,,drop=FALSE]
+ }
+
+ new("parboot", call = call, t0 = t0, t.star = t.star)
+
})
@@ -194,9 +179,7 @@ setMethod("nonparboot", "unmarkedFit",
data.b <- data[sites,]
y <- getY(data.b)
if (bsType == "both") {
- obs.per.site <- alply(y, 1, function(row) {
- which(!is.na(row))
- })
+ obs.per.site <- lapply(1:nrow(y), function(i) which(!is.na(y[i,])))
obs <- lapply(obs.per.site,
function(obs) sample(obs, replace = TRUE))
data.b <- data.b[obs]
@@ -281,7 +264,7 @@ setMethod("nonparboot", "unmarkedFitGDS",
-setMethod("nonparboot", "unmarkedFitPCO",
+setMethod("nonparboot", "unmarkedFitDailMadsen",
function(object, B = 0, keepOldSamples = TRUE, ...)
{
callNextMethod(object, B=B, keepOldSamples=keepOldSamples,
@@ -382,9 +365,7 @@ setMethod("nonparboot", "unmarkedFitOccuPEN",
data.b <- data[sites,]
y <- getY(data.b)
if (bsType == "both") {
- obs.per.site <- alply(y, 1, function(row) {
- which(!is.na(row))
- })
+ obs.per.site <- lapply(1:nrow(y), function(i) which(!is.na(y[i,])))
obs <- lapply(obs.per.site,
function(obs) sample(obs, replace = TRUE))
data.b <- data.b[obs]
@@ -440,9 +421,7 @@ setMethod("nonparboot", "unmarkedFitOccuPEN_CV",
data.b <- data[sites,]
y <- getY(data.b)
if (bsType == "both") {
- obs.per.site <- alply(y, 1, function(row) {
- which(!is.na(row))
- })
+ obs.per.site <- lapply(1:nrow(y), function(i) which(!is.na(y[i,])))
obs <- lapply(obs.per.site,
function(obs) sample(obs, replace = TRUE))
data.b <- data.b[obs]
diff --git a/R/distsampOpen.R b/R/distsampOpen.R
index 679e994..0f9f743 100644
--- a/R/distsampOpen.R
+++ b/R/distsampOpen.R
@@ -90,8 +90,18 @@ distsampOpen <- function(lambdaformula, gammaformula, omegaformula, pformula,
K <- max(y, na.rm=T) + 20
warning("K was not specified and was set to ", K, ".")
}
- if(K <= max(y, na.rm = TRUE))
- stop("specified K is too small. Try a value larger than any observation")
+
+ J <- ncol(data@y) / data@numPrimary
+ inds <- split(1:ncol(data@y), ceiling(1:ncol(data@y)/J))
+ Tobs <- sapply(1:length(inds), function(i){
+ rowSums(data@y[,inds[[i]], drop=FALSE], na.rm=TRUE)
+ })
+ Kmin <- max(Tobs, na.rm=TRUE)
+
+ if(K < Kmin){
+ stop("Specified K is too small, must be larger than the max total count in a primary period",
+ call.=FALSE)
+ }
k <- 0:K
lk <- length(k)
#Some k-related indices to avoid repeated calculations in likelihood
diff --git a/R/gdistremoval.R b/R/gdistremoval.R
index 7ed0e9a..dc91934 100644
--- a/R/gdistremoval.R
+++ b/R/gdistremoval.R
@@ -449,44 +449,6 @@ gdistremoval <- function(lambdaformula=~1, phiformula=~1, removalformula=~1,
# Methods
-setMethod("predict", "unmarkedFitGDR", function(object, type, newdata,
- level=0.95, re.form=NULL, ...){
-
- type <- match.arg(type, c("lambda", "phi", "rem", "dist"))
- nm <- switch(type, lambda="lam", phi="phi", rem="rem", dist="dist")
- est <- object[ifelse(nm=="lam","lambda",nm)]
-
- if(missing(newdata)){
- gd <- getDesign(object@data, object@formlist)
- X <- gd[[paste0("X",nm)]]
- Z <- gd[[paste0("Z",nm)]]
- if(is.null(re.form)) X <- cbind(X, Z)
- } else{
- if(!inherits(newdata, "data.frame")){
- stop("newdata must be a data frame")
- }
- gd <- getDesign(object@data, object@formlist, return.frames=TRUE)
- fname <- switch(type, lambda="lambda", phi="phi", rem="removal", dist="distance")
- covs <- switch(type, lambda="sc", phi="ysc", rem="oc", dist="ysc")
- X <- make_mod_matrix(object@formlist[[paste0(fname,"formula")]],
- gd[[covs]], newdata=newdata, re.form)$X
- }
- X <- as.matrix(X)
-
- if(is.null(level)){
- pred <- do.call(est@invlink, list(drop(X %*% est@estimates)))
- names(pred) <- NULL
- return(data.frame(Predicted=pred, SE=NA, lower=NA, upper=NA))
- }
-
- stats <- t(sapply(1:nrow(X), function(i){
- bt <- backTransform(linearComb(est, X[i,], re.form=re.form))
- ci <- confint(bt, level=level)
- c(Predicted=coef(bt), SE=SE(bt), lower=ci[1], upper=ci[2])
- }))
- as.data.frame(stats)
-})
-
setMethod("getP", "unmarkedFitGDR", function(object){
M <- numSites(object@data)
@@ -554,7 +516,19 @@ setMethod("fitted", "unmarkedFitGDR", function(object){
T <- object@data@numPrimary
+ # Adjust log lambda when there is a random intercept
+ #loglam <- log(predict(object, "lambda", level=NULL)$Predicted)
+ #loglam <- E_loglam(loglam, object, "lambda")
+ #lam <- exp(loglam)
lam <- predict(object, "lambda", level=NULL)$Predicted
+ if(object@output == "density"){
+ ua <- getUA(object@data)
+ A <- rowSums(ua$a)
+ switch(object@data@unitsIn, m = A <- A / 1e6, km = A <- A)
+ switch(object@unitsOut,ha = A <- A * 100, kmsq = A <- A)
+ lam <- lam * A
+ }
+
gp <- getP(object)
rem <- gp$rem
dist <- gp$dist
@@ -614,7 +588,18 @@ setMethod("ranef", "unmarkedFitGDR", function(object){
Kmin = apply(ysum, 1, max, na.rm=T)
+ #loglam <- log(predict(object, "lambda", level=NULL)$Predicted)
+ #loglam <- E_loglam(loglam, object, "lambda")
+ #lam <- exp(loglam)
lam <- predict(object, "lambda", level=NULL)$Predicted
+ if(object@output == "density"){
+ ua <- getUA(object@data)
+ A <- rowSums(ua$a)
+ switch(object@data@unitsIn, m = A <- A / 1e6, km = A <- A)
+ switch(object@unitsOut,ha = A <- A * 100, kmsq = A <- A)
+ lam <- lam * A
+ }
+
if(object@mixture != "P"){
alpha <- backTransform(object, "alpha")@estimate
}
@@ -660,7 +645,18 @@ setMethod("ranef", "unmarkedFitGDR", function(object){
setMethod("simulate", "unmarkedFitGDR", function(object, nsim, seed=NULL, na.rm=FALSE){
+ # Adjust log lambda when there is a random intercept
+ #loglam <- log(predict(object, "lambda", level=NULL)$Predicted)
+ #loglam <- E_loglam(loglam, object, "lambda")
+ #lam <- exp(loglam)
lam <- predict(object, "lambda", level=NULL)$Predicted
+ if(object@output == "density"){
+ ua <- getUA(object@data)
+ A <- rowSums(ua$a)
+ switch(object@data@unitsIn, m = A <- A / 1e6, km = A <- A)
+ switch(object@unitsOut,ha = A <- A * 100, kmsq = A <- A)
+ lam <- lam * A
+ }
dets <- getP(object)
if(object@mixture != "P"){
@@ -819,3 +815,8 @@ setMethod("plot", c(x = "unmarkedFitGDR", y = "missing"), function(x, y, ...)
main="Removal")
abline(h = 0, lty = 3, col = "gray")
})
+
+# Used with fitList
+setMethod("fl_getY", "unmarkedFitGDR", function(fit, ...){
+ getDesign(getData(fit), fit@formlist)$yDist
+})
diff --git a/R/getDesign.R b/R/getDesign.R
index 76e5c27..79f20e6 100644
--- a/R/getDesign.R
+++ b/R/getDesign.R
@@ -737,9 +737,9 @@ setMethod("getDesign", "unmarkedFrameOccuMS",
return(c('p[1]','p[2]','delta'))
}
inds <- matrix(NA,nrow=S,ncol=S)
- inds <- lower.tri(inds,diag=T)
+ inds <- lower.tri(inds,diag=TRUE)
inds[,1] <- FALSE
- inds <- which(inds,arr.ind=T) - 1
+ inds <- which(inds,arr.ind=TRUE) - 1
paste0('p[',inds[,2],inds[,1],']')
}
@@ -930,6 +930,7 @@ setMethod("getDesign", "unmarkedFramePCO",
M <- nrow(y)
T <- umf@numPrimary
J <- ncol(y) / T
+ R <- obsNum(umf) / T
delta <- umf@primaryPeriod
if(is.null(umf@yearlySiteCovs))
@@ -955,18 +956,18 @@ setMethod("getDesign", "unmarkedFramePCO",
Xlam.offset[is.na(Xlam.offset)] <- 0
if(is.null(obsCovs(umf)))
- obsCovs <- data.frame(placeHolder = rep(1, M*J*T))
+ obsCovs <- data.frame(placeHolder = rep(1, M*R*T))
else
obsCovs <- obsCovs(umf)
colNames <- c(colnames(obsCovs), colnames(yearlySiteCovs))
# Add yearlySiteCovs, which contains siteCovs
- obsCovs <- cbind(obsCovs, yearlySiteCovs[rep(1:(M*T), each = J),])
+ obsCovs <- cbind(obsCovs, yearlySiteCovs[rep(1:(M*T), each = R),])
colnames(obsCovs) <- colNames
if(!("obsNum" %in% names(obsCovs)))
- obsCovs <- cbind(obsCovs, obsNum = as.factor(rep(1:(J*T), M)))
+ obsCovs <- cbind(obsCovs, obsNum = as.factor(rep(1:(R*T), M)))
# Ignore last year of data
transCovs <- yearlySiteCovs[-seq(T, M*T, by=T),,drop=FALSE]
diff --git a/R/mixedModelTools.R b/R/mixedModelTools.R
index 472d7f1..8c6a96d 100644
--- a/R/mixedModelTools.R
+++ b/R/mixedModelTools.R
@@ -1,29 +1,3 @@
-model_frame <- function(formula, data, newdata=NULL){
-
- formula <- lme4::nobars(formula)
- mf <- model.frame(formula, data, na.action=stats::na.pass)
-
- if(is.null(newdata)){
- return(mf)
- }
-
- check_newdata(newdata, formula)
- model.frame(stats::terms(mf), newdata, na.action=stats::na.pass,
- xlev=get_xlev(data, mf))
-}
-
-model_matrix <- function(formula, data, newdata=NULL){
- mf <- model_frame(formula, data, newdata)
- model.matrix(lme4::nobars(formula), mf)
-}
-
-model_offset <- function(formula, data, newdata=NULL){
- mf <- model_frame(formula, data, newdata)
- out <- model.offset(mf)
- if(is.null(out)) out <- rep(0, nrow(mf))
- out
-}
-
get_xlev <- function(data, model_frame){
fac_col <- data[, sapply(data, is.factor), drop=FALSE]
xlevs <- lapply(fac_col, levels)
@@ -98,16 +72,6 @@ check_formula <- function(formula, data){
}
}
-check_newdata <- function(newdata, formula){
- inp_vars <- names(newdata)
- term_vars <- all.vars(formula)
- not_found <- ! term_vars %in% inp_vars
- if(any(not_found)){
- stop(paste0("Required variables not found in newdata: ",
- paste(term_vars[not_found], collapse=", ")), call.=FALSE)
- }
-}
-
split_formula <- function(formula){
if(length(formula) != 3) stop("Double right-hand side formula required")
char <- lapply(formula, function(x){
@@ -118,13 +82,6 @@ split_formula <- function(formula){
list(p1, p2)
}
-nobars_double <- function(form){
- spl <- split_formula(form)
- spl <- lapply(spl, lme4::nobars)
- spl <- paste(unlist(lapply(spl, as.character)),collapse="")
- as.formula(spl)
-}
-
is_tmb_fit <- function(mod){
if(!methods::.hasSlot(mod, "TMB")) return(FALSE)
!is.null(mod@TMB)
@@ -369,3 +326,43 @@ get_ranef_inputs <- function(forms, datalist, dms, Zs){
list(data=dat, pars=pars, rand_ef=rand_ef)
}
+add_covariates <- function(covs_long, covs_short, n){
+
+ if(is.null(covs_short)){
+ return(covs_long)
+ }
+
+ if(is.null(covs_long)){
+ covs_long <- data.frame(.dummy=rep(1, n))
+ } else {
+ stopifnot(nrow(covs_long) == n)
+ }
+
+ exp_factor <- nrow(covs_long) / nrow(covs_short)
+ stopifnot(exp_factor > 1)
+
+ rep_idx <- rep(1:nrow(covs_short), each=exp_factor)
+
+ to_add <- covs_short[rep_idx, ]
+ stopifnot(nrow(covs_long) == nrow(to_add))
+
+ cbind(covs_long, to_add)
+}
+
+vcov_TMB <- function(object, type, fixedOnly){
+
+ if(!missing(type)){
+ return(vcov(object[type], fixedOnly=fixedOnly))
+ }
+
+ v <- get_joint_cov(TMB::sdreport(object@TMB, getJointPrecision=TRUE))
+ no_sig <- !grepl("lsigma_",colnames(v))
+ v <- v[no_sig, no_sig]
+ colnames(v) <- rownames(v) <- names(coef(object, fixedOnly=FALSE))
+
+ if(fixedOnly){
+ no_re <- !grepl("b_", colnames(v))
+ v <- v[no_re, no_re]
+ }
+ v
+}
diff --git a/R/multinomPois.R b/R/multinomPois.R
index 7704b2e..924e77b 100644
--- a/R/multinomPois.R
+++ b/R/multinomPois.R
@@ -84,7 +84,8 @@ multinomPois <- function(formula, data, starts, method = "BFGS",
} else if(engine == "TMB"){
forms <- split_formula(formula)
- inps <- get_ranef_inputs(forms, list(det=obsCovs(data), state=siteCovs(data)),
+ obs_all <- add_covariates(obsCovs(data), siteCovs(data), numSites(data)*obsNum(data))
+ inps <- get_ranef_inputs(forms, list(det=obs_all, state=siteCovs(data)),
list(V, X), designMats[c("Z_det","Z_state")])
if(!piFun%in%c('doublePiFun','removalPiFun','depDoublePiFun')){
@@ -110,7 +111,7 @@ multinomPois <- function(formula, data, starts, method = "BFGS",
# Organize random-effect estimates from TMB output
state_rand_info <- get_randvar_info(tmb_out$sdr, "state", forms[[2]], siteCovs(data))
- det_rand_info <- get_randvar_info(tmb_out$sdr, "det", forms[[1]], obsCovs(data))
+ det_rand_info <- get_randvar_info(tmb_out$sdr, "det", forms[[1]], obs_all)
}
diff --git a/R/multmixOpen.R b/R/multmixOpen.R
index 7fe1835..725c9fc 100644
--- a/R/multmixOpen.R
+++ b/R/multmixOpen.R
@@ -35,6 +35,7 @@ multmixOpen <- function(lambdaformula, gammaformula, omegaformula, pformula,
M <- nrow(y)
T <- data@numPrimary
J <- ncol(getY(data)) / T
+ R <- obsNum(data) / T
y <- array(y, c(M, J, T))
yt <- apply(y, c(1,3), function(x) {
@@ -59,7 +60,7 @@ multmixOpen <- function(lambdaformula, gammaformula, omegaformula, pformula,
if(is.null(Xlam.offset)) Xlam.offset <- rep(0, M)
if(is.null(Xgam.offset)) Xgam.offset <- rep(0, M*(T-1))
if(is.null(Xom.offset)) Xom.offset <- rep(0, M*(T-1))
- if(is.null(Xp.offset)) Xp.offset <- rep(0, M*T*J)
+ if(is.null(Xp.offset)) Xp.offset <- rep(0, M*T*R)
if(is.null(Xiota.offset)) Xiota.offset <- rep(0, M*(T-1))
#K stuff
@@ -176,7 +177,7 @@ multmixOpen <- function(lambdaformula, gammaformula, omegaformula, pformula,
parms, beta_ind - 1,
Xlam.offset, Xgam.offset, Xom.offset, Xp.offset, Xiota.offset,
ytna, yna,
- lk, mixture, first - 1, last - 1, first1 - 1, M, T, J,
+ lk, mixture, first - 1, last - 1, first1 - 1, M, T, J, R,
D$delta, dynamics, fix, D$go.dims, immigration,
I, I1, lik_trans$Ib, lik_trans$Ip,
piFun, lfac.k, kmyt, lfac.kmyt, fin,
diff --git a/R/nmixTTD.R b/R/nmixTTD.R
index a8227e3..6d2fcf7 100644
--- a/R/nmixTTD.R
+++ b/R/nmixTTD.R
@@ -6,10 +6,13 @@ nmixTTD <- function(stateformula=~1, detformula=~1, data, K=100,
#Check arguments-------------------------------------------------------------
if(!is(data, "unmarkedFrameOccuTTD")){
- stop("Data is not an unmarkedFrameOccuTTD object.")
+ stop("Data is not an unmarkedFrameOccuTTD object.", call.=FALSE)
}
if(data@numPrimary > 1){
- stop("Multi-season data not supported.")
+ stop("Multi-season data not supported.", call.=FALSE)
+ }
+ if(any(grepl("offset", as.character(stateformula)))){
+ stop("Offsets not currently supported", call.=FALSE)
}
engine <- match.arg(engine)
@@ -46,7 +49,7 @@ nmixTTD <- function(stateformula=~1, detformula=~1, data, K=100,
pinds <- matrix(NA, nrow=4, ncol=2)
pinds[1,] <- c(1, nAP)
- pinds[2,] <- c((nAP+1):(nAP+nDP))
+ pinds[2,] <- c((nAP+1),(nAP+nDP))
pinds[3,] <- nAP+nDP+1
pinds[4,] <- nAP+nDP+(mixture=="NB")+1
diff --git a/R/occu.R b/R/occu.R
index 9d0159d..0379ca8 100644
--- a/R/occu.R
+++ b/R/occu.R
@@ -100,7 +100,8 @@ occu <- function(formula, data, knownOcc = numeric(0),
# Set up TMB input data
forms <- split_formula(formula)
- inps <- get_ranef_inputs(forms, list(det=obsCovs(data), state=siteCovs(data)),
+ obs_all <- add_covariates(obsCovs(data), siteCovs(data), length(getY(data)))
+ inps <- get_ranef_inputs(forms, list(det=obs_all, state=siteCovs(data)),
list(V, X), designMats[c("Z_det","Z_state")])
tmb_dat <- c(list(y=y, no_detect=nd, link=ifelse(linkPsi=="cloglog",1,0),
@@ -123,7 +124,7 @@ occu <- function(formula, data, knownOcc = numeric(0),
state_rand_info <- get_randvar_info(tmb_out$sdr, "state", forms[[2]],
siteCovs(data))
det_rand_info <- get_randvar_info(tmb_out$sdr, "det", forms[[1]],
- obsCovs(data))
+ obs_all)
}
diff --git a/R/occuMS.R b/R/occuMS.R
index 244e6af..5bf2d36 100644
--- a/R/occuMS.R
+++ b/R/occuMS.R
@@ -41,9 +41,9 @@ occuMS <- function(detformulas, psiformulas, phiformulas=NULL, data,
#Index guide used to organize p values
guide <- matrix(NA,nrow=S,ncol=S)
- guide <- lower.tri(guide,diag=T)
+ guide <- lower.tri(guide,diag=TRUE)
guide[,1] <- FALSE
- guide <- which(guide,arr.ind=T)
+ guide <- which(guide,arr.ind=TRUE)
#----------------------------------------------------------------------------
#Likelihood function in R----------------------------------------------------
diff --git a/R/occuMulti.R b/R/occuMulti.R
index 8182db4..8b20dd1 100644
--- a/R/occuMulti.R
+++ b/R/occuMulti.R
@@ -58,7 +58,7 @@ occuMulti <- function(detformulas, stateformulas, data, maxOrder,
}
}
psi <- exp(f %*% t_dmF)
- psi <- psi/rowSums(psi)
+ psi <- psi/rowSums(as.matrix(psi))
#p
p <- matrix(NA,nrow=nrow(y),ncol=S)
@@ -82,7 +82,7 @@ occuMulti <- function(detformulas, stateformulas, data, maxOrder,
pen <- penalty * 0.5 * sum(params^2)
#neg log likelihood
- -1 * (sum(log(rowSums(psi*prdProbY))) - pen)
+ -1 * (sum(log(rowSums(as.matrix(psi*prdProbY)))) - pen)
}
#----------------------------------------------------------------------------
@@ -128,7 +128,11 @@ occuMulti <- function(detformulas, stateformulas, data, maxOrder,
estimateList <- unmarkedEstimateList(list(state=state, det=det))
- umfit <- new("unmarkedFitOccuMulti", fitType = "occuMulti", call = match.call(),
+ if(missing(maxOrder)) maxOrder <- S
+ cl <- match.call()
+ cl$maxOrder <- maxOrder
+
+ umfit <- new("unmarkedFitOccuMulti", fitType = "occuMulti", call = cl,
detformulas = detformulas, stateformulas = stateformulas,
formula = ~1, data = data,
#sitesRemoved = designMats$removed.sites,
diff --git a/R/pcount.R b/R/pcount.R
index 2ed8183..bbce47e 100644
--- a/R/pcount.R
+++ b/R/pcount.R
@@ -118,7 +118,8 @@ pcount <- function(formula, data, K, mixture = c("P", "NB", "ZIP"), starts,
# Set up TMB input data
forms <- split_formula(formula)
- inps <- get_ranef_inputs(forms, list(det=obsCovs(data), state=siteCovs(data)),
+ obs_all <- add_covariates(obsCovs(data), siteCovs(data), length(getY(data)))
+ inps <- get_ranef_inputs(forms, list(det=obs_all, state=siteCovs(data)),
list(V, X), designMats[c("Z_det","Z_state")])
tmb_dat <- c(list(y=y, K=K, Kmin=Kmin, mixture=mixture_code,
@@ -146,7 +147,7 @@ pcount <- function(formula, data, K, mixture = c("P", "NB", "ZIP"), starts,
# Organize random-effect estimates from TMB output
state_rand_info <- get_randvar_info(tmb_out$sdr, "state", forms[[2]], siteCovs(data))
- det_rand_info <- get_randvar_info(tmb_out$sdr, "det", forms[[1]], obsCovs(data))
+ det_rand_info <- get_randvar_info(tmb_out$sdr, "det", forms[[1]], obs_all)
}
diff --git a/R/power.R b/R/power.R
new file mode 100644
index 0000000..da2072c
--- /dev/null
+++ b/R/power.R
@@ -0,0 +1,438 @@
+setClass("unmarkedPower",
+ representation(call="call", data="unmarkedFrame", M="numeric",
+ J="numeric", T="numeric", coefs="list", estimates="list",
+ alpha="numeric", nulls="list")
+)
+
+powerAnalysis <- function(object, coefs=NULL, design=NULL, alpha=0.05, nulls=list(),
+ datalist=NULL,
+ nsim=ifelse(is.null(datalist), 100, length(datalist)),
+ parallel=FALSE){
+
+ stopifnot(inherits(object, "unmarkedFit"))
+
+ submodels <- names(object@estimates@estimates)
+ coefs <- check_coefs(coefs, object)
+ coefs <- generate_random_effects(coefs, object)
+ fit_temp <- replace_estimates(object, coefs)
+
+ T <- 1
+ bdata <- NULL
+ if(!is.null(datalist)){
+ if(length(datalist) != nsim){
+ stop("Length of data list must equal value of nsim", call.=FALSE)
+ }
+ tryCatch({test <- update(object, data=datalist[[1]], se=FALSE,
+ control=list(maxit=1))
+ }, error=function(e){
+ stop("Incorrect format of entries in datalist", call.=FALSE)
+ })
+ bdata <- datalist
+ M <- numSites(bdata[[1]])
+ sims <- lapply(bdata, function(x){
+ #fit_temp@data <- x
+ #temporary workaround - not necessary??
+ #if(methods::.hasSlot(fit_temp, "knownOcc")){
+ # fit_temp@knownOcc <- rep(FALSE, M)
+ #}
+ #simulate(fit_temp, 1)[[1]]
+ if(inherits(x, "unmarkedFrameOccuMulti")){
+ return(x@ylist)
+ } else if(inherits(x, "unmarkedFrameGDR")){
+ return(list(yDistance=x@yDistance, yRemoval=x@yRemoval))
+ } else {
+ return(x@y)
+ }
+ })
+ if(methods::.hasSlot(bdata[[1]], "numPrimary")){
+ T <- bdata[[1]]@numPrimary
+ }
+ J <- obsNum(bdata[[1]]) / T
+ } else if(is.null(design)){
+ sims <- simulate(fit_temp, nsim)
+ M <- numSites(object@data)
+ if(methods::.hasSlot(object@data, "numPrimary")){
+ T <- object@data@numPrimary
+ }
+ J <- obsNum(object@data) / T
+ } else {
+ bdata <- bootstrap_data(fit_temp@data, nsim, design)
+ sims <- lapply(bdata, function(x){
+ fit_temp@data <- x
+ #temporary workaround
+ if(methods::.hasSlot(fit_temp, "knownOcc")){
+ fit_temp@knownOcc <- rep(FALSE, design$M)
+ }
+ simulate(fit_temp, 1)[[1]]
+ })
+ M <- design$M
+ if(methods::.hasSlot(fit_temp@data, "numPrimary")){
+ T <- fit_temp@data@numPrimary
+ }
+ J <- design$J
+ }
+
+ cl <- NULL
+ if(parallel){
+ cl <- parallel::makeCluster(parallel::detectCores()-1)
+ on.exit(parallel::stopCluster(cl))
+ parallel::clusterEvalQ(cl, library(unmarked))
+ }
+
+ if(!is.null(options()$unmarked_shiny)&&options()$unmarked_shiny){
+ ses <- options()$unmarked_shiny_session
+ ses <- shiny::getDefaultReactiveDomain()
+ pb <- shiny::Progress$new(ses, min=0, max=1)
+ pb$set(message="Running simulations")
+ fits <- pbapply::pblapply(1:nsim, function(i, sims, fit, bdata=NULL){
+ if(!is.null(design)) fit@data <- bdata[[i]]
+ if(inherits(fit, "unmarkedFitOccuMulti")){
+ fit@data@ylist <- sims[[i]]
+ } else{
+ fit@data@y <- sims[[i]]
+ }
+ out <- update(fit, data=fit@data, se=TRUE)
+ pb$set(value=i/nsim, message=NULL, detail=NULL)
+ out
+ }, sims=sims, fit=object, bdata=bdata, cl=NULL)
+ pb$close()
+
+ } else {
+
+ fits <- pbapply::pblapply(1:nsim, function(i, sims, fit, bdata=NULL){
+ if(!is.null(design)) fit@data <- bdata[[i]]
+ if(inherits(fit, "unmarkedFitOccuMulti")){
+ fit@data@ylist <- sims[[i]]
+ } else if(inherits(fit, "unmarkedFitGDR")){
+ fit@data@yDistance <- sims[[i]]$yDistance
+ fit@data@yRemoval <- sims[[i]]$yRemoval
+ } else {
+ fit@data@y <- sims[[i]]
+ }
+ update(fit, data=fit@data, se=TRUE)
+ }, sims=sims, fit=object, bdata=bdata, cl=cl)
+
+ }
+
+ sum_dfs <- lapply(fits, get_summary_df)
+
+ new("unmarkedPower", call=object@call, data=object@data, M=M,
+ J=J, T=T, coefs=coefs, estimates=sum_dfs, alpha=alpha, nulls=nulls)
+}
+
+bootstrap_data <- function(data, nsims, design){
+ M <- design$M
+ J <- design$J
+ sites <- 1:numSites(data)
+ if(!is.null(J) & methods::.hasSlot(data, "numPrimary")){
+ stop("Can't automatically bootstrap observations with > 1 primary period", call.=FALSE)
+ }
+ if(J > obsNum(data)){
+ stop("Can't currently bootstrap more than the actual number of observations", call.=FALSE)
+ }
+ obs <- 1:obsNum(data)
+
+ if(M > numSites(data)){
+ M_samps <- lapply(1:nsims, function(i) sample(sites, M, replace=TRUE))
+ } else if(M < numSites(data)){
+ M_samps <- lapply(1:nsims, function(i) sample(sites, M, replace=FALSE))
+ } else {
+ M_samps <- replicate(nsims, sites, simplify=FALSE)
+ }
+
+ if(J > obsNum(data)){
+ J_samps <- lapply(1:nsims, function(i) sample(obs, J, replace=TRUE))
+ } else if(J < obsNum(data)){
+ J_samps <- lapply(1:nsims, function(i) sample(obs, J, replace=FALSE))
+ } else {
+ J_samps <- replicate(nsims, obs, simplify=FALSE)
+ }
+
+ lapply(1:nsims, function(i) data[M_samps[[i]], J_samps[[i]]])
+}
+
+check_coefs <- function(coefs, fit, template=FALSE){
+ required_subs <- names(fit@estimates@estimates)
+ required_coefs <- lapply(fit@estimates@estimates, function(x) names(x@estimates))
+ required_lens <- lapply(required_coefs, length)
+
+ formulas <- sapply(names(fit), function(x) get_formula(fit, x))
+
+ # If there are random effects, adjust the expected coefficient names
+ # to remove the b vector and add the grouping covariate name
+ rand <- lapply(formulas, lme4::findbars)
+ if(!all(sapply(rand, is.null))){
+ stopifnot(all(required_subs %in% names(formulas)))
+ rvar <- lapply(rand, function(x) unlist(lapply(x, all.vars)))
+ if(!all(sapply(rvar, length)<2)){
+ stop("Only 1 random effect per parameter is supported", call.=FALSE)
+ }
+ for (i in required_subs){
+ if(!is.null(rand[[i]][[1]])){
+ signame <- rvar[[i]]
+ old_coefs <- required_coefs[[i]]
+ new_coefs <- old_coefs[!grepl("b_", old_coefs, fixed=TRUE)]
+ new_coefs <- c(new_coefs, signame)
+ required_coefs[[i]] <- new_coefs
+ }
+ }
+ }
+
+ dummy_coefs <- lapply(required_coefs, function(x){
+ out <- rep(0, length(x))
+ x <- gsub("(Intercept)", "intercept", x, fixed=TRUE)
+ names(out) <- x
+ out
+ })
+
+ if(template) return(dummy_coefs)
+
+ if(is.null(coefs)){
+ cat("coefs argument should be a named list of named vectors, with the following structure
+ (replacing 0s with your desired coefficient values):\n\n")
+ print(dummy_coefs)
+ stop("Supply coefs argument as specified above", call.=FALSE)
+ }
+
+ for (i in 1:length(required_subs)){
+ if(!required_subs[i] %in% names(coefs)){
+ stop(paste0("Missing required list element '",required_subs[i], "' in coefs list"), call.=FALSE)
+ }
+
+ sub_coefs <- coefs[[required_subs[i]]]
+
+ if(is.null(sub_coefs)){
+ stop(paste("Required coefficients for the", required_subs[i], "submodel are:",
+ paste(required_coefs[[i]],collapse=", ")))
+ }
+
+ is_named <- !is.null(names(sub_coefs)) & !any(names(sub_coefs)=="")
+
+ if(!is_named){
+ warning(paste("At least one coefficient in vector for submodel",required_subs[i],
+ "is unnamed; assuming the following order:\n",
+ paste(required_coefs[[i]], collapse=", ")))
+ if(length(sub_coefs) != required_lens[i]){
+ stop(paste0("Entry '",required_subs[[i]], "' in coefs list must be length ",
+ required_lens[[i]]), call.=FALSE)
+ }
+ } else {
+ rsi <- required_subs[i]
+ change_int <- names(coefs[[rsi]])%in%c("intercept","Intercept")
+ names(coefs[[rsi]])[change_int] <- "(Intercept)"
+ change_int <- names(coefs[[rsi]])%in%c("sigmaintercept","sigmaIntercept")
+ names(coefs[[rsi]])[change_int] <- "sigma(Intercept)"
+ change_int <- names(coefs[[rsi]])%in%c("shapeintercept","shapeIntercept")
+ names(coefs[[rsi]])[change_int] <- "shape(Intercept)"
+ change_int <- names(coefs[[rsi]])%in%c("rateintercept","rateIntercept")
+ names(coefs[[rsi]])[change_int] <- "rate(Intercept)"
+ change_int <- grepl(" intercept", names(coefs[[rsi]]))
+ names(coefs[[rsi]])[change_int] <- gsub(" intercept", " (Intercept)",
+ names(coefs[[rsi]])[change_int])
+ change_int <- grepl(" Intercept", names(coefs[[rsi]]))
+ names(coefs[[rsi]])[change_int] <- gsub(" Intercept", " (Intercept)",
+ names(coefs[[rsi]])[change_int])
+ sub_coefs <- coefs[[rsi]]
+
+ not_inc <- !required_coefs[[i]] %in% names(sub_coefs)
+ extra <- !names(sub_coefs) %in% required_coefs[[i]]
+
+ if(any(not_inc)){
+ stop(paste("The following required coefficients in the", required_subs[i], "submodel were not found:",
+ paste(required_coefs[[i]][not_inc], collapse=", ")))
+ }
+ if(any(extra)){
+ warning(paste("Ignoring extra coefficients in the", required_subs[i], "submodel:",
+ paste(names(sub_coefs)[extra], collapse=", ")))
+ }
+ coefs[[rsi]] <- coefs[[rsi]][required_coefs[[i]]]
+ }
+ }
+ coefs[required_subs]
+}
+
+wald <- function(est, se, null_hyp=NULL){
+ if(is.null(null_hyp) || is.na(null_hyp)) null_hyp <- 0
+ Z <- (est-null_hyp)/se
+ 2*pnorm(abs(Z), lower.tail = FALSE)
+}
+
+diff_dir <- function(est, hyp, null_hyp=NULL){
+ if(is.null(null_hyp) || is.na(null_hyp)) null_hyp <- 0
+ dif <- est - null_hyp
+ dif_hyp <- hyp - null_hyp
+ dif * dif_hyp > 0
+}
+
+setMethod("summary", "unmarkedPower", function(object, ...){
+ sum_dfs <- object@estimates
+ npar <- nrow(sum_dfs[[1]])
+
+ nulls <- object@nulls
+ nulls <- lapply(nulls, function(x){
+ nm <- names(x)
+ nm[nm %in% c("Intercept","intercept")] <- "(Intercept)"
+ names(x) <- nm
+ x
+ })
+
+ coefs_no_rand <- unlist(object@coefs)[!grepl("b_", names(unlist(object@coefs)))]
+
+ pow <- sapply(1:npar, function(ind){
+ submod <- sum_dfs[[1]]$submodel[ind]
+ param <- sum_dfs[[1]]$param[ind]
+ ni <- nulls[[submod]][param]
+
+ pcrit <- sapply(sum_dfs, function(x) wald(x$Estimate[ind], x$SE[ind], ni)) < object@alpha
+ direct <- sapply(sum_dfs, function(x) diff_dir(x$Estimate[ind], coefs_no_rand[ind], ni))
+ mean(pcrit & direct, na.rm=T)
+ })
+
+ all_nulls <- sapply(1:npar, function(ind){
+ submod <- sum_dfs[[1]]$submodel[ind]
+ param <- sum_dfs[[1]]$param[ind]
+ ni <- nulls[[submod]][param]
+ if(is.null(ni) || is.na(ni)) ni <- 0
+ ni
+ })
+
+ effect_no_random <- unlist(object@coefs)[!grepl("b_",names(unlist(object@coefs)))]
+
+ out <- cbind(sum_dfs[[1]][,1:2], effect=effect_no_random, null=all_nulls, power=pow)
+ rownames(out) <- NULL
+ names(out) <- c("Submodel", "Parameter", "Effect", "Null", "Power")
+ out
+})
+
+setMethod("show", "unmarkedPower", function(object){
+ cat("\nModel:\n")
+ print(object@call)
+ cat("\n")
+
+ cat("Power Statistics:\n")
+ sumtab <- summary(object)
+ sumtab$Power <- round(sumtab$Power, 3)
+ print(sumtab, row.names=FALSE)
+})
+
+replace_estimates <- function(object, new_ests){
+ for (i in 1:length(new_ests)){
+ est <- object@estimates@estimates[[names(new_ests)[i]]]@estimates
+ stopifnot(length(est) == length(new_ests[[i]]))
+ object@estimates@estimates[[names(new_ests)[i]]]@estimates <- new_ests[[i]]
+ }
+ object
+}
+
+get_summary_df <- function(fit){
+ n_est <- length(fit@estimates@estimates)
+ #est_names <- unname(sapply(fit@estimates@estimates, function(x) x@name))
+ est_names <- names(fit@estimates@estimates)
+ all_est <- lapply(1:n_est, function(i){
+ utils::capture.output(out <- summary(fit@estimates@estimates[[i]]))
+ out <- cbind(submodel=est_names[i], param=rownames(out), out)
+ rownames(out) <- NULL
+ out
+ })
+ do.call(rbind, all_est)
+}
+
+setClass("unmarkedPowerList", representation(powerAnalyses="list"))
+
+setGeneric("unmarkedPowerList", function(object, ...){
+ standardGeneric("unmarkedPowerList")})
+
+setMethod("unmarkedPowerList", "list", function(object, ...){
+ new("unmarkedPowerList", powerAnalyses=object)
+})
+
+setMethod("unmarkedPowerList", "unmarkedFit",
+ function(object, coefs, design, alpha=0.05, nulls=list(),
+ nsim=100, parallel=FALSE, ...){
+
+ ndesigns <- nrow(design)
+ out <- lapply(1:ndesigns, function(i){
+ cat(paste0("M = ",design$M[i],", J = ",design$J[i],"\n"))
+ powerAnalysis(object, coefs, as.list(design[i,]), alpha=alpha, nsim=nsim,
+ nulls=nulls, parallel=FALSE)
+ })
+ unmarkedPowerList(out)
+})
+
+setMethod("summary", "unmarkedPowerList", function(object, ...){
+ out <- lapply(object@powerAnalyses, function(x){
+ stats <- summary(x)
+ cbind(M=x@M, T=x@T, J=x@J, stats)
+ })
+ out <- do.call(rbind, out)
+ out$M <- factor(out$M)
+ out$T <- factor(out$T)
+ out$J <- factor(out$J)
+ out
+})
+
+setMethod("show", "unmarkedPowerList", function(object){
+ print(summary(object))
+})
+
+setMethod("plot", "unmarkedPowerList", function(x, power=NULL, param=NULL, ...){
+ dat <- summary(x)
+ if(is.null(param)) param <- dat$Parameter[1]
+ dat <- dat[dat$Parameter==param,,drop=FALSE]
+ ylim <- range(dat$Power, na.rm=T)
+ if(!is.null(power)) ylim[2] <- max(power, ylim[2])
+ xlim <- range(as.numeric(as.character(dat$M)), na.rm=T)
+ cols <- palette.colors(length(levels(dat$J)), palette="Dark 2")
+ old_par <- graphics::par()[c("mfrow","mar")]
+ nT <- length(levels(dat$T))
+ mar <- old_par$mar
+ if(nT == 1) mar <- c(5.1, 4.1, 2.1, 2.1)
+ graphics::par(mfrow=c(length(levels(dat$T)),1), mar=mar)
+ for (i in levels(dat$T)){
+ plot_title <- ""
+ if(nT > 1) plot_title <- paste0("T = ", i)
+ tsub <- dat[dat$T==i,,drop=FALSE]
+ Jlev <- levels(tsub$J)
+ jsub <- tsub[tsub$J==Jlev[1],,drop=FALSE]
+ plot(as.numeric(as.character(jsub$M)), jsub$Power, type="o",
+ col=cols[1], ylim=ylim, xlim=xlim, xlab="Sites",
+ ylab="Power", pch=19, main=plot_title)
+ if(!is.null(power)) abline(h=power, lty=2)
+ for (j in 2:length(Jlev)){
+ jsub <- tsub[tsub$J==Jlev[j],,drop=FALSE]
+ graphics::lines(as.numeric(as.character(jsub$M)), jsub$Power, type="o",
+ col=cols[j], pch=19)
+ }
+ graphics::legend('bottomright', lwd=1, pch=19, col=cols, legend=Jlev, title="Observations")
+ }
+ graphics::par(mfrow=old_par)
+})
+
+setMethod("update", "unmarkedPower", function(object, ...){
+ args <- list(...)
+ if(!is.null(args$alpha)) object@alpha <- args$alpha
+ if(!is.null(args$coefs)){
+ if(!is.list(args$coefs) || all(names(args$coefs) == names(object@coefs))){
+ stop("coefs list structure is incorrect", call.=FALSE)
+ object@coefs <- args$coefs
+ }
+ }
+ if(!is.null(args$nulls)) object@nulls <- args$nulls
+ object
+})
+
+shinyPower <- function(object, ...){
+
+ if(!inherits(object, "unmarkedFit")){
+ stop("Requires unmarkedFit object", call.=FALSE)
+ }
+ if(!requireNamespace("shiny")){
+ stop("Install the shiny library to use this function", call.=FALSE)
+ }
+ options(unmarked_shiny=TRUE)
+ on.exit(options(unmarked_shiny=FALSE))
+ .shiny_env$.SHINY_MODEL <- object
+
+ shiny::runApp(system.file("shinyPower", package="unmarked"))
+
+}
diff --git a/R/predict.R b/R/predict.R
new file mode 100644
index 0000000..68efbb7
--- /dev/null
+++ b/R/predict.R
@@ -0,0 +1,948 @@
+# General predict method-------------------------------------------------------
+
+# Common predict function for all fit types
+# with exception of occuMulti and occuMS (at the end of this file)
+setMethod("predict", "unmarkedFit",
+ function(object, type, newdata, backTransform = TRUE, na.rm = TRUE,
+ appendData = FALSE, level=0.95, re.form=NULL, ...){
+
+ # If no newdata, get actual data
+ if(missing(newdata) || is.null(newdata)) newdata <- object@data
+
+ # Check inputs
+ check_predict_arguments(object, type, newdata)
+
+ # Get model matrix (X) and offset
+ # If newdata is an unmarkedFrame, use getDesign via predict_inputs_from_umf()
+ is_raster <- FALSE
+ if(inherits(newdata, "unmarkedFrame")){
+ # Generate model matrix and offsets
+ pred_inps <- predict_inputs_from_umf(object, type, newdata, na.rm, re.form)
+ } else {
+ # If newdata is provided
+ # 1. Get original data and appropriate formula for type
+ orig_data <- get_orig_data(object, type)
+ orig_formula <- get_formula(object, type)
+
+ # 2. If newdata is raster, get newdata from raster as data.frame
+ if(inherits(newdata, c("RasterLayer","RasterStack"))){
+ if(!require(raster)) stop("raster package required", call.=FALSE)
+ is_raster <- TRUE
+ orig_raster <- newdata
+ newdata <- newdata_from_raster(newdata, all.vars(orig_formula))
+ }
+
+ # 3. Make model matrix and offset with newdata, informed by original data
+ pred_inps <- make_mod_matrix(orig_formula, orig_data, newdata, re.form)
+ }
+
+ # Calculate predicted values in chunks (for speed) based on X and offset
+ out <- predict_by_chunk(object, type, level, pred_inps$X, pred_inps$offset,
+ chunk_size = 70, backTransform, re.form)
+
+ # Convert output to raster if newdata was raster
+ if(is_raster){
+ out <- raster_from_predict(out, orig_raster, appendData)
+ } else if(appendData){
+ # Append data if needed
+ out <- data.frame(out, as(newdata, "data.frame"))
+ }
+
+ out
+
+})
+
+# Function to make model matrix and offset from formula, newdata and original data
+# This function makes sure factor levels in newdata match, and that
+# any functions in the formula are handled properly (e.g. scale)
+make_mod_matrix <- function(formula, data, newdata, re.form=NULL){
+ form_nobars <- lme4::nobars(formula)
+ mf <- model.frame(form_nobars, data, na.action=stats::na.pass)
+ X.terms <- stats::terms(mf)
+ fac_cols <- data[, sapply(data, is.factor), drop=FALSE]
+ xlevs <- lapply(fac_cols, levels)
+ xlevs <- xlevs[names(xlevs) %in% names(mf)]
+ nmf <- model.frame(X.terms, newdata, na.action=stats::na.pass, xlev=xlevs)
+ #X <- model.matrix(X.terms, newdata, xlev=xlevs)
+ X <- model.matrix(form_nobars, nmf)
+ offset <- model.offset(nmf)
+ if(is.null(re.form) & !is.null(lme4::findbars(formula))){
+ Z <- get_Z(formula, data, newdata)
+ X <- cbind(X, Z)
+ }
+ list(X=X, offset=offset)
+}
+
+
+# Fit-type specific methods----------------------------------------------------
+
+# Fit type-specific methods to generate different components of prediction
+# 1. check_predict_arguments(): Check arguments
+# 2. predict_inputs_from_umf(): Generating inputs from an unmarked
+# frame (e.g. when no newdata) using getDesign
+# 3. get_formula: Get formula for submodel type
+# 4. get_orig_data(): Get original dataset for use in building model frame
+# 5. predict_by_chunk(): Take inputs and generate predictions
+# Basic methods are shown below; fit type-specific methods in their own sections
+
+setGeneric("check_predict_arguments", function(object, ...){
+ standardGeneric("check_predict_arguments")
+})
+
+setMethod("check_predict_arguments", "unmarkedFit",
+ function(object, type, newdata, ...){
+ # Check if type is supported (i.e., is it in names(object)?)
+ check_type(object, type)
+
+ # Check newdata class
+ if(!inherits(newdata, c("unmarkedFrame", "data.frame", "RasterLayer", "RasterStack"))){
+ stop("newdata must be unmarkedFrame, data.frame, RasterLayer, or RasterStack", call.=FALSE)
+ }
+ invisible(TRUE)
+})
+
+# Check if predict type is valid
+check_type <- function(mod, type){
+ opts <- names(mod)
+ if(type %in% opts) return(invisible(TRUE))
+ stop("Valid types are ", paste(opts, collapse=", "), call.=FALSE)
+}
+
+# Get X and offset when newdata is umf
+setGeneric("predict_inputs_from_umf", function(object, ...){
+ standardGeneric("predict_inputs_from_umf")
+})
+
+setMethod("predict_inputs_from_umf", "unmarkedFit",
+ function(object, type, newdata, na.rm, re.form){
+ designMats <- getDesign(newdata, object@formula, na.rm = na.rm)
+ if(type == "state") list_els <- c("X","Z_state","X.offset")
+ if(type == "det") list_els <- c("V","Z_det","V.offset")
+
+ X <- designMats[[list_els[1]]]
+ if(is.null(re.form)) X <- cbind(X, designMats[[list_els[2]]])
+ offset <- designMats[[list_els[3]]]
+
+ list(X=X, offset=offset)
+})
+
+# Get correct individual formula based on type
+setGeneric("get_formula", function(object, type, ...){
+ standardGeneric("get_formula")
+})
+
+setMethod("get_formula", "unmarkedFit", function(object, type, ...){
+ if(type == "state"){
+ return(as.formula(paste("~", object@formula[3], sep="")))
+ } else if(type == "det"){
+ return(as.formula(object@formula[[2]]))
+ }
+ NULL
+})
+
+# When newdata is data.frame/raster, get original dataset
+# For use in building correct model frame
+setGeneric("get_orig_data", function(object, type, ...){
+ standardGeneric("get_orig_data")
+})
+
+# Note that by default, final year of yearlySiteCov data at each site is dropped
+# Because transition probabilities are not estimated for final year
+# this is appropriate for dynamic models but not temporary emigration models
+# for which the drop_final should be FALSE
+setMethod("get_orig_data", "unmarkedFit", function(object, type, ...){
+ clean_covs <- clean_up_covs(object@data, drop_final=TRUE)
+ datatype <- switch(type, state='site_covs', det='obs_covs')
+ clean_covs[[datatype]]
+})
+
+# Convert NULL data frames to dummy data frames of proper dimension
+# Add site covs to yearlysitecovs, ysc to obs covs, etc.
+# Drop final year of ysc if necessary
+clean_up_covs <- function(object, drop_final=FALSE){
+ M <- numSites(object)
+ R <- obsNum(object)
+ T <- 1
+ J <- R
+ is_mult <- methods::.hasSlot(object, "numPrimary")
+ if(is_mult){
+ T <- object@numPrimary
+ J <- R/T
+ }
+
+ sc <- siteCovs(object)
+ if(is.null(sc)) sc <- data.frame(.dummy=rep(1,M))
+ out <- list(site_covs=sc)
+
+ if(is_mult){
+ ysc <- yearlySiteCovs(object)
+ if(is.null(ysc)) ysc <- data.frame(.dummy2=rep(1,M*T))
+ ysc <- cbind(ysc, sc[rep(1:M, each=T),,drop=FALSE])
+ }
+
+ if(methods::.hasSlot(object, "obsCovs")){
+ oc <- obsCovs(object)
+ if(is.null(oc)) oc <- data.frame(.dummy3=rep(1,M*T*J))
+ if(is_mult){
+ oc <- cbind(oc, ysc[rep(1:(M*T), each=J),,drop=FALSE])
+ } else {
+ oc <- cbind(oc, sc[rep(1:M, each=J),,drop=FALSE])
+ }
+ out$obs_covs=oc
+ }
+
+ if(is_mult){
+ if(drop_final & (T > 1)){
+ # Drop final year of data at each site
+ # Also drop factor levels only found in last year of data
+ ysc <- drop_final_year(ysc, M, T)
+ }
+ out$yearly_site_covs <- ysc
+ }
+
+ out
+}
+
+#Remove data in final year of yearlySiteCovs (replacing with NAs)
+#then drop factor levels found only in that year
+drop_final_year <- function(dat, nsites, nprimary){
+ dat[seq(nprimary, nsites*nprimary, by=nprimary), ] <- NA
+ dat <- lapply(dat, function(x) x[,drop = TRUE])
+ as.data.frame(dat)
+}
+
+
+# Take inputs (most importantly model matrix and offsets) and generate prediction
+# done in chunks for speed, 70 was optimal after tests
+setGeneric("predict_by_chunk", function(object, ...){
+ standardGeneric("predict_by_chunk")
+})
+
+setMethod("predict_by_chunk", "unmarkedFit",
+ function(object, type, level, xmat, offsets, chunk_size, backTransform=TRUE,
+ re.form=NULL, ...){
+
+ if(is.vector(xmat)) xmat <- matrix(xmat, nrow=1)
+ nr <- nrow(xmat)
+ ind <- rep(1:ceiling(nr/chunk_size), each=chunk_size, length.out=nr)
+
+ # should find a way to keep xmat sparse, but it doesn't
+ # work with linearComb
+ #x_chunk <- lapply(split(as.data.frame(xmat), ind), as.matrix)
+ x_chunk <- lapply(unique(ind),
+ function(i) as.matrix(xmat[ind==i,,drop=FALSE]))
+
+ if(is.null(offsets)) offsets <- rep(0, nr)
+ off_chunk <- split(offsets, ind)
+ out <- mapply(function(x_i, off_i){
+ has_na <- apply(x_i, 1, function(x_i) any(is.na(x_i)))
+ # Work around linearComb bug where there can't be NAs in inputs
+ x_i[has_na,] <- 0
+ off_i[has_na] <- 0
+ lc <- linearComb(object, x_i, type, offset=off_i, re.form=re.form)
+ if(backTransform) lc <- backTransform(lc)
+ out <- data.frame(Predicted=coef(lc))
+ if(!is.null(level)){
+ se <- SE(lc)
+ ci <- confint(lc, level=level)
+ out$SE <- se
+ out$lower <- ci[,1]
+ out$upper <- ci[,2]
+ }
+ out[has_na,] <- NA
+ out
+ }, x_chunk, off_chunk, SIMPLIFY=FALSE)
+ out <- do.call(rbind, out)
+ rownames(out) <- NULL
+ out
+})
+
+
+# Raster handling functions----------------------------------------------------
+
+# Convert a raster into a data frame to use as newdata
+newdata_from_raster <- function(rst, vars){
+ nd <- raster::as.data.frame(rst)
+ # Handle factor rasters
+ is_fac <- raster::is.factor(rst)
+ rem_string <- paste(paste0("^",names(rst),"_"), collapse="|")
+ names(nd)[is_fac] <- gsub(rem_string, "", names(nd)[is_fac])
+ # Check if variables are missing
+ no_match <- vars[! vars %in% names(nd)]
+ if(length(no_match) > 0){
+ stop(paste0("Variable(s) ",paste(no_match, collapse=", "), " not found in raster stack"),
+ call.=FALSE)
+ }
+ return(nd)
+}
+
+# Convert predict output into a raster
+raster_from_predict <- function(pr, orig_rst, appendData){
+ new_rast <- data.frame(raster::coordinates(orig_rst), pr)
+ new_rast <- raster::stack(raster::rasterFromXYZ(new_rast))
+ raster::crs(new_rast) <- raster::crs(orig_rst)
+ if(appendData) new_rast <- raster::stack(new_rast, orig_rst)
+ new_rast
+}
+
+
+# pcount methods---------------------------------------------------------------
+
+setMethod("check_predict_arguments", "unmarkedFitPCount",
+ function(object, type, newdata, ...){
+ if(type %in% c("psi", "alpha")){
+ stop(paste0(type, " is scalar. Use backTransform instead."), call.=FALSE)
+ }
+ methods::callNextMethod(object, type, newdata)
+})
+
+# Special predict approach for ZIP distribution in pcount
+# All other distributions use default method
+setMethod("predict_by_chunk", "unmarkedFitPCount",
+ function(object, type, level, xmat, offsets, chunk_size, backTransform=TRUE,
+ re.form=NULL, ...){
+ if(type == "state" & object@mixture == "ZIP"){
+
+ out <- data.frame(matrix(NA, nrow(xmat), 4))
+ names(out) <- c("Predicted", "SE", "lower", "upper")
+
+ psi.hat <- plogis(coef(object, type="psi"))
+ lamEst <- object["state"]
+ psiEst <- object["psi"]
+ fixedOnly <- !is.null(re.form)
+ lam.mle <- coef(lamEst, fixedOnly=fixedOnly)
+ lam_vcov <- vcov(lamEst, fixedOnly=fixedOnly)
+ if(is.null(offsets)) offsets <- rep(0, nrow(xmat))
+
+ for(i in 1:nrow(xmat)) {
+ if(nrow(xmat) > 5000) {
+ if(i %% 1000 == 0)
+ cat(" doing row", i, "of", nrow(xmat), "\n")
+ }
+ if(any(is.na(xmat[i,]))) next
+ ## for the ZIP model the predicted values on the log scale have us
+ ## add log(1-psi.hat) to the normal linear prediction
+ out$Predicted[i] <- xmat[i,] %*% lam.mle + offsets[i] + log(1 - psi.hat)
+ ## to compute the approximate SE, I compute the variance of the usual
+ ## linear part -- that is easy, and to that I add the variance of
+ ## log(1-psi.hat) obtained by the delta approximation
+ logit.psi<-coef(object,type="psi")
+ # To do that I took derivative of log(1-psi.hat) using application
+ # of chain rule.... hopefully correctly.
+ delta.approx.2ndpart<- ( ((1/(1-psi.hat))*(exp(logit.psi)/((1+exp(logit.psi))^2)))^2 ) * (SE(psiEst)^2)
+ ## now the SE is the sqrt of the whole thing
+ out$SE[i]<- sqrt( t(xmat[i,])%*% lam_vcov %*%xmat[i,] + delta.approx.2ndpart )
+
+ #From Mike Meredith
+ alf <- (1 - level) / 2
+ crit<-qnorm(c(alf, 1 - alf))
+ ci <- out$Predicted[i] + crit * out$SE[i]
+ out$lower[i]<- ci[1]
+ out$upper[i]<- ci[2]
+ if(backTransform){
+ out$Predicted[i] <- exp(out$Predicted[i])
+ ### If back-transform, delta approx says var = (exp(linear.predictor)^2)*Var(linear.predictor)
+ ### also I exponentiate the confidence interval.....
+ out$SE[i]<- out$Predicted[i]*out$SE[i]
+ ci<-exp(ci)
+ }
+ out$lower[i] <- ci[1]
+ out$upper[i] <- ci[2]
+ }
+ return(out)
+ }
+ methods::callNextMethod(object, type, level, xmat, offsets, chunk_size,
+ backTransform, re.form, ...)
+})
+
+
+# colext methods---------------------------------------------------------------
+
+setMethod("predict_inputs_from_umf", "unmarkedFitColExt",
+ function(object, type, newdata, na.rm, re.form=NA){
+ designMats <- getDesign(newdata, object@formula, na.rm = na.rm)
+ list_el <- switch(type, psi="W", col="X.gam", ext="X.eps", det="V")
+ # colext doesn't support offsets
+ list(X=designMats[[list_el]], offset=NULL)
+})
+
+setMethod("get_formula", "unmarkedFitColExt", function(object, type, ...){
+ switch(type, psi=object@psiformula, col=object@gamformula,
+ ext=object@epsformula, det=object@detformula)
+})
+
+setMethod("get_orig_data", "unmarkedFitColExt", function(object, type, ...){
+ clean_covs <- clean_up_covs(object@data, drop_final=TRUE)
+ datatype <- switch(type, psi='site_covs', col='yearly_site_covs',
+ ext='yearly_site_covs', det='obs_covs')
+ clean_covs[[datatype]]
+})
+
+
+# occuFP methods---------------------------------------------------------------
+
+setMethod("predict_inputs_from_umf", "unmarkedFitOccuFP",
+ function(object, type, newdata, na.rm, re.form=NA){
+ designMats <- getDesign(newdata, object@detformula, object@FPformula,
+ object@Bformula, object@stateformula, na.rm=na.rm)
+ X_idx <- switch(type, state="X", det="V", fp="U", b="W")
+ off_idx <- paste0(X_idx, ".offset")
+ list(X=designMats[[X_idx]], offset=designMats[[off_idx]])
+})
+
+setMethod("get_formula", "unmarkedFitOccuFP", function(object, type, ...){
+ switch(type, state=object@stateformula, det=object@detformula,
+ b=object@Bformula, fp=object@FPformula)
+})
+
+setMethod("get_orig_data", "unmarkedFitOccuFP", function(object, type, ...){
+ # Get obs data if fp, b, or det
+ new_type <- ifelse(type %in% c("fp", "b"), "det", type)
+ methods::callNextMethod(object, new_type, ...)
+})
+
+
+# Dail-Madsen model methods----------------------------------------------------
+
+# Includes unmarkedFitPCO, unmarkedFitMMO, unmarkedFitDSO
+
+setMethod("check_predict_arguments", "unmarkedFitDailMadsen",
+ function(object, type, newdata, ...){
+ if(type %in% c("psi", "alpha", "scale")){
+ stop(paste0(type, " is scalar. Use backTransform instead."), call.=FALSE)
+ }
+ dynamics <- object@dynamics
+ immigration <- tryCatch(object@immigration, error=function(e) FALSE)
+ if(identical(dynamics, "notrend") & identical(type, "gamma"))
+ stop("gamma is a derived parameter for this model: (1-omega)*lambda")
+ if(identical(dynamics, "trend") && identical(type, "omega"))
+ stop("omega is not a parameter in the dynamics='trend' model")
+ if(!immigration && identical(type, "iota"))
+ stop("iota is not a parameter in the immigration=FALSE model")
+ methods::callNextMethod(object, type, newdata)
+})
+
+setMethod("predict_inputs_from_umf", "unmarkedFitDailMadsen",
+ function(object, type, newdata, na.rm, re.form=NA){
+ designMats <- getDesign(newdata, object@formula, na.rm=na.rm)
+ X_idx <- switch(type, lambda="Xlam", gamma="Xgam", omega="Xom",
+ iota="Xiota", det="Xp")
+ off_idx <- paste0(X_idx, ".offset")
+ list(X=designMats[[X_idx]], offset=designMats[[off_idx]])
+})
+
+setMethod("get_formula", "unmarkedFitDailMadsen", function(object, type, ...){
+ fl <- object@formlist
+ switch(type, lambda=fl$lambdaformula, gamma=fl$gammaformula,
+ omega=fl$omegaformula, iota=fl$iotaformula, det=fl$pformula)
+})
+
+setMethod("get_orig_data", "unmarkedFitDailMadsen", function(object, type, ...){
+ clean_covs <- clean_up_covs(object@data, drop_final=TRUE)
+ datatype <- switch(type, lambda='site_covs', gamma='yearly_site_covs',
+ omega='yearly_site_covs', iota='yearly_site_covs',
+ det='obs_covs')
+ clean_covs[[datatype]]
+})
+
+# This method differs for DSO
+setMethod("get_orig_data", "unmarkedFitDSO", function(object, type, ...){
+ clean_covs <- clean_up_covs(object@data, drop_final=TRUE)
+ datatype <- switch(type, lambda='site_covs', gamma='yearly_site_covs',
+ omega='yearly_site_covs', iota='yearly_site_covs',
+ det='yearly_site_covs')
+ clean_covs[[datatype]]
+})
+
+# Special handling for ZIP distribution
+setMethod("predict_by_chunk", "unmarkedFitDailMadsen",
+ function(object, type, level, xmat, offsets, chunk_size, backTransform=TRUE,
+ re.form=NULL, ...){
+ if(type == "lambda" & object@mixture == "ZIP"){
+ warning("Method to compute SE for ZIP model has not been written", call.=FALSE)
+ out <- data.frame(matrix(NA, nrow(xmat), 4))
+ names(out) <- c("Predicted", "SE", "lower", "upper")
+ lam.mle <- coef(object, type="lambda")
+ psi.hat <- plogis(coef(object, type="psi"))
+ if(is.null(offsets)) offsets <- rep(0, nrow(xmat))
+ out$Predicted <- as.numeric(xmat %*% lam.mle + offsets + log(1 - psi.hat))
+ if(backTransform) out$Predicted <- exp(out$Predicted)
+ return(out)
+ }
+ methods::callNextMethod(object, type, level, xmat, offsets, chunk_size,
+ backTransform, re.form, ...)
+})
+
+
+# Temporary emigration models--------------------------------------------------
+
+# All inherit from GMM so only one set of methods is required
+# (except GDR which has its own predict method right now)
+
+setMethod("predict_inputs_from_umf", "unmarkedFitGMM",
+ function(object, type, newdata, na.rm, re.form=NA){
+ designMats <- getDesign(newdata, object@formula, na.rm=na.rm)
+ X_idx <- switch(type, lambda="Xlam", phi="Xphi", det="Xdet")
+ off_idx <- paste0(X_idx, ".offset")
+ list(X=designMats[[X_idx]], offset=designMats[[off_idx]])
+})
+
+setMethod("get_formula", "unmarkedFitGMM", function(object, type, ...){
+ fl <- object@formlist
+ switch(type, lambda=fl$lambdaformula, phi=fl$phiformula, det=fl$pformula)
+})
+
+setMethod("get_orig_data", "unmarkedFitGMM", function(object, type, ...){
+ clean_covs <- clean_up_covs(object@data, drop_final=FALSE)
+ datatype <- switch(type, lambda='site_covs', phi='yearly_site_covs',
+ det='obs_covs')
+ clean_covs[[datatype]]
+})
+
+
+# occuTTD----------------------------------------------------------------------
+
+# Identical to colext
+
+setMethod("predict_inputs_from_umf", "unmarkedFitOccuTTD",
+ function(object, type, newdata, na.rm, re.form=NA){
+ designMats <- getDesign(newdata, object@formula, na.rm = na.rm)
+ list_el <- switch(type, psi="W", col="X.gam", ext="X.eps", det="V")
+ list(X=designMats[[list_el]], offset=NULL)
+})
+
+setMethod("get_formula", "unmarkedFitOccuTTD", function(object, type, ...){
+ switch(type, psi=object@psiformula, col=object@gamformula,
+ ext=object@epsformula, det=object@detformula)
+})
+
+setMethod("get_orig_data", "unmarkedFitOccuTTD", function(object, type, ...){
+ clean_covs <- clean_up_covs(object@data, drop_final=TRUE)
+ datatype <- switch(type, psi='site_covs', col='yearly_site_covs',
+ ext='yearly_site_covs', det='obs_covs')
+ clean_covs[[datatype]]
+})
+
+
+# nmixTTD----------------------------------------------------------------------
+
+setMethod("predict_inputs_from_umf", "unmarkedFitNmixTTD",
+ function(object, type, newdata, na.rm, re.form=NA){
+ designMats <- getDesign(newdata, object@formula, na.rm = na.rm)
+ list_el <- switch(type, state="W", det="V")
+ list(X=designMats[[list_el]], offset=NULL)
+})
+
+setMethod("get_formula", "unmarkedFitNmixTTD", function(object, type, ...){
+ switch(type, state=object@stateformula, det=object@detformula)
+})
+
+setMethod("get_orig_data", "unmarkedFitNmixTTD", function(object, type, ...){
+ clean_covs <- clean_up_covs(object@data, drop_final=FALSE)
+ datatype <- switch(type, state='site_covs', det='obs_covs')
+ clean_covs[[datatype]]
+})
+
+
+# gdistremoval-----------------------------------------------------------------
+
+setMethod("predict_inputs_from_umf", "unmarkedFitGDR",
+ function(object, type, newdata, na.rm, re.form=NA){
+ designMats <- getDesign(newdata, object@formlist)
+ if(type == "lambda") list_els <- c("Xlam","Zlam")
+ if(type == "phi") list_els <- c("Xphi","Zphi")
+ if(type == "dist") list_els <- c("Xdist","Zdist")
+ if(type == "rem") list_els <- c("Xrem", "Zrem")
+ X <- designMats[[list_els[1]]]
+ if(is.null(re.form)) X <- cbind(X, designMats[[list_els[2]]])
+ list(X=X, offset=NULL)
+})
+
+setMethod("get_formula", "unmarkedFitGDR", function(object, type, ...){
+ fl <- object@formlist
+ switch(type, lambda=fl$lambdaformula, phi=fl$phiformula,
+ dist=fl$distanceformula, rem=fl$removalformula)
+})
+
+setMethod("get_orig_data", "unmarkedFitGDR", function(object, type, ...){
+ clean_covs <- clean_up_covs(object@data, drop_final=FALSE)
+ datatype <- switch(type, lambda='site_covs', phi='yearly_site_covs',
+ dist='yearly_site_covs', rem='obs_covs')
+ clean_covs[[datatype]]
+})
+
+
+# occuMulti--------------------------------------------------------------------
+
+# bespoke predict method since it has numerious unusual options
+# and requires bootstrapping
+
+# This method is used by simulate but not by predict
+setMethod("get_formula", "unmarkedFitOccuMulti", function(object, type, ...){
+ switch(type, state=object@stateformulas,
+ det=object@detformulas)
+})
+
+setMethod("predict", "unmarkedFitOccuMulti",
+ function(object, type, newdata,
+ #backTransform = TRUE, na.rm = TRUE,
+ #appendData = FALSE,
+ se.fit=TRUE, level=0.95, species=NULL, cond=NULL, nsims=100,
+ ...)
+ {
+
+ type <- match.arg(type, c("state", "det"))
+
+ if(is.null(hessian(object))){
+ se.fit = FALSE
+ }
+
+ species <- name_to_ind(species, names(object@data@ylist))
+ cond <- name_to_ind(cond, names(object@data@ylist))
+
+ if(missing(newdata)){
+ newdata <- NULL
+ } else {
+ if(! class(newdata) %in% c('data.frame')){
+ stop("newdata must be a data frame")
+ }
+ }
+
+ maxOrder <- object@call$maxOrder
+ if(is.null(maxOrder)) maxOrder <- length(object@data@ylist)
+ dm <- getDesign(object@data,object@detformulas,object@stateformulas,
+ maxOrder, na.rm=F, newdata=newdata, type=type)
+
+ params <- coef(object)
+ low_bound <- (1-level)/2
+ up_bound <- level + (1-level)/2
+
+
+ if(type=="state"){
+ N <- nrow(dm$dmOcc[[1]]); nF <- dm$nF; dmOcc <- dm$dmOcc;
+ fStart <- dm$fStart; fStop <- dm$fStop; fixed0 <- dm$fixed0
+ t_dmF <- t(dm$dmF)
+
+ calc_psi <- function(params){
+
+ f <- matrix(NA,nrow=N,ncol=nF)
+ index <- 1
+ for (i in 1:nF){
+ if(fixed0[i]){
+ f[,i] <- 0
+ } else {
+ f[,i] <- dmOcc[[index]] %*% params[fStart[index]:fStop[index]]
+ index <- index + 1
+ }
+ }
+ psi <- exp(f %*% t_dmF)
+ as.matrix(psi/rowSums(psi))
+ }
+
+ psi_est <- calc_psi(params)
+
+ if(se.fit){
+ message('Bootstrapping confidence intervals with ',nsims,' samples')
+ Sigma <- vcov(object)
+ samp <- array(NA,c(dim(psi_est),nsims))
+ for (i in 1:nsims){
+ samp[,,i] <- calc_psi(mvrnorm(1, coef(object), Sigma))
+ }
+ }
+
+ if(!is.null(species)){
+
+ sel_col <- species
+
+ if(!is.null(cond)){
+ if(any(sel_col %in% abs(cond))){
+ stop("Species can't be conditional on itself")
+ }
+ ftemp <- object@data@fDesign
+ swap <- -1*cond[which(cond<0)]
+ ftemp[,swap] <- 1 - ftemp[,swap]
+ num_inds <- apply(ftemp[,c(sel_col,abs(cond))] == 1,1,all)
+ denom_inds <- apply(ftemp[,abs(cond),drop=F] == 1,1,all)
+ est <- rowSums(psi_est[,num_inds,drop=F]) /
+ rowSums(psi_est[,denom_inds, drop=F])
+ if(se.fit){
+ samp_num <- apply(samp[,num_inds,,drop=F],3,rowSums)
+ samp_denom <- apply(samp[,denom_inds,,drop=F],3,rowSums)
+ samp <- samp_num / samp_denom
+ }
+
+ } else {
+ num_inds <- apply(object@data@fDesign[,sel_col,drop=FALSE] == 1,1,all)
+ est <- rowSums(psi_est[,num_inds,drop=F])
+ if(se.fit){
+ samp <- samp[,num_inds,,drop=F]
+ samp <- apply(samp, 3, rowSums)
+ }
+ }
+
+ if(se.fit){
+ if(!is.matrix(samp)) samp <- matrix(samp, nrow=1)
+ boot_se <- apply(samp,1,sd, na.rm=T)
+ boot_low <- apply(samp,1,quantile,low_bound, na.rm=T)
+ boot_up <- apply(samp,1,quantile,up_bound, na.rm=T)
+ } else{
+ boot_se <- boot_low <- boot_up <- NA
+ }
+ return(data.frame(Predicted=est,
+ SE=boot_se,
+ lower=boot_low,
+ upper=boot_up))
+
+ } else {
+ codes <- apply(dm$z,1,function(x) paste(x,collapse=""))
+ colnames(psi_est) <- paste('psi[',codes,']',sep='')
+ if(se.fit){
+ boot_se <- apply(samp,c(1,2),sd, na.rm=T)
+ boot_low <- apply(samp,c(1,2),quantile,low_bound, na.rm=T)
+ boot_up <- apply(samp,c(1,2),quantile,up_bound, na.rm=T)
+ colnames(boot_se) <- colnames(boot_low) <- colnames(boot_up) <-
+ colnames(psi_est)
+ } else {
+ boot_se <- boot_low <- boot_up <- NA
+ }
+ return(list(Predicted=psi_est,
+ SE=boot_se,
+ lower=boot_low,
+ upper=boot_up))
+ }
+ }
+
+ if(type=="det"){
+ S <- dm$S; dmDet <- dm$dmDet
+ dStart <- dm$dStart; dStop <- dm$dStop
+
+ out <- list()
+ for (i in 1:S){
+ #Subset estimate to species i
+ inds <- dStart[i]:dStop[i]
+ new_est <- object@estimates@estimates$det
+ new_est@estimates <- coef(object)[inds]
+ new_est@fixed <- 1:length(inds)
+ if(se.fit){
+ new_est@covMat <- vcov(object)[inds,inds,drop=FALSE]
+ new_est@covMatBS <- object@covMatBS[inds,inds,drop=FALSE]
+ } else{
+ new_est@covMat <- matrix(NA, nrow=length(inds), ncol=length(inds))
+ new_est@covMatBS <- matrix(NA, nrow=length(inds), ncol=length(inds))
+ }
+
+ prmat <- t(apply(dmDet[[i]], 1, function(x){
+ bt <- backTransform(linearComb(new_est, x))
+ if(!se.fit){
+ return(c(Predicted=bt@estimate, SE=NA, lower=NA, upper=NA))
+ }
+ ci <- confint(bt, level=level)
+ names(ci) <- c("lower", "upper")
+ c(Predicted=bt@estimate, SE=SE(bt), ci)
+ }))
+ rownames(prmat) <- NULL
+ out[[i]] <- as.data.frame(prmat)
+ }
+ names(out) <- names(object@data@ylist)
+ if(!is.null(species)){
+ return(out[[species]])
+ }
+ return(out)
+ }
+ stop("type must be 'det' or 'state'")
+})
+
+
+# occuMS-----------------------------------------------------------------------
+
+# bespoke predict method since it requires bootstrapping
+
+# This method is used by simulate by not by predict
+setMethod("get_formula", "unmarkedFitOccuMS", function(object, type, ...){
+ switch(type, psi=object@psiformulas, phi=object@phiformulas,
+ det=object@detformulas)
+})
+
+setMethod("predict", "unmarkedFitOccuMS",
+ function(object, type, newdata,
+ #backTransform = TRUE, na.rm = TRUE,
+ #appendData = FALSE,
+ se.fit=TRUE, level=0.95, nsims=100, ...)
+{
+
+ #Process input---------------------------------------------------------------
+ if(! type %in% c("psi","phi", "det")){
+ stop("type must be 'psi', 'phi', or 'det'")
+ }
+
+ if(is.null(hessian(object))){
+ se.fit = FALSE
+ }
+
+ if(missing(newdata)){
+ newdata <- NULL
+ } else {
+ if(! class(newdata) %in% c('data.frame')){
+ stop("newdata must be a data frame")
+ }
+ }
+
+ S <- object@data@numStates
+ gd <- getDesign(object@data,object@psiformulas,object@phiformulas,
+ object@detformulas, object@parameterization, na.rm=F,
+ newdata=newdata, type=type)
+
+ #Index guide used to organize p values
+ guide <- matrix(NA,nrow=S,ncol=S)
+ guide <- lower.tri(guide,diag=TRUE)
+ guide[,1] <- FALSE
+ guide <- which(guide,arr.ind=TRUE)
+ #----------------------------------------------------------------------------
+
+ #Utility functions-----------------------------------------------------------
+ #Get matrix of linear predictor values
+ get_lp <- function(params, dm_list, ind){
+ L <- length(dm_list)
+ out <- matrix(NA,nrow(dm_list[[1]]),L)
+ for (i in 1:L){
+ out[,i] <- dm_list[[i]] %*% params[ind[i,1]:ind[i,2]]
+ }
+ out
+ }
+
+ #Get SE/CIs for conditional binomial using delta method
+ split_estimate <- function(object, estimate, inds, se.fit){
+ out <- estimate
+ out@estimates <- coef(object)[inds]
+ if(se.fit){
+ out@covMat <- vcov(object)[inds,inds,drop=FALSE]
+ } else{
+ out@covMat <- matrix(NA, nrow=length(inds), ncol=length(inds))
+ }
+ out
+ }
+
+ lc_to_predict <- function(object, estimate, inds, dm, level, se.fit){
+
+ new_est <- split_estimate(object, estimate, inds[1]:inds[2], se.fit)
+
+ out <- t(apply(dm, 1, function(x){
+ bt <- backTransform(linearComb(new_est, x))
+ if(!se.fit) return(c(Predicted=bt@estimate, SE=NA, lower=NA, upper=NA))
+ ci <- confint(bt, level=level)
+ names(ci) <- c("lower", "upper")
+ c(Predicted=bt@estimate, SE=SE(bt), ci)
+ }))
+ rownames(out) <- NULL
+ as.data.frame(out)
+ }
+
+
+ #Calculate row-wise multinomial logit prob
+ #implemented in C++ below as it is quite slow
+ get_mlogit_R <- function(lp_mat){
+ if(type == 'psi'){
+ out <- cbind(1,exp(lp_mat))
+ out <- out/rowSums(out)
+ out <- out[,-1]
+ } else if(type == 'phi'){ #doesn't work
+ np <- nrow(lp_mat)
+ out <- matrix(NA,np,ncol(lp_mat))
+ ins <- outer(1:S, 1:S, function(i,j) i!=j)
+ for (i in 1:np){
+ phimat <- diag(S)
+ phimat[ins] <- exp(lp_mat[i,])
+ phimat <- t(phimat)
+ phimat <- phimat/rowSums(phimat)
+ out[i,] <- phimat[ins]
+ }
+ } else {
+ R <- nrow(lp_mat)
+ out <- matrix(NA,R,ncol(lp_mat))
+ for (i in 1:R){
+ sdp <- matrix(0,nrow=S,ncol=S)
+ sdp[guide] <- exp(lp_mat[i,])
+ sdp[,1] <- 1
+ sdp <- sdp/rowSums(sdp)
+ out[i,] <- sdp[guide]
+ }
+ }
+ out
+ }
+
+ get_mlogit <- function(lp_mat){
+ .Call("get_mlogit",
+ lp_mat, type, S, guide-1)
+ }
+
+ #----------------------------------------------------------------------------
+
+ if(type=="psi"){
+ dm_list <- gd$dm_state
+ ind <- gd$state_ind
+ est <- object@estimates@estimates$state
+ } else if(type=="phi"){
+ dm_list <- gd$dm_phi
+ ind <- gd$phi_ind
+ est <- object@estimates@estimates$transition
+ } else {
+ dm_list <- gd$dm_det
+ ind <- gd$det_ind
+ est <- object@estimates@estimates$det
+ }
+
+ P <- length(dm_list)
+
+ low_bound <- (1-level)/2
+ z <- qnorm(low_bound,lower.tail=F)
+
+ out <- vector("list", P)
+ names(out) <- names(dm_list)
+
+ if(object@parameterization == 'condbinom'){
+ out <- lapply(1:length(dm_list), function(i){
+ lc_to_predict(object, est, ind[i,], dm_list[[i]], level, se.fit)
+ })
+ names(out) <- names(dm_list)
+ return(out)
+
+ } else if (object@parameterization == "multinomial"){
+ lp <- get_lp(coef(object), dm_list, ind)
+ pred <- get_mlogit(lp)
+
+ M <- nrow(pred)
+ upr <- lwr <- se <- matrix(NA,M,P)
+
+ if(se.fit){
+ message('Bootstrapping confidence intervals with',nsims,'samples')
+
+ sig <- vcov(object)
+ param_mean <- coef(object)
+ rparam <- mvrnorm(nsims, param_mean, sig)
+
+ get_pr <- function(i){
+ lp <- get_lp(rparam[i,], dm_list, ind)
+ get_mlogit(lp)
+ }
+ samp <- sapply(1:nsims, get_pr, simplify='array')
+
+ for (i in 1:M){
+ for (j in 1:P){
+ dat <- samp[i,j,]
+ se[i,j] <- sd(dat, na.rm=TRUE)
+ quants <- quantile(dat, c(low_bound, (1-low_bound)),na.rm=TRUE)
+ lwr[i,j] <- quants[1]
+ upr[i,j] <- quants[2]
+ }
+ }
+
+ }
+ }
+
+ for (i in 1:P){
+ out[[i]] <- data.frame(Predicted=pred[,i], SE=se[,i],
+ lower=lwr[,i], upper=upr[,i])
+ }
+
+ out
+})
diff --git a/R/ranef.R b/R/ranef.R
index 454dc4f..9dca184 100644
--- a/R/ranef.R
+++ b/R/ranef.R
@@ -98,7 +98,7 @@ setMethod("ranef", "unmarkedFitOccuMS", function(object, ...)
N <- numSites(object@data)
S <- object@data@numStates
- psi <- predict(object, "state", se.fit=F)
+ psi <- predict(object, "psi", se.fit=F)
psi <- sapply(psi, function(x) x$Predicted)
z <- 0:(S-1)
@@ -113,14 +113,15 @@ setMethod("ranef", "unmarkedFitOccuMS", function(object, ...)
psi <- cbind(1-rowSums(psi), psi)
guide <- matrix(NA,nrow=S,ncol=S)
- guide <- lower.tri(guide,diag=T)
+ guide <- lower.tri(guide,diag=TRUE)
guide[,1] <- FALSE
- guide <- which(guide,arr.ind=T)
+ guide <- which(guide,arr.ind=TRUE)
for (i in 1:N){
f <- psi[i,]
g <- rep(1, S)
p_raw <- sapply(p_all, function(x) x[i,])
for (j in 1:nrow(p_raw)){
+ if(any(is.na(p_raw[j,])) | is.na(y[i,j])) next
sdp <- matrix(0, nrow=S, ncol=S)
sdp[guide] <- p_raw[j,]
sdp[,1] <- 1 - rowSums(sdp)
@@ -142,6 +143,7 @@ setMethod("ranef", "unmarkedFitOccuMS", function(object, ...)
p_raw <- sapply(p_all, function(x) x[i,])
for (j in 1:nrow(p_raw)){
probs <- p_raw[j,]
+ if(any(is.na(probs)) | is.na(y[i,j])) next
sdp <- matrix(0, nrow=S, ncol=S)
sdp[1,1] <- 1
sdp[2,1:2] <- c(1-probs[1], probs[1])
@@ -828,9 +830,10 @@ setMethod("ranef", "unmarkedFitOccuTTD",
})
-#Common function for DSO and MMO
-postMultinomOpen <- function(object){
-
+# DSO and MMO
+setMethod("ranef", "unmarkedFitDailMadsen",
+ function(object, ...)
+{
dyn <- object@dynamics
formlist <- object@formlist
formula <- as.formula(paste(unlist(formlist), collapse=" "))
@@ -984,23 +987,6 @@ postMultinomOpen <- function(object){
}
}
}
- post
-
-}
-
-
-setMethod("ranef", "unmarkedFitDSO",
- function(object, ...)
-{
- post <- postMultinomOpen(object)
- new("unmarkedRanef", post=post)
-})
-
-
-setMethod("ranef", "unmarkedFitMMO",
- function(object, ...)
-{
- post <- postMultinomOpen(object)
new("unmarkedRanef", post=post)
})
diff --git a/R/simulate.R b/R/simulate.R
new file mode 100644
index 0000000..a8887cb
--- /dev/null
+++ b/R/simulate.R
@@ -0,0 +1,558 @@
+get_vars <- function(inp){
+ if(is.list(inp)){
+ out <- unique(unlist(lapply(inp, all.vars)))
+ } else {
+ out <- all.vars(inp)
+ }
+ names(out) <- out
+ out
+}
+
+var_data <- function(var, guide, n){
+ out <- rep(NA, n)
+ gv <- guide[[var]]
+ if(is.null(gv)){
+ out <- stats::rnorm(n, 0, 1)
+ } else if(inherits(gv, "factor")){
+ levs <- levels(gv)
+ out <- factor(sample(levs, n, replace=TRUE), levels=levs)
+ } else{
+ gv$n <- n
+ out <- do.call(gv$dist, gv[!names(gv)=="dist"])
+ }
+ out
+}
+
+generate_data <- function(formulas, guide, n){
+ vars <- get_vars(formulas)
+ if(length(vars)==0) return(NULL)
+ as.data.frame(lapply(vars, var_data, guide=guide, n=n))
+}
+
+capitalize <- function(inp){
+ paste0(toupper(substring(inp,1,1)),
+ substring(inp,2,nchar(inp)))
+}
+
+parse_func_name <- function(inp){
+ if(!is.character(inp)){
+ stop("Argument must be a character string", call.=FALSE)
+ }
+ capitalize(inp)
+}
+
+blank_umFit <- function(fit_function){
+ type <- parse_func_name(fit_function)
+ type <- ifelse(type=="Pcount", "PCount", type)
+ type <- ifelse(type=="MultinomPois", "MPois", type)
+ type <- ifelse(type=="Distsamp", "DS", type)
+ type <- ifelse(type=="Colext", "ColExt", type)
+ type <- ifelse(type=="Gdistsamp", "GDS", type)
+ type <- ifelse(type=="Gpcount", "GPC", type)
+ type <- ifelse(type=="Gmultmix", "GMM", type)
+ type <- ifelse(type=="PcountOpen", "PCO", type)
+ type <- ifelse(type=="DistsampOpen", "DSO", type)
+ type <- ifelse(type=="MultmixOpen", "MMO", type)
+ type <- ifelse(type=="Gdistremoval", "GDR", type)
+ type <- paste0("unmarkedFit", type)
+ new(type)
+}
+
+
+setMethod("simulate", "character",
+ function(object, nsim=1, seed=NULL, formulas, coefs=NULL, design, guide=NULL, ...){
+ model <- blank_umFit(object)
+ fit <- suppressWarnings(simulate_fit(model, formulas, guide, design, ...))
+ coefs <- check_coefs(coefs, fit)
+ #fit <- replace_sigma(coefs, fit)
+ coefs <- generate_random_effects(coefs, fit)
+ fit <- replace_estimates(fit, coefs)
+ ysims <- suppressWarnings(simulate(fit, nsim))
+ umf <- fit@data
+ # fix this
+ umfs <- lapply(ysims, function(x){
+ if(object=="occuMulti"){
+ umf@ylist <- x
+ } else if(object=="gdistremoval"){
+ umf@yDistance=x$yDistance
+ umf@yRemoval=x$yRemoval
+ } else {
+ umf@y <- x
+ }
+ umf
+ })
+ if(length(umfs)==1) umfs <- umfs[[1]]
+ umfs
+})
+
+# Insert specified random effects SD into proper S4 slot in model object
+# This is mostly needed by GDR which uses the SD to calculate
+# N with E_loglam (this is currently disabled so the function is not needed)
+#replace_sigma <- function(coefs, fit){
+# required_subs <- names(fit@estimates@estimates)
+# formulas <- sapply(names(fit), function(x) get_formula(fit, x))
+# rand <- lapply(formulas, lme4::findbars)
+# if(!all(sapply(rand, is.null))){
+# rvar <- lapply(rand, function(x) unlist(lapply(x, all.vars)))
+# for (i in required_subs){
+# if(!is.null(rand[[i]][[1]])){
+# signame <- rvar[[i]]
+# old_coefs <- coefs[[i]]
+# fit@estimates@estimates[[i]]@randomVarInfo$estimates <- coefs[[i]][[signame]]
+# }
+# }
+# }
+# fit
+#}
+
+generate_random_effects <- function(coefs, fit){
+ required_subs <- names(fit@estimates@estimates)
+ formulas <- sapply(names(fit), function(x) get_formula(fit, x))
+ rand <- lapply(formulas, lme4::findbars)
+ if(!all(sapply(rand, is.null))){
+ rvar <- lapply(rand, function(x) unlist(lapply(x, all.vars)))
+ for (i in required_subs){
+ if(!is.null(rand[[i]][[1]])){
+ signame <- rvar[[i]]
+ old_coefs <- coefs[[i]]
+ new_coefs <- old_coefs[names(old_coefs)!=signame]
+
+ # Find levels of factor variable
+ if(signame %in% names(siteCovs(fit@data))){
+ lvldata <- siteCovs(fit@data)[[signame]]
+ } else if(signame %in% names(obsCovs(fit@data))){
+ lvldata <- obsCovs(fit@data)[[signame]]
+ } else if(methods::.hasSlot(fit@data, "yearlySiteCovs") && signame %in% names(yearlySiteCovs(fit@data))){
+ lvldata <- yearlySiteCovs(fit@data)[[signame]]
+ } else {
+ stop("Random effect covariate missing from data", call.=FALSE)
+ }
+
+ if(!is.factor(lvldata)){
+ stop("Random effect covariates must be specified as factors with guide argument", call.=FALSE)
+ }
+ b <- stats::rnorm(length(levels(lvldata)), 0, old_coefs[signame])
+ names(b) <- rep(paste0("b_",i), length(b))
+ new_coefs <- c(new_coefs, b)
+ coefs[[i]] <- new_coefs
+ }
+ }
+ }
+ coefs
+}
+
+
+setGeneric("get_umf_components", function(object, ...) standardGeneric("get_umf_components"))
+
+setMethod("get_umf_components", "unmarkedFit",
+ function(object, formulas, guide, design, ...){
+ sc <- generate_data(formulas$state, guide, design$M)
+ oc <- generate_data(formulas$det, guide, design$J*design$M)
+ yblank <- matrix(0, design$M, design$J)
+ list(y=yblank, siteCovs=sc, obsCovs=oc)
+})
+
+
+setGeneric("simulate_fit", function(object, ...) standardGeneric("simulate_fit"))
+
+setMethod("simulate_fit", "unmarkedFitOccu",
+ function(object, formulas, guide, design, ...){
+ parts <- get_umf_components(object, formulas, guide, design, ...)
+ umf <- unmarkedFrameOccu(y=parts$y, siteCovs=parts$siteCovs,
+ obsCovs=parts$obsCovs)
+ occu(as.formula(paste(deparse(formulas$det), deparse(formulas$state))),
+ data=umf, se=FALSE, control=list(maxit=1))
+})
+
+setMethod("simulate_fit", "unmarkedFitPCount",
+ function(object, formulas, guide, design, ...){
+ parts <- get_umf_components(object, formulas, guide, design, ...)
+ umf <- unmarkedFramePCount(y=parts$y, siteCovs=parts$siteCovs,
+ obsCovs=parts$obsCovs)
+ args <- list(...)
+ K <- ifelse(is.null(args$K), 100, args$K)
+ mixture <- ifelse(is.null(args$mixture), "P", args$mixture)
+ pcount(as.formula(paste(deparse(formulas$det), deparse(formulas$state))),
+ data=umf, mixture=mixture, K=K, se=FALSE, control=list(maxit=1))
+})
+
+setMethod("simulate_fit", "unmarkedFitOccuRN",
+ function(object, formulas, guide, design, ...){
+ parts <- get_umf_components(object, formulas, guide, design, ...)
+ umf <- unmarkedFrameOccu(y=parts$y, siteCovs=parts$siteCovs,
+ obsCovs=parts$obsCovs)
+ occuRN(as.formula(paste(deparse(formulas$det), deparse(formulas$state))),
+ data=umf, se=FALSE, control=list(maxit=1))
+})
+
+
+setMethod("get_umf_components", "unmarkedFitMPois",
+ function(object, formulas, guide, design, ...){
+ args <- list(...)
+ sc <- generate_data(formulas$state, guide, design$M)
+ oc <- generate_data(formulas$det, guide, design$J*design$M)
+ J <- ifelse(args$type=="double", 3, design$J)
+ yblank <- matrix(0, design$M, design$J)
+ list(y=yblank, siteCovs=sc, obsCovs=oc)
+})
+
+setMethod("simulate_fit", "unmarkedFitMPois",
+ function(object, formulas, guide, design, ...){
+ parts <- get_umf_components(object, formulas, guide, design, ...)
+ args <- list(...)
+ type <- ifelse(is.null(args$type), "removal", args$type)
+ umf <- unmarkedFrameMPois(y=parts$y, siteCovs=parts$siteCovs,
+ obsCovs=parts$obsCovs, type=type)
+ multinomPois(as.formula(paste(deparse(formulas$det), deparse(formulas$state))),
+ data=umf, se=FALSE, control=list(maxit=1))
+})
+
+setMethod("get_umf_components", "unmarkedFitDS",
+ function(object, formulas, guide, design, ...){
+ #args <- list(...)
+ sc <- generate_data(formulas$state, guide, design$M)
+ sc2 <- generate_data(formulas$det, guide, design$M)
+ dat <- list(sc, sc2)
+ keep <- sapply(dat, function(x) !is.null(x))
+ dat <- dat[keep]
+ sc <- do.call(cbind, dat)
+ yblank <- matrix(0, design$M, design$J)
+ list(y=yblank, siteCovs=sc)
+})
+
+setMethod("simulate_fit", "unmarkedFitDS",
+ function(object, formulas, guide, design, ...){
+ parts <- get_umf_components(object, formulas, guide, design, ...)
+ args <- list(...)
+ if(is.null(args$tlength)) args$tlength <- 0
+ umf <- unmarkedFrameDS(y=parts$y, siteCovs=parts$siteCovs,
+ tlength=args$tlength, survey=args$survey, unitsIn=args$unitsIn,
+ dist.breaks=args$dist.breaks)
+ keyfun <- ifelse(is.null(args$keyfun), "halfnorm", args$keyfun)
+ output <- ifelse(is.null(args$output), "density", args$output)
+ unitsOut <- ifelse(is.null(args$unitsOut), "ha", args$unitsOut)
+
+ distsamp(as.formula(paste(deparse(formulas$det), deparse(formulas$state))),
+ data=umf, se=FALSE, control=list(maxit=1), keyfun=keyfun,
+ output=output, unitsOut=unitsOut)
+})
+
+
+setMethod("get_umf_components", "unmarkedFitColExt",
+ function(object, formulas, guide, design, ...){
+ sc <- generate_data(formulas$psi, guide, design$M)
+ ysc <- generate_data(list(formulas$col, formulas$ext), guide, design$M*design$T)
+ oc <- generate_data(formulas$det, guide, design$J*design$M*design$T)
+ yblank <- matrix(0, design$M, design$T*design$J)
+ list(y=yblank, siteCovs=sc, yearlySiteCovs=ysc, obsCovs=oc)
+})
+
+
+setMethod("simulate_fit", "unmarkedFitColExt",
+ function(object, formulas, guide, design, ...){
+ parts <- get_umf_components(object, formulas, guide, design, ...)
+ umf <- unmarkedMultFrame(y=parts$y, siteCovs=parts$siteCovs,
+ yearlySiteCovs=parts$yearlySiteCovs,
+ obsCovs=parts$obsCovs, numPrimary=design$T)
+ colext(psiformula=formulas$psi, gammaformula=formulas$col,
+ epsilonformula=formulas$ext,pformula=formulas$det,
+ data=umf, se=FALSE, control=list(maxit=1))
+})
+
+setMethod("get_umf_components", "unmarkedFitOccuTTD",
+ function(object, formulas, guide, design, ...){
+ sc <- generate_data(formulas$psi, guide, design$M)
+ ysc <- NULL
+ if(design$T>1){
+ ysc <- generate_data(list(formulas$col, formulas$ext), guide, design$M*design$T)
+ }
+ oc <- generate_data(formulas$det, guide, design$J*design$M*design$T)
+ yblank <- matrix(0, design$M, design$T*design$J)
+ list(y=yblank, siteCovs=sc, yearlySiteCovs=ysc, obsCovs=oc)
+})
+
+
+setMethod("simulate_fit", "unmarkedFitOccuTTD",
+ function(object, formulas, guide, design, ...){
+ if(is.null(design$T)) design$T <- 1
+ parts <- get_umf_components(object, formulas, guide, design, ...)
+ args <- list(...)
+ umf <- unmarkedFrameOccuTTD(y=parts$y,
+ surveyLength=args$surveyLength,
+ siteCovs=parts$siteCovs,
+ yearlySiteCovs=parts$yearlySiteCovs,
+ obsCovs=parts$obsCovs, numPrimary=design$T)
+ linkPsi <- ifelse(is.null(args$linkPsi), "logit", args$linkPsi)
+ ttdDist <- ifelse(is.null(args$ttdDist), "exp", args$ttdDist)
+ occuTTD(psiformula=formulas$psi, gammaformula=formulas$col,
+ epsilonformula=formulas$ext,detformula=formulas$det,
+ linkPsi=linkPsi, ttdDist=ttdDist,
+ data=umf, se=FALSE, control=list(maxit=1))
+})
+
+
+setMethod("get_umf_components", "unmarkedFitGMM",
+ function(object, formulas, guide, design, ...){
+ sc <- generate_data(formulas$lambda, guide, design$M)
+ ysc <- generate_data(formulas$phi, guide, design$M*design$T)
+ yblank <- matrix(0, design$M, design$T*design$J)
+ list(y=yblank, siteCovs=sc, yearlySiteCovs=ysc)
+})
+
+
+setMethod("simulate_fit", "unmarkedFitGDS",
+ function(object, formulas, guide, design, ...){
+ parts <- get_umf_components(object, formulas, guide, design, ...)
+ args <- list(...)
+ if(args$survey=="line"){
+ umf <- unmarkedFrameGDS(y=parts$y, siteCovs=parts$siteCovs,
+ yearlySiteCovs=parts$yearlySiteCovs,
+ numPrimary=design$T,
+ tlength=args$tlength, survey=args$survey,
+ unitsIn=args$unitsIn, dist.breaks=args$dist.breaks)
+ } else if(args$survey=="point"){
+ umf <- unmarkedFrameGDS(y=parts$y, siteCovs=parts$siteCovs,
+ yearlySiteCovs=parts$yearlySiteCovs,
+ numPrimary=design$T, survey=args$survey,
+ unitsIn=args$unitsIn, dist.breaks=args$dist.breaks)
+ }
+
+ keyfun <- ifelse(is.null(args$keyfun), "halfnorm", args$keyfun)
+ output <- ifelse(is.null(args$output), "density", args$output)
+ unitsOut <- ifelse(is.null(args$unitsOut), "ha", args$unitsOut)
+ mixture <- ifelse(is.null(args$mixture), "P", args$mixture)
+ K <- ifelse(is.null(args$K), 100, args$K)
+
+ gdistsamp(lambdaformula=formulas$lambda, phiformula=formulas$phi,
+ pformula=formulas$det, data=umf, keyfun=keyfun, output=output,
+ unitsOut=unitsOut, mixture=mixture, K=K,
+ se=FALSE, control=list(maxit=1))
+})
+
+setMethod("simulate_fit", "unmarkedFitGPC",
+ function(object, formulas, guide, design, ...){
+ parts <- get_umf_components(object, formulas, guide, design, ...)
+ args <- list(...)
+ umf <- unmarkedFrameGPC(y=parts$y, siteCovs=parts$siteCovs,
+ yearlySiteCovs=parts$yearlySiteCovs,
+ numPrimary=design$T)
+ K <- ifelse(is.null(args$K), 100, args$K)
+ mixture <- ifelse(is.null(args$mixture), "P", args$mixture)
+
+ gpcount(lambdaformula=formulas$lambda, phiformula=formulas$phi,
+ pformula=formulas$det, data=umf, mixture=mixture, K=K,
+ se=FALSE, control=list(maxit=1))
+})
+
+
+setMethod("simulate_fit", "unmarkedFitGMM",
+ function(object, formulas, guide, design, ...){
+ parts <- get_umf_components(object, formulas, guide, design, ...)
+ args <- list(...)
+ umf <- unmarkedFrameGMM(y=parts$y, siteCovs=parts$siteCovs,
+ yearlySiteCovs=parts$yearlySiteCovs,
+ numPrimary=design$T, type=args$type)
+ K <- ifelse(is.null(args$K), 100, args$K)
+ mixture <- ifelse(is.null(args$mixture), "P", args$mixture)
+
+ gmultmix(lambdaformula=formulas$lambda, phiformula=formulas$phi,
+ pformula=formulas$det, data=umf, mixture=mixture, K=K,
+ se=FALSE, control=list(maxit=1))
+})
+
+
+setMethod("get_umf_components", "unmarkedFitDailMadsen",
+ function(object, formulas, guide, design, ...){
+ sc <- generate_data(formulas$lambda, guide, design$M)
+ ysc <- generate_data(list(formulas$gamma, formulas$omega), guide, design$M*design$T)
+ oc <- generate_data(formulas$det, guide, design$M*design$T*design$J)
+ yblank <- matrix(0, design$M, design$T*design$J)
+ list(y=yblank, siteCovs=sc, yearlySiteCovs=ysc, obsCovs=oc)
+})
+
+setMethod("simulate_fit", "unmarkedFitPCO",
+ function(object, formulas, guide, design, ...){
+ parts <- get_umf_components(object, formulas, guide, design, ...)
+ args <- list(...)
+ if(is.null(args$primaryPeriod)){
+ args$primaryPeriod <- matrix(1:design$T, design$M, design$T, byrow=TRUE)
+ }
+ umf <- unmarkedFramePCO(y=parts$y, siteCovs=parts$siteCovs,
+ yearlySiteCovs=parts$yearlySiteCovs,
+ numPrimary=design$T, primaryPeriod=args$primaryPeriod)
+ K <- ifelse(is.null(args$K), 100, args$K)
+ mixture <- ifelse(is.null(args$mixture), "P", args$mixture)
+ dynamics <- ifelse(is.null(args$dynamics), "constant", args$dynamics)
+ fix <- ifelse(is.null(args$fix), "none", args$fix)
+ immigration <- ifelse(is.null(args$immigration), FALSE, args$immigration)
+ iotaformula <- args$iotaformula
+ if(is.null(iotaformula)) iotaformula <- ~1
+
+ pcountOpen(lambdaformula=formulas$lambda, gammaformula=formulas$gamma,
+ omegaformula=formulas$omega, pformula=formulas$det,
+ data=umf, mixture=mixture, K=K, dynamics=dynamics, fix=fix,
+ se=FALSE, method='SANN', control=list(maxit=1), immigration=immigration,
+ iotaformula=iotaformula)
+})
+
+setMethod("simulate_fit", "unmarkedFitMMO",
+ function(object, formulas, guide, design, ...){
+ parts <- get_umf_components(object, formulas, guide, design, ...)
+ args <- list(...)
+ if(is.null(args$primaryPeriod)){
+ args$primaryPeriod <- matrix(1:design$T, design$M, design$T, byrow=TRUE)
+ }
+ umf <- unmarkedFrameMMO(y=parts$y, siteCovs=parts$siteCovs,
+ yearlySiteCovs=parts$yearlySiteCovs,
+ type=args$type,
+ numPrimary=design$T, primaryPeriod=args$primaryPeriod)
+ K <- ifelse(is.null(args$K), 100, args$K)
+ mixture <- ifelse(is.null(args$mixture), "P", args$mixture)
+ dynamics <- ifelse(is.null(args$dynamics), "constant", args$dynamics)
+ fix <- ifelse(is.null(args$fix), "none", args$fix)
+ immigration <- ifelse(is.null(args$immigration), FALSE, args$immigration)
+ iotaformula <- args$iotaformula
+ if(is.null(iotaformula)) iotaformula <- ~1
+
+ multmixOpen(lambdaformula=formulas$lambda, gammaformula=formulas$gamma,
+ omegaformula=formulas$omega, pformula=formulas$det,
+ data=umf, mixture=mixture, K=K, dynamics=dynamics, fix=fix,
+ se=FALSE, method='SANN', control=list(maxit=1), immigration=immigration,
+ iotaformula=iotaformula)
+})
+
+setMethod("get_umf_components", "unmarkedFitDSO",
+ function(object, formulas, guide, design, ...){
+ sc <- generate_data(formulas$lambda, guide, design$M)
+ ysc <- generate_data(list(formulas$gamma, formulas$omega, formulas$det),
+ guide, design$M*design$T)
+ yblank <- matrix(0, design$M, design$T*design$J)
+ list(y=yblank, siteCovs=sc, yearlySiteCovs=ysc)
+})
+
+setMethod("simulate_fit", "unmarkedFitDSO",
+ function(object, formulas, guide, design, ...){
+ parts <- get_umf_components(object, formulas, guide, design, ...)
+ args <- list(...)
+ if(is.null(args$primaryPeriod)){
+ args$primaryPeriod <- matrix(1:design$T, design$M, design$T, byrow=TRUE)
+ }
+ if(args$survey=="line"){
+ umf <- unmarkedFrameDSO(y=parts$y, siteCovs=parts$siteCovs,
+ yearlySiteCovs=parts$yearlySiteCovs,
+ tlength=args$tlength, survey=args$survey,
+ unitsIn=args$unitsIn, dist.breaks=args$dist.breaks,
+ numPrimary=design$T, primaryPeriod=args$primaryPeriod)
+ } else if(args$survey == "point"){
+ umf <- unmarkedFrameDSO(y=parts$y, siteCovs=parts$siteCovs,
+ yearlySiteCovs=parts$yearlySiteCovs,survey=args$survey,
+ unitsIn=args$unitsIn, dist.breaks=args$dist.breaks,
+ numPrimary=design$T, primaryPeriod=args$primaryPeriod)
+ }
+ K <- ifelse(is.null(args$K), 100, args$K)
+ keyfun <- ifelse(is.null(args$keyfun), "halfnorm", args$keyfun)
+ output <- ifelse(is.null(args$output), "density", args$output)
+ unitsOut <- ifelse(is.null(args$unitsOut), "ha", args$unitsOut)
+ mixture <- ifelse(is.null(args$mixture), "P", args$mixture)
+ dynamics <- ifelse(is.null(args$dynamics), "constant", args$dynamics)
+ fix <- ifelse(is.null(args$fix), "none", args$fix)
+ immigration <- ifelse(is.null(args$immigration), FALSE, args$immigration)
+ iotaformula <- args$iotaformula
+ if(is.null(iotaformula)) iotaformula <- ~1
+ distsampOpen(lambdaformula=formulas$lambda, gammaformula=formulas$gamma,
+ omegaformula=formulas$omega, pformula=formulas$det,
+ keyfun=keyfun, unitsOut=unitsOut, output=output,
+ data=umf, mixture=mixture, K=K, dynamics=dynamics, fix=fix,
+ se=FALSE, method='SANN', control=list(maxit=1), immigration=immigration,
+ iotaformula=iotaformula)
+})
+
+
+setMethod("get_umf_components", "unmarkedFitOccuMulti",
+ function(object, formulas, guide, design, ...){
+ sc <- generate_data(lapply(formulas$state, as.formula), guide, design$M)
+ oc <- generate_data(lapply(formulas$det, as.formula), guide, design$J*design$M)
+ nspecies <- length(formulas$det)
+ yblank <- lapply(1:nspecies, function(x) matrix(0, design$M, design$J))
+ list(y=yblank, siteCovs=sc, obsCovs=oc)
+})
+
+setMethod("simulate_fit", "unmarkedFitOccuMulti",
+ function(object, formulas, guide, design, ...){
+ parts <- get_umf_components(object, formulas, guide, design, ...)
+ args <- list(...)
+ if(is.null(args$maxOrder)) args$maxOrder <- length(parts$y)
+ umf <- unmarkedFrameOccuMulti(y=parts$y, siteCovs=parts$siteCovs,
+ obsCovs=parts$obsCovs, maxOrder=args$maxOrder)
+ occuMulti(formulas$det, formulas$state, data=umf, maxOrder=args$maxOrder,
+ se=FALSE, control=list(maxit=1))
+})
+
+setMethod("get_umf_components", "unmarkedFitOccuMS",
+ function(object, formulas, guide, design, ...){
+ sc <- generate_data(lapply(formulas$state, as.formula), guide, design$M)
+ ysc <- NULL
+ if(!is.null(formulas$phi)){
+ ysc <- generate_data(lapply(formulas$phi, as.formula), guide, design$M*design$T*design$J)
+ }
+ oc <- generate_data(lapply(formulas$det, as.formula), guide, design$J*design$M)
+ nspecies <- length(formulas$det)
+ yblank <- matrix(0, design$M, design$T*design$J)
+ yblank[1,1] <- 2 # To bypass sanity checker in unmarkedFrameOccuMS
+ list(y=yblank, siteCovs=sc, yearlySiteCovs=ysc, obsCovs=oc)
+})
+
+setMethod("simulate_fit", "unmarkedFitOccuMS",
+ function(object, formulas, guide, design, ...){
+ if(is.null(design$T)) design$T <- 1
+ parts <- get_umf_components(object, formulas, guide, design, ...)
+ args <- list(...)
+ umf <- unmarkedFrameOccuMS(y=parts$y, siteCovs=parts$siteCovs,
+ yearlySiteCovs=parts$yearlySiteCovs,
+ obsCovs=parts$obsCovs, numPrimary=design$T)
+ if(is.null(args$parameterization)) args$parameterization <- "multinomial"
+ occuMS(formulas$det, formulas$state, formulas$phi, data=umf,
+ parameterization=args$parameterization,
+ se=FALSE, control=list(maxit=1))
+})
+
+setMethod("get_umf_components", "unmarkedFitGDR",
+ function(object, formulas, guide, design, ...){
+ if(any(! c("M","Jdist","Jrem") %in% names(design))){
+ stop("Required design components are M, Jdist, and Jrem")
+ }
+ sc <- generate_data(list(formulas$lambda, formulas$dist), guide, design$M)
+ ysc <- NULL
+ if(design$T > 1){
+ ysc <- generate_data(formulas$phi, guide, design$M*design$T)
+ }
+ oc <- generate_data(formulas$rem, guide, design$M*design$T*design$Jrem)
+
+ list(yDistance=matrix(0, design$M, design$T*design$Jdist),
+ yRemoval=matrix(0, design$M, design$T*design$Jrem),
+ siteCovs=sc, yearlySiteCovs=ysc, obsCovs=oc)
+})
+
+setMethod("simulate_fit", "unmarkedFitGDR",
+ function(object, formulas, guide, design, ...){
+ if(is.null(design$T)) design$T <- 1
+ if(is.null(formulas$phi)) formulas$phi <- ~1
+ parts <- get_umf_components(object, formulas, guide, design, ...)
+ args <- list(...)
+ umf <- unmarkedFrameGDR(yDistance=parts$yDistance, yRemoval=parts$yRemoval,
+ numPrimary=design$T, siteCovs=parts$siteCovs,
+ obsCovs=parts$obsCovs, yearlySiteCovs=parts$yearlySiteCovs,
+ dist.breaks=args$dist.breaks, unitsIn=args$unitsIn,
+ period.lengths=args$period.lengths)
+
+ keyfun <- ifelse(is.null(args$keyfun), "halfnorm", args$keyfun)
+ output <- ifelse(is.null(args$output), "density", args$output)
+ unitsOut <- ifelse(is.null(args$unitsOut), "ha", args$unitsOut)
+ mixture <- ifelse(is.null(args$mixture), "P", args$mixture)
+ K <- ifelse(is.null(args$K), 100, args$K)
+
+ gdistremoval(lambdaformula=formulas$lambda, phiformula=formulas$phi,
+ removalformula=formulas$rem, distanceformula=formulas$dist,
+ data=umf, keyfun=keyfun, output=output, unitsOut=unitsOut,
+ mixture=mixture, K=K, se=FALSE, control=list(maxit=1), method='L-BFGS-B')
+})
diff --git a/R/unmarkedCrossVal.R b/R/unmarkedCrossVal.R
index 9df9d0e..a49d067 100644
--- a/R/unmarkedCrossVal.R
+++ b/R/unmarkedCrossVal.R
@@ -22,7 +22,7 @@ setClass("unmarkedCrossVal",
setMethod("crossVal", "unmarkedFit",
function(object, method=c("Kfold","holdout","leaveOneOut"),
folds=10, holdoutPct=0.25,
- statistic=RMSE_MAE, parallel=FALSE, ...){
+ statistic=RMSE_MAE, parallel=FALSE, ncores, ...){
method <- match.arg(method, c('Kfold','holdout','leaveOneOut'))
@@ -57,7 +57,8 @@ setMethod("crossVal", "unmarkedFit",
}
if(parallel){
- cl <- parallel::makeCluster(detectCores()-1)
+ if(missing(ncores)) ncores <- parallel::detectCores()-1
+ cl <- parallel::makeCluster(ncores)
on.exit(parallel::stopCluster(cl))
stat_raw <- pblapply(1:n_reps, do_crossval, object,
partitions, statistic, ..., cl = cl)
@@ -157,14 +158,15 @@ setClass("unmarkedCrossValList",
setMethod("crossVal", "unmarkedFitList",
function(object, method=c("Kfold","holdout","leaveOneOut"),
folds=10, holdoutPct=0.25,
- statistic=RMSE_MAE, parallel=FALSE,
+ statistic=RMSE_MAE, parallel=FALSE, ncores,
sort = c("none", "increasing", "decreasing"), ...){
method <- match.arg(method, c('Kfold','holdout','leaveOneOut'))
sort <- match.arg(sort, c('none','increasing','decreasing'))
+ if(missing(ncores)) ncores <- parallel::detectCores()-1
stats <- lapply(object@fits, crossVal, method, folds,
- holdoutPct, statistic, parallel, ...)
+ holdoutPct, statistic, parallel, ncores, ...)
out <- new("unmarkedCrossValList", stats_list=stats, method=method,
folds=folds, holdoutPct=holdoutPct, sort=sort)
diff --git a/R/unmarkedFit.R b/R/unmarkedFit.R
index 8254023..d0fac62 100644
--- a/R/unmarkedFit.R
+++ b/R/unmarkedFit.R
@@ -43,30 +43,27 @@ setClass("unmarkedFitPCount",
mixture = "character"),
contains = "unmarkedFit")
-
-
-setClass("unmarkedFitPCO",
+# This class is not used directly, just used as a base for for PCO, MMO, DSO
+setClass("unmarkedFitDailMadsen",
representation(
+ K = "numeric",
+ mixture = "character",
formlist = "list",
dynamics = "character",
immigration = "logical",
fix = "character"),
- contains = "unmarkedFitPCount")
+ contains = "unmarkedFit")
-setClass("unmarkedFitDSO",
- representation(
- formlist = "list",
- dynamics = "character",
- immigration = "logical",
- fix = "character",
- K="numeric",
- mixture="character"),
- contains = "unmarkedFitDS")
+setClass("unmarkedFitPCO", contains = "unmarkedFitDailMadsen")
-setClassUnion("unmarkedFitPCOorDSO",
- c("unmarkedFitPCO", "unmarkedFitDSO"))
+setClass("unmarkedFitMMO", contains = "unmarkedFitDailMadsen")
-setClass("unmarkedFitMMO", contains = "unmarkedFitPCO")
+setClass("unmarkedFitDSO",
+ representation(
+ keyfun = "character",
+ unitsOut = "character",
+ output = "character"),
+ contains = "unmarkedFitDailMadsen")
setClass("unmarkedFitOccu",
representation(knownOcc = "logical"),
@@ -264,1922 +261,6 @@ setMethod("names", "unmarkedFit",
-# ----------------------------- Prediction -----------------------------
-
-#Utility function to make model matrix and offset from newdata
-make_mod_matrix <- function(formula, data, newdata, re.form=NULL){
- form_nobars <- lme4::nobars(formula)
- mf <- model.frame(form_nobars, data)
- X.terms <- stats::terms(mf)
- fac_cols <- data[, sapply(data, is.factor), drop=FALSE]
- xlevs <- lapply(fac_cols, levels)
- xlevs <- xlevs[names(xlevs) %in% names(mf)]
- X <- model.matrix(X.terms, newdata, xlev=xlevs)
- nmf <- model.frame(X.terms, newdata)
- offset <- model.offset(nmf)
- if(is.null(re.form)){
- Z <- get_Z(formula, data, newdata)
- X <- cbind(X, Z)
- }
- list(X=X, offset=offset)
-}
-
-#Remove data in final year of yearlySiteCovs
-#then drop factor levels found only in that year
-droplevels_final_year <- function(dat, nsites, nprimary){
- dat[seq(nprimary, nsites*nprimary, by=nprimary), ] <- NA
- dat <- lapply(dat, function(x) x[,drop = TRUE])
- as.data.frame(dat)
-}
-
-setMethod("predict", "unmarkedFit",
- function(object, type, newdata, backTransform = TRUE, na.rm = TRUE,
- appendData = FALSE, level=0.95, re.form=NULL, ...)
- {
- if(missing(newdata) || is.null(newdata))
- newdata <- getData(object)
- formula <- object@formula
- detformula <- as.formula(formula[[2]])
- stateformula <- as.formula(paste("~", formula[3], sep=""))
-
- origdata <- getData(object)
- M <- numSites(origdata)
- R <- obsNum(origdata)
- if(is.null(siteCovs(origdata))) {
- sitedata <- data.frame(site = rep(1, M))
- } else {
- sitedata <- siteCovs(origdata)
- }
- if(is.null(obsCovs(origdata))) {
- obsCovs <- data.frame(obs = rep(1, M*R))
- } else {
- obsCovs <- obsCovs(origdata)
- }
- obsdata <- cbind(obsCovs, sitedata[rep(1:M, each = R), , drop = FALSE])
-
- if(inherits(newdata, "unmarkedFrame"))
- class(newdata) <- "unmarkedFrame"
- cls <- class(newdata)[1]
- if(!cls %in% c("unmarkedFrame", "data.frame", "RasterStack"))
- stop("newdata should be an unmarkedFrame, data.frame, or RasterStack", call.=FALSE)
- if(identical(cls, "RasterStack"))
- if(!require(raster))
- stop("raster package is required")
- switch(cls,
- unmarkedFrame = {
- designMats <- getDesign(newdata, formula, na.rm = na.rm)
- switch(type,
- state = {
- X <- designMats$X
- if(is.null(re.form)) X <- cbind(X, designMats$Z_state)
- offset <- designMats$X.offset
- },
- det = {
- X <- designMats$V
- if(is.null(re.form)) X <- cbind(X, designMats$Z_det)
- offset <- designMats$V.offset
- })
- },
- data.frame = {
- switch(type,
- state = {
- pred_data <- sitedata
- pred_form <- stateformula
- },
- det = {
- pred_data <- obsdata
- pred_form <- detformula
- }
- )
- mm <- make_mod_matrix(pred_form, pred_data, newdata, re.form)
- X <- mm$X
- offset <- mm$offset
- },
- RasterStack = {
- # browser()
- cd.names <- names(newdata)
- npix <- prod(dim(newdata)[1:2])
- isfac <- is.factor(newdata)
- if(any(isfac))
- stop("This method currently does not handle factors")
- z <- as.data.frame(matrix(raster::getValues(newdata), npix))
- names(z) <- cd.names
- switch(type,
- state = {
- varnames <- all.vars(stateformula)
- if(!all(varnames %in% cd.names))
- stop("At least 1 covariate in the formula is not in the raster stack.\n You probably need to assign them using\n\t 'names(object) <- covariate.names'")
- mf <- model.frame(stateformula, z, na.action="na.pass")
- X.terms <- attr(mf, "terms")
- X <- model.matrix(X.terms, mf)
- offset <- model.offset(mf)
- },
- det= {
- varnames <- all.vars(detformula)
- if(!all(varnames %in% cd.names))
- stop("At least 1 covariate in the formula is not in the raster stack.\n You probably need to assign them using\n\t 'names(object) <- covariate.names'")
- mf <- model.frame(detformula, z, na.action="na.pass")
- X.terms <- attr(mf, "terms")
- X <- model.matrix(X.terms, mf)
- offset <- model.offset(mf)
- })
- })
- out <- data.frame(matrix(NA, nrow(X), 4,
- dimnames=list(NULL, c("Predicted", "SE", "lower", "upper"))))
- for(i in 1:nrow(X)) {
- if(nrow(X) > 5000) {
- if(i %% 1000 == 0)
- cat(" doing row", i, "of", nrow(X), "\n")
- }
- if(any(is.na(X[i,])))
- next
- lc <- linearComb(object, X[i,], type, offset = offset[i], re.form)
- if(backTransform)
- lc <- backTransform(lc)
- out$Predicted[i] <- coef(lc)
- out$SE[i] <- SE(lc)
- ci <- confint(lc, level=level)
- out$lower[i] <- ci[1]
- out$upper[i] <- ci[2]
- }
- if(appendData) {
- if(!identical(cls, "RasterStack"))
- out <- data.frame(out, as(newdata, "data.frame"))
- else
- out <- data.frame(out, z)
- }
- if(identical(cls, "RasterStack")) {
- E.mat <- matrix(out[,1], dim(newdata)[1], dim(newdata)[2],
- byrow=TRUE)
- E.raster <- raster::raster(E.mat)
- raster::extent(E.raster) <- raster::extent(newdata)
- out.rasters <- list(E.raster)
- for(i in 2:ncol(out)) {
- i.mat <- matrix(out[,i], dim(newdata)[1], dim(newdata)[2],
- byrow=TRUE)
- i.raster <- raster::raster(i.mat)
- raster::extent(i.raster) <- raster::extent(newdata)
- out.rasters[[i]] <- i.raster
- }
- out.stack <- stack(out.rasters)
- names(out.stack) <- colnames(out)
- out <- out.stack
- }
- return(out)
- })
-
-
-
-
-
-## setMethod("predict", "unmarkedFitPCount",
-## function(object, type, newdata, backTransform = TRUE, na.rm = TRUE,
-## appendData = FALSE, level=0.95, ...)
-## {
-## if(type %in% c("psi", "alpha"))
-## stop(type, " is scalar, so use backTransform instead")
-## if(missing(newdata) || is.null(newdata))
-## newdata <- getData(object)
-## formula <- object@formula
-## detformula <- as.formula(formula[[2]])
-## stateformula <- as.formula(paste("~", formula[3], sep=""))
-## if(inherits(newdata, "unmarkedFrame"))
-## class(newdata) <- "unmarkedFrame"
-## cls <- class(newdata)[1]
-## if(!cls %in% c("unmarkedFrame", "data.frame", "RasterStack"))
-## stop("newdata should be an unmarkedFrame, data.frame, or RasterStack", call.=FALSE)
-## if(identical(cls, "RasterStack"))
-## if(!require(raster))
-## stop("raster package is required")
-## switch(cls,
-## unmarkedFrame = {
-## designMats <- getDesign(newdata, formula, na.rm = na.rm)
-## switch(type,
-## state = {
-## X <- designMats$X
-## offset <- designMats$X.offset
-## },
-## det = {
-## X <- designMats$V
-## offset <- designMats$V.offset
-## })
-## },
-## data.frame = {
-## switch(type,
-## state = {
-## mf <- model.frame(stateformula, newdata)
-## X <- model.matrix(stateformula, mf)
-## offset <- model.offset(mf)
-## },
-## det = {
-## mf <- model.frame(detformula, newdata)
-## X <- model.matrix(detformula, mf)
-## offset <- model.offset(mf)
-## })
-## },
-## RasterStack = {
-## cd.names <- names(newdata)
-## npix <- prod(dim(newdata)[1:2])
-## isfac <- is.factor(newdata)
-## if(any(isfac))
-## stop("This method currently does not handle factors")
-## z <- as.data.frame(matrix(raster::getValues(newdata), npix))
-## names(z) <- cd.names
-## switch(type,
-## state = {
-## varnames <- all.vars(stateformula)
-## if(!all(varnames %in% cd.names))
-## stop("At least 1 covariate in the formula is not in the raster stack.\n You probably need to assign them using\n\t 'names(object) <- covariate.names'")
-## mf <- model.frame(stateformula, z, na.action="na.pass")
-## X.terms <- attr(mf, "terms")
-## X <- model.matrix(X.terms, mf)
-## offset <- model.offset(mf)
-## },
-## det= {
-## varnames <- all.vars(detformula)
-## if(!all(varnames %in% cd.names))
-## stop("At least 1 covariate in the formula is not in the raster stack.\n You probably need to assign them using\n\t 'names(object) <- covariate.names'")
-## mf <- model.frame(detformula, z, na.action="na.pass")
-## X.terms <- attr(mf, "terms")
-## X <- model.matrix(X.terms, mf)
-## offset <- model.offset(mf)
-## })
-## })
-## out <- data.frame(matrix(NA, nrow(X), 4,
-## dimnames=list(NULL, c("Predicted", "SE", "lower", "upper"))))
-## mix <- object@mixture
-## lam.mle <- coef(object, type="state")
-## if(identical(mix, "ZIP") & identical(type, "state")) {
-## psi.hat <- plogis(coef(object, type="psi"))
-## if(is.null(offset))
-## offset <- rep(0, nrow(X))
-## warning("Method to compute SE for ZIP model has not been written")
-## }
-## for(i in 1:nrow(X)) {
-## if(nrow(X) > 5000) {
-## if(i %% 1000 == 0)
-## cat(" doing row", i, "of", nrow(X), "\n")
-## }
-## if(any(is.na(X[i,])))
-## next
-## if(identical(mix, "ZIP") & identical(type, "state")) {
-## out$Predicted[i] <-
-## X[i,] %*% lam.mle + offset[i] + log(1 - psi.hat)
-## if(backTransform)
-## out$Predicted[i] <- exp(out$Predicted[i])
-## out$SE <- NA
-## ci <- c(NA, NA)
-## } else {
-## lc <- linearComb(object, X[i,], type, offset = offset[i])
-## if(backTransform)
-## lc <- backTransform(lc)
-## out$Predicted[i] <- coef(lc)
-## out$SE[i] <- SE(lc)
-## ci <- confint(lc, level=level)
-## }
-## out$lower[i] <- ci[1]
-## out$upper[i] <- ci[2]
-## }
-## if(appendData) {
-## if(!identical(cls, "RasterStack"))
-## out <- data.frame(out, as(newdata, "data.frame"))
-## else
-## out <- data.frame(out, z)
-## }
-## if(identical(cls, "RasterStack")) {
-## E.mat <- matrix(out[,1], dim(newdata)[1], dim(newdata)[2],
-## byrow=TRUE)
-## E.raster <- raster::raster(E.mat)
-## raster::extent(E.raster) <- raster::extent(newdata)
-## out.rasters <- list(E.raster)
-## for(i in 2:ncol(out)) {
-## i.mat <- matrix(out[,i], dim(newdata)[1], dim(newdata)[2],
-## byrow=TRUE)
-## i.raster <- raster::raster(i.mat)
-## raster::extent(i.raster) <- raster::extent(newdata)
-## out.rasters[[i]] <- i.raster
-## }
-## out.stack <- stack(out.rasters)
-## names(out.stack) <- colnames(out)
-## out <- out.stack
-## }
-## return(out)
-## })
-
-
-
-
-
-# Functions for the book Applied Hierarchical Modeling in Ecology (AHM)
-# Marc Kery & Andy Royle, Academic Press, 2016.
-
-# predict Method for unmarkedFitPCount - section 6.9.4 p265
-
-# Revised predict function for "unmarkedFitPCount" (in Section 6.9.4)
-# -------------------------------------------------------------------
-# (1) this has not been tested.
-# (2) Only gives 95% confidence interval.
-# (introduced in Section)
-setMethod("predict", "unmarkedFitPCount",
- function(object, type, newdata, backTransform = TRUE, na.rm = TRUE,
- appendData = FALSE, level=0.95, re.form=NULL, ...)
-{
- if(type %in% c("psi", "alpha"))
- stop(type, " is scalar, so use backTransform instead")
- if(missing(newdata) || is.null(newdata))
- newdata <- getData(object)
- formula <- object@formula
- detformula <- as.formula(formula[[2]])
- stateformula <- as.formula(paste("~", formula[3], sep=""))
-
- origdata <- getData(object)
- M <- numSites(origdata)
- R <- obsNum(origdata)
- if(is.null(siteCovs(origdata))) {
- sitedata <- data.frame(site = rep(1, M))
- } else {
- sitedata <- siteCovs(origdata)
- }
- if(is.null(obsCovs(origdata))) {
- obsCovs <- data.frame(obs = rep(1, M*R))
- } else {
- obsCovs <- obsCovs(origdata)
- }
- obsdata <- cbind(obsCovs, sitedata[rep(1:M, each = R), , drop = FALSE])
-
- if(inherits(newdata, "unmarkedFrame"))
- class(newdata) <- "unmarkedFrame"
- cls <- class(newdata)[1]
- if(!cls %in% c("unmarkedFrame", "data.frame", "RasterStack"))
- stop("newdata should be an unmarkedFrame, data.frame, or RasterStack", call.=FALSE)
- if(identical(cls, "RasterStack"))
- if(!require(raster))
- stop("raster package is required")
- switch(cls,
- unmarkedFrame = {
- designMats <- getDesign(newdata, formula, na.rm = na.rm)
- switch(type,
- state = {
- X <- designMats$X
- if(is.null(re.form)) X <- cbind(X, designMats$Z_state)
- offset <- designMats$X.offset
- },
- det = {
- X <- designMats$V
- if(is.null(re.form)) X <- cbind(X, designMats$Z_det)
- offset <- designMats$V.offset
- })
- },
- data.frame = {
- switch(type,
- state = {
- pred_data <- sitedata
- pred_form <- stateformula
- },
- det = {
- pred_data <- obsdata
- pred_form <- detformula
- })
- mm <- make_mod_matrix(pred_form, pred_data, newdata, re.form)
- X <- mm$X
- offset <- mm$offset
- },
- RasterStack = {
- cd.names <- names(newdata)
- npix <- prod(dim(newdata)[1:2])
- isfac <- is.factor(newdata)
- if(any(isfac))
- stop("This method currently does not handle factors")
- z <- as.data.frame(matrix(getValues(newdata), npix))
- names(z) <- cd.names
- switch(type,
- state = {
- varnames <- all.vars(stateformula)
- if(!all(varnames %in% cd.names))
- stop("At least 1 covariate in the formula is not in the raster stack.\n You probably need to assign them using\n\t 'names(object) <- covariate.names'")
- mf <- model.frame(stateformula, z, na.action="na.pass")
- X.terms <- attr(mf, "terms")
- X <- model.matrix(X.terms, mf)
- offset <- model.offset(mf)
- },
- det= {
- varnames <- all.vars(detformula)
- if(!all(varnames %in% cd.names))
- stop("At least 1 covariate in the formula is not in the raster stack.\n You probably need to assign them using\n\t 'names(object) <- covariate.names'")
- mf <- model.frame(detformula, z, na.action="na.pass")
- X.terms <- attr(mf, "terms")
- X <- model.matrix(X.terms, mf)
- offset <- model.offset(mf)
- })
- })
- out <- data.frame(matrix(NA, nrow(X), 4,
- dimnames=list(NULL, c("Predicted", "SE", "lower", "upper"))))
- mix <- object@mixture
-
- if(identical(mix, "ZIP") & identical(type, "state")) {
- psi.hat <- plogis(coef(object, type="psi"))
- lamEst <- object["state"]
- psiEst <- object["psi"]
- fixedOnly <- !is.null(re.form)
- lam.mle <- coef(lamEst, fixedOnly=fixedOnly)
- lam_vcov <- vcov(lamEst, fixedOnly=fixedOnly)
- if(is.null(offset))
- offset <- rep(0, nrow(X))
- #warning("Method to compute SE for ZIP model has not been written. Scratch that.
- #Method has been written but not tested/evaluated.
- #Also, you only get a 95% confidence interval for the ZIP model. ")
- }
- for(i in 1:nrow(X)) {
- if(nrow(X) > 5000) {
- if(i %% 1000 == 0)
- cat(" doing row", i, "of", nrow(X), "\n")
- }
- if(any(is.na(X[i,])))
- next
- if(identical(mix, "ZIP") & identical(type, "state")) {
-
- ## for the ZIP model the predicted values on the log scale have us
- ## add log(1-psi.hat) to the normal linear prediction
- out$Predicted[i] <- X[i,] %*% lam.mle + offset[i] + log(1 - psi.hat)
- ## to compute the approximate SE, I compute the variance of the usual
- ## linear part -- that is easy, and to that I add the variance of
- ## log(1-psi.hat) obtained by the delta approximation
- logit.psi<-coef(object,type="psi")
- # To do that I took derivative of log(1-psi.hat) using application
- # of chain rule.... hopefully correctly.
- delta.approx.2ndpart<- ( ((1/(1-psi.hat))*(exp(logit.psi)/((1+exp(logit.psi))^2)))^2 ) * (SE(psiEst)^2)
- ## now the SE is the sqrt of the whole thing
- out$SE[i]<- sqrt( t(X[i,])%*% lam_vcov %*%X[i,] + delta.approx.2ndpart )
-
- #From Mike Meredith
- alf <- (1 - level) / 2
- crit<-qnorm(c(alf, 1 - alf))
- ci <- out$Predicted[i] + crit * out$SE[i]
- ## Here I use a 95% confidence interval b/c I'm not sure how to use "confint"!!!
- #### ci <- c(out$Predicted[i]-1.96*out$SE[i],out$Predicted[i] + 1.96*out$SE[i])
- ##
- out$lower[i]<- ci[1]
- out$upper[i]<- ci[2]
- if(backTransform){
- out$Predicted[i] <- exp(out$Predicted[i])
- ### If back-transform, delta approx says var = (exp(linear.predictor)^2)*Var(linear.predictor)
- ### also I exponentiate the confidence interval.....
- out$SE[i]<- out$Predicted[i]*out$SE[i]
- ci<-exp(ci)
- # formula from Goodman 1960 JASA. This is the se based on "lambda*(1-psi)"
- ## not sure how well it compares to what I did above.
- #part2<- coef(object,type="psi")
- #var.psi.part<- (exp(part2)/((1+exp(part2))^2))*(SE(object)["psi(psi)"]^2)
- #part1<- X[i,]*exp(X[i,]%*%lam.mle)
- #var.lambda.part<- t(part1)%*%vcov(object)[1:ncol(X),1:ncol(X)]%*%(part1)
- #out$SE[i]<-out$Predicted[i]*out$Predicted[i]*var.psi.part + (1-psi.hat)*(1-psi.hat)*var.lambda.part - var.psi.part*var.lambda.part
- #ci<- c( NA, NA)
- }
-
- } else {
- lc <- linearComb(object, X[i,], type, offset = offset[i], re.form=re.form)
- if(backTransform)
- lc <- backTransform(lc)
- out$Predicted[i] <- coef(lc)
- out$SE[i] <- SE(lc)
- ci <- confint(lc, level=level)
- }
- out$lower[i] <- ci[1]
- out$upper[i] <- ci[2]
- }
- if(appendData) {
- if(!identical(cls, "RasterStack"))
- out <- data.frame(out, as(newdata, "data.frame"))
- else
- out <- data.frame(out, z)
- }
- if(identical(cls, "RasterStack")) {
- E.mat <- matrix(out[,1], dim(newdata)[1], dim(newdata)[2],
- byrow=TRUE)
- E.raster <- raster(E.mat)
- extent(E.raster) <- extent(newdata)
- out.rasters <- list(E.raster)
- for(i in 2:ncol(out)) {
- i.mat <- matrix(out[,i], dim(newdata)[1], dim(newdata)[2],
- byrow=TRUE)
- i.raster <- raster(i.mat)
- extent(i.raster) <- extent(newdata)
- out.rasters[[i]] <- i.raster
- }
- out.stack <- stack(out.rasters)
- names(out.stack) <- colnames(out)
- out <- out.stack
- }
- return(out)
-})
-
-
-
-
-
-### prediction
-
-setMethod("predict", "unmarkedFitOccuFP",
- function(object, type, newdata, backTransform = TRUE, na.rm = TRUE,
- appendData = FALSE, ...)
- {
- if(missing(newdata) || is.null(newdata))
- newdata <- getData(object)
- detformula <- object@detformula
- stateformula <- object@stateformula
- FPformula <- object@FPformula
- Bformula <- object@Bformula
-
- origdata <- getData(object)
- M <- numSites(origdata)
- R <- obsNum(origdata)
- if(is.null(siteCovs(origdata))) {
- sitedata <- data.frame(site = rep(1, M))
- } else {
- sitedata <- siteCovs(origdata)
- }
- if(is.null(obsCovs(origdata))) {
- obsCovs <- data.frame(obs = rep(1, M*R))
- } else {
- obsCovs <- obsCovs(origdata)
- }
- obsdata <- cbind(obsCovs, sitedata[rep(1:M, each = R), , drop = FALSE])
-
- if(inherits(newdata, "unmarkedFrameOccuFP"))
- class(newdata) <- "unmarkedFrameOccuFP"
- cls <- class(newdata)[1]
- if(!cls %in% c("unmarkedFrameOccuFP", "data.frame", "RasterStack"))
- stop("newdata should be an unmarkedFrameOccuFP, data.frame, or RasterStack", call.=FALSE)
- if(identical(cls, "RasterStack"))
- stop("RasterStack not implemented for occuFP")
- switch(cls,
- unmarkedFrameOccuFP = {
- designMats <- getDesign(newdata, detformula,FPformula,Bformula,stateformula, na.rm = na.rm)
- switch(type,
- state = {
- X <- designMats$X
- offset <- designMats$X.offset
- },
- det = {
- X <- designMats$V
- offset <- designMats$V.offset
- },
- fp = {
- X <- designMats$U
- offset <- designMats$U.offset
- },
- b = {
- X <- designMats$W
- offset <- designMats$W.offset
- })
- },
- data.frame = {
- switch(type,
- state = {
- pred_data <- sitedata
- pred_form <- stateformula
- },
- det = {
- pred_data <- obsdata
- pred_form <- detformula
- },
- fp = {
- pred_data <- obsdata
- pred_form <- FPformula
- },
- b = {
- pred_data <- obsdata
- pred_form <- Bformula
- })
- mm <- make_mod_matrix(pred_form, pred_data, newdata)
- X <- mm$X
- offset <- mm$offset
- })
-
- out <- data.frame(matrix(NA, nrow(X), 4,
- dimnames=list(NULL, c("Predicted", "SE", "lower", "upper"))))
- for(i in 1:nrow(X)) {
- if(nrow(X) > 5000) {
- if(i %% 1000 == 0)
- cat(" doing row", i, "of", nrow(X), "rows\n")
- }
- if(any(is.na(X[i,])))
- next
- lc <- linearComb(object, X[i,], type, offset = offset)
- if(backTransform)
- lc <- backTransform(lc)
- out$Predicted[i] <- coef(lc)
- out$SE[i] <- SE(lc)
- ci <- confint(lc)
- out$lower[i] <- ci[1]
- out$upper[i] <- ci[2]
- }
- if(appendData) {
- out <- data.frame(out, newdata)
- }
- return(out)
- })
-
-
-
-
-
-
-
-setMethod("predict", "unmarkedFitColExt",
- function(object, type, newdata, backTransform = TRUE, na.rm = TRUE,
- appendData = FALSE, level=0.95, ...)
-{
- if(missing(newdata) || is.null(newdata))
- newdata <- getData(object)
- formula <- object@formula
- cls <- class(newdata)[1]
- if(!cls %in% c("unmarkedMultFrame", "data.frame", "RasterStack"))
- stop("newdata should be have class 'unmarkedMultFrame', 'data.frame', or 'RasterStack'")
- if(identical(cls, "RasterStack"))
- if(!require(raster))
- stop("raster package is required")
- switch(cls,
- unmarkedMultFrame = {
- designMats <- getDesign(newdata, formula, na.rm = na.rm)
- switch(type,
- psi = {
- X <- designMats$W
- #offset <- designMats$W.offset
- },
- col = X <- designMats$X.gam,
- ext = X <- designMats$X.eps,
- det = {
- X <- designMats$V
- #offset <- designMats$V.offset
- })
- },
- data.frame = {
- aschar1 <- as.character(formula)
- aschar2 <- as.character(formula[[2]])
- aschar3 <- as.character(formula[[2]][[2]])
-
- detformula <- as.formula(paste(aschar1[1], aschar1[3]))
- epsformula <- as.formula(paste(aschar2[1], aschar2[3]))
- gamformula <- as.formula(paste(aschar3[1], aschar3[3]))
- psiformula <- as.formula(formula[[2]][[2]][[2]])
-
- origdata <- getData(object)
- M <- numSites(origdata)
- R <- obsNum(origdata)
- T <- origdata@numPrimary
- J <- R / T
-
- if(is.null(siteCovs(origdata))) {
- sitedata <- data.frame(site = rep(1, M))
- } else {
- sitedata <- siteCovs(origdata)
- }
- if(is.null(yearlySiteCovs(origdata))) {
- yearlySiteCovs <- data.frame(year = rep(1, M*T))
- } else {
- yearlySiteCovs <- yearlySiteCovs(origdata)
- }
- yearlydata <- cbind(yearlySiteCovs, sitedata[rep(1:M, each = T), , drop = FALSE])
- if(is.null(obsCovs(origdata))) {
- obsCovs <- data.frame(obs = rep(1, M*R))
- } else {
- obsCovs <- obsCovs(origdata)
- }
- obsdata <- cbind(obsCovs, yearlydata[rep(1:(M*T), each = J), ])
-
- yearlydata <- droplevels_final_year(yearlydata, M, T)
-
- switch(type,
- psi = {
- pred_data <- sitedata
- pred_form <- psiformula
- },
- col = {
- pred_data <- yearlydata
- pred_form <- gamformula
- },
- ext = {
- pred_data <- yearlydata
- pred_form <- epsformula
- },
- det = {
- pred_data <- obsdata
- pred_form <- detformula
- })
- X <- make_mod_matrix(pred_form, pred_data, newdata)$X
- },
- RasterStack = {
- aschar1 <- as.character(formula)
- aschar2 <- as.character(formula[[2]])
- aschar3 <- as.character(formula[[2]][[2]])
-
- detformula <- as.formula(paste(aschar1[1], aschar1[3]))
- epsformula <- as.formula(paste(aschar2[1], aschar2[3]))
- gamformula <- as.formula(paste(aschar3[1], aschar3[3]))
- psiformula <- as.formula(formula[[2]][[2]][[2]])
-
- cd.names <- names(newdata)
- npix <- prod(dim(newdata)[1:2])
- isfac <- is.factor(newdata)
- if(any(isfac))
- stop("This method currently does not handle factors")
- z <- as.data.frame(matrix(raster::getValues(newdata), npix))
- names(z) <- cd.names
- switch(type,
- psi = {
- varnames <- all.vars(psiformula)
- if(!all(varnames %in% cd.names))
- stop("At least 1 covariate in the formula is not in the raster stack.\n You probably need to assign them using\n\t 'names(object) <- covariate.names'")
- mf <- model.frame(psiformula, z, na.action="na.pass")
- X.terms <- attr(mf, "terms")
- X <- model.matrix(X.terms, mf)
-# offset <- model.offset(mf)
- },
- col = {
- varnames <- all.vars(gamformula)
- if(!all(varnames %in% cd.names))
- stop("At least 1 covariate in the formula is not in the raster stack.\n You probably need to assign them using\n\t 'names(object) <- covariate.names'")
- mf <- model.frame(gamformula, z, na.action="na.pass")
- X.terms <- attr(mf, "terms")
- X <- model.matrix(X.terms, mf)
-# offset <- model.offset(mf)
- },
- ext = {
- varnames <- all.vars(epsformula)
- if(!all(varnames %in% cd.names))
- stop("At least 1 covariate in the formula is not in the raster stack.\n You probably need to assign them using\n\t 'names(object) <- covariate.names'")
- mf <- model.frame(epsformula, z, na.action="na.pass")
- X.terms <- attr(mf, "terms")
- X <- model.matrix(X.terms, mf)
-# offset <- model.offset(mf)
- },
- det= {
- varnames <- all.vars(detformula)
- if(!all(varnames %in% cd.names))
- stop("At least 1 covariate in the formula is not in the raster stack.\n You probably need to assign them using\n\t 'names(object) <- covariate.names'")
- mf <- model.frame(detformula, z, na.action="na.pass")
- X.terms <- attr(mf, "terms")
- X <- model.matrix(X.terms, mf)
- offset <- model.offset(mf)
- })
- })
- out <- data.frame(matrix(NA, nrow(X), 4,
- dimnames=list(NULL, c("Predicted", "SE", "lower", "upper"))))
- for(i in 1:nrow(X)) {
- if(nrow(X) > 5000) {
- if(i %% 1000 == 0)
- cat(" doing row", i, "of", nrow(X), "\n")
- }
- if(any(is.na(X[i,])))
- next
- lc <- linearComb(object, X[i,], type)
- if(backTransform)
- lc <- backTransform(lc)
- out$Predicted[i] <- coef(lc)
- out$SE[i] <- SE(lc)
- ci <- confint(lc, level=level)
- out$lower[i] <- ci[1]
- out$upper[i] <- ci[2]
- }
- if(appendData) {
- if(!identical(cls, "RasterStack"))
- out <- data.frame(out, as(newdata, "data.frame"))
- else
- out <- data.frame(out, z)
- }
- if(identical(cls, "RasterStack")) {
- E.mat <- matrix(out[,1], dim(newdata)[1], dim(newdata)[2],
- byrow=TRUE)
- E.raster <- raster::raster(E.mat)
- raster::extent(E.raster) <- raster::extent(newdata)
- out.rasters <- list(E.raster)
- for(i in 2:ncol(out)) {
- i.mat <- matrix(out[,i], dim(newdata)[1], dim(newdata)[2],
- byrow=TRUE)
- i.raster <- raster::raster(i.mat)
- raster::extent(i.raster) <- raster::extent(newdata)
- out.rasters[[i]] <- i.raster
- }
- out.stack <- stack(out.rasters)
- names(out.stack) <- colnames(out)
- out <- out.stack
- }
- return(out)
-})
-
-
-
-
-
-
-
-
-setMethod("predict", "unmarkedFitPCO",
- function(object, type, newdata, backTransform = TRUE, na.rm = TRUE,
- appendData = FALSE, level=0.95, ...)
-{
- if(type %in% c("psi", "alpha"))
- stop(type, " is scalar, so use backTransform instead")
- if(missing(newdata) || is.null(newdata))
- newdata <- getData(object)
- dynamics <- object@dynamics
- immigration <- tryCatch(object@immigration, error=function(e) FALSE)
- if(identical(dynamics, "notrend") & identical(type, "gamma"))
- stop("gamma is a derived parameter for this model: (1-omega)*lambda")
- if(identical(dynamics, "trend") && identical(type, "omega"))
- stop("omega is not a parameter in the dynamics='trend' model")
- if(!immigration && identical(type, "iota"))
- stop("iota is not a parameter in the immigration=FALSE model")
- formula <- object@formula
- formlist <- object@formlist
- if(inherits(newdata, "unmarkedFrame"))
- cls <- "unmarkedFrame"
- else if(identical(class(newdata)[1], "data.frame"))
- cls <- "data.frame"
- else if(identical(class(newdata)[1], "RasterStack"))
- cls <- "RasterStack"
- else
- stop("newdata should be a data.frame, unmarkedFrame, or RasterStack")
- if(identical(cls, "RasterStack"))
- if(!require(raster))
- stop("raster package must be loaded")
- switch(cls,
- unmarkedFrame = {
- D <- getDesign(newdata, formula, na.rm = na.rm)
- switch(type,
- lambda = {
- X <- D$Xlam
- offset <- D$Xlam.offset
- },
- gamma = {
- X <- D$Xgam
- offset <- D$Xgam.offset
- },
- omega = {
- X <- D$Xom
- offset <- D$Xom.offset
- },
- iota = {
- X <- D$Xiota
- offset <- D$Xiota.offset
- },
- det = {
- X <- D$Xp
- offset <- D$Xp.offset
- })
- },
- data.frame = {
- lambdaformula <- formlist$lambdaformula
- gammaformula <- formlist$gammaformula
- omegaformula <- formlist$omegaformula
- pformula <- formlist$pformula
- iotaformula <- formlist$iotaformula
-
- origdata <- getData(object)
- M <- numSites(origdata)
- R <- obsNum(origdata)
- T <- origdata@numPrimary
- J <- R / T
-
- if(is.null(siteCovs(origdata))) {
- sitedata <- data.frame(site = rep(1, M))
- } else {
- sitedata <- siteCovs(origdata)
- }
- if(is.null(yearlySiteCovs(origdata))) {
- yearlySiteCovs <- data.frame(year = rep(1, M*T))
- } else {
- yearlySiteCovs <- yearlySiteCovs(origdata)
- }
- yearlydata <- cbind(yearlySiteCovs, sitedata[rep(1:M, each = T), , drop = FALSE])
- if(is.null(obsCovs(origdata))) {
- obsCovs <- data.frame(obs = rep(1, M*R))
- } else {
- obsCovs <- obsCovs(origdata)
- }
- obsdata <- cbind(obsCovs, yearlydata[rep(1:(M*T), each = J), ])
-
- yearlydata <- droplevels_final_year(yearlydata, M, T)
-
- switch(type,
- lambda = {
- pred_data <- sitedata
- pred_form <- lambdaformula
- },
- gamma = {
- pred_data <- yearlydata
- pred_form <- gammaformula
- },
- omega = {
- pred_data <- yearlydata
- pred_form <- omegaformula
- },
- iota = {
- pred_data <- yearlydata
- pred_form <- iotaformula
- },
- det = {
- pred_data <- obsdata
- pred_form <- pformula
- })
- mm <- make_mod_matrix(pred_form, pred_data, newdata)
- X <- mm$X
- offset <- mm$offset
- },
- RasterStack = {
- lambdaformula <- formlist$lambdaformula
- gammaformula <- formlist$gammaformula
- omegaformula <- formlist$omegaformula
- pformula <- formlist$pformula
-
- cd.names <- names(newdata)
- npix <- prod(dim(newdata)[1:2])
- isfac <- is.factor(newdata)
- if(any(isfac))
- stop("This method currently does not handle factors")
- z <- as.data.frame(matrix(raster::getValues(newdata), npix))
- names(z) <- cd.names
- switch(type,
- lambda = {
- varnames <- all.vars(lambdaformula)
- if(!all(varnames %in% cd.names))
- stop("At least 1 covariate in the formula is not in the raster stack.\n You probably need to assign them using\n\t 'names(object) <- covariate.names'")
- mf <- model.frame(lambdaformula, z,
- na.action="na.pass")
- X.terms <- attr(mf, "terms")
- X <- model.matrix(X.terms, mf)
- offset <- model.offset(mf)
- },
- gamma = {
- varnames <- all.vars(gammaformula)
- if(!all(varnames %in% cd.names))
- stop("At least 1 covariate in the formula is not in the raster stack.\n You probably need to assign them using\n\t 'names(object) <- covariate.names'")
- mf <- model.frame(gammaformula, z,
- na.action="na.pass")
- X.terms <- attr(mf, "terms")
- X <- model.matrix(X.terms, mf)
- offset <- model.offset(mf)
- },
- omega = {
- varnames <- all.vars(omegaformula)
- if(!all(varnames %in% cd.names))
- stop("At least 1 covariate in the formula is not in the raster stack.\n You probably need to assign them using\n\t 'names(object) <- covariate.names'")
- mf <- model.frame(omegaformula, z,
- na.action="na.pass")
- X.terms <- attr(mf, "terms")
- X <- model.matrix(X.terms, mf)
- offset <- model.offset(mf)
- },
- det= {
- varnames <- all.vars(pformula)
- if(!all(varnames %in% cd.names))
- stop("At least 1 covariate in the formula is not in the raster stack.\n You probably need to assign them using\n\t 'names(object) <- covariate.names'")
- mf <- model.frame(pformula, z,
- na.action="na.pass")
- X.terms <- attr(mf, "terms")
- X <- model.matrix(X.terms, mf)
- offset <- model.offset(mf)
- })
- })
- out <- data.frame(matrix(NA, nrow(X), 4,
- dimnames=list(NULL, c("Predicted", "SE", "lower", "upper"))))
- mix <- object@mixture
- lam.mle <- coef(object, type="lambda")
- if(identical(mix, "ZIP") & identical(type, "lambda")) {
- psi.hat <- plogis(coef(object, type="psi"))
- if(is.null(offset))
- offset <- rep(0, nrow(X))
- warning("Method to compute SE for ZIP model has not been written")
- }
- for(i in 1:nrow(X)) {
- if(nrow(X) > 5000) {
- if(i %% 1000 == 0)
- cat(" doing row", i, "of", nrow(X), "\n")
- }
- if(any(is.na(X[i,])))
- next
- if(identical(mix, "ZIP") & identical(type, "lambda")) {
- out$Predicted[i] <-
- X[i,] %*% lam.mle + offset[i] + log(1 - psi.hat)
- if(backTransform)
- out$Predicted[i] <- exp(out$Predicted[i])
- out$SE <- NA
- ci <- c(NA, NA)
- } else {
- lc <- linearComb(object, X[i,], type, offset = offset[i])
- if(backTransform)
- lc <- backTransform(lc)
- out$Predicted[i] <- coef(lc)
- out$SE[i] <- SE(lc)
- ci <- confint(lc, level=level)
- }
- out$lower[i] <- ci[1]
- out$upper[i] <- ci[2]
- }
- if(appendData) {
- if(!identical(cls, "RasterStack"))
- out <- data.frame(out, as(newdata, "data.frame"))
- else
- out <- data.frame(out, z)
- }
- if(identical(cls, "RasterStack")) {
- E.mat <- matrix(out[,1], dim(newdata)[1], dim(newdata)[2],
- byrow=TRUE)
- E.raster <- raster::raster(E.mat)
- raster::extent(E.raster) <- raster::extent(newdata)
- out.rasters <- list(E.raster)
- for(i in 2:ncol(out)) {
- i.mat <- matrix(out[,i], dim(newdata)[1], dim(newdata)[2],
- byrow=TRUE)
- i.raster <- raster::raster(i.mat)
- raster::extent(i.raster) <- raster::extent(newdata)
- out.rasters[[i]] <- i.raster
- }
- out.stack <- stack(out.rasters)
- names(out.stack) <- colnames(out)
- out <- out.stack
- }
- return(out)
-})
-
-
-setMethod("predict", "unmarkedFitDSO",
- function(object, type, newdata, backTransform = TRUE, na.rm = TRUE,
- appendData = FALSE, level=0.95, ...)
-{
- if(type %in% c("psi", "alpha", "scale"))
- stop(type, " is scalar, so use backTransform instead")
- if(missing(newdata) || is.null(newdata))
- newdata <- getData(object)
- dynamics <- object@dynamics
- immigration <- tryCatch(object@immigration, error=function(e) FALSE)
- if(identical(dynamics, "notrend") & identical(type, "gamma"))
- stop("gamma is a derived parameter for this model: (1-omega)*lambda")
- if(identical(dynamics, "trend") && identical(type, "omega"))
- stop("omega is not a parameter in the dynamics='trend' model")
- if(!immigration && identical(type, "iota"))
- stop("iota is not a parameter in the immigration=FALSE model")
- formula <- object@formula
- formlist <- object@formlist
- if(inherits(newdata, "unmarkedFrame"))
- cls <- "unmarkedFrame"
- else if(identical(class(newdata)[1], "data.frame"))
- cls <- "data.frame"
- else if(identical(class(newdata)[1], "RasterStack"))
- cls <- "RasterStack"
- else
- stop("newdata should be a data.frame, unmarkedFrame, or RasterStack")
- if(identical(cls, "RasterStack"))
- if(!require(raster))
- stop("raster package must be loaded")
- switch(cls,
- unmarkedFrame = {
- D <- getDesign(newdata, formula, na.rm = na.rm)
- switch(type,
- lambda = {
- X <- D$Xlam
- offset <- D$Xlam.offset
- },
- gamma = {
- X <- D$Xgam
- offset <- D$Xgam.offset
- },
- omega = {
- X <- D$Xom
- offset <- D$Xom.offset
- },
- iota = {
- X <- D$Xiota
- offset <- D$Xiota.offset
- },
- det = {
- X <- D$Xp
- offset <- D$Xp.offset
- })
- },
- data.frame = {
- lambdaformula <- formlist$lambdaformula
- gammaformula <- formlist$gammaformula
- omegaformula <- formlist$omegaformula
- pformula <- formlist$pformula
- iotaformula <- formlist$iotaformula
-
- origdata <- getData(object)
- M <- numSites(origdata)
- R <- obsNum(origdata)
- T <- origdata@numPrimary
- J <- R / T
-
- if(is.null(siteCovs(origdata))) {
- sitedata <- data.frame(site = rep(1, M))
- } else {
- sitedata <- siteCovs(origdata)
- }
- if(is.null(yearlySiteCovs(origdata))) {
- yearlySiteCovs <- data.frame(year = rep(1, M*T))
- } else {
- yearlySiteCovs <- yearlySiteCovs(origdata)
- }
- yearlydata <- cbind(yearlySiteCovs, sitedata[rep(1:M, each = T), , drop = FALSE])
- yearlydata <- droplevels_final_year(yearlydata, M, T)
-
- switch(type,
- lambda = {
- pred_data <- sitedata
- pred_form <- lambdaformula
- },
- gamma = {
- pred_data <- yearlydata
- pred_form <- gammaformula
- },
- omega = {
- pred_data <- yearlydata
- pred_form <- omegaformula
- },
- iota = {
- pred_data <- yearlydata
- pred_form <- iotaformula
- },
- det = {
- pred_data <- yearlydata
- pred_form <- pformula
- })
- mm <- make_mod_matrix(pred_form, pred_data, newdata)
- X <- mm$X
- offset <- mm$offset
- },
- RasterStack = {
- lambdaformula <- formlist$lambdaformula
- gammaformula <- formlist$gammaformula
- omegaformula <- formlist$omegaformula
- pformula <- formlist$pformula
-
- cd.names <- names(newdata)
- npix <- prod(dim(newdata)[1:2])
- isfac <- is.factor(newdata)
- if(any(isfac))
- stop("This method currently does not handle factors")
- z <- as.data.frame(matrix(raster::getValues(newdata), npix))
- names(z) <- cd.names
- switch(type,
- lambda = {
- varnames <- all.vars(lambdaformula)
- if(!all(varnames %in% cd.names))
- stop("At least 1 covariate in the formula is not in the raster stack.\n You probably need to assign them using\n\t 'names(object) <- covariate.names'")
- mf <- model.frame(lambdaformula, z,
- na.action="na.pass")
- X.terms <- attr(mf, "terms")
- X <- model.matrix(X.terms, mf)
- offset <- model.offset(mf)
- },
- gamma = {
- varnames <- all.vars(gammaformula)
- if(!all(varnames %in% cd.names))
- stop("At least 1 covariate in the formula is not in the raster stack.\n You probably need to assign them using\n\t 'names(object) <- covariate.names'")
- mf <- model.frame(gammaformula, z,
- na.action="na.pass")
- X.terms <- attr(mf, "terms")
- X <- model.matrix(X.terms, mf)
- offset <- model.offset(mf)
- },
- omega = {
- varnames <- all.vars(omegaformula)
- if(!all(varnames %in% cd.names))
- stop("At least 1 covariate in the formula is not in the raster stack.\n You probably need to assign them using\n\t 'names(object) <- covariate.names'")
- mf <- model.frame(omegaformula, z,
- na.action="na.pass")
- X.terms <- attr(mf, "terms")
- X <- model.matrix(X.terms, mf)
- offset <- model.offset(mf)
- },
- det= {
- varnames <- all.vars(pformula)
- if(!all(varnames %in% cd.names))
- stop("At least 1 covariate in the formula is not in the raster stack.\n You probably need to assign them using\n\t 'names(object) <- covariate.names'")
- mf <- model.frame(pformula, z,
- na.action="na.pass")
- X.terms <- attr(mf, "terms")
- X <- model.matrix(X.terms, mf)
- offset <- model.offset(mf)
- })
- })
- out <- data.frame(matrix(NA, nrow(X), 4,
- dimnames=list(NULL, c("Predicted", "SE", "lower", "upper"))))
- mix <- object@mixture
- lam.mle <- coef(object, type="lambda")
- if(identical(mix, "ZIP") & identical(type, "lambda")) {
- psi.hat <- plogis(coef(object, type="psi"))
- if(is.null(offset))
- offset <- rep(0, nrow(X))
- warning("Method to compute SE for ZIP model has not been written")
- }
- for(i in 1:nrow(X)) {
- if(nrow(X) > 5000) {
- if(i %% 1000 == 0)
- cat(" doing row", i, "of", nrow(X), "\n")
- }
- if(any(is.na(X[i,])))
- next
- if(identical(mix, "ZIP") & identical(type, "lambda")) {
- out$Predicted[i] <-
- X[i,] %*% lam.mle + offset[i] + log(1 - psi.hat)
- if(backTransform)
- out$Predicted[i] <- exp(out$Predicted[i])
- out$SE <- NA
- ci <- c(NA, NA)
- } else {
- lc <- linearComb(object, X[i,], type, offset = offset[i])
- if(backTransform)
- lc <- backTransform(lc)
- out$Predicted[i] <- coef(lc)
- out$SE[i] <- SE(lc)
- ci <- confint(lc, level=level)
- }
- out$lower[i] <- ci[1]
- out$upper[i] <- ci[2]
- }
- if(appendData) {
- if(!identical(cls, "RasterStack"))
- out <- data.frame(out, as(newdata, "data.frame"))
- else
- out <- data.frame(out, z)
- }
- if(identical(cls, "RasterStack")) {
- E.mat <- matrix(out[,1], dim(newdata)[1], dim(newdata)[2],
- byrow=TRUE)
- E.raster <- raster::raster(E.mat)
- raster::extent(E.raster) <- raster::extent(newdata)
- out.rasters <- list(E.raster)
- for(i in 2:ncol(out)) {
- i.mat <- matrix(out[,i], dim(newdata)[1], dim(newdata)[2],
- byrow=TRUE)
- i.raster <- raster::raster(i.mat)
- raster::extent(i.raster) <- raster::extent(newdata)
- out.rasters[[i]] <- i.raster
- }
- out.stack <- stack(out.rasters)
- names(out.stack) <- colnames(out)
- out <- out.stack
- }
- return(out)
-})
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-setMethod("predict", "unmarkedFitGMM",
- function(object, type, newdata, backTransform = TRUE, na.rm = TRUE,
- appendData = FALSE, level=0.95, ...)
-{
- if(missing(newdata) || is.null(newdata))
- newdata <- getData(object)
- formlist <- object@formlist
- lambdaformula <- formlist$lambdaformula
- phiformula <- formlist$phiformula
- pformula <- formlist$pformula
- formula <- object@formula
-
- origdata <- getData(object)
- M <- numSites(origdata)
- R <- obsNum(origdata)
- T <- origdata@numPrimary
- J <- R/T
-
- if(is.null(siteCovs(origdata))) {
- sitedata <- data.frame(site = rep(1, M))
- } else {
- sitedata <- siteCovs(origdata)
- }
- if(is.null(yearlySiteCovs(origdata))) {
- yearlySiteCovs <- data.frame(year = rep(1, M*T))
- } else {
- yearlySiteCovs <- yearlySiteCovs(origdata)
- }
- yearlydata <- cbind(yearlySiteCovs, sitedata[rep(1:M, each = T), , drop = FALSE])
- if(is.null(obsCovs(origdata))) {
- obsCovs <- data.frame(obs = rep(1, M*R))
- } else {
- obsCovs <- obsCovs(origdata)
- }
- obsdata <- cbind(obsCovs, yearlydata[rep(1:(M*T), each = J), ])
-
- if(inherits(newdata, "unmarkedFrame"))
- cls <- "unmarkedFrame"
- else
- cls <- class(newdata)[1]
- if(!cls %in% c("unmarkedFrame", "data.frame", "RasterStack"))
- stop("newdata must be an unmarkedFrame, data.frame, or RasterStack")
- if(identical(cls, "RasterStack"))
- if(!require(raster))
- stop("raster package must be loaded")
- switch(cls,
- unmarkedFrame = {
- D <- getDesign(newdata, formula, na.rm = na.rm)
- switch(type,
- lambda = {
- X <- D$Xlam
- offset <- D$Xlam.offset
- },
- phi = {
- X <- D$Xphi
- offset <- D$Xphi.offset
- },
- det = { # Note, this is p not pi
- X <- D$Xdet
- offset <- D$Xdet.offset
- })
- },
- data.frame = {
- switch(type,
- lambda = {
- pred_data <- sitedata
- pred_form <- lambdaformula
- },
- phi = {
- pred_data <- yearlydata
- pred_form <- phiformula
- },
- det = { # Note, this is p not pi
- pred_data <- obsdata
- pred_form <- pformula
- })
- mm <- make_mod_matrix(pred_form, pred_data, newdata)
- X <- mm$X
- offset <- mm$offset
- },
- RasterStack = {
- cd.names <- names(newdata)
- npix <- prod(dim(newdata)[1:2])
- isfac <- is.factor(newdata)
- z <- as.data.frame(matrix(raster::getValues(newdata), npix))
- names(z) <- cd.names
- if(any(isfac)) {
- stop("This method currently does not handle factors", call.=FALSE)
- oumf <- getData(object)
- sc <- siteCovs(oumf)
- oc <- obsCovs(oumf)
- for(i in 1:ncol(z)) {
- if(!isfac)
- next
- lab.i <- labels(newdata)[[i]][[1]]
- if(is.null(lab.i))
- stop("A factor in the raster stack does not have labels.", call.=FALSE)
- z[,i] <- factor(lab.i)
- if(names(z)[i] %in% names(sc))
- levels(z[,i]) <- levels(sc[,i])
- else
- levels(z[,i]) <- levels(oc[,i])
- }
- }
- switch(type,
- lambda = {
- varnames <- all.vars(lambdaformula)
- if(!all(varnames %in% cd.names))
- stop("At least 1 covariate in the formula is not in the raster stack.\n You probably need to assign them using\n\t 'names(object) <- covariate.names'", call.=FALSE)
- mf <- model.frame(lambdaformula, z,
- na.action="na.pass")
- X.terms <- attr(mf, "terms")
- X <- model.matrix(X.terms, mf)
- offset <- model.offset(mf)
- },
- phi = {
- varnames <- all.vars(phiformula)
- if(!all(varnames %in% cd.names))
- stop("At least 1 covariate in the formula is not in the raster stack.\n You probably need to assign them using\n\t 'names(object) <- covariate.names'")
- mf <- model.frame(phiformula, z,
- na.action="na.pass")
- X.terms <- attr(mf, "terms")
- X <- model.matrix(X.terms, mf)
- offset <- model.offset(mf)
- },
- det= {
- varnames <- all.vars(pformula)
- if(!all(varnames %in% cd.names))
- stop("At least 1 covariate in the formula is not in the raster stack.\n You probably need to assign them using\n\t 'names(object) <- covariate.names'")
- mf <- model.frame(pformula, z, na.action="na.pass")
- X.terms <- attr(mf, "terms")
- X <- model.matrix(X.terms, mf)
- offset <- model.offset(mf)
- })
- }
- )
- out <- data.frame(matrix(NA, nrow(X), 4,
- dimnames=list(NULL, c("Predicted", "SE", "lower", "upper"))))
- for(i in 1:nrow(X)) {
- if(nrow(X) > 5000) {
- if(i %% 1000 == 0)
- cat(" doing row", i, "of", nrow(X), "\n")
- }
- if(any(is.na(X[i,])))
- next
- lc <- linearComb(object, X[i,], type, offset = offset[i])
- if(backTransform)
- lc <- backTransform(lc)
- out$Predicted[i] <- coef(lc)
- out$SE[i] <- SE(lc)
- ci <- confint(lc, level=level)
- out$lower[i] <- ci[1]
- out$upper[i] <- ci[2]
- }
- if(appendData) {
- if(!identical(cls, "RasterStack"))
- out <- data.frame(out, as(newdata, "data.frame"))
- else
- out <- data.frame(out, z)
- }
- if(identical(cls, "RasterStack")) {
- E.mat <- matrix(out[,1], dim(newdata)[1], dim(newdata)[2],
- byrow=TRUE)
- E.raster <- raster::raster(E.mat)
- raster::extent(E.raster) <- raster::extent(newdata)
- out.rasters <- list(E.raster)
- for(i in 2:ncol(out)) {
- i.mat <- matrix(out[,i], dim(newdata)[1], dim(newdata)[2],
- byrow=TRUE)
- i.raster <- raster::raster(i.mat)
- raster::extent(i.raster) <- raster::extent(newdata)
- out.rasters[[i]] <- i.raster
- }
- out.stack <- stack(out.rasters)
- names(out.stack) <- colnames(out)
- out <- out.stack
- }
- return(out)
-})
-
-# OccuMulti
-
-setMethod("predict", "unmarkedFitOccuMulti",
- function(object, type, newdata,
- #backTransform = TRUE, na.rm = TRUE,
- #appendData = FALSE,
- se.fit=TRUE, level=0.95, species=NULL, cond=NULL, nsims=100,
- ...)
- {
-
- type <- match.arg(type, c("state", "det"))
-
- if(is.null(hessian(object))){
- se.fit = FALSE
- }
-
- species <- name_to_ind(species, names(object@data@ylist))
- cond <- name_to_ind(cond, names(object@data@ylist))
-
- if(missing(newdata)){
- newdata <- NULL
- } else {
- if(! class(newdata) %in% c('data.frame')){
- stop("newdata must be a data frame")
- }
- }
-
- maxOrder <- object@call$maxOrder
- if(is.null(maxOrder)) maxOrder <- length(object@data@ylist)
- dm <- getDesign(object@data,object@detformulas,object@stateformulas,
- maxOrder, na.rm=F, newdata=newdata, type=type)
-
- params <- coef(object)
- low_bound <- (1-level)/2
- up_bound <- level + (1-level)/2
-
-
- if(type=="state"){
- N <- nrow(dm$dmOcc[[1]]); nF <- dm$nF; dmOcc <- dm$dmOcc;
- fStart <- dm$fStart; fStop <- dm$fStop; fixed0 <- dm$fixed0
- t_dmF <- t(dm$dmF)
-
- calc_psi <- function(params){
-
- f <- matrix(NA,nrow=N,ncol=nF)
- index <- 1
- for (i in 1:nF){
- if(fixed0[i]){
- f[,i] <- 0
- } else {
- f[,i] <- dmOcc[[index]] %*% params[fStart[index]:fStop[index]]
- index <- index + 1
- }
- }
- psi <- exp(f %*% t_dmF)
- as.matrix(psi/rowSums(psi))
- }
-
- psi_est <- calc_psi(params)
-
- if(se.fit){
- cat('Bootstrapping confidence intervals with',nsims,'samples\n')
- Sigma <- vcov(object)
- samp <- array(NA,c(dim(psi_est),nsims))
- for (i in 1:nsims){
- samp[,,i] <- calc_psi(mvrnorm(1, coef(object), Sigma))
- }
- }
-
- if(!is.null(species)){
-
- sel_col <- species
-
- if(!is.null(cond)){
- if(any(sel_col %in% abs(cond))){
- stop("Species can't be conditional on itself")
- }
- ftemp <- object@data@fDesign
- swap <- -1*cond[which(cond<0)]
- ftemp[,swap] <- 1 - ftemp[,swap]
- num_inds <- apply(ftemp[,c(sel_col,abs(cond))] == 1,1,all)
- denom_inds <- apply(ftemp[,abs(cond),drop=F] == 1,1,all)
- est <- rowSums(psi_est[,num_inds,drop=F]) /
- rowSums(psi_est[,denom_inds, drop=F])
- if(se.fit){
- samp_num <- apply(samp[,num_inds,,drop=F],3,rowSums)
- samp_denom <- apply(samp[,denom_inds,,drop=F],3,rowSums)
- samp <- samp_num / samp_denom
- }
-
- } else {
- num_inds <- apply(object@data@fDesign[,sel_col,drop=FALSE] == 1,1,all)
- est <- rowSums(psi_est[,num_inds,drop=F])
- if(se.fit){
- samp <- samp[,num_inds,,drop=F]
- samp <- apply(samp, 3, rowSums)
- }
- }
-
- if(se.fit){
- if(!is.matrix(samp)) samp <- matrix(samp, nrow=1)
- boot_se <- apply(samp,1,sd, na.rm=T)
- boot_low <- apply(samp,1,quantile,low_bound, na.rm=T)
- boot_up <- apply(samp,1,quantile,up_bound, na.rm=T)
- } else{
- boot_se <- boot_low <- boot_up <- NA
- }
- return(data.frame(Predicted=est,
- SE=boot_se,
- lower=boot_low,
- upper=boot_up))
-
- } else {
- codes <- apply(dm$z,1,function(x) paste(x,collapse=""))
- colnames(psi_est) <- paste('psi[',codes,']',sep='')
- if(se.fit){
- boot_se <- apply(samp,c(1,2),sd, na.rm=T)
- boot_low <- apply(samp,c(1,2),quantile,low_bound, na.rm=T)
- boot_up <- apply(samp,c(1,2),quantile,up_bound, na.rm=T)
- colnames(boot_se) <- colnames(boot_low) <- colnames(boot_up) <-
- colnames(psi_est)
- } else {
- boot_se <- boot_low <- boot_up <- NA
- }
- return(list(Predicted=psi_est,
- SE=boot_se,
- lower=boot_low,
- upper=boot_up))
- }
- }
-
- if(type=="det"){
- S <- dm$S; dmDet <- dm$dmDet
- dStart <- dm$dStart; dStop <- dm$dStop
-
- out <- list()
- for (i in 1:S){
- #Subset estimate to species i
- inds <- dStart[i]:dStop[i]
- new_est <- object@estimates@estimates$det
- new_est@estimates <- coef(object)[inds]
- new_est@fixed <- 1:length(inds)
- if(se.fit){
- new_est@covMat <- vcov(object)[inds,inds,drop=FALSE]
- new_est@covMatBS <- object@covMatBS[inds,inds,drop=FALSE]
- } else{
- new_est@covMat <- matrix(NA, nrow=length(inds), ncol=length(inds))
- new_est@covMatBS <- matrix(NA, nrow=length(inds), ncol=length(inds))
- }
-
- prmat <- t(apply(dmDet[[i]], 1, function(x){
- bt <- backTransform(linearComb(new_est, x))
- if(!se.fit){
- return(c(Predicted=bt@estimate, SE=NA, lower=NA, upper=NA))
- }
- ci <- confint(bt, level=level)
- names(ci) <- c("lower", "upper")
- c(Predicted=bt@estimate, SE=SE(bt), ci)
- }))
- rownames(prmat) <- NULL
- out[[i]] <- as.data.frame(prmat)
- }
- names(out) <- names(object@data@ylist)
- if(!is.null(species)){
- return(out[[species]])
- }
- return(out)
- }
- stop("type must be 'det' or 'state'")
-})
-
-setMethod("predict", "unmarkedFitOccuMS",
- function(object, type, newdata,
- #backTransform = TRUE, na.rm = TRUE,
- #appendData = FALSE,
- se.fit=TRUE, level=0.95, nsims=100, ...)
-{
-
- #Process input---------------------------------------------------------------
- if(! type %in% c("psi","phi", "det")){
- stop("type must be 'psi', 'phi', or 'det'")
- }
-
- if(is.null(hessian(object))){
- se.fit = FALSE
- }
-
- if(missing(newdata)){
- newdata <- NULL
- } else {
- if(! class(newdata) %in% c('data.frame')){
- stop("newdata must be a data frame")
- }
- }
-
- S <- object@data@numStates
- gd <- getDesign(object@data,object@psiformulas,object@phiformulas,
- object@detformulas, object@parameterization, na.rm=F,
- newdata=newdata, type=type)
-
- #Index guide used to organize p values
- guide <- matrix(NA,nrow=S,ncol=S)
- guide <- lower.tri(guide,diag=T)
- guide[,1] <- FALSE
- guide <- which(guide,arr.ind=T)
- #----------------------------------------------------------------------------
-
- #Utility functions-----------------------------------------------------------
- #Get matrix of linear predictor values
- get_lp <- function(params, dm_list, ind){
- L <- length(dm_list)
- out <- matrix(NA,nrow(dm_list[[1]]),L)
- for (i in 1:L){
- out[,i] <- dm_list[[i]] %*% params[ind[i,1]:ind[i,2]]
- }
- out
- }
-
- #Get SE/CIs for conditional binomial using delta method
- split_estimate <- function(object, estimate, inds, se.fit){
- out <- estimate
- out@estimates <- coef(object)[inds]
- if(se.fit){
- out@covMat <- vcov(object)[inds,inds,drop=FALSE]
- } else{
- out@covMat <- matrix(NA, nrow=length(inds), ncol=length(inds))
- }
- out
- }
-
- lc_to_predict <- function(object, estimate, inds, dm, level, se.fit){
-
- new_est <- split_estimate(object, estimate, inds[1]:inds[2], se.fit)
-
- out <- t(apply(dm, 1, function(x){
- bt <- backTransform(linearComb(new_est, x))
- if(!se.fit) return(c(Predicted=bt@estimate, SE=NA, lower=NA, upper=NA))
- ci <- confint(bt, level=level)
- names(ci) <- c("lower", "upper")
- c(Predicted=bt@estimate, SE=SE(bt), ci)
- }))
- rownames(out) <- NULL
- as.data.frame(out)
- }
-
-
- #Calculate row-wise multinomial logit prob
- #implemented in C++ below as it is quite slow
- get_mlogit_R <- function(lp_mat){
- if(type == 'psi'){
- out <- cbind(1,exp(lp_mat))
- out <- out/rowSums(out)
- out <- out[,-1]
- } else if(type == 'phi'){ #doesn't work
- np <- nrow(lp_mat)
- out <- matrix(NA,np,ncol(lp_mat))
- ins <- outer(1:S, 1:S, function(i,j) i!=j)
- for (i in 1:np){
- phimat <- diag(S)
- phimat[ins] <- exp(lp_mat[i,])
- phimat <- t(phimat)
- phimat <- phimat/rowSums(phimat)
- out[i,] <- phimat[ins]
- }
- } else {
- R <- nrow(lp_mat)
- out <- matrix(NA,R,ncol(lp_mat))
- for (i in 1:R){
- sdp <- matrix(0,nrow=S,ncol=S)
- sdp[guide] <- exp(lp_mat[i,])
- sdp[,1] <- 1
- sdp <- sdp/rowSums(sdp)
- out[i,] <- sdp[guide]
- }
- }
- out
- }
-
- get_mlogit <- function(lp_mat){
- .Call("get_mlogit",
- lp_mat, type, S, guide-1)
- }
-
- #----------------------------------------------------------------------------
-
- if(type=="psi"){
- dm_list <- gd$dm_state
- ind <- gd$state_ind
- est <- object@estimates@estimates$state
- } else if(type=="phi"){
- dm_list <- gd$dm_phi
- ind <- gd$phi_ind
- est <- object@estimates@estimates$transition
- } else {
- dm_list <- gd$dm_det
- ind <- gd$det_ind
- est <- object@estimates@estimates$det
- }
-
- P <- length(dm_list)
-
- low_bound <- (1-level)/2
- z <- qnorm(low_bound,lower.tail=F)
-
- out <- vector("list", P)
- names(out) <- names(dm_list)
-
- if(object@parameterization == 'condbinom'){
- out <- lapply(1:length(dm_list), function(i){
- lc_to_predict(object, est, ind[i,], dm_list[[i]], level, se.fit)
- })
- names(out) <- names(dm_list)
- return(out)
-
- } else if (object@parameterization == "multinomial"){
- lp <- get_lp(coef(object), dm_list, ind)
- pred <- get_mlogit(lp)
-
- M <- nrow(pred)
- upr <- lwr <- se <- matrix(NA,M,P)
-
- if(se.fit){
- cat('Bootstrapping confidence intervals with',nsims,'samples\n')
-
- sig <- vcov(object)
- param_mean <- coef(object)
- rparam <- mvrnorm(nsims, param_mean, sig)
-
- get_pr <- function(i){
- lp <- get_lp(rparam[i,], dm_list, ind)
- get_mlogit(lp)
- }
- samp <- sapply(1:nsims, get_pr, simplify='array')
-
- for (i in 1:M){
- for (j in 1:P){
- dat <- samp[i,j,]
- se[i,j] <- sd(dat, na.rm=TRUE)
- quants <- quantile(dat, c(low_bound, (1-low_bound)),na.rm=TRUE)
- lwr[i,j] <- quants[1]
- upr[i,j] <- quants[2]
- }
- }
-
- }
- }
-
- for (i in 1:P){
- out[[i]] <- data.frame(Predicted=pred[,i], SE=se[,i],
- lower=lwr[,i], upper=upr[,i])
- }
-
- out
-})
-
-
-setMethod("predict", "unmarkedFitOccuTTD",
- function(object, type, newdata, backTransform = TRUE,
- na.rm = TRUE, appendData = FALSE,
- level=0.95, ...){
-
- if(missing(newdata) || is.null(newdata)){
- no_newdata <- TRUE
- newdata <- getData(object)
- } else {
- no_newdata <- FALSE
- }
-
- cls <- class(newdata)[1]
- allow <- c("unmarkedFrameOccuTTD", "data.frame", "RasterStack")
- if(!cls %in% allow){
- stop(paste("newdata should be class:",paste(allow, collapse=", ")))
- }
-
- #Check type
- allow_types <- names(object@estimates@estimates)
- if(!type %in% allow_types){
- stop(paste("type must be one of",paste(allow_types, collapse=", ")))
- }
-
- #Allow passthrough to colext predict method
- new_obj <- object
- class(new_obj)[1] <- "unmarkedFitColExt"
- if(cls == "unmarkedFrameOccuTTD"){
- class(newdata)[1] <- "unmarkedMultFrame"
- }
-
- predict(new_obj, type=type, newdata=newdata,
- backTransform=backTransform, na.rm=na.rm,
- appendData=appendData, level=level, ...)
-
-})
-
-
-setMethod("predict", "unmarkedFitNmixTTD",
- function(object, type, newdata, backTransform = TRUE,
- na.rm = TRUE, appendData = FALSE,
- level=0.95, ...){
-
- if(missing(newdata) || is.null(newdata)){
- no_newdata <- TRUE
- newdata <- getData(object)
- } else {
- no_newdata <- FALSE
- }
-
- cls <- class(newdata)[1]
- allow <- c("unmarkedFrameOccuTTD", "data.frame", "RasterStack")
- if(!cls %in% allow){
- stop(paste("newdata should be class:",paste(allow, collapse=", ")))
- }
-
- #Check type
- allow_types <- names(object@estimates@estimates)
- if(!type %in% allow_types){
- stop(paste("type must be one of",paste(allow_types, collapse=", ")))
- }
-
- #Allow passthrough to colext predict method
- new_obj <- object
- class(new_obj)[1] <- "unmarkedFitColExt"
- if(type == "state") type <- 'psi'
- names(new_obj@estimates@estimates)[1] <- 'psi'
- if(cls == "unmarkedFrameOccuTTD"){
- class(newdata)[1] <- "unmarkedMultFrame"
- }
-
- predict(new_obj, type=type, newdata=newdata,
- backTransform=backTransform, na.rm=na.rm,
- appendData=appendData, level=level, ...)
-
-})
-
-
# ---------------------- coef, vcov, and SE ------------------------------
@@ -2199,9 +280,10 @@ setMethod("coef", "unmarkedFit",
setMethod("vcov", "unmarkedFit",
- function (object, type, altNames = TRUE, method = "hessian", ...)
+ function (object, type, altNames = TRUE, method = "hessian", fixedOnly=TRUE, ...)
{
method <- match.arg(method, c("hessian", "nonparboot"))
+ if(.hasSlot(object, "TMB") && !is.null(object@TMB)) method <- "TMB"
switch(method,
hessian = {
if (is.null(object@opt$hessian)) {
@@ -2214,6 +296,9 @@ setMethod("vcov", "unmarkedFit",
stop("No bootstrap samples have been drawn. Use nonparboot first.")
}
v <- object@covMatBS
+ },
+ TMB = {
+ return(vcov_TMB(object, type, fixedOnly))
})
rownames(v) <- colnames(v) <- names(coef(object, altNames=altNames))
if (missing(type)) {
@@ -2446,9 +531,9 @@ setMethod("fitted", "unmarkedFitPCount", function(object, K, na.rm = FALSE)
return(fitted)
})
-#Get fitted N from Dail-Madsen type models
-#This part is the same across different detection models
-fittedOpenN <- function(object, K, na.rm=FALSE)
+
+setMethod("fitted", "unmarkedFitDailMadsen",
+ function(object, K, na.rm = FALSE)
{
dynamics <- object@dynamics
mixture <- object@mixture
@@ -2558,21 +643,7 @@ fittedOpenN <- function(object, K, na.rm=FALSE)
}
N <- N[,rep(1:T, each=J)]
-}
-
-setMethod("fitted", "unmarkedFitPCO",
- function(object, K, na.rm = FALSE)
-{
- N <- fittedOpenN(object, K, na.rm)
- p <- getP(object, na.rm)
- N * p
-})
-
-setMethod("fitted", "unmarkedFitDSO",
- function(object, K, na.rm = FALSE)
-{
- N <- fittedOpenN(object, K, na.rm)
p <- getP(object, na.rm)
N * p
})
@@ -2634,9 +705,9 @@ setMethod("fitted", "unmarkedFitOccuMS", function(object, na.rm = FALSE)
}
guide <- matrix(NA,nrow=S,ncol=S)
- guide <- lower.tri(guide,diag=T)
+ guide <- lower.tri(guide,diag=TRUE)
guide[,1] <- FALSE
- guide <- which(guide,arr.ind=T)
+ guide <- which(guide,arr.ind=TRUE)
#Get predictions
pr <- predict(object, 'psi', se.fit=F)
@@ -2991,7 +1062,9 @@ setMethod("update", "unmarkedFitOccuMS",
if(!missing(phiformulas)){
call[["phiformulas"]] <- phiformulas
} else {
- call[["phiformulas"]] <- object@phiformulas
+ if(!is.null(call$phiformulas)){
+ call[["phiformulas"]] <- object@phiformulas
+ }
}
extras <- match.call(call=sys.call(-1),
expand.dots = FALSE)$...
@@ -3133,7 +1206,7 @@ setMethod("update", "unmarkedFitGMM",
})
-setMethod("update", "unmarkedFitPCOorDSO",
+setMethod("update", "unmarkedFitDailMadsen",
function(object, lambdaformula., gammaformula., omegaformula.,
pformula., iotaformula., ..., evaluate = TRUE) {
call <- object@call
@@ -3558,13 +1631,13 @@ setMethod("getP", "unmarkedFitDS",
umf <- object@data
designMats <- getDesign(umf, formula, na.rm = na.rm)
y <- designMats$y
- V <- designMats$V
+ V <- cbind(designMats$V, designMats$Z_det)
V.offset <- designMats$V.offset
if (is.null(V.offset))
V.offset <- rep(0, nrow(V))
M <- nrow(y)
J <- ncol(y)
- ppars <- coef(object, type = "det")
+ ppars <- coef(object, type = "det", fixedOnly=FALSE)
db <- umf@dist.breaks
w <- diff(db)
survey <- umf@survey
@@ -3829,13 +1902,13 @@ setMethod("getP", "unmarkedFitMPois", function(object, na.rm = TRUE)
umf <- object@data
designMats <- getDesign(umf, formula, na.rm = na.rm)
y <- designMats$y
- V <- designMats$V
+ V <- as.matrix(cbind(designMats$V, designMats$Z_det))
V.offset <- designMats$V.offset
if (is.null(V.offset))
V.offset <- rep(0, nrow(V))
M <- nrow(y)
J <- obsNum(umf) #ncol(y)
- ppars <- coef(object, type = "det")
+ ppars <- coef(object, type = "det", fixedOnly=FALSE)
p <- plogis(V %*% ppars + V.offset)
p <- matrix(p, M, J, byrow = TRUE)
pi <- do.call(piFun, list(p = p))
@@ -3935,7 +2008,7 @@ setMethod("getP", "unmarkedFitGMM",
p <- aperm(p, c(1,3,2))
cp <- array(as.numeric(NA), c(M, T, R))
- for(t in 1:T) cp[,t,] <- do.call(piFun, list(p[,t,]))
+ for(t in 1:T) cp[,t,] <- do.call(piFun, list(matrix(p[,t,], M, J)))
cp <- aperm(cp, c(1,3,2))
cp <- matrix(cp, nrow=M, ncol=numY(object@data))
@@ -3990,13 +2063,13 @@ setMethod("simulate", "unmarkedFitDS",
w <- diff(db)
designMats <- getDesign(umf, formula, na.rm = na.rm)
y <- designMats$y
- X <- designMats$X
+ X <- as.matrix(cbind(designMats$X, designMats$Z_state))
X.offset <- designMats$X.offset
if (is.null(X.offset))
X.offset <- rep(0, nrow(X))
M <- nrow(y)
J <- ncol(y)
- lamParms <- coef(object, type = "state")
+ lamParms <- coef(object, type = "state", fixedOnly=FALSE)
lambda <- drop(exp(X %*% lamParms + X.offset))
if(identical(object@output, "density")) {
switch(umf@survey,
@@ -4220,9 +2293,9 @@ setMethod("simulate", "unmarkedFitPCO",
})
-#Function used by both unmarkedFitDSO and MMO
-multinomOpenSim <- function(object, nsim, seed, na.rm){
-
+setMethod("simulate", "unmarkedFitDailMadsen",
+ function(object, nsim = 1, seed = NULL, na.rm = TRUE)
+{
umf <- object@data
D <- getDesign(umf, object@formula, na.rm = na.rm)
y <- D$y
@@ -4259,19 +2332,6 @@ multinomOpenSim <- function(object, nsim, seed, na.rm){
simList[[s]] <- y.sim
}
return(simList)
-}
-
-setMethod("simulate", "unmarkedFitDSO",
- function(object, nsim = 1, seed = NULL, na.rm = TRUE)
-{
- multinomOpenSim(object, nsim, seed, na.rm)
-})
-
-
-setMethod("simulate", "unmarkedFitMMO",
- function(object, nsim = 1, seed = NULL, na.rm = TRUE)
-{
- multinomOpenSim(object, nsim, seed, na.rm)
})
@@ -4282,14 +2342,14 @@ setMethod("simulate", "unmarkedFitMPois",
umf <- object@data
designMats <- getDesign(umf, formula, na.rm = na.rm)
y <- designMats$y
- X <- designMats$X
+ X <- as.matrix(cbind(designMats$X, designMats$Z_state))
X.offset <- designMats$X.offset
if (is.null(X.offset)) {
X.offset <- rep(0, nrow(X))
}
M <- nrow(y)
J <- ncol(y)
- lamParms <- coef(object, type = "state")
+ lamParms <- coef(object, type = "state", fixedOnly=FALSE)
lam <- as.numeric(exp(X %*% lamParms + X.offset))
lamvec <- rep(lam, each = J)
pivec <- as.vector(t(getP(object, na.rm = na.rm)))
@@ -4433,9 +2493,9 @@ setMethod("simulate", "unmarkedFitOccuMS",
p <- getP(object)
guide <- matrix(NA,nrow=S,ncol=S)
- guide <- lower.tri(guide,diag=T)
+ guide <- lower.tri(guide,diag=TRUE)
guide[,1] <- FALSE
- guide <- which(guide,arr.ind=T)
+ guide <- which(guide,arr.ind=TRUE)
out <- vector("list",nsim)
@@ -4492,14 +2552,15 @@ setMethod("simulate", "unmarkedFitOccuMS",
for (n in 1:N){
yindex <- 1
for (t in 1:T){
- if (z[n,t] == 0) {
- yindex <- yindex + J
- next
- }
for (j in 1:J){
-
if(prm == "multinomial"){
probs_raw <- sapply(p, function(x) x[n,yindex])
+ # Make sure output is NA if probs have NA
+ if(any(is.na(probs_raw))){
+ y[n,yindex] <- NA
+ yindex <- yindex + 1
+ next
+ }
sdp <- matrix(0, nrow=S, ncol=S)
sdp[guide] <- probs_raw
@@ -4511,13 +2572,22 @@ setMethod("simulate", "unmarkedFitOccuMS",
p11 <- p[[1]][n,yindex]
p12 <- p[[2]][n,yindex]
p22 <- p[[3]][n,yindex]
+ # Trap NAs in probability of detection
+ if(any(is.na(c(p11, p12, p22)))){
+ y[n,yindex] <- NA
+ next
+ }
probs <- switch(z[n,t]+1,
c(1,0,0),
c(1-p11,p11,0),
c(1-p12,p12*(1-p22),p12*p22))
}
-
- y[n,yindex] <- sample(0:(S-1), 1, prob=probs)
+ # this NA trap probably isn't necessary but leaving it in just in case
+ if(all(!is.na(probs))){
+ y[n,yindex] <- sample(0:(S-1), 1, prob=probs)
+ } else {
+ y[n,yindex] <- NA
+ }
yindex <- yindex + 1
}
}
@@ -4542,6 +2612,13 @@ setMethod("simulate", "unmarkedFitOccuTTD",
#Get predicted values
psi <- predict(object, 'psi', na.rm=FALSE)$Predicted
lam <- predict(object, 'det', na.rm=FALSE)$Predicted
+ if(T>1){
+ p_col <- predict(object, 'col', na.rm=FALSE)$Predicted
+ p_col <- matrix(p_col, N, T, byrow=TRUE)
+ p_ext <- predict(object, 'ext', na.rm=FALSE)$Predicted
+ p_ext <- matrix(p_ext, N, T, byrow=TRUE)
+ }
+
tmax <- object@data@surveyLength
not_na <- which(!is.na(lam))
@@ -4558,13 +2635,6 @@ setMethod("simulate", "unmarkedFitOccuTTD",
ttd <- matrix(ttd, nrow=N, byrow=T)
ttd[which(ttd>tmax)] <- tmax[which(ttd>tmax)]
- if(T>1){
- p_col <- predict(object, 'col', na.rm=FALSE)$Predicted
- p_col <- matrix(p_col, N, T, byrow=TRUE)
- p_ext <- predict(object, 'ext', na.rm=FALSE)$Predicted
- p_ext <- matrix(p_ext, N, T, byrow=TRUE)
- }
-
#Latent state
z <- matrix(NA, N, T)
z[,1] <- rbinom(N, 1, psi)
diff --git a/R/unmarkedFitList.R b/R/unmarkedFitList.R
index c97bace..2974678 100644
--- a/R/unmarkedFitList.R
+++ b/R/unmarkedFitList.R
@@ -120,7 +120,7 @@ setMethod("predict", "unmarkedFitList", function(object, type, newdata=NULL,
ese <- lapply(fitList, predict, type = type, newdata = newdata,
backTransform = backTransform, level=level)
- if(class(newdata) == "RasterStack"){
+ if(inherits(newdata, "RasterStack")){
if(!require(raster)) stop("raster package is required")
ese <- lapply(ese, as.matrix)
}
@@ -139,7 +139,7 @@ setMethod("predict", "unmarkedFitList", function(object, type, newdata=NULL,
out$lower <- as.numeric(lower %*% wts)
out$upper <- as.numeric(upper %*% wts)
- if(class(newdata) == "RasterStack"){
+ if(inherits(newdata, "RasterStack")){
E.mat <- matrix(out[,1], dim(newdata)[1], dim(newdata)[2], byrow=TRUE)
E.raster <- raster::raster(E.mat)
raster::extent(E.raster) <- raster::extent(newdata)
@@ -150,7 +150,7 @@ setMethod("predict", "unmarkedFitList", function(object, type, newdata=NULL,
raster::extent(i.raster) <- raster::extent(newdata)
out.rasters[[i]] <- i.raster
}
- out.stack <- stack(out.rasters)
+ out.stack <- raster::stack(out.rasters)
names(out.stack) <- colnames(out)
raster::crs(out.stack) <- raster::crs(newdata)
return(out.stack)
diff --git a/R/unmarkedFrame.R b/R/unmarkedFrame.R
index d8286b2..b6a9273 100644
--- a/R/unmarkedFrame.R
+++ b/R/unmarkedFrame.R
@@ -317,6 +317,10 @@ unmarkedFrameMPois <- function(y, siteCovs = NULL, obsCovs = NULL, type,
depDouble = {
obsToY <- matrix(1, 2, 2)
piFun <- "depDoublePiFun"
+ if(ncol(y) != 2){
+ stop("y must have exactly 2 columns when type = 'depDouble'",
+ call.=FALSE)
+ }
})
} else {
if(missing(obsToY))
@@ -436,6 +440,9 @@ unmarkedFrameGMM <- function(y, siteCovs = NULL, obsCovs = NULL, numPrimary,
piFun <- "doublePiFun"
},
depDouble = {
+ if(J!=2){
+ stop("y must have exactly 2 columns per primary period", call.=FALSE)
+ }
obsToY <- matrix(1, 2, 2)
obsToY <- kronecker(diag(numPrimary), obsToY)
piFun <- "depDoublePiFun"
@@ -1126,9 +1133,10 @@ setMethod("[", c("unmarkedFrame", "numeric", "missing", "missing"),
if (!is.null(obsCovs)) {
R <- obsNum(x)
.site <- rep(1:M, each = R)
- obsCovs <- ldply(i, function(site) {
- subset(obsCovs, .site == site)
- })
+ oc <- lapply(i, function(ind){
+ obsCovs[.site==ind,,drop=FALSE]
+ })
+ obsCovs <- do.call(rbind, oc)
}
umf <- x
umf@y <- y
@@ -1184,17 +1192,20 @@ setMethod("[", c("unmarkedFrame","list", "missing", "missing"),
if (m != length(i)) stop("list length must be same as number of sites.")
siteCovs <- siteCovs(x)
y <- cbind(.site=1:m, getY(x))
- obsCovs <- as.data.frame(cbind(.site=rep(1:m, each=R), obsCovs(x)))
-
- obsCovs <- ddply(obsCovs, ~.site, function(df) {
- site <- df$.site[1]
- obs <- i[[site]]
- if (length(obs) > R)
- stop("All elements of list must be less than or equal to R.")
- obs <- c(obs, rep(NA, R-length(obs)))
- df[obs,]
- })
- obsCovs$.site <- NULL
+ obsCovs <- obsCovs(x)
+ site_idx <- rep(1:m, each=R)
+ stopifnot(length(site_idx) == nrow(obsCovs))
+
+ oc <- lapply(1:m, function(ind){
+ df <- obsCovs[site_idx==ind,,drop=FALSE]
+ obs <- i[[ind]]
+ if (length(obs) > R)
+ stop("All elements of list must be less than or equal to R.")
+ obs <- c(obs, rep(NA, R-length(obs)))
+ df[obs,,drop=FALSE]
+ })
+ obsCovs <- do.call(rbind, oc)
+ rownames(obsCovs) <- NULL
y <- apply(y, 1, function(row) {
site <- row[1]
@@ -1228,9 +1239,10 @@ setMethod("[", c("unmarkedFrameOccuMulti", "numeric", "missing", "missing"),
if (!is.null(obsCovs)) {
R <- obsNum(x)
.site <- rep(1:M, each = R)
- obsCovs <- ldply(i, function(site) {
- subset(obsCovs, .site == site)
- })
+ oc <- lapply(i, function(ind){
+ obsCovs[.site==ind,,drop=FALSE]
+ })
+ obsCovs <- do.call(rbind, oc)
}
umf <- x
umf@y <- ylist[[1]]
@@ -1303,9 +1315,10 @@ setMethod("[", c("unmarkedMultFrame", "numeric", "missing", "missing"),
if (!is.null(obsCovs)) {
R <- obsNum(x)
.site <- rep(1:M, each = obsNum(x)) #NULL ## testing
- obsCovs <- ldply(i, function(site) {
- subset(obsCovs, .site == site)
- })
+ oc <- lapply(i, function(ind){
+ obsCovs[.site==ind,,drop=FALSE]
+ })
+ obsCovs <- do.call(rbind, oc)
}
u <- unmarkedMultFrame(y=matrix(y, ncol=ncol(oldy)),
siteCovs=siteCovs,
@@ -1337,12 +1350,28 @@ setMethod("[", c("unmarkedFrameOccuMS", "numeric", "missing", "missing"),
setMethod("[", c("unmarkedFrameGMM", "numeric", "missing", "missing"),
function(x, i, j)
{
- multf <- callNextMethod(x, i, j) # unmarkedMultFrame
- unmarkedFrameGMM(y=getY(multf), siteCovs=siteCovs(multf),
- yearlySiteCovs=yearlySiteCovs(multf),
- obsCovs=obsCovs(multf),
+ M <- nrow(x@y)
+ y <- x@y[i,,drop=FALSE]
+ R <- obsNum(x)
+ T <- x@numPrimary
+
+ sc <- siteCovs(x)[i,,drop=FALSE]
+
+ ysc_ind <- rep(1:M, each=T)
+ ysc <- do.call("rbind", lapply(i, function(ind){
+ yearlySiteCovs(x)[ysc_ind == ind,,drop=FALSE]
+ }))
+
+ oc_ind <- rep(1:M, each=R)
+ oc <- do.call("rbind", lapply(i, function(ind){
+ obsCovs(x)[oc_ind == ind,,drop=FALSE]
+ }))
+
+ unmarkedFrameGMM(y=y, siteCovs=sc,
+ yearlySiteCovs=ysc,
+ obsCovs=oc,
piFun=x@piFun, type=x@samplingMethod,
- obsToY=multf@obsToY, numPrimary=multf@numPrimary)
+ obsToY=x@obsToY, numPrimary=x@numPrimary)
})
diff --git a/R/utils.R b/R/utils.R
index 95da966..9e9dff6 100644
--- a/R/utils.R
+++ b/R/utils.R
@@ -736,7 +736,11 @@ invertHessian <- function(optimOut, nparam, SE){
getUA <- function(umf){
M <- numSites(umf)
- J <- ncol(getY(umf)) / umf@numPrimary
+ if(inherits(umf, "unmarkedFrameGDR")){
+ J <- ncol(umf@yDistance) / umf@numPrimary
+ } else{
+ J <- ncol(getY(umf)) / umf@numPrimary
+ }
db <- umf@dist.breaks
w <- diff(db)
@@ -884,3 +888,22 @@ dzip <- function(x, lambda, psi) {
den[gr0] <- (1-psi)*dpois(x[gr0], lambda[gr0])
den
}
+
+# Expected value of log lambda when there is a random intercept
+E_loglam <- function(log_lam, object, name){
+
+ if(!methods::.hasSlot(object, "TMB") || is.null(object@TMB)){
+ return(log_lam)
+ }
+ sig <- sigma(object)
+ if(! name %in% sig$Model) return(log_lam)
+
+ sig <- sig[sig$Model==name,]
+ can_calculate <- (nrow(sig) == 1) & (sig$Name[1] == "(Intercept)")
+ if(! can_calculate){
+ stop("No support for models with > 1 random effect", call.=FALSE)
+ }
+ v <- sig$sigma^2
+ ll <- log_lam + v/2
+ ll
+}
diff --git a/R/zzz.R b/R/zzz.R
new file mode 100644
index 0000000..063c71c
--- /dev/null
+++ b/R/zzz.R
@@ -0,0 +1 @@
+.shiny_env <- new.env(parent=emptyenv())
diff --git a/README.Rmd b/README.Rmd
new file mode 100644
index 0000000..e4c34a3
--- /dev/null
+++ b/README.Rmd
@@ -0,0 +1,86 @@
+---
+output:
+ md_document:
+ variant: gfm
+---
+
+# R package unmarked
+
+<!-- badges: start -->
+[![R build status](https://github.com/rbchan/unmarked/workflows/R-CMD-check/badge.svg)](https://github.com/rbchan/unmarked/actions)
+[![CRAN status](https://www.r-pkg.org/badges/version/unmarked)](https://cran.r-project.org/package=unmarked)
+<!-- badges: end -->
+
+`unmarked` is an [R](https://www.r-project.org/) package for analyzing ecological data arising from several popular sampling techniques. The sampling methods include point counts, occurrence sampling, distance sampling, removal, double observer, and many others. `unmarked` uses hierarchical models to incorporate covariates of the latent abundance (or occupancy) and imperfect detection processes.
+
+## Installation
+
+The latest stable version of unmarked can be downloaded from [CRAN](https://cran.r-project.org/package=unmarked):
+
+```{r, eval=FALSE}
+install.packages("unmarked")
+```
+
+The latest development version can be installed from Github:
+
+```{r, eval=FALSE}
+install.packages("remotes")
+remotes::install_github("rbchan/unmarked")
+```
+
+## Support
+
+Support is provided through the [unmarked Google group](http://groups.google.com/group/unmarked).
+The package [website](https://rbchan.github.io/unmarked) has more information.
+You can report bugs [here](https://github.com/rbchan/unmarked/issues), by posting to the Google group, or by emailing [the current maintainer](https://kenkellner.com).
+
+## Example analysis
+
+Below we demonstrate a simple single-season occupancy analysis using `unmarked`.
+First, load in a dataset from a CSV file and format:
+
+```{r}
+library(unmarked)
+wt <- read.csv(system.file("csv","widewt.csv", package="unmarked"))
+
+# Presence/absence matrix
+y <- wt[,2:4]
+
+# Site and observation covariates
+siteCovs <- wt[,c("elev", "forest", "length")]
+obsCovs <- list(date=wt[,c("date.1", "date.2", "date.3")])
+```
+
+Create an `unmarkedFrame`, a special type of `data.frame` for `unmarked` analyses:
+
+```{r}
+umf <- unmarkedFrameOccu(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
+summary(umf)
+```
+
+Fit a null occupancy model and a model with covariates, using the `occu` function:
+
+```{r}
+(mod_null <- occu(~1~1, data=umf))
+(mod_covs <- occu(~date~elev, data=umf))
+```
+
+Rank them using AIC:
+
+```{r}
+fl <- fitList(null=mod_null, covs=mod_covs)
+modSel(fl)
+```
+
+Estimate occupancy probability using the top-ranked model at the first six sites:
+
+```{r}
+head(predict(mod_covs, type='state'))
+```
+
+Predict occupancy probability at a new site with given covariate values:
+
+```{r}
+nd <- data.frame(elev = 1.2)
+predict(mod_covs, type="state", newdata=nd)
+```
diff --git a/README.md b/README.md
index 5f4896a..7f237e9 100644
--- a/README.md
+++ b/README.md
@@ -1,15 +1,173 @@
# R package unmarked
<!-- badges: start -->
-[![R build status](https://github.com/rbchan/unmarked/workflows/R-CMD-check/badge.svg)](https://github.com/rbchan/unmarked/actions)
+
+[![R build
+status](https://github.com/rbchan/unmarked/workflows/R-CMD-check/badge.svg)](https://github.com/rbchan/unmarked/actions)
+[![CRAN
+status](https://www.r-pkg.org/badges/version/unmarked)](https://cran.r-project.org/package=unmarked)
<!-- badges: end -->
-Unmarked is an [R](https://www.r-project.org/) package for analyzing ecological data arising from several popular sampling techniques. The sampling methods include point counts, occurrence sampling, distance sampling, removal, double observer, and many others. Unmarked uses hierarchical models to incorporate covariates of the latent abundance (or occupancy) and imperfect detection processes.
+`unmarked` is an [R](https://www.r-project.org/) package for analyzing
+ecological data arising from several popular sampling techniques. The
+sampling methods include point counts, occurrence sampling, distance
+sampling, removal, double observer, and many others. `unmarked` uses
+hierarchical models to incorporate covariates of the latent abundance
+(or occupancy) and imperfect detection processes.
+
+## Installation
-The latest stable version of unmarked can be downloaded from CRAN with the R command:
+The latest stable version of unmarked can be downloaded from
+[CRAN](https://cran.r-project.org/package=unmarked):
-```R
+``` r
install.packages("unmarked")
```
-Support is provided through the [unmarked google group](http://groups.google.com/group/unmarked).
+The latest development version can be installed from Github:
+
+``` r
+install.packages("remotes")
+remotes::install_github("rbchan/unmarked")
+```
+
+## Support
+
+Support is provided through the [unmarked Google
+group](http://groups.google.com/group/unmarked). The package
+[website](https://rbchan.github.io/unmarked) has more information. You
+can report bugs [here](https://github.com/rbchan/unmarked/issues), by
+posting to the Google group, or by emailing [the current
+maintainer](https://kenkellner.com).
+
+## Example analysis
+
+Below we demonstrate a simple single-season occupancy analysis using
+`unmarked`. First, load in a dataset from a CSV file and format:
+
+``` r
+library(unmarked)
+wt <- read.csv(system.file("csv","widewt.csv", package="unmarked"))
+
+# Presence/absence matrix
+y <- wt[,2:4]
+
+# Site and observation covariates
+siteCovs <- wt[,c("elev", "forest", "length")]
+obsCovs <- list(date=wt[,c("date.1", "date.2", "date.3")])
+```
+
+Create an `unmarkedFrame`, a special type of `data.frame` for `unmarked`
+analyses:
+
+``` r
+umf <- unmarkedFrameOccu(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
+summary(umf)
+```
+
+ ## unmarkedFrame Object
+ ##
+ ## 237 sites
+ ## Maximum number of observations per site: 3
+ ## Mean number of observations per site: 2.81
+ ## Sites with at least one detection: 79
+ ##
+ ## Tabulation of y observations:
+ ## 0 1 <NA>
+ ## 483 182 46
+ ##
+ ## Site-level covariates:
+ ## elev forest length
+ ## Min. :-1.436125 Min. :-1.265352 Min. :0.1823
+ ## 1st Qu.:-0.940726 1st Qu.:-0.974355 1st Qu.:1.4351
+ ## Median :-0.166666 Median :-0.064987 Median :1.6094
+ ## Mean : 0.007612 Mean : 0.000088 Mean :1.5924
+ ## 3rd Qu.: 0.994425 3rd Qu.: 0.808005 3rd Qu.:1.7750
+ ## Max. : 2.434177 Max. : 2.299367 Max. :2.2407
+ ##
+ ## Observation-level covariates:
+ ## date
+ ## Min. :-2.90434
+ ## 1st Qu.:-1.11862
+ ## Median :-0.11862
+ ## Mean :-0.00022
+ ## 3rd Qu.: 1.30995
+ ## Max. : 3.80995
+ ## NA's :42
+
+Fit a null occupancy model and a model with covariates, using the `occu`
+function:
+
+``` r
+(mod_null <- occu(~1~1, data=umf))
+```
+
+ ##
+ ## Call:
+ ## occu(formula = ~1 ~ 1, data = umf)
+ ##
+ ## Occupancy:
+ ## Estimate SE z P(>|z|)
+ ## -0.665 0.139 -4.77 1.82e-06
+ ##
+ ## Detection:
+ ## Estimate SE z P(>|z|)
+ ## 1.32 0.174 7.61 2.82e-14
+ ##
+ ## AIC: 528.987
+
+``` r
+(mod_covs <- occu(~date~elev, data=umf))
+```
+
+ ##
+ ## Call:
+ ## occu(formula = ~date ~ elev, data = umf)
+ ##
+ ## Occupancy:
+ ## Estimate SE z P(>|z|)
+ ## (Intercept) -0.738 0.157 -4.71 2.45e-06
+ ## elev 0.885 0.174 5.10 3.49e-07
+ ##
+ ## Detection:
+ ## Estimate SE z P(>|z|)
+ ## (Intercept) 1.2380 0.180 6.869 6.47e-12
+ ## date 0.0603 0.121 0.497 6.19e-01
+ ##
+ ## AIC: 498.158
+
+Rank them using AIC:
+
+``` r
+fl <- fitList(null=mod_null, covs=mod_covs)
+modSel(fl)
+```
+
+ ## nPars AIC delta AICwt cumltvWt
+ ## covs 4 498.16 0.00 1e+00 1.00
+ ## null 2 528.99 30.83 2e-07 1.00
+
+Estimate occupancy probability using the top-ranked model at the first
+six sites:
+
+``` r
+head(predict(mod_covs, type='state'))
+```
+
+ ## Predicted SE lower upper
+ ## 1 0.1448314 0.03337079 0.09080802 0.2231076
+ ## 2 0.1499962 0.03351815 0.09535878 0.2280473
+ ## 3 0.2864494 0.03346270 0.22555773 0.3562182
+ ## 4 0.3035399 0.03371489 0.24175619 0.3733387
+ ## 5 0.1607798 0.03374307 0.10502635 0.2382512
+ ## 6 0.1842147 0.03392277 0.12669813 0.2600662
+
+Predict occupancy probability at a new site with given covariate values:
+
+``` r
+nd <- data.frame(elev = 1.2)
+predict(mod_covs, type="state", newdata=nd)
+```
+
+ ## Predicted SE lower upper
+ ## 1 0.5803085 0.06026002 0.4598615 0.6918922
diff --git a/_pkgdown.yml b/_pkgdown.yml
new file mode 100644
index 0000000..25e44c8
--- /dev/null
+++ b/_pkgdown.yml
@@ -0,0 +1,61 @@
+authors:
+ Richard Chandler:
+ href: https://chandlerlab.uga.edu/richard-chandler-phd/
+ Ken Kellner:
+ href: https://kenkellner.com
+
+home:
+ links:
+ - text: Get help from the community
+ href: https://groups.google.com/g/unmarked
+
+reference:
+ - title: Occupancy models
+ contents:
+ - occu
+ - colext
+ - occuFP
+ - occuMS
+ - occuMulti
+ - occuPEN
+ - occuTTD
+ - title: Abundance models
+ contents:
+ - occuRN
+ - pcount
+ - distsamp
+ - multinomPois
+ - pcount.spHDS
+ - gpcount
+ - gmultmix
+ - gdistsamp
+ - gdistremoval
+ - pcountOpen
+ - distsampOpen
+ - multmixOpen
+ - nmixTTD
+ - title: Model diagnostics
+ contents:
+ - fitted,unmarkedFit-method
+ - parboot
+ - nonparboot,unmarkedFit-method
+ - residuals
+ - powerAnalysis
+ - simulate
+ - vif
+ - title: Model selection
+ contents:
+ - fitList
+ - modSel
+ - crossVal,unmarkedFit-method
+ - title: Model results
+ contents:
+ - coef,unmarkedFit-method
+ - predict,unmarkedFit-method
+ - linearComb
+ - backTransform
+ - ranef
+ - bup
+ - posteriorSamples,unmarkedRanef-method
+ - projected
+ - turnover
diff --git a/data/MesoCarnivores.rda b/data/MesoCarnivores.rda
new file mode 100644
index 0000000..ba91386
--- /dev/null
+++ b/data/MesoCarnivores.rda
Binary files differ
diff --git a/inst/shinyPower/server.R b/inst/shinyPower/server.R
new file mode 100644
index 0000000..75b27c0
--- /dev/null
+++ b/inst/shinyPower/server.R
@@ -0,0 +1,141 @@
+if (exists(".SHINY_MODEL")) {
+ mod <- .SHINY_MODEL
+} else {
+ object <- get(".SHINY_MODEL", envir = unmarked:::.shiny_env)
+}
+
+coefs <- unmarked:::check_coefs(NULL, mod, TRUE)
+
+inline_wrap <- function(f, ...){
+ out <- f(...)
+ div(style='display:inline-block; width: 100px; vertical-align:top', out)
+}
+
+get_coef_ui <- function(coefs, nulls=FALSE){
+
+ parbase <- "coef_"
+ if(nulls){
+ parbase <- "null_"
+ }
+ out <- list()
+
+ for (i in 1:length(coefs)){
+ pars <- coefs[[i]]
+ submod_name <- names(coefs)[i]
+ inps <- lapply(1:length(pars), function(x){
+ par_name <- names(pars)[x]
+ inp_name <- paste0(parbase,submod_name,"_",par_name)
+ inline_wrap(numericInput, inputId=inp_name, label=par_name,
+ value=0, step=0.01)
+ })
+ out <- c(out, list(h4(submod_name)), inps)
+ }
+ out
+}
+
+get_coefs <- function(input, nulls=FALSE){
+ parbase <- "coef_"
+ if(nulls) parbase <- "null_"
+ pass <- reactiveValuesToList(input)
+ inp_sub <- pass[grepl(parbase,names(pass), fixed=TRUE)]
+ inp_sub <- pass[!is.na(names(inp_sub))]
+ names(inp_sub) <- gsub(parbase, "", names(inp_sub))
+ submods <- gsub("_(.*)$","",names(inp_sub))
+ pars <- gsub("^(.*)_","",names(inp_sub))
+ out <- lapply(unique(submods), function(x){
+ vals <- unlist(inp_sub[which(submods==x)])
+ names(vals) <- pars[which(submods==x)]
+ vals
+ })
+ names(out) <- unique(submods)
+ out
+}
+
+get_design_ui <- function(input, default, name){
+ nval <- input[[paste0("ndesign_",name)]]
+ inps <- lapply(1:nval, function(x){
+ inp_name <- paste0("design_",name,"_",x)
+ inline_wrap(numericInput, inputId=inp_name, label=NULL,
+ value=default, min=1, step=1)
+ })
+ inps
+}
+
+get_design <- function(input){
+ pass <- reactiveValuesToList(input)
+ inp_M <- unlist(pass[grepl("design_sites_",names(pass),fixed=TRUE)])
+ inp_M <- inp_M[1:input[["ndesign_sites"]]]
+ inp_J <- unlist(pass[grepl("design_obs_",names(pass),fixed=TRUE)])
+ inp_J <- inp_J[1:input[["ndesign_obs"]]]
+ expand.grid(J=sort(inp_J), M=sort(inp_M), T=1)
+ #expand.grid(J=inp_J, M=inp_M, T=1)
+}
+
+run_analysis <- function(mod, coefs, alpha, nsim, nulls, design){
+ unmarkedPowerList(mod, coefs, design, alpha, nulls, nsim)
+}
+
+get_coef_tabset <- function(coefs){
+ tabsetPanel(
+ tabPanel("Effect sizes", get_coef_ui(coefs)),
+ tabPanel("Null hypotheses", get_coef_ui(coefs, nulls=TRUE))
+ )
+}
+
+get_power_plot <- function(object, param){
+ if(inherits(object, "unmarkedPowerList")){
+ plot(object, param=param)
+ } else {
+ plot(1, type="n",xlab="",ylab="",xaxt="n",yaxt="n")
+ }
+}
+
+get_param_selector <- function(input, object){
+ dat <- suppressWarnings(summary(object))
+ dat <- dat[dat$M==dat$M[1]&dat$J==dat$J[1]&dat$T==dat$T[1],]
+ dat <- dat[dat$Parameter != "(Intercept)",]
+ ops <- dat$Parameter
+ selectInput("plot_param", "Parameter to plot", choices=ops)
+}
+
+
+function(input, output, session){
+
+ #res_auth <- secure_server(
+ # check_credentials = check_credentials(credentials)
+ #)
+
+ #output$auth_output <- renderPrint({
+ # reactiveValuesToList(res_auth)
+ #})
+
+ options(unmarked_shiny_session=session)
+ output$plot <- renderPlot(plot(mod))
+ output$coef_ui <- renderUI(get_coef_tabset(coefs))
+ output$coefs <- renderPrint(get_coefs(input))
+ output$nulls <- renderPrint(get_coefs(input, nulls=TRUE))
+ output$mod <- renderUI(HTML(paste0("<b>Model:</b> ","mod")))
+ output$class <- renderUI(HTML(paste0("<b>Type:</b>&nbsp&nbsp&nbsp",
+ class(mod)[1])))
+ output$sites <- renderUI(HTML(paste0("<b>Sites:</b>&nbsp&nbsp",
+ numSites(mod@data))))
+ output$design_sites <- renderUI(get_design_ui(input,numSites(mod@data),"sites"))
+ output$design_obs <- renderUI(get_design_ui(input,obsNum(mod@data),"obs"))
+
+ observeEvent(input$run, {
+ coefs <- isolate(get_coefs(input))
+ nulls <- isolate(get_coefs(input, nulls=TRUE))
+ design <- isolate(get_design(input))
+ alpha <- isolate(input$alpha)
+ nsims <- isolate(input$nsims)
+ pa <- run_analysis(mod, coefs, alpha, nsims, nulls, design)
+ output$summary <- renderTable(
+ suppressWarnings(summary(pa))
+ )
+ output$param_selector <- renderUI(get_param_selector(input, pa))
+ output$plot <- renderPlot(suppressWarnings(get_power_plot(pa, input$plot_param)))
+ })
+}
+
+
+
diff --git a/inst/shinyPower/ui.R b/inst/shinyPower/ui.R
new file mode 100644
index 0000000..636c629
--- /dev/null
+++ b/inst/shinyPower/ui.R
@@ -0,0 +1,51 @@
+library(shiny)
+
+inline_wrap <- function(f, ...){
+ out <- f(...)
+ div(style='display:inline-block; width: 100px; vertical-align:top', out)
+}
+
+ui <- fluidPage(
+ tags$head(
+ tags$style(HTML('#run{background-color:orange}'))
+ ),
+ titlePanel("Power Analysis"),
+ sidebarLayout(
+ sidebarPanel(width=4,
+ htmlOutput("mod"),
+ htmlOutput("class"),
+ htmlOutput("sites"),
+ br(),
+ inline_wrap(numericInput, inputId="alpha", label="Type I error (alpha)",
+ value=0.05, min=0.001, max=1),
+ inline_wrap(numericInput, inputId="nsims", label="Number of simulations",
+ value=10, min=1, max=300, step=1),
+ br(), br(),
+ #h3("Site scenarios"),
+ HTML("<b>Number of site (M) scenarios:</b>"),
+ inline_wrap(numericInput, inputId="ndesign_sites", label=NULL,
+ min=1, max=10, value=1, step=1),
+ uiOutput("design_sites"),
+
+ HTML("<b>Number of obs (J) scenarios:</b>"),
+ inline_wrap(numericInput, inputId="ndesign_obs", label=NULL,
+ min=1, max=10, value=1, step=1),
+ uiOutput("design_obs"),
+ #uiOutput("scenarios"),
+ br(),
+ uiOutput("coef_ui"),
+ br(),
+ actionButton("run", "Run analysis")
+ ),
+ mainPanel(width=8,
+ tabsetPanel(
+ tabPanel("Summary", tableOutput("summary")),
+ tabPanel("Plot",
+ uiOutput("param_selector"),
+ plotOutput("plot"))
+ )
+ )
+ )
+)
+
+ui
diff --git a/inst/unitTests/runTests.R b/inst/unitTests/runTests.R
deleted file mode 100644
index 9363716..0000000
--- a/inst/unitTests/runTests.R
+++ /dev/null
@@ -1,99 +0,0 @@
-## Adapted this from Rcpp package
-
-pkg <- "unmarked"
-
-if(require("RUnit", quietly = TRUE)) {
-
- is_local <- function(){
- if( exists( "argv", globalenv() ) && "--local" %in% argv ) return(TRUE)
- if( "--local" %in% commandArgs(TRUE) ) return(TRUE)
- FALSE
- }
- if( is_local() ) path <- getwd()
-
- library(package=pkg, character.only = TRUE)
- if(!(exists("path") && file.exists(path)))
- path <- system.file("unitTests", package = pkg)
-
- ## --- Testing ---
-
- ## Define tests
- testSuite <- defineTestSuite(name=paste(pkg, "unit testing"),
- dirs = path,
- rngKind="Mersenne-Twister",
- rngNormalKind="Inversion")
-
- if(interactive()) {
- cat("Now have RUnit Test Suite 'testSuite' for package '", pkg,
- "' :\n", sep='')
- str(testSuite)
- cat('', "Consider doing",
- "\t tests <- runTestSuite(testSuite)", "\nand later",
- "\t printTextProtocol(tests)", '', sep="\n")
- } else { ## run from shell / Rscript / R CMD Batch / ...
- ## Run
- tests <- runTestSuite(testSuite)
-
- output <- NULL
-
- process_args <- function(argv){
- if( !is.null(argv) && length(argv) > 0 ){
- rx <- "^--output=(.*)$"
- g <- grep( rx, argv, value = TRUE )
- if( length(g) ){
- sub( rx, "\\1", g[1L] )
- }
- }
- }
-
- # give a chance to the user to customize where he/she wants
- # the unit tests results to be stored with the --output= command
- # line argument
- if( exists( "argv", globalenv() ) ){
- # littler
- output <- process_args(argv)
- } else {
- # Rscript
- output <- process_args(commandArgs(TRUE))
- }
-
- # if it did not work, try to use /tmp
- if( is.null(output) ){
- if( file.exists( "/tmp" ) ){
- output <- "/tmp"
- } else{
- output <- getwd()
- }
- }
-
- ## Print results
- printTextProtocol(tests)
- output.txt <- file.path( output, sprintf("%s-unitTests.txt", pkg))
- output.html <- file.path( output, sprintf("%s-unitTests.html", pkg))
-
- printTextProtocol(tests, fileName=output.txt)
- message( sprintf( "saving txt unit test report to '%s'", output.txt ) )
-
- ## Print HTML version to a file
- ## printHTMLProtocol has problems on Mac OS X
- if (Sys.info()["sysname"] != "Darwin"){
- message( sprintf( "saving html unit test report to '%s'", output.html ) )
- printHTMLProtocol(tests, fileName=output.html)
- }
-
- ## stop() if there are any failures i.e. FALSE to unit test.
- ## This will cause R CMD check to return error and stop
- if(getErrors(tests)$nFail > 0) {
- stop("one of the unit tests failed")
- }
- }
-} else {
- cat("R package 'RUnit' cannot be loaded -- no unit tests run\n",
- "for package", pkg,"\n")
-}
-
-
-
-
-#tests <- runTestSuite(testSuite)
-#printTextProtocol(tests)
diff --git a/inst/unitTests/runit.colext.R b/inst/unitTests/runit.colext.R
deleted file mode 100644
index 768565c..0000000
--- a/inst/unitTests/runit.colext.R
+++ /dev/null
@@ -1,105 +0,0 @@
-
-test.colext <- function()
-{
-
- nsites <- 6
- nyr <- 4
- nrep <- 2
- y <- matrix(c(
- 1,0, 1,1, 0,0, 0,0,
- 1,1, 0,0, 0,0, 0,0,
- 0,0, 0,0, 0,0, 0,0,
- 0,0, 1,1, 0,0, 0,0,
- 1,1, 1,0, 0,1, 0,0,
- 0,0, 0,0, 0,0, 1,1), nrow=nsites, ncol=nyr*nrep, byrow=TRUE)
-
- umf1 <- unmarkedMultFrame(y=y, numPrimary=4)
- fm1 <- colext(~1, ~1, ~1, ~1, umf1)
- checkEqualsNumeric(coef(fm1),
- c(0.1422577, -1.4950576, 0.2100365, 1.1998444),
- tol=1e-6)
-
- oc <- matrix(1:nsites, nsites, nyr*nrep)
- umf2 <- unmarkedMultFrame(y=y, obsCovs=list(oc=oc), numPrimary=nyr)
- fm2 <- colext(~1, ~1, ~1, ~oc, umf2, starts=c(coef(fm1), 0))
- checkEqualsNumeric(coef(fm2),
- c(0.14720927, -1.49813673, 0.20885145, 1.30867241, -0.03056995),
- tol=1e-6)
-
- y1 <- y
- y1[1,3] <- NA
-
- umf3 <- unmarkedMultFrame(y=y1, obsCovs=list(oc=oc), numPrimary=nyr)
- fm3 <- colext(~1, ~1, ~1, ~1, umf3, starts=coef(fm1))
- checkEqualsNumeric(coef(fm3),
- c(0.2058462, -1.5612409, 0.4320085, 0.9616805),
- tol=1e-6)
-
- oc1 <- oc
- oc1[is.na(y1)] <- NA
- umf4 <- unmarkedMultFrame(y=y1, obsCovs=list(oc=oc1), numPrimary=nyr)
- fm4 <- colext(~1, ~1, ~1, ~oc, umf4, starts=coef(fm2))
- checkEqualsNumeric(coef(fm4),
- c(0.1934965, -1.5207296, 0.4305665, 0.2514093, 0.1790207),
- tol=1e-6)
-
- y2 <- y
- y2[4,] <- NA
-
- umf5 <- unmarkedMultFrame(y=y2, numPrimary=nyr)
- fm5 <- colext(~1, ~1, ~1, ~1, umf5, starts=coef(fm1))
- checkEqualsNumeric(coef(fm5),
- c(0.50002469, -1.99947927, -0.03660814, 1.09667556),
- tol=1e-6)
- checkEqualsNumeric(fm5@sitesRemoved, 4)
-
- ysc <- matrix(1:nyr, nsites, nyr, byrow=TRUE)
- ysc[1,1] <- NA
- umf6 <- unmarkedMultFrame(y=y, yearlySiteCovs=list(ysc=ysc),
- numPrimary=nyr)
- checkException(fm3.1 <- colext(~1, ~1, ~ysc, ~1, umf6))
- checkException(fm3.2 <- colext(~1, ~ysc, ~1, ~1, umf6))
-
- ysc <- matrix(1:3, nsites, nyr, byrow=TRUE)
- ysc[1,1] <- NA
- y4 <- y
- y4[1,1:2] <- NA
- ysc4 <- ysc
- ysc4[1,1] <- 1 # NA
- umf7 <- unmarkedMultFrame(y=y4, yearlySiteCovs=list(ysc=ysc4),
- numPrimary=nyr)
- fm7.1 <- colext(~1, ~1, ~ysc, ~1, umf7)
- fm7.2 <- colext(~1, ~ysc, ~1, ~1, umf7)
-
- # Check error when random term in formula
- checkException(colext(~(1|dummy), ~1, ~ysc, ~1, umf7))
-}
-
-test.colext.predict <- function(){
-
- nsites <- 6
- nyr <- 4
- nrep <- 2
- y <- matrix(c(
- 1,0, 1,1, 0,0, 0,0,
- 1,1, 0,0, 0,0, 0,0,
- 0,0, 0,0, 0,0, 0,0,
- 0,0, 1,1, 0,0, 0,0,
- 1,1, 1,0, 0,1, 0,0,
- 0,0, 0,0, 0,0, 1,1), nrow=nsites, ncol=nyr*nrep, byrow=TRUE)
-
- ysc <- data.frame(year=rep(c("1","2","3","4"), 6))
-
- umf1 <- unmarkedMultFrame(y=y, numPrimary=4, yearlySiteCovs=ysc)
- fm1 <- colext(~1, ~year, ~1, ~year, umf1)
-
- nd1 <- data.frame(year=c("1","2","3","4"))
- checkException(predict(fm1, "col", nd1))
-
- nd2 <- data.frame(year=c("1","2","3"))
- pr_gam <- predict(fm1, "col", nd2)
- checkTrue(inherits(pr_gam, "data.frame"))
-
- pr_det <- predict(fm1, "det", nd1)
- checkTrue(inherits(pr_det, "data.frame"))
-}
diff --git a/inst/unitTests/runit.crossVal.R b/inst/unitTests/runit.crossVal.R
deleted file mode 100644
index 93876dc..0000000
--- a/inst/unitTests/runit.crossVal.R
+++ /dev/null
@@ -1,86 +0,0 @@
-
-
-
-
-test.crossVal.occu <- function() {
-
- set.seed(123)
- data(frogs)
- pferUMF <- unmarkedFrameOccu(pfer.bin)
- siteCovs(pferUMF) <- data.frame(sitevar1 = rnorm(numSites(pferUMF)))
- obsCovs(pferUMF) <- data.frame(obsvar1 = rnorm(numSites(pferUMF) * obsNum(pferUMF)))
-
-
- fm <- occu(~ obsvar1 ~ 1, pferUMF)
-
- kfold <- crossVal(fm, method='Kfold', folds=10)
-
- checkEqualsNumeric(nrow(kfold@stats),10)
-
- checkEqualsNumeric(as.numeric(kfold@stats[1,]),
- c(0.3213177,0.2159953), tolerance=1e-4)
-
- holdout <- crossVal(fm, method='holdout', holdoutPct=0.25)
-
- checkEqualsNumeric(as.numeric(holdout@stats[1,]),
- c(0.3695291,0.2414929), tolerance=1e-4)
-
- leave <- crossVal(fm, method='leaveOneOut')
-
- checkEqualsNumeric(nrow(leave@stats),130)
- checkEqualsNumeric(as.numeric(leave@stats[1,]),
- c(0.6220418,0.4985790), tolerance=1e-4)
-
- #Check parallel
- set.seed(123)
- kfold <- crossVal(fm, method='Kfold', folds=10)
- set.seed(123)
- kfold_par <- crossVal(fm, method='Kfold', folds=10, parallel=TRUE)
- checkEqualsNumeric(kfold@stats, kfold_par@stats)
-
- #Check custom stat function
- checkException(crossVal(fm, statistic=function(x) "fake"))
-
- new_stat <- function(object){
- c(mean_res = mean(residuals(object),na.rm=T))
- }
-
- kfold_custom <- crossVal(fm, statistic=new_stat)
- checkEqualsNumeric(kfold_custom@stats[,1], rep(0,10), tol=0.05)
-
-}
-
-test.crossValList <- function(){
-
- set.seed(123)
- data(frogs)
- pferUMF <- unmarkedFrameOccu(pfer.bin)
- siteCovs(pferUMF) <- data.frame(sitevar1 = rnorm(numSites(pferUMF)))
- obsCovs(pferUMF) <- data.frame(obsvar1 = rnorm(numSites(pferUMF) * obsNum(pferUMF)))
-
-
- fm <- occu(~ obsvar1 ~ 1, pferUMF)
- fm2 <- occu(~1 ~1, pferUMF)
-
- fl <- fitList(fm2=fm2,fm=fm)
-
- cvlist <- crossVal(fl, method='Kfold')
-
- checkEqualsNumeric(length(cvlist@stats_list),2)
-}
-
-
-test.crossVal.multinomPois <- function(){
-
- set.seed(123)
- data(ovendata)
- ovenFrame <- unmarkedFrameMPois(ovendata.list$data,
- siteCovs=as.data.frame(scale(ovendata.list$covariates[,-1])),
- type = "removal")
- fm1 <- multinomPois(~ 1 ~ ufc + trba, ovenFrame)
-
- mout <- crossVal(fm1, method='Kfold')
- checkEqualsNumeric(as.numeric(mout@stats[1,]),
- c(0.5521100,0.3335076), tolerance=1e-4)
-
-}
diff --git a/inst/unitTests/runit.distsamp.r b/inst/unitTests/runit.distsamp.r
deleted file mode 100644
index 53c189b..0000000
--- a/inst/unitTests/runit.distsamp.r
+++ /dev/null
@@ -1,201 +0,0 @@
-test.distsamp.covs <- function() {
- y <- matrix(rep(4:1, 10), 5, 2, byrow=TRUE)
- siteCovs <- data.frame(x = c(0, 2, 3, 4, 1))
- #Check error thrown when length(tlength!=nrow(y))
- checkException(unmarkedFrameDS(y = y, siteCovs = siteCovs,
- dist.breaks=c(0, 5, 10)/1000, survey="line", tlength=rep(1, (5-1)),
- unitsIn="km"))
- #Check error thrown when length(dist.breaks) != J+1
- checkException(unmarkedFrameDS(y = y, siteCovs = siteCovs,
- dist.breaks=c(5,10)/1000, survey="line", tlength=rep(1, 5),
- unitsIn="km"))
-
- umf <- unmarkedFrameDS(y = y, siteCovs = siteCovs,
- dist.breaks=c(0, 5, 10)/1000, survey="line", tlength=rep(1, 5),
- unitsIn="km")
- fm <- distsamp(~ x ~ x, data = umf)
-
- lam <- fm['state']
- det <- fm['det']
-
- checkEqualsNumeric(coef(lam), c(1.4340999, -0.1102387), tolerance = 1e-4)
- checkEqualsNumeric(coef(det), c(-4.64686395, -0.09337832), tolerance = 1e-4)
-
- lam.lc <- linearComb(fm, type = 'state', c(1, 2))
- det.lc <- linearComb(fm, type = 'det', c(1, 2))
-
- checkEqualsNumeric(coef(lam.lc), 1.213623, tol = 1e-4)
- checkEqualsNumeric(coef(det.lc), -4.833621, tol = 1e-4)
-
- checkEqualsNumeric(coef(backTransform(lam.lc)), 3.365655, tol = 1e-4)
- checkEqualsNumeric(coef(backTransform(det.lc)), 0.007957658, tol = 1e-4)
-
-}
-
-
-
-test.distsamp.line.keyfuns <- function()
-{
- y <- structure(c(7, 7, 12, 9, 9, 11, 9, 5, 7, 6, 25, 26, 30, 26, 23,
- 24, 20, 33, 26, 32, 5, 3, 8, 7, 1, 4, 4, 7, 7, 6, 3, 1, 1, 4,
- 4, 4, 3, 6, 2, 3), .Dim = c(10L, 4L))
- umf <- unmarkedFrameDS(y = y, dist.breaks=c(0, 3, 15, 18, 20),
- survey="line", unitsIn="m", tlength=rep(100, nrow(y)))
-
- fm.halfnorm <- distsamp(~1~1, umf)
- D <- backTransform(fm.halfnorm, type="state")
- S <- backTransform(fm.halfnorm, type="det")
- checkEqualsNumeric(coef(D), 129.5509, tol=1e-4)
- checkEqualsNumeric(SE(D), 9.446125, tol=1e-4)
- checkEqualsNumeric(coef(S), 18.15386, tol=1e-4)
- checkEqualsNumeric(SE(S), 2.893362, tol=1e-4)
-
- fm.exp <- distsamp(~1~1, umf, keyfun="exp", starts=c(4, 0))
- D <- backTransform(fm.exp, type="state")
- S <- backTransform(fm.exp, type="det")
- checkEqualsNumeric(coef(D), 144.8802, tol=1e-4)
- checkEqualsNumeric(SE(D), 14.31655, tol=1e-4)
- checkEqualsNumeric(coef(S), 31.75738, tol=1e-4)
- checkEqualsNumeric(SE(S), 9.711254, tol=1e-4)
-
- fm.haz <- distsamp(~1~1, umf, keyfun="hazard", starts=c(4, 3, 1))
- D <- backTransform(fm.haz, type="state")
- Sh <- backTransform(fm.haz, type="det")
- Sc <- backTransform(fm.haz, type="scale")
- checkEqualsNumeric(coef(D), 137.0375, tol=1e-4)
- checkEqualsNumeric(SE(D), 16.82505, tol=1e-4)
- checkEqualsNumeric(coef(Sh), 15.90262, tol=1e-4)
- checkEqualsNumeric(SE(Sh), 5.099981, tol=1e-4)
- checkEqualsNumeric(coef(Sc), 0.8315524, tol=1e-4)
- checkEqualsNumeric(SE(Sc), 0.4753275, tol=1e-4)
-
- fm.unif <- distsamp(~1~1, umf, keyfun="uniform")
- D <- backTransform(fm.unif, type="state")
- checkEqualsNumeric(coef(D), 107.5000, tol=1e-4)
-
- checkEqualsNumeric(coef(fm.halfnorm),
- coef(update(fm.halfnorm, engine="R")))
- checkEqualsNumeric(coef(fm.exp),
- coef(update(fm.exp, engine="R")))
- checkEqualsNumeric(coef(fm.halfnorm),
- coef(update(fm.halfnorm, engine="R")))
- checkEqualsNumeric(coef(fm.halfnorm),
- coef(update(fm.halfnorm, engine="R")))
-
-}
-
-
-
-test.distsamp.point.keyfuns <- function()
-{
- y <- structure(c(1, 0, 0, 0, 0, 0, 3, 1, 1, 0, 16, 15, 18, 14, 22,
- 24, 12, 20, 20, 21, 10, 9, 9, 5, 6, 6, 6, 9, 5, 6, 6, 6, 4, 2,
- 6, 3, 3, 3, 1, 4), .Dim = c(10L, 4L))
-
- umf <- unmarkedFrameDS(y = y, dist.breaks=c(0, 3, 15, 18, 20),
- survey="point", unitsIn="m", tlength=rep(100, 20))
-
- fm.halfnorm <- distsamp(~1~1, umf)
- D <- backTransform(fm.halfnorm, type="state")
- S <- backTransform(fm.halfnorm, type="det")
- checkEqualsNumeric(coef(D), 316.1711, tol=1e-4)
- checkEqualsNumeric(SE(D), 37.08797, tol=1e-4)
- checkEqualsNumeric(coef(S), 18.05958, tol=1e-4)
- checkEqualsNumeric(SE(S), 3.341798, tol=1e-4)
-
- fm.exp <- distsamp(~1~1, umf, keyfun="exp", starts=c(6, 0))
- D <- backTransform(fm.exp, type="state")
- S <- backTransform(fm.exp, type="det")
- checkEqualsNumeric(coef(D), 369.7526, tol=1e-4)
- checkEqualsNumeric(SE(D), 68.11901, tol=1e-4)
- checkEqualsNumeric(coef(S), 28.90848, tol=1e-4)
- checkEqualsNumeric(SE(S), 11.66219, tol=1e-4)
-
- fm.haz <- distsamp(~1~1, umf, keyfun="hazard", starts=c(5, 3, 1))
- D <- backTransform(fm.haz, type="state")
- Sh <- backTransform(fm.haz, type="det")
- Sc <- backTransform(fm.haz, type="scale")
- checkEqualsNumeric(coef(D), 266.3911, tol=1e-4)
- checkEqualsNumeric(SE(D), 20.45144, tol=1e-4)
- checkEqualsNumeric(coef(Sh), 18.69351, tol=1e-4)
- checkEqualsNumeric(SE(Sh), 0.8950444, tol=1e-4)
- checkEqualsNumeric(coef(Sc), 5.797366, tol=1e-4)
- checkEqualsNumeric(SE(Sc), 4.054381, tol=1e-4)
-
- fm.unif <- distsamp(~1~1, umf, keyfun="uniform")
- D <- backTransform(fm.unif, type="state")
- checkEqualsNumeric(coef(D), 236.3451, tol=1e-4)
-
- checkEqualsNumeric(coef(fm.halfnorm),
- coef(update(fm.halfnorm, engine="R")))
- checkEqualsNumeric(coef(fm.exp),
- coef(update(fm.exp, engine="R")),tol=1e-5)
- checkEqualsNumeric(coef(fm.halfnorm),
- coef(update(fm.halfnorm, engine="R")))
- checkEqualsNumeric(coef(fm.halfnorm),
- coef(update(fm.halfnorm, engine="R")))
-
-}
-
-test.distsamp.getP <- function() {
-
- data(issj)
- jayumf <- unmarkedFrameDS(y=as.matrix(
- issj[,1:3]),
- siteCovs=data.frame(scale(issj[,c("elevation","forest","chaparral")])),
- dist.breaks=c(0,100,200,300), unitsIn="m", survey="point")
-
- hn <- distsamp(~1 ~1, jayumf)
- neg <- distsamp(~1 ~1, jayumf,keyfun="exp")
- unif <- distsamp(~1 ~1, jayumf, keyfun="unif")
- haz <- distsamp(~1 ~1, jayumf, keyfun="hazard")
-
- checkEqualsNumeric(getP(hn)[1,], c(0.08634098, 0.09873522, 0.02369782),
- tol=1e-5)
- checkEqualsNumeric(getP(neg)[1,], c(0.1111111, 0.3333333, 0.5555556),
- tol=1e-5)
- checkEqualsNumeric(getP(unif)[1,], c(0.1111111, 0.3333333, 0.5555556),
- tol=1e-5)
- checkEqualsNumeric(getP(haz)[1,], c(0.04946332, 0.02826854, 0.01589744),
- tol=1e-3)
-}
-
-test.distsamp.random <- function(){
-
- data(linetran)
- umf <- unmarkedFrameDS(y=as.matrix(linetran[,1:4]), siteCovs=linetran[,6:7],
- survey="line", tlength=linetran$Length, unitsIn='m',
- dist.breaks=c(0,10,20,30,40))
-
- hn <- distsamp(~1~area+(1|habitat), umf)
- ex <- distsamp(~1~area+(1|habitat), umf, keyfun="exp")
- hz <- distsamp(~1~area+(1|habitat), umf, keyfun="hazard")
- un <- distsamp(~1~area+(1|habitat), umf, keyfun="uniform")
- mods <- list(hn=hn, ex=ex, hz=hz, un=un)
- checkTrue(all(sapply(mods, function(x) is.list(x@TMB))))
-
- sigs <- sapply(mods, function(x) sigma(x)$sigma)
- checkTrue(all(sigs < 0.01) & all(sigs > 0.0001))
-
- pr <- lapply(mods, function(x) predict(x, "state"))
- checkTrue(all(sapply(pr, inherits, "data.frame")))
-
- data(pointtran)
- umf <- unmarkedFrameDS(y=as.matrix(pointtran[,1:4]), siteCovs=pointtran[,6:7],
- survey="point", unitsIn='m',
- dist.breaks=c(0,10,20,30,40))
-
- hn <- distsamp(~1~area+(1|habitat), umf)
- ex <- distsamp(~1~area+(1|habitat), umf, keyfun="exp")
- hz <- distsamp(~1~area+(1|habitat), umf, keyfun="hazard")
- un <- distsamp(~1~area+(1|habitat), umf, keyfun="uniform")
- mods <- list(hn=hn, ex=ex, hz=hz, un=un)
- checkTrue(all(sapply(mods, function(x) is.list(x@TMB))))
-
- sigs <- sapply(mods, function(x) sigma(x)$sigma)
- checkTrue(all(sigs < 0.01) & all(sigs > 0.0001))
-
- pr <- lapply(mods, function(x) predict(x, "state"))
- checkTrue(all(sapply(pr, inherits, "data.frame")))
-
-}
diff --git a/inst/unitTests/runit.format.R b/inst/unitTests/runit.format.R
deleted file mode 100644
index 8b2bfa4..0000000
--- a/inst/unitTests/runit.format.R
+++ /dev/null
@@ -1,43 +0,0 @@
-test.formatDistData <- function() {
- dat <- data.frame(distance=1:100, site=gl(5, 20),
- visit=factor(rep(1:4, each=5)))
- cutpt <- seq(0, 100, by=25)
- y <- formatDistData(dat, "distance", "site", cutpt)
- checkEqualsNumeric(y, matrix(c(20, 0, 0, 0,
- 5, 15, 0, 0,
- 0, 10, 10, 0,
- 0, 0, 15, 5,
- 0, 0, 0, 20), 5, 4, byrow=TRUE))
- dat.bad <- dat
- dat.bad$distance <- as.character(dat$distance)
- checkException(formatDistData(dat.bad, "distance", "site", cutpt))
-
- dat.bad <- dat
- dat.bad$site <- as.character(dat$site)
- y2 <- formatDistData(dat.bad, "distance", "site", cutpt)
- checkEqualsNumeric(y2, matrix(c(20, 0, 0, 0,
- 5, 15, 0, 0,
- 0, 10, 10, 0,
- 0, 0, 15, 5,
- 0, 0, 0, 20), 5, 4, byrow=TRUE))
-
- y3 <- formatDistData(dat, "distance", "site", cutpt, "visit")
- checkEqualsNumeric(y3, matrix(c(
-5, 0, 0, 0, 5, 0, 0, 0, 5, 0, 0, 0, 5, 0, 0, 0,
-5, 0, 0, 0, 0, 5, 0, 0, 0, 5, 0, 0, 0, 5, 0, 0,
-0, 5, 0, 0, 0, 5, 0, 0, 0, 0, 5, 0, 0, 0, 5, 0,
-0, 0, 5, 0, 0, 0, 5, 0, 0, 0, 5, 0, 0, 0, 0, 5,
-0, 0, 0, 5, 0, 0, 0, 5, 0, 0, 0, 5, 0, 0, 0, 5), 5, 16, byrow=TRUE))
-
- effortMatrix <- matrix(ncol=4, nrow=5,c(1,0))
- y4 <- formatDistData(dat, "distance","site",cutpt, "visit",effortMatrix)
- checkEqualsNumeric(y4, matrix(c(
- 5, 0, 0, 0, NA,NA,NA,NA, 5, 0, 0, 0, NA,NA,NA,NA,
- NA,NA,NA,NA, 0, 5, 0, 0, NA,NA,NA,NA, 0, 5, 0, 0,
- 0, 5, 0, 0, NA,NA,NA,NA, 0, 0, 5, 0, NA,NA,NA,NA,
- NA,NA,NA,NA, 0, 0, 5, 0, NA,NA,NA,NA, 0, 0, 0, 5,
- 0, 0, 0, 5, NA,NA,NA,NA, 0, 0, 0, 5, NA,NA,NA,NA), 5, 16, byrow=TRUE))
-
- effortMatrix <- matrix(ncol=4, nrow=5,"a")
- checkException(formatDistData(dat, "distance","site",cutpt, "visit",effortMatrix))
-}
diff --git a/inst/unitTests/runit.gmultmix.R b/inst/unitTests/runit.gmultmix.R
deleted file mode 100644
index fc8d2f5..0000000
--- a/inst/unitTests/runit.gmultmix.R
+++ /dev/null
@@ -1,88 +0,0 @@
-
-
-
-
-test.gmultmix.fit <- function()
-{
- y <- matrix(0:3, 5, 4)
- siteCovs <- data.frame(x = c(0,2,3,4,1))
- siteCovs[3,1] <- NA
- obsCovs <- data.frame(o1 = 1:20, o2 = exp(-5:4)/20)
- yrSiteCovs <- data.frame(yr=factor(rep(1:2, 5)))
-
- umf <- unmarkedFrameGMM(y = y, siteCovs = siteCovs, obsCovs = obsCovs,
- yearlySiteCovs = yrSiteCovs, type="removal", numPrimary=2)
- fm_R <- gmultmix(~x, ~yr, ~o1 + o2, data = umf, K=23, engine="R")
- fm_C <- gmultmix(~x, ~yr, ~o1 + o2, data = umf, K=23, engine="C")
-
- checkEquals(fm_R@sitesRemoved, 3)
- coef_truth <- c(2.50638554, 0.06226627, 0.21787839, 6.46029769, -1.51885928,
- -0.03409375, 0.43424295)
- checkEqualsNumeric(coef(fm_R), coef_truth, tol = 1e-5)
- checkEqualsNumeric(coef(fm_C), coef_truth, tol = 1e-5)
-
- obsCovs[10,2] <- NA
- umf <- unmarkedFrameGMM(y = y, siteCovs = siteCovs, obsCovs = obsCovs,
- yearlySiteCovs = yrSiteCovs, type="removal", numPrimary=2)
- fm_R <- gmultmix(~x, ~yr, ~o1 + o2, data = umf, K=23, engine="R")
- fm_C <- gmultmix(~x, ~yr, ~o1 + o2, data = umf, K=23, engine="C")
-
- checkEquals(fm_R@sitesRemoved, 3)
- checkEqualsNumeric(coef(fm_R), coef_truth, tol = 1e-5)
- checkEqualsNumeric(coef(fm_C), coef_truth, tol = 1e-5)
-
- yrSiteCovs[2, 1] <- NA
- umf <- unmarkedFrameGMM(y = y, siteCovs = siteCovs, obsCovs = obsCovs,
- yearlySiteCovs = yrSiteCovs, type="removal", numPrimary=2)
- fm_R <- gmultmix(~x, ~yr, ~o1 + o2, data = umf, K=23, engine="R")
- fm_C <- gmultmix(~x, ~yr, ~o1 + o2, data = umf, K=23, engine="C")
-
- coef_truth <- c(1.17280104, 0.37694710, 2.38249795, 2.87354955, -0.83875134,
- -0.08446507, 1.88056826)
- checkEqualsNumeric(coef(fm_R), coef_truth, tol = 1e-5)
- checkEqualsNumeric(coef(fm_C), coef_truth, tol = 1e-5)
-
- #Negative binomial
- fm_R <- gmultmix(~x, ~yr, ~o1 + o2, data = umf, mixture="NB", K=23, engine="R")
- fm_C <- gmultmix(~x, ~yr, ~o1 + o2, data = umf, mixture="NB", K=23, engine="C")
- checkEqualsNumeric(coef(fm_R), coef(fm_C), tol=1e-5)
-
- #Check error when random effect in formula
- checkException(gmultmix(~(1|dummy), ~1, ~1, umf))
-}
-
-
-
-test.gmultmix.na <- function()
-{
- y <- matrix(0:3, 8, 9)
- oc <- matrix(c(
- 0,1,1, 0,0,0, 1,2,1,
- 0,0,1, 0,1,2, 2,0,3,
- 2,0,0, 0,1,0, 0,0,NA,
- 2,0,NA, 0,0,NA, 0,0,NA,
- NA,0,0, NA,0,0, NA,0,0,
- 1,NA,3, 0,NA,0, 0,NA,0,
- NA,NA,NA, 1,2,0, 0,0,0,
- NA,NA,NA, NA,NA,NA, NA,NA,NA), byrow=TRUE, nrow=8, ncol=9)
- o2y <- diag(3)
- o2y[upper.tri(o2y)] <- 1
- m <- matrix(0, 3, 3)
-
- kronecker(diag(3), o2y)
-
- o2y <- rbind(
- cbind(o2y, m, m),
- cbind(m, o2y, m),
- cbind(m, m, o2y))
-
- oc.na <- is.na(oc)
- oc.na %*% o2y
-
- kronecker(diag(3), matrix(1, 3, 2))
-
-
- }
-
-
-
diff --git a/inst/unitTests/runit.gpcount.R b/inst/unitTests/runit.gpcount.R
deleted file mode 100644
index f2759f4..0000000
--- a/inst/unitTests/runit.gpcount.R
+++ /dev/null
@@ -1,30 +0,0 @@
-
-
-test.gpcount.fit <- function()
-{
- y <- matrix(c(0,0,0, 1,0,1, 2,2,2,
- 3,2,3, 2,2,2, 1,1,1,
- NA,0,0, 0,0,0, 0,0,0,
- 3,3,3, 3,1,3, 2,2,1,
- 0,0,0, 0,0,0, 0,0,0), 5, 9, byrow=TRUE)
- siteCovs <- data.frame(x = c(0,2,-1,4,-1))
- obsCovs <- list(o1 = matrix(seq(-3, 3, length=length(y)), 5, 9))
- obsCovs$o1[5,4:6] <- NA
- yrSiteCovs <- list(yr=matrix(c('1','2','2'), 5, 3, byrow=TRUE))
- yrSiteCovs$yr[4,2] <- NA
-
- umf <- unmarkedFrameGPC(y = y, siteCovs = siteCovs, obsCovs = obsCovs,
- yearlySiteCovs = yrSiteCovs, numPrimary=3)
- fm <- gpcount(~x, ~yr, ~o1, data = umf, K=23)
- checkEquals(fm@sitesRemoved, integer(0))
- checkEqualsNumeric(coef(fm),
- c(1.14754541, 0.44499137, -1.52079283, -0.08881542, 2.52037155, -0.10950615), tol = 1e-5)
-
- fm0c <- gpcount(~1, ~1, ~1, umf, K=20)
- fm0r <- gpcount(~1, ~1, ~1, umf, K=20, engine="R")
- checkEqualsNumeric(coef(fm0c), coef(fm0r))
-
- # Check error when random effect in formula
- checkException(gpcount(~(1|dummy),~1,~1,umf))
-
-}
diff --git a/inst/unitTests/runit.modSel.R b/inst/unitTests/runit.modSel.R
deleted file mode 100644
index 4bb0c0d..0000000
--- a/inst/unitTests/runit.modSel.R
+++ /dev/null
@@ -1,62 +0,0 @@
-test.fitList <- function() {
- y <- matrix(rep(1, 10), 5, 2)
- umf <- unmarkedFrameOccu(y = y, siteCovs=data.frame(x=-2:2),
- obsCovs= data.frame(z=-5:4))
- obsCovs(umf)[3, 1] <- NA
- fm1 <- occu(~ 1 ~ 1, data = umf)
- fm2 <- occu(~ 1 ~ x, data = umf)
-
- fits1.1 <- fitList(m1=fm1, m2=fm2)
- fits1.2 <- fitList(fm1, fm2)
- fits2.1 <- fitList(fits = list(m1=fm1, m2=fm2))
- fits2.2 <- fitList(fits = list(fm1, fm2))
-
- checkIdentical(fits1.1, fits2.1)
-
- checkException(fitList(fm1, fm2, fits=list(fm1, fm2))) # ... and fits
-
- siteCovs(umf) <- data.frame(x=-3:1)
- fm2 <- occu(~ 1 ~ x, data = umf)
- checkException(fitList(fm1, fm2)) # Different umf used
-
- fm3 <- occu(~ z ~ 1, data = umf)
- checkException(fitList(fm1, fm3)) # Missing value problem
- }
-
-
-
-
-
-test.modSel <- function() {
- y <- matrix(rep(1, 10), 5, 2)
- umf <- unmarkedFrameOccu(y = y, siteCovs=data.frame(x=-2:2),
- obsCovs= data.frame(z=-5:4))
- fm1 <- occu(~ 1 ~ 1, data = umf)
- fm2 <- occu(~ 1 ~ x, data = umf)
-
- fits <- fitList(m1=fm1, m2=fm2)
- ms1 <- modSel(fits)
-
- checkTrue(all(is.na(ms1@Full$Rsq)))
- checkEqualsNumeric(sum(ms1@Full$AICwt), 1)
- checkEqualsNumeric(ms1@Full$delta[1L], 0)
-
- checkException(modSel(fits, nullmod=fm2))
-
- ms2 <- modSel(fits, nullmod='m1')
-
- checkIdentical(
- ms1@Full[,-which(colnames(ms1@Full)=="Rsq")],
- ms1@Full[,-which(colnames(ms2@Full)=="Rsq")]
- )
-
- # Fake hessian problem
- fm1@opt$hessian[] <- NA
- fm1@estimates@estimates$state@covMat[] <- NA
- fits2 <- fitList(m1=fm1, m2=fm2)
- ms3 <- modSel(fits2)
- checkEquals(coef(ms1), coef(ms3))
-
-
- }
-
diff --git a/inst/unitTests/runit.multinomPois.R b/inst/unitTests/runit.multinomPois.R
deleted file mode 100644
index d6c86bd..0000000
--- a/inst/unitTests/runit.multinomPois.R
+++ /dev/null
@@ -1,140 +0,0 @@
-
-
-test.removal <- function() {
-
- y <- matrix(c(
- 5, 3, 2,
- 3, 3, 1,
- 2, 0, 0,
- 0, 0, 0,
- 0, 0, 0), nrow=5, ncol=3, byrow=TRUE)
-
- sc <- data.frame(x1 = c(NA, 2, 3, 4, 3))
- oc <- list(x2 = matrix(c(
- 1, 1, 1,
- 3, NA, 1,
- 0, 0, 1,
- NA, NA, NA,
- NA, 1, 0), nrow=5, ncol=3, byrow=TRUE))
-
- umf1 <- unmarkedFrameMPois(y = y, siteCovs = sc, obsCovs = oc,
- type="removal")
-
- o2y <- diag(ncol(y))
- o2y[upper.tri(o2y)] <- 1
- checkEquals(obsToY(umf1), o2y)
-
- m1_R <- multinomPois(~1 ~1, umf1, engine="R")
- m1_C <- multinomPois(~1 ~1, umf1, engine="C")
- checkEqualsNumeric(coef(m1_R), c(1.5257743, -0.2328092), tol=1e-5)
- checkEqualsNumeric(coef(m1_R), coef(m1_C), tol=1e-5)
-
- m2_R <- multinomPois(~x2 ~1, umf1, engine="R")
- m2_C <- multinomPois(~x2 ~1, umf1, engine="C")
- checkEqualsNumeric(coef(m2_R), c(1.9159845, 0.2248897, -0.1808144), tol=1e-5)
- checkEquals(m2_R@sitesRemoved, 4:5)
- checkEqualsNumeric(coef(m2_R),coef(m2_C), tol=1e-5)
-
- m3_R <- multinomPois(~x2 ~x1, umf1, engine="R")
- m3_C <- multinomPois(~x2 ~x1, umf1, engine="C")
- checkEqualsNumeric(m3_R@sitesRemoved, c(1, 4:5))
- checkEqualsNumeric(coef(m3_R),
- c(1.9118525, -0.4071202, 8.3569943, 0.3232485), tol=1e-5)
- checkEqualsNumeric(coef(m3_R),coef(m3_C), tol=1e-5)
-
-}
-
-
-
-test.double <- function() {
- y <- matrix(c(
- 1, 0, 0,
- 2, 1, 0,
- 1, 0, 1,
- 2, 1, 2,
- 1, 0, 3,
- 1, 1, 1), nrow=6, ncol=3, byrow=TRUE)
- oc <- matrix(c(
- 1, 0,
- 2, 1,
- 1, 1,
- NA, 0,
- 1, NA,
- NA, NA), nrow=6, ncol=2, byrow=TRUE)
-
- umf <- unmarkedFrameMPois(y = y, obsCovs = list(x=oc), type="double")
-
- m1_R <- multinomPois(~1 ~1, umf, engine="R")
- m1_C <- multinomPois(~1 ~1, umf, engine="C")
- checkEqualsNumeric(coef(m1_R), c(1.3137876, 0.2411609), tol=1e-5)
- checkEqualsNumeric(coef(m1_R),coef(m1_C))
-
- m2 <- multinomPois(~x ~1, umf, starts=c(1.3, 0, 0.2))
- checkEquals(m2@sitesRemoved, 4:6)
- }
-
-test.ranef.multinomPois <- function(){
- set.seed(9023)
- nSites <- 50
- lambda <- 10
- p1 <- 0.5
- p2 <- 0.3
- cp <- c(p1*(1-p2), p2*(1-p1), p1*p2)
- N <- rpois(nSites, lambda)
- y <- matrix(NA, nSites, 3)
- for(i in 1:nSites) {
- y[i,] <- rmultinom(1, N[i], c(cp, 1-sum(cp)))[1:3]
- }
-
- # Fit model
- observer <- matrix(c('A','B'), nSites, 2, byrow=TRUE)
- umf <- unmarkedFrameMPois(y=y, obsCovs=list(observer=observer),
- type="double")
- fm <- multinomPois(~observer-1 ~1, umf)
- checkTrue(inherits(fm, "unmarkedFitMPois"))
- checkTrue(is.null(fm@TMB))
- pr <- predict(fm, "state")
- checkEqualsNumeric(dim(pr), c(50,4))
-
- set.seed(1)
- nSites <- 100
- lambda <- 5
- sc <- data.frame(ref=sample(letters[1:10], nSites, replace=T),
- x1=rnorm(nSites))
- observer <- matrix(c('A','B'), nSites, 2, byrow=TRUE)
-
- ef <- rnorm(10, 0, 0.4)
- names(ef) <- letters[1:10]
- lambda <- exp(log(lambda) + ef[sc$ref])
- N <- rpois(nSites, lambda)
-
- y <- matrix(NA, nSites, 3)
- for(i in 1:nSites) {
- y[i,] <- rmultinom(1, N[i], c(cp, 1-sum(cp)))[1:3]
- }
- umf2 <- unmarkedFrameMPois(y=y, obsCovs=list(observer=observer),
- type="double", siteCovs=sc)
-
- fm <- multinomPois(~observer-1 ~x1 + (1|ref), umf2)
-
- checkTrue(inherits(fm@TMB, "list"))
- checkEqualsNumeric(sigma(fm)$sigma, 0.3655, tol=1e-3)
- checkTrue(inherits(randomTerms(fm), "data.frame"))
- pr <- predict(fm, type='state')
- pr2 <- predict(fm, "state", newdata=umf2@siteCovs[1:5,])
- checkEqualsNumeric(dim(pr), c(100, 4))
- checkEqualsNumeric(dim(pr2), c(5,4))
-
- umf2@y[1,1] <- NA
- umf2@y[2,] <- NA
- umf2@siteCovs$x1[3] <- NA
- umf2@obsCovs$observer[80] <- NA
-
- fm_na <- multinomPois(~observer-1 ~x1 + (1|ref), umf2)
- checkTrue(inherits(fm_na, "unmarkedFitMPois"))
-
- umf3 <- unmarkedFrameMPois(y=y, obsCovs=list(observer=observer),
- piFun="fake", obsToY=umf@obsToY, siteCovs=sc)
-
- checkException(multinomPois(~observer-1 ~x1 + (1|ref), umf3))
-}
diff --git a/inst/unitTests/runit.occu.R b/inst/unitTests/runit.occu.R
deleted file mode 100644
index e06e7c8..0000000
--- a/inst/unitTests/runit.occu.R
+++ /dev/null
@@ -1,326 +0,0 @@
-test.occu.fit.simple.1 <- function() {
-
- y <- matrix(rep(1,10),5,2)
- umf <- unmarkedFrameOccu(y = y)
- fm <- occu(~ 1 ~ 1, data = umf)
-
- occ <- fm['state']
- det <- fm['det']
-
- occ <- coef(backTransform(occ))
- checkEqualsNumeric(occ,1)
-
- det <- coef(backTransform(det))
- checkEqualsNumeric(det,1)
-
- bt <- backTransform(fm, type = 'state')
- checkEqualsNumeric(coef(bt), 1)
-
- bt <- backTransform(fm, type = 'det')
- checkEqualsNumeric(coef(bt), 1)
-
- est_obj <- fm@estimates@estimates$state
- checkEquals(est_obj@invlink, "logistic")
- checkEquals(est_obj@invlinkGrad, "logistic.grad")
-}
-
-test.occu.fit.simple.0 <- function() {
-
- y <- matrix(rep(0,10),5,2)
- umf <- unmarkedFrameOccu(y = y)
- fm <- occu(~ 1 ~ 1, data = umf)
-
- occ <- fm['state']
- det <- fm['det']
-
- occ <- coef(backTransform(occ))
- checkEqualsNumeric(occ, 0, tolerance = 1e-4)
-
- det <- coef(backTransform(det))
- checkEqualsNumeric(det,0, tolerance = 1e-4)
-
- bt <- backTransform(fm, type = 'state')
- checkEqualsNumeric(coef(bt), 0, tolerance = 1e-4)
-
- bt <- backTransform(fm, type = 'det')
- checkEqualsNumeric(coef(bt), 0, tolerance = 1e-4)
-
-
-}
-
-test.occu.fit.covs <- function() {
-
- y <- matrix(rep(0:1,10),5,2)
- siteCovs <- data.frame(x = c(0,2,3,4,1))
- obsCovs <- data.frame(o1 = 1:10, o2 = exp(-5:4)/10)
- umf <- unmarkedFrameOccu(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
- fm <- occu(~ o1 + o2 ~ x, data = umf)
-
- occ <- fm['state']
- det <- fm['det']
-
- checkException(occ <- coef(backTransform(occ)))
-
- checkEqualsNumeric(coef(occ), c(8.590737, 2.472220), tolerance = 1e-4)
- checkEqualsNumeric(coef(det), c(0.44457, -0.14706, 0.44103), tolerance = 1e-4)
-
- occ.lc <- linearComb(fm, type = 'state', c(1, 0.5))
- det.lc <- linearComb(fm, type = 'det', c(1, 0.3, -0.3))
-
- checkEqualsNumeric(coef(occ.lc), 9.826848, tol = 1e-4)
- checkEqualsNumeric(coef(det.lc), 0.2681477, tol = 1e-4)
-
- checkEqualsNumeric(coef(backTransform(occ.lc)), 1, tol = 1e-4)
- checkEqualsNumeric(coef(backTransform(det.lc)), 0.5666381, tol = 1e-4)
-
- checkException(backTransform(fm, type = "state"))
- checkException(backTransform(fm, type = "det"))
-
- fitted <- fitted(fm)
- checkEqualsNumeric(fitted, structure(c(0.5738, 0.5014, 0.4318, 0.38581, 0.50171, 0.53764,
-0.46563, 0.40283, 0.39986, 0.79928), .Dim = c(5L, 2L)), tol = 1e-5)
-
-}
-
-test.occu.fit.covs.0 <- function() {
-
- y <- matrix(rep(0,10),5,2)
- siteCovs <- data.frame(x = c(0,2,3,4,1))
- obsCovs <- data.frame(o1 = 1:10, o2 = exp(-5:4)/10)
- umf <- unmarkedFrameOccu(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
- options(warn=2)
- checkException(fm <- occu(~ o1 + o2 ~ x, data = umf))
- options(warn=0)
- fm <- occu(~ o1 + o2 ~ x, data = umf)
- detMat <- fm@estimates@estimates$det@covMat
- stMat <- fm@estimates@estimates$state@covMat
- checkEqualsNumeric(detMat, matrix(rep(NA,9),nrow=3))
- checkEqualsNumeric(stMat, matrix(rep(NA,4),nrow=2))
-
-}
-
-test.occu.fit.NA <- function() {
-
- y <- matrix(rep(0:1,10),5,2)
- siteCovs <- data.frame(x = c(0,2,3,4,1))
- siteCovs[3,1] <- NA
- obsCovs <- data.frame(o1 = 1:10, o2 = exp(-5:4)/10)
- umf <- unmarkedFrameOccu(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
- fm <- occu(~ o1 + o2 ~ x, data = umf)
- checkEquals(fm@sitesRemoved, 3)
- checkEqualsNumeric(coef(fm), c(8.70123, 4.58255, 0.66243, -0.22862, 0.58192), tol = 1e-5)
-
- obsCovs[10,2] <- NA
- umf <- unmarkedFrameOccu(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
- fm <- occu(~ o1 + o2 ~ x, data = umf)
- checkEquals(fm@sitesRemoved, 3)
- checkEqualsNumeric(coef(fm), c(8.91289, 1.89291, -1.42471, 0.67011, -8.44608), tol = 1e-5)
-
-}
-
-## Add some checks here.
-test.occu.offest <- function() {
-
- y <- matrix(rep(0:1,10),5,2)
- siteCovs <- data.frame(x = c(0,2,3,4,1))
- obsCovs <- data.frame(o1 = 1:10, o2 = exp(-5:4)/10)
- umf <- unmarkedFrameOccu(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
- fm <- occu(~ o1 + o2 ~ offset(x), data = umf)
- checkEqualsNumeric(coef(fm),
- structure(c(9.74361, 0.44327, -0.14683, 0.44085), .Names = c("psi(Int)",
-"p(Int)", "p(o1)", "p(o2)")), tol = 1e-5)
- fm <- occu(~ o1 + offset(o2) ~ offset(x), data = umf)
- checkEqualsNumeric(coef(fm), structure(c(8.59459, 0.97574, -0.3096), .Names = c("psi(Int)",
-"p(Int)", "p(o1)")), tol=1e-5)
-
-}
-
-test.occu.cloglog <- function() {
-
- #Adapted from example by J. Cohen
- set.seed(123)
- M = 500 #sample size
- J = 3 #number of visits
-
- #standardized covariates
- elev <- runif(n = M, 0,100)
- forest <- runif(n = M, 0,1)
- wind <- array(runif(n = M * J, 0,20), dim = c(M, J))
- elev=as.numeric(scale(elev))
- forest=as.numeric(scale(forest))
- wind[,1] <- as.numeric(scale(wind[,1]))
- wind[,2] <- as.numeric(scale(wind[,2]))
- wind[,3] <- as.numeric(scale(wind[,3]))
-
- #regression parameters for abundance
- beta0 = -0.69
- beta1 = 0.71
- beta2 = -0.5
-
- #simulate abundance and derive true occupancy
- lambda <- exp(beta0 + beta1 * elev + beta2 * forest)
- N <- rpois(n = M, lambda = lambda)
- z <- as.numeric(N>0)
- #regression parameters for detection
- alpha0 = -0.84
- alpha1 = 2.
- alpha2 = -1.2
-
- #simulate detection
- p <- plogis(alpha0 + alpha1 * elev + alpha2 * wind )
-
- #create vectors of simulation values, for easy comparison to model estimates
- true.beta.p <- c(alpha0,alpha1,alpha2)
- true.beta.occ <- c(beta0,beta1,beta2)
-
- #generate observed presence
- Obs.pres <- matrix(NA,M,J)
- for (i in 1:M){
- for (j in 1:J){
- Obs.pres[i,j] <- rbinom(1,1,z[i]*p[i,j])
- }
- }
- Obs.ever <- apply(Obs.pres,1,max)
-
- #create observation-level covariate data frame for unmarked
- sitevec <- rep(1:M,3) #vector of site ID's
- wind.df <- data.frame("wind"=wind)
- colnames(wind.df) <- c("Wind.1","Wind.2","Wind.3")
- wind.vec <- c(wind.df$Wind.1,wind.df$Wind.2,wind.df$Wind.3)
- wind.frame <- data.frame("site"=sitevec,"wind"=wind.vec)
- wind.frame.order <- wind.frame[order(wind.frame$site),]
- wind.for.um <- data.frame(wind.frame.order$wind)
- colnames(wind.for.um)="wind"
-
- #create unmarked data object
- occ.frame <- unmarkedFrameOccu(Obs.pres,
- siteCovs=data.frame("ele"=elev,"forest"=forest),
- obsCovs=wind.for.um)
-
- #create model object
- occ_test <-occu(~ele+wind ~ele+forest, occ.frame, linkPsi="cloglog",
- se=F)
- truth <- c(true.beta.occ, true.beta.p)
- est <- coef(occ_test)
- checkEqualsNumeric(truth, est, tol=0.1)
- checkEqualsNumeric(est,
- c(-0.7425,0.6600,-0.3333,-0.87547,2.0677,-1.3082), tol=1e-4)
-
- est_obj <- occ_test@estimates@estimates$state
- checkEquals(est_obj@invlink, "cloglog")
- checkEquals(est_obj@invlinkGrad, "cloglog.grad")
-
- #Check error if wrong link function
- checkException(occu(~ele+wind ~ele+forest, occ.frame, linkPsi="fake"))
-}
-
-test.occu.predict.complexFormulas <- function() {
-
- y <- matrix(rep(0:1,10),5,2)
- siteCovs <- data.frame(x = c(0,2,3,4,1))
- obsCovs <- data.frame(o1 = 1:10, o2 = exp(-5:4)/10)
- umf <- unmarkedFrameOccu(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
- fm <- occu(~ scale(o1) + o2 ~ x, data = umf)
-
- #Predict values should not depend on means/variance of newdata itself
- nd1 <- obsCovs(umf[1:2,])
- pr1 <- predict(fm, 'det', newdata=nd1)
- nd2 <- obsCovs(umf[1:4,])
- pr2 <- predict(fm, 'det', newdata=nd2)[1:4,]
-
- checkEqualsNumeric(pr1, pr2)
-
- #Check factors
- siteCovs$fac_cov <- factor(sample(c('a','b','c'), 5, replace=T),
- levels=c('b','a','c'))
-
- umf <- unmarkedFrameOccu(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
- fm <- occu(~ o1 + o2 ~ fac_cov, data = umf)
-
- pr3 <- predict(fm, 'state', newdata=data.frame(fac_cov=c('a','b')))
- pr4 <- predict(fm, 'state', newdata=data.frame(fac_cov=c('b','a')))
-
- checkEqualsNumeric(as.matrix(pr3),as.matrix(pr4[2:1,]))
- checkException(predict(fm, 'state', newdata=data.frame(fac_cov=c('a','d'))))
-
- #Check when original covs contain factor not used in formula
- siteCovs$fac_cov2 <- factor(sample(c('a','b','c'), 5, replace=T),
- levels=c('b','a','c'))
-
- umf <- unmarkedFrameOccu(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
- fm <- occu(~ o1 + o2 ~ fac_cov, data = umf)
- #Should error if any warnings appear
- options(warn=2)
- pr <- predict(fm, 'state', newdata=data.frame(fac_cov=c('a','b')))
- options(warn=0)
-
-}
-
-## Add some checks here.
-test.occu.offest <- function() {
-
- y <- matrix(rep(0:1,10),5,2)
- siteCovs <- data.frame(x = c(0,2,3,4,1))
- obsCovs <- data.frame(o1 = 1:10, o2 = exp(-5:4)/10)
- umf <- unmarkedFrameOccu(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
- fm <- occu(~ o1 + o2 ~ offset(x), data = umf)
- checkEqualsNumeric(coef(fm),
- structure(c(9.74361, 0.44327, -0.14683, 0.44085), .Names = c("psi(Int)",
-"p(Int)", "p(o1)", "p(o2)")), tol = 1e-5)
- fm <- occu(~ o1 + offset(o2) ~ offset(x), data = umf)
- checkEqualsNumeric(coef(fm), structure(c(8.59459, 0.97574, -0.3096), .Names = c("psi(Int)",
-"p(Int)", "p(o1)")), tol=1e-5)
-
-}
-
-test.occu.randomeffects <- function(){
- set.seed(123)
- n_sites <- 100
- n_years <- 8
- site_id <- rep(1:n_sites, each=n_years)
- M <- n_sites * n_years
- J <- 5 # number of obs per year
- site_covs <- data.frame(cov1=rnorm(M), site_id=factor(site_id))
- beta <- c(intercept=0.5, cov1=0.3)
- sig <- 1.2
- site_effect <- rnorm(n_sites, 0, sig)
- true_site_means <- plogis(beta[1] + site_effect)
-
- psi <- rep(NA, M)
- for (i in 1:M){
- #Random group intercept on psi
- psi[i] <- plogis(beta[1] + beta[2]*site_covs$cov1[i]
- + site_effect[site_id[i]])
- }
-
- p <- 0.5
- z <- rbinom(M, 1, psi)
- y <- matrix(0, nrow=M, ncol=J)
-
- for (i in 1:M){
- if(z[i]==1){
- y[i,] <- rbinom(J, 1, p)
- }
- }
-
- umf <- unmarkedFrameOccu(y=y, siteCovs=site_covs)
- fm <- occu(~1~cov1 + (1|site_id), umf)
- checkEqualsNumeric(coef(fm), c(0.65293, 0.39965, -0.02822), tol=1e-4)
- checkEqualsNumeric(sigma(fm)$sigma, 1.18816, tol=1e-4)
-
- pr <- predict(fm, "state", newdata=data.frame(cov1=0, site_id=factor(1:100)))
- checkTrue(inherits(pr, "data.frame"))
-
- ft <- fitted(fm)
- checkEqualsNumeric(dim(ft), c(n_sites*n_years, J))
-
- pb <- parboot(fm, nsim=2)
- checkTrue(inherits(pb, "parboot"))
-
- # Check custom initial values
- checkEquals(fm@TMB$starts_order[1], "beta_det")
- fmi <- occu(~1~cov1 + (1|site_id), umf, starts=c(10,0,0,0))
- checkEqualsNumeric(fmi@TMB$par["beta_det"], 10)
- checkException(occu(~1~cov1 + (1|site_id), umf, starts=rep(0,3)))
- checkException(occu(~1~cov1 + (1|site_id), umf, starts=c(100,0,0,0)))
-}
diff --git a/inst/unitTests/runit.occuPEN.R b/inst/unitTests/runit.occuPEN.R
deleted file mode 100644
index 9731fd5..0000000
--- a/inst/unitTests/runit.occuPEN.R
+++ /dev/null
@@ -1,160 +0,0 @@
-test.occu.fit.simple.1 <- function() {
-
- y <- matrix(rep(1,10),5,2)
- umf <- unmarkedFrameOccu(y = y)
- fm <- occuPEN(~ 1 ~ 1, data = umf)
-
- occ <- fm['state']
- det <- fm['det']
-
- occ <- coef(backTransform(occ))
- checkEqualsNumeric(occ,1)
-
- det <- coef(backTransform(det))
- checkEqualsNumeric(det,1)
-
- bt <- backTransform(fm, type = 'state')
- checkEqualsNumeric(coef(bt), 1)
-
- bt <- backTransform(fm, type = 'det')
- checkEqualsNumeric(coef(bt), 1)
-
- #Check error when random effect in formula
- checkException(occuPEN(~(1|dummy)~1, umf))
-
-}
-
-test.occu.fit.simple.0 <- function() {
-
- y <- matrix(rep(0,10),5,2)
- umf <- unmarkedFrameOccu(y = y)
- fm <- occuPEN(~ 1 ~ 1, data = umf)
-
- occ <- fm['state']
- det <- fm['det']
-
- occ <- coef(backTransform(occ))
- checkEqualsNumeric(occ, 0, tolerance = 1e-4)
-
- det <- coef(backTransform(det))
- checkEqualsNumeric(det,0, tolerance = 1e-4)
-
- bt <- backTransform(fm, type = 'state')
- checkEqualsNumeric(coef(bt), 0, tolerance = 1e-4)
-
- bt <- backTransform(fm, type = 'det')
- checkEqualsNumeric(coef(bt), 0, tolerance = 1e-4)
-
-
-}
-
-test.occu.fit.covs <- function() {
-
- y <- matrix(rep(0:1,10),5,2)
- siteCovs <- data.frame(x = c(0,2,3,4,1))
- obsCovs <- data.frame(o1 = 1:10, o2 = exp(-5:4)/10)
- umf <- unmarkedFrameOccu(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
- fm <- occuPEN(~ o1 + o2 ~ x, data = umf)
- fm1 <- occuPEN(~ o1 + o2 ~ x, data = umf,lambda=1,pen.type="Bayes")
- fm2 <- occuPEN(~ o1 + o2 ~ x, data = umf,lambda=1,pen.type="Ridge")
- MPLEla <- computeMPLElambda(~ o1 + o2 ~ x, data = umf)
- fm3 <- occuPEN(~ o1 + o2 ~ x, data = umf,lambda=MPLEla,pen.type="MPLE")
-
- occ <- fm['state']
- det <- fm['det']
-
- occ1 <- fm1['state']
- det1 <- fm1['det']
-
- occ2 <- fm2['state']
- det2 <- fm2['det']
-
- occ3 <- fm3['state']
- det3 <- fm3['det']
-
- checkException(occ <- coef(backTransform(occ)))
-
- checkEqualsNumeric(coef(occ), c(8.590737, 2.472220), tolerance = 1e-4)
- checkEqualsNumeric(coef(det), c(0.44457, -0.14706, 0.44103), tolerance = 1e-4)
-
- checkEqualsNumeric(coef(occ1), c(0.7171743, 0.6977753), tolerance = 1e-4)
- checkEqualsNumeric(coef(det1), c(0.08143832, -0.06451574, 0.28695210), tolerance = 1e-4)
-
- checkEqualsNumeric(coef(occ2), c(1.009337e+01, 4.329662e-04), tolerance = 1e-4)
- checkEqualsNumeric(coef(det2), c(0.25892308, -0.09459618, 0.31092107), tolerance = 1e-4)
-
- checkEqualsNumeric(coef(occ3), c(8.590738, 2.472220), tolerance = 1e-4)
- checkEqualsNumeric(coef(det3), c(0.4445733, -0.1470601, 0.4410251), tolerance = 1e-4)
-
- occ.lc <- linearComb(fm, type = 'state', c(1, 0.5))
- det.lc <- linearComb(fm, type = 'det', c(1, 0.3, -0.3))
-
- checkEqualsNumeric(coef(occ.lc), 9.826848, tol = 1e-4)
- checkEqualsNumeric(coef(det.lc), 0.2681477, tol = 1e-4)
-
- checkEqualsNumeric(coef(backTransform(occ.lc)), 1, tol = 1e-4)
- checkEqualsNumeric(coef(backTransform(det.lc)), 0.5666381, tol = 1e-4)
-
- checkException(backTransform(fm, type = "state"))
- checkException(backTransform(fm, type = "det"))
-
- fitted <- fitted(fm)
- checkEqualsNumeric(fitted, structure(c(0.5738, 0.5014, 0.4318, 0.38581, 0.50171, 0.53764,
-0.46563, 0.40283, 0.39986, 0.79928), .Dim = c(5L, 2L)), tol = 1e-5)
-
- checkException(occuPEN_CV(~ o1 + o2 ~ x, data = umf, k=15))
- fmCV <- occuPEN_CV(~ o1 + o2 ~ x, data = umf)
- checkEqualsNumeric(fmCV@chosenLambda, 1, tol = 1e-4)
- checkEqualsNumeric(fmCV@lambdaScores, c(31.423777, 15.603297, 12.330360, 10.130768, 8.981720, 8.572523, 8.572841, 8.798436, 9.153270, 9.543802), tol = 1e-4)
-
-}
-
-test.occu.fit.covs.0 <- function() {
-
- y <- matrix(rep(0:1,10),5,2)
- siteCovs <- data.frame(x = c(0,2,3,4,1))
- obsCovs <- data.frame(o1 = 1:10, o2 = exp(-5:4)/10)
- umf <- unmarkedFrameOccu(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
- checkEqualsNumeric(computeMPLElambda(~ o1 + o2 ~ x, data = umf),4.017164e-11)
- checkException(fm <- occuPEN(~ o1 + o2 ~ x, data = umf,pen.type="none"))
- checkException(fm <- occuPEN(~ o1 + o2 ~ 1, data = umf,pen.type="MPLE"))
- checkException(fm <- occuPEN(~ 1 ~ 1, data = umf,pen.type="Ridge"))
- checkException(fm <- occuPEN_CV(~ o1 + o2 ~ x, data = umf,lambda=c(0)))
- checkException(fm <- occuPEN_CV(~ o1 + o2 ~ x, data = umf,foldAssignments=c(1,2,3,4,5),k=6))
-}
-
-test.occu.fit.NA <- function() {
-
- y <- matrix(rep(0:1,10),5,2)
- siteCovs <- data.frame(x = c(0,2,3,4,1))
- siteCovs[3,1] <- NA
- obsCovs <- data.frame(o1 = 1:10, o2 = exp(-5:4)/10)
- umf <- unmarkedFrameOccu(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
- fm <- occuPEN(~ o1 + o2 ~ x, data = umf)
- checkEquals(fm@sitesRemoved, 3)
- checkEqualsNumeric(coef(fm), c(8.70123, 4.58255, 0.66243, -0.22862, 0.58192), tol = 1e-5)
-
- obsCovs[10,2] <- NA
- umf <- unmarkedFrameOccu(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
- fm <- occuPEN(~ o1 + o2 ~ x, data = umf)
- checkEquals(fm@sitesRemoved, 3)
- checkEqualsNumeric(coef(fm), c(8.91289, 1.89291, -1.42471, 0.67011, -8.44608), tol = 1e-5)
-
-}
-
-## Add some checks here.
-test.occu.offest <- function() {
-
- y <- matrix(rep(0:1,10),5,2)
- siteCovs <- data.frame(x = c(0,2,3,4,1))
- obsCovs <- data.frame(o1 = 1:10, o2 = exp(-5:4)/10)
- umf <- unmarkedFrameOccu(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
- fm <- occuPEN(~ o1 + o2 ~ offset(x), data = umf)
- checkEqualsNumeric(coef(fm),
- structure(c(9.74361, 0.44327, -0.14683, 0.44085), .Names = c("psi(Int)",
-"p(Int)", "p(o1)", "p(o2)")), tol = 1e-5)
- fm <- occuPEN(~ o1 + offset(o2) ~ offset(x), data = umf)
- checkEqualsNumeric(coef(fm), structure(c(8.59459, 0.97574, -0.3096), .Names = c("psi(Int)",
-"p(Int)", "p(o1)")), tol=1e-5)
-
-}
diff --git a/inst/unitTests/runit.occuRN.R b/inst/unitTests/runit.occuRN.R
deleted file mode 100644
index 39574c1..0000000
--- a/inst/unitTests/runit.occuRN.R
+++ /dev/null
@@ -1,77 +0,0 @@
-test.occuRN.fit <- function() {
-
- data(birds)
- woodthrushUMF <- unmarkedFrameOccu(woodthrush.bin)
-
- # survey occasion-specific detection probabilities
- fm_C <- occuRN(~ obsNum ~ 1, woodthrushUMF, engine="C")
- fm_R <- occuRN(~ obsNum ~ 1, woodthrushUMF, engine="R")
-
- # check that output matches
- checkEqualsNumeric(coef(fm_C),coef(fm_R),tol=1e-5)
-
- # check output is correct
- checkEqualsNumeric(coef(fm_C),
- c(0.7921122,-1.8328867,0.4268205,-0.1442194,0.4634105,0.7787513,
- 0.8008794,1.0569827,0.8048578,0.8779660,0.9374874,0.7064848),tol=1e-5)
-
- # check error if random effect in formula
- checkException(occuRN(~(1|dummy)~1, umf))
-}
-
-test.occuRN.na <- function() {
-
- data(birds)
- woodthrushUMF <- unmarkedFrameOccu(woodthrush.bin)
-
- #Remove one observation
- woodthrushUMF@y[1,1] <- NA
-
- fm_C <- occuRN(~ obsNum ~ 1, woodthrushUMF, engine="C")
- fm_R <- occuRN(~ obsNum ~ 1, woodthrushUMF, engine="R")
-
- # check that output matches
- checkEqualsNumeric(coef(fm_C),coef(fm_R),tol=1e-5)
-
- # check output is correct
- checkEqualsNumeric(coef(fm_C),
- c(0.793042, -1.902789, 0.494098, -0.074573, 0.53074, 0.845903,
- 0.867936, 1.123959, 0.871912, 0.944917, 1.004499, 0.773679), tol=1e-5)
-
- #Remove entire site
- woodthrush.bin_na <- woodthrush.bin
- woodthrush.bin_na[1,] <- NA
- woodthrushUMF <- unmarkedFrameOccu(woodthrush.bin_na)
-
- fm_C <- occuRN(~ obsNum ~ 1, woodthrushUMF, engine="C")
- fm_R <- occuRN(~ obsNum ~ 1, woodthrushUMF, engine="R")
-
- # check that site was removed
- checkEqualsNumeric(fm_C@sitesRemoved,1)
-
- # check that output matches
- checkEqualsNumeric(coef(fm_C),coef(fm_R),tol=1e-5)
-
- # check output is correct
- checkEqualsNumeric(coef(fm_C),
- c(0.783066, -1.920232, 0.448369, -0.009701, 0.490085, 0.814767,
- 0.837669, 1.097903, 0.842467, 0.916831, 0.976707, 0.740672), tol=1e-5)
-}
-
-#Test that parboot works
-test.occuRN.parboot <- function(){
-
- data(birds)
- woodthrushUMF <- unmarkedFrameOccu(woodthrush.bin)
- fm <- occuRN(~ obsNum ~ 1, woodthrushUMF, engine="C")
-
- chisq2 <- function(fm) {
- observed <- getY(fm)
- expected <- fitted(fm)
- sum((observed - expected)^2/expected, na.rm=T)
- }
-
- set.seed(123)
- pb <- parboot(fm, statistic=chisq2, nsim=2)
- checkEqualsNumeric(as.numeric(pb@t.star), c(342.2285, 318.0965), tol=1e-5)
-}
diff --git a/inst/unitTests/runit.parboot.R b/inst/unitTests/runit.parboot.R
deleted file mode 100644
index 9912659..0000000
--- a/inst/unitTests/runit.parboot.R
+++ /dev/null
@@ -1,266 +0,0 @@
-
-test.parboot.occu <- function() {
-
- set.seed(6546)
- R <- 20
- J <- 5
- z <- rbinom(R, 1, 0.6)
- y <- matrix(NA, R, J)
- y[] <- rbinom(R*J, 1, z*0.7)
- x1 <- rnorm(R)
- x2 <- y
- x2[] <- rnorm(R*J)
- x2[1,] <- NA
- x2[3,1] <- NA
- umf <- unmarkedFrameOccu(y=y, siteCovs=data.frame(x1=x1),
- obsCovs=list(x2=x2))
-
- fitstats <- function(fm) {
- observed <- getY(fm@data)
- expected <- fitted(fm)
- resids <- residuals(fm)
- sse <- sum(resids^2,na.rm=TRUE)
- chisq <- sum((observed - expected)^2 / expected,na.rm=TRUE)
- freeTuke <- sum((sqrt(observed) - sqrt(expected))^2,na.rm=TRUE)
- out <- c(SSE=sse, Chisq=chisq, freemanTukey=freeTuke)
- return(out)
- }
-
- x.1 <- "x1"
- x.2 <- "x2"
-## frm.obj <- as.formula(paste("~", x.2, "~", x.1))
- fm1 <- occu(~x2 ~x1, umf)
-## fm2 <- occu(frm.obj, umf)
- gof0 <- parboot(fm1, fitstats, nsim = 100, seed = 6546, parallel = FALSE)
- gof1 <- parboot(fm1, fitstats, nsim = 100, seed = 6546, report = 100, parallel = FALSE)
-## gof2 <- parboot(fm2, fitstats, nsim = 100, seed = 6546)
-
-## checkEquals(gof@t.star, gof2@t.star)
- ## checkEquals(gof@t.star,
- ## structure(c(19.5618449798627, 17.4002359377683, 17.9537040353665,
- ## 21.075371921093, 16.0962042909353, 20.325552699814, 23.7198566870693,
- ## 19.5108924194316, 19.8642253546241, 21.5327320826537, 21.1187621901383,
- ## 16.7956032348677, 22.0287240694084, 22.3480005863275, 18.7973008017797,
- ## 23.1214849443085, 13.3506204184759, 21.5072703730266, 20.4061806452888,
- ## 14.6052617734126, 18.8706802331149, 13.0708994826577, 20.1372507635082,
- ## 14.6298678460545, 14.6057681371775, 18.831780320931, 17.120219947307,
- ## 19.4171670630644, 21.4957335846724, 22.4888402383621, 12.322613247868,
- ## 21.5454567695879, 14.6852414309207, 19.7838342994475, 17.8245593195829,
- ## 22.1969431231403, 17.7606626580712, 19.3546579192266, 20.2796878074241,
- ## 13.1625669588524, 20.1565567700057, 18.4624537665433, 18.7281497995722,
- ## 17.084276968227, 18.7749912147129, 21.51782846093, 22.7333831188702,
- ## 16.5775111637824, 18.2032322719839, 22.4139063387728, 15.9946392373616,
- ## 15.5915117285785, 21.19490854222, 17.827591586556, 21.3012334843756,
- ## 21.6488943962608, 17.6126714952445, 18.8307613494122, 20.1703098549003,
- ## 15.1625669579498, 19.826946456208, 15.7205534649991, 20.3656552130317,
- ## 16.2150934276948, 21.751225967568, 19.1377654709796, 18.4258360327573,
- ## 21.7833681303917, 21.0655247805897, 21.9629466970292, 16.6242076104607,
- ## 15.1981816691142, 12.5702905066807, 19.6157287827686, 20.9402336996149,
- ## 14.7123207579701, 21.4435346035415, 22.203853561449, 19.3693120876226,
- ## 18.541012442289, 20.8523885801662, 17.5557349612729, 21.1092291315395,
- ## 15.3409036607707, 22.2534589622124, 19.3384363437181, 13.0019012153355,
- ## 18.4330918039649, 21.6586617051047, 17.881798324457, 22.6601416905637,
- ## 18.616287158617, 19.0554188699823, 17.4220384268791, 16.7061405736726,
- ## 22.6182783715741, 22.1268109325025, 21.9230866316946, 15.2082641262436,
- ## 18.0812577912096, 43.3811085710622, 45.9748066338993, 53.1267194500903,
- ## 53.9226412608954, 57.2322853419496, 56.81913797575, 42.843092859435,
- ## 71.645827922274, 54.9269841336055, 50.0243834249273, 49.4273985801733,
- ## 43.0939544330471, 55.7119685217531, 55.2558872423902, 47.7870495776912,
- ## 52.6225653375692, 21.1044790363835, 60.7708658750924, 59.9864660260814,
- ## 48.158395289865, 61.7457993539094, 37.0625570895648, 50.1620681411728,
- ## 107.147790014673, 75.8456014881641, 73.1799441669325, 66.5580949970634,
- ## 66.5923835657879, 43.2525590763885, 49.6312006043033, 50.1301251225221,
- ## 52.8556920360704, 52.4751938312775, 56.4790071460586, 36.8647563645067,
- ## 59.2938627030736, 67.4047022626281, 52.9528060465144, 59.4117890330828,
- ## 96.5345848217843, 45.0662041888096, 61.9689590696746, 46.7435460147703,
- ## 66.1761660198351, 52.9320582824706, 61.4889836317416, 55.9574703456775,
- ## 37.8266167880213, 96.8599350204107, 69.2816343189622, 47.3277238738376,
- ## 42.3484674062992, 56.7952852409591, 65.6088755086021, 58.8365068950566,
- ## 48.1777438550257, 57.793775564308, 77.6740293003584, 68.5207148634468,
- ## 62.0601548039289, 59.0183338904649, 62.2703649855977, 49.8261111448057,
- ## 64.8256636904662, 48.3927867616504, 61.4841796026201, 73.88006108371,
- ## 51.8816936520876, 48.5461720712801, 56.9866166106678, 69.3993834402648,
- ## 54.8704280205806, 53.7461657636567, 67.1426253749932, 59.4522997378742,
- ## 53.9775639251258, 51.8880881698028, 46.7652137312378, 54.7160400929552,
- ## 82.1622240570002, 63.4847263649612, 48.2103917727117, 55.0178942648036,
- ## 55.6473439310099, 54.3938693100806, 71.9583575909036, 85.4748087238452,
- ## 73.3103805543379, 67.6745322247688, 46.5483213094101, 62.9901631672752,
- ## 66.978261744477, 68.6352895991559, 36.229360963399, 65.2150267164381,
- ## 50.5686157431811, 55.6084482038548, 52.2075884629467, 38.1507417643389,
- ## 53.4129283520586, 23.2664577864302, 21.0750583945179, 22.6262152397489,
- ## 26.0567150448873, 20.4403218751078, 25.7594470302298, 26.5121247843041,
- ## 24.209733661715, 24.9785133948159, 25.5169785617333, 24.9847874670303,
- ## 20.1061010934685, 26.9129640852366, 26.5874571048698, 22.8912318274687,
- ## 27.262379925334, 14.9143114366755, 25.8352685143758, 24.6913130913828,
- ## 18.237633777394, 23.8829720420229, 15.5867212282945, 24.7824806665662,
- ## 19.620841205235, 19.2916899251373, 22.839576313349, 21.7274734394576,
- ## 22.2922040497901, 25.2604485627385, 26.5400357020065, 16.1731884602148,
- ## 26.1384672346904, 17.5893536807727, 24.5020407308938, 21.8260195910276,
- ## 27.1746057194612, 23.3287029690398, 23.5276963545107, 24.8954041928928,
- ## 18.4758269380415, 23.5954906760685, 21.6370332727459, 23.0349712484037,
- ## 22.2194937217677, 23.1543976924809, 25.8737217459936, 27.8513283250486,
- ## 19.6965071514396, 23.0268570741737, 28.0677719124672, 19.8840377834397,
- ## 18.4603389863306, 25.8298086845132, 23.2485637347826, 25.9168966206968,
- ## 26.1887756301694, 22.0435838347155, 22.4088635238283, 24.4074264892885,
- ## 20.8130191441585, 23.961059426556, 19.9071500178624, 24.9198338755164,
- ## 20.3318469099804, 25.7014219567935, 23.1867285598034, 23.6312172996782,
- ## 26.0231017648937, 25.5379206389201, 26.930788231955, 22.4731473297016,
- ## 20.2329929484612, 16.6778609896376, 25.1297713236246, 26.5495503537427,
- ## 18.9205151612852, 26.2004914124675, 25.9815529035957, 23.9187162955908,
- ## 23.4859888111333, 26.7429680608443, 20.9712900937786, 25.9103649128181,
- ## 19.4568163614539, 27.2478522089053, 24.8188282021128, 17.6645199950128,
- ## 23.0689346700379, 26.9644431478494, 21.2922969391002, 27.1491334558255,
- ## 24.3752059401432, 23.4504323299462, 20.5969557152295, 21.8180949333664,
- ## 26.4219322965689, 26.974047815842, 26.5215425452644, 18.5907018551572,
- ## 22.1663811466474), .Dim = c(100L, 3L),
- ## .Dimnames = list(NULL, c("SSE", "Chisq", "freemanTukey"))))
- checkEquals(gof0@t.star,
- structure(c(22.7233928126168, 12.3470513091314, 23.7920502079817,
- 17.562548865536, 15.8274704541987, 21.5149949042608, 18.3364213295809,
- 19.5370792522799, 23.3002776112391, 22.1362628199284, 15.5854689339351,
- 15.1277395349963, 18.3828771510762, 22.7128385736052, 21.6013417065336,
- 14.3137001062674, 13.6651731460017, 21.6375475753657, 15.7936523110773,
- 16.8864270821705, 18.9557142685823, 17.6410490820112, 18.8131612569099,
- 21.0904192210448, 14.1182286468629, 17.013562616852, 21.163360860191,
- 16.0843700107381, 15.2633690023902, 21.3433906372418, 20.3900662174045,
- 17.2265724981855, 21.0456502431369, 18.0145390375389, 17.3831729415441,
- 20.5665443766834, 20.0672720633256, 18.0453886074926, 21.0176570830052,
- 20.3827441604234, 21.0531219967315, 13.8616751536837, 15.4777345180738,
- 23.2686021615517, 23.0803566363563, 20.1668559314916, 18.1790476763143,
- 17.0808510218274, 20.9444696275573, 20.7770892589072, 16.7109124021832,
- 18.3580675455657, 23.1930009936209, 23.8538143094007, 16.4582665354875,
- 19.2105974920747, 20.6643012214347, 15.7059047130661, 19.6969525827628,
- 17.5145881975532, 19.7590963063933, 23.537571869555, 22.9734087595291,
- 20.6947496339553, 21.9336725495054, 21.0217473764709, 18.15479864132,
- 20.7988926386094, 21.6512172560475, 18.0121784351756, 17.8236150782961,
- 15.5070684019809, 20.3188438391569, 17.1075881178638, 23.7649112442344,
- 22.0149403215063, 18.5589400451582, 11.4130400689746, 20.7516976527603,
- 17.4614212961767, 16.3050943716475, 21.4406768816817, 19.2358057749613,
- 19.961294492026, 14.3583983338228, 21.2999444426061, 23.0397634096146,
- 15.7797191967604, 20.011304627921, 20.9613288539077, 15.7796545713692,
- 17.2676354147528, 19.4461769440979, 18.2818574582096, 18.0707416986471,
- 21.4992608963319, 22.3955981128822, 19.1835491436784, 18.9893496511941,
- 18.7382918257025, 51.9856971536444, 67.6102228126359, 48.7007259828727,
- 70.9696425175052, 75.6800614962169, 50.6393909710163, 70.0866005875347,
- 59.7006460060852, 50.9062463644471, 53.9952051410813, 75.4755013878626,
- 58.0792954269582, 64.546059885491, 55.6780355721395, 60.3773404549984,
- 52.6232571181147, 58.7713242147682, 55.5244499485268, 76.7403389716958,
- 74.4397251021063, 61.2808408559695, 73.4805893712095, 67.5985215079632,
- 55.8680467132114, 82.8404002665877, 40.9257175582078, 49.1545573345842,
- 76.1290436960065, 62.3342471297642, 58.4881275555864, 61.3015423834998,
- 69.2982774008338, 57.8480331109274, 57.115156714144, 70.5926016143194,
- 64.3089945811578, 64.0454363217668, 73.6342724332328, 63.0973538945623,
- 46.0079724789278, 60.824163178328, 62.3369143375445, 65.7779202012562,
- 50.9838985407446, 55.9649037046276, 65.3059759483931, 61.7048561065541,
- 89.1495239320995, 62.4255191246129, 55.9666371908698, 64.9711553418659,
- 44.7955283204842, 52.7263330734089, 53.0102378378038, 62.7363753573863,
- 65.5108921765033, 51.3104017672061, 74.6738643978355, 61.2377022816563,
- 64.5705758805414, 64.5907138845152, 46.2671394510726, 58.3426749468043,
- 65.3930872961233, 51.7297475883299, 60.9378842164194, 69.4185294997595,
- 62.2320869296418, 58.6755221153412, 69.4755999917795, 51.1751415044348,
- 70.2162397717456, 60.1541293708152, 57.1660465472361, 53.1631075611234,
- 60.1548930528115, 67.6662657363848, 55.579790735032, 38.5975278615509,
- 57.4963623986252, 67.6907061470825, 63.1755612437132, 67.9016192451441,
- 64.900914367349, 56.1793282464025, 63.2304545063742, 58.4474590740589,
- 74.4055641448641, 65.7751317250688, 50.6780283433276, 75.5548591440746,
- 60.5709855281592, 64.1749504683645, 66.668026981514, 78.1565969968747,
- 49.4769141477712, 57.4527425748052, 66.0145861091829, 53.7271987704509,
- 67.4599505754041, 27.4386597690967, 16.5191057026163, 27.9496215841815,
- 23.9730914979175, 21.5069784244525, 25.5956263229809, 24.071745207076,
- 24.0340487258294, 27.8368610086022, 27.0313791223911, 21.3608163234604,
- 19.6424588818649, 23.7998797052906, 27.8132913666895, 26.8469677476742,
- 19.3195594264092, 18.5083369202647, 26.2708042872481, 21.0593582860758,
- 21.6903230800287, 23.5601695897029, 23.7631126751929, 24.7954405645187,
- 26.089740396713, 19.9046820116032, 21.4363147204981, 25.1376392737642,
- 21.7133418278442, 20.3830856896976, 26.5588472210756, 26.047482907622,
- 23.2654263407478, 26.2500554619614, 22.1180860462792, 23.4805945636441,
- 26.1261588483031, 25.4996410166251, 23.8310335718184, 26.4644074605471,
- 24.6337633324892, 26.669444393487, 18.2865711313409, 20.6197732441125,
- 27.5529123320628, 27.8749553881739, 25.484416426684, 23.8388188526714,
- 22.0164037680539, 26.7214167293085, 25.963394971704, 22.2749104460635,
- 22.3055116489428, 28.0372725526757, 28.2094824173975, 21.6551637172699,
- 24.6197964511732, 25.0946260082923, 21.3521526186868, 24.9382294588377,
- 23.4633217564073, 25.9619845657965, 27.275230924503, 28.1178917855965,
- 26.3395996631699, 26.5179746994942, 26.4562893535018, 23.6757859405614,
- 26.0599802578119, 27.1286862874745, 23.2331442579466, 22.1413971804387,
- 21.7884831023537, 25.5078566341171, 22.3430427088187, 28.1935325146442,
- 27.1065222414039, 23.9879361663935, 14.9257383945917, 24.21951409719,
- 22.0102354862931, 21.7090400653363, 27.3685363273551, 25.2003971749359,
- 25.1633277517419, 19.0521630979451, 26.8889405698337, 27.8349529397291,
- 21.7727972966867, 25.147157454298, 25.6079910074641, 21.4884526376261,
- 22.4569005478273, 24.3891012972191, 23.5776428291445, 23.8234274170797,
- 26.2362490023563, 27.3968772939196, 24.315277880481, 23.0244824053688,
- 24.4926411206519), .Dim = c(100L, 3L), .Dimnames = list(NULL,
- c("SSE", "Chisq", "freemanTukey")))
- )
-
- #Check parallel
- gof2 <- parboot(fm1, fitstats, nsim = 100, seed = 6546, parallel=TRUE)
- checkIdentical(gof0@t.star, gof1@t.star)
- checkIdentical(gof0@t.star, gof2@t.star)
-
-}
-
-test.parboot.distsamp <- function() {
-
- data(issj)
- jayumf <- unmarkedFrameDS(y=as.matrix(issj[,1:3]),
- siteCovs=data.frame(scale(issj[,c("elevation","forest","chaparral")])),
- dist.breaks=c(0,100,200,300), unitsIn="m", survey="point")
-
- hn <- distsamp(~1 ~1, jayumf)
- neg <- distsamp(~1 ~1, jayumf,keyfun="exp")
-
- fitstats <- function(fm) {
- observed <- getY(fm@data)
- expected <- fitted(fm)
- resids <- residuals(fm)
- sse <- sum(resids^2)
- chisq <- sum((observed - expected)^2 / expected)
- out <- c(SSE=sse, Chisq=chisq)
- return(out)
- }
-
- set.seed(123)
- pb_hn <- parboot(hn, fitstats, nsim=2)
- checkEqualsNumeric(pb_hn@t0, c(435.8911, 2580.4320), tol=1e-4)
- checkEqualsNumeric(pb_hn@t.star, matrix(c(162.7815,156.1777,
- 878.5063,931.6237),nrow=2),
- tol=1e-4)
-
- pb_neg <- parboot(neg, fitstats, nsim=2)
- checkEqualsNumeric(pb_neg@t0, c(458.8042, 6007.6463), tol=1e-4)
- checkEqualsNumeric(pb_neg@t.star, matrix(c(164.8892,144.9085,
- 938.8101,880.0353),nrow=2),
- tol=1e-4)
-}
-
-test.parboot.occuMulti <- function(){
-
- set.seed(123)
- y <- list(matrix(rbinom(40,1,0.2),20,2),
- matrix(rbinom(40,1,0.3),20,2))
-
- N <- dim(y[[1]])[1]
- J <- dim(y[[1]])[2]
- occ_covs <- as.data.frame(matrix(rnorm(N * 3),ncol=3))
- names(occ_covs) <- paste('occ_cov',1:3,sep='')
-
- det_covs <- as.data.frame(matrix(rnorm(N*J*2),ncol=2))
- names(det_covs) <- paste('det_cov',1:2,sep='')
-
- stateformulas <- c('~occ_cov1','~occ_cov2','0')
- detformulas <- c('~det_cov1','~det_cov2')
-
- umf <- unmarkedFrameOccuMulti(y = y, siteCovs = occ_covs, obsCovs = det_covs)
-
- fm <- occuMulti(detformulas, stateformulas, data = umf)
-
- set.seed(456)
- pb <- parboot(fm, nsim=10)
- set.seed(456)
- pb2 <- parboot(fm, nsim=10, parallel=TRUE)
-
- checkEqualsNumeric(pb@t.star[1:3], c(12.61437, 12.14443, 15.88755),tol=1e-6)
- checkTrue(all(pb@t.star == pb2@t.star))
-}
diff --git a/inst/unitTests/runit.pcount.R b/inst/unitTests/runit.pcount.R
deleted file mode 100644
index 9dfffe4..0000000
--- a/inst/unitTests/runit.pcount.R
+++ /dev/null
@@ -1,137 +0,0 @@
-test.pcount.offest <- function()
-{
-
- y <- matrix(c(
- 8,7,
- 6,7,
- 8,8,
- 8,6,
- 7,7), nrow=5, ncol=2, byrow=TRUE)
- siteCovs <- data.frame(x = c(0,2,3,4,1))
- obsCovs <- data.frame(o1 = 1:10)
- umf <- unmarkedFramePCount(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
- fm <- pcount(~ o1 ~ offset(x), data = umf, K=30)
- checkEqualsNumeric(coef(fm), structure(c(-0.78814924, 2.62569034, -0.02578801),
- .Names = c("lam(Int)", "p(Int)", "p(o1)")), tol = 1e-5)
-
-}
-
-
-
-test.pcount.covs <- function()
-{
- y <- matrix(c(
- 8,7,7,8,
- 6,7,7,5,
- 8,8,7,8,
- 4,5,5,5,
- 4,4,3,3), nrow=5, ncol=4, byrow=TRUE)
- siteCovs <- data.frame(x = c(0,2,3,4,1))
- obsCovs <- data.frame(o1 = seq(-1, 1, length=length(y)))
- umf <- unmarkedFramePCount(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
- fm <- pcount(~ o1 ~ x, data = umf, K=30)
- checkEqualsNumeric(coef(fm),
- c(1.91984184, -0.02987393, 2.49421875, -0.23350448),
- tol = 1e-5)
-
-}
-
-test.pcount.randomeffects <- function()
-{
-
-set.seed(35)
-nSites <- 300
-nVisits <- 3
-x <- rnorm(nSites) # a covariate
-beta0 <- 0
-beta1 <- 0.4
-
-ran <- rnorm(100, 0, 1)
-group <- factor(as.character(rep(1:100, each=3)))
-ran_ind <- as.numeric(group)
-
-lambda <- exp(beta0 + beta1*x +
- ran[ran_ind]) # expected counts at each site
-N <- rpois(nSites, lambda) # latent abundance
-y <- matrix(NA, nSites, nVisits)
-p <- c(0.3, 0.6, 0.8) # detection prob for each visit
-for(j in 1:nVisits) {
- y[,j] <- rbinom(nSites, N, p[j])
-}
-
-# Organize data
-visitMat <- matrix(as.character(1:nVisits), nSites, nVisits, byrow=TRUE)
-
-umf <- unmarkedFramePCount(y=y, siteCovs=data.frame(x=x,group=group),
- obsCovs=list(visit=visitMat))
-
-fm <- pcount(~1~x, umf, K=50)
-checkTrue(inherits(fm, "unmarkedFitPCount"))
-
-fmr <- pcount(~visit~x+(1|group), umf, K=50)
-
-checkEqualsNumeric(coef(fmr), c(0.05535, 0.3200, -0.8795, 1.3638, 2.07098),
- tol=1e-4)
-
-checkTrue(inherits(sigma(fmr), 'data.frame'))
-checkEquals(sigma(fmr)$sigma, 1.060223, tol=1e-5)
-
-pr <- predict(fmr, "state")
-checkEqualsNumeric(as.numeric(pr[1,]),
- c(1.0385, 0.5827, 0.3457, 3.1192), tol=1e-4)
-
-pr2 <- predict(fmr, "state", re.form=NA)
-checkEqualsNumeric(as.numeric(pr2[1,]),
- c(1.4862, 0.2019, 1.1387, 1.9396), tol=1e-4)
-
-pr3 <- predict(fmr, "det")
-checkTrue(inherits(pr3, "data.frame"))
-
-nd <- data.frame(x=siteCovs(umf)$x[c(1,4)], group=factor(c(1,2)))
-pr4 <- predict(fmr, "state", newdata=nd)
-checkEqualsNumeric(pr4$Predicted, pr$Predicted[c(1,4)])
-
-# New group level
-nd <- data.frame(x=c(0,1), group=factor(101))
-checkException(predict(fmr, "state", newdata=nd))
-
-nd <- data.frame(x=c(0,1))
-checkException(predict(fmr, "state", newdata=nd))
-
-pr5 <- predict(fmr, "state", newdata=nd, re.form=NA)
-checkTrue(inherits(pr5, "data.frame"))
-
-ft <- fitted(fmr)
-checkEqualsNumeric(dim(ft), c(300,3))
-
-r <- ranef(fmr)
-checkTrue(inherits(r, "unmarkedRanef"))
-b <- bup(r)
-checkTrue(cor(N, b) > 0.95)
-
-rt <- randomTerms(fmr)
-checkTrue(inherits(rt, "data.frame"))
-checkEqualsNumeric(dim(rt), c(100,8))
-checkTrue(cor(ran, rt$Estimate) > 0.8)
-
-
-# Multiple random effects
-umf2 <- umf
-siteCovs(umf2)$id <- sample(letters[1:3], 300, replace=T)
-
-fmr2 <- pcount(~1~x+(1|group)+(1|id), umf2, K=50)
-
-checkTrue(nrow(sigma(fmr2))==2)
-rt2 <- randomTerms(fmr2)
-checkTrue(all(rt2$Groups==c(rep("group",100), rep("id",3))))
-
-# Check other distributions
-fmnb <- pcount(~1~1, umf, engine="TMB", mixture="NB", K=50)
-checkTrue(inherits(fmnb@TMB, "list"))
-checkTrue(all(names(fmnb@estimates@estimates)==c("state","det","alpha")))
-
-fmzip <- pcount(~1~1, umf, engine="TMB", mixture="ZIP", K=50)
-checkTrue(inherits(fmnb@TMB, "list"))
-checkTrue(all(names(fmnb@estimates@estimates)==c("state","det","alpha")))
-
-}
diff --git a/inst/unitTests/runit.pifun.R b/inst/unitTests/runit.pifun.R
deleted file mode 100644
index 560c187..0000000
--- a/inst/unitTests/runit.pifun.R
+++ /dev/null
@@ -1,123 +0,0 @@
-test.pifun.gmultmix <- function(){
-
- set.seed(123)
- y <- matrix(0:3, 5, 4)
- siteCovs <- data.frame(x = c(0,2,3,4,1))
- siteCovs[3,1] <- NA
- obsCovs <- data.frame(o1 = 1:20, o2 = exp(-5:4)/20)
- yrSiteCovs <- data.frame(yr=factor(rep(1:2, 5)))
-
- #bad type
- checkException(unmarkedFrameGMM(y = y, siteCovs = siteCovs,
- obsCovs = obsCovs,
- yearlySiteCovs = yrSiteCovs,
- type="fake", numPrimary=2))
-
- #type = "removal"
- umf <- unmarkedFrameGMM(y = y, siteCovs = siteCovs, obsCovs = obsCovs,
- yearlySiteCovs = yrSiteCovs, type="removal", numPrimary=2)
- fm_R <- gmultmix(~x, ~yr, ~o1 + o2, data = umf, K=23, engine="R")
- fm_C <- gmultmix(~x, ~yr, ~o1 + o2, data = umf, K=23, engine="C")
- coef_truth <- c(2.50638554, 0.06226627, 0.21787839, 6.46029769, -1.51885928,
- -0.03409375, 0.43424295)
- checkEqualsNumeric(coef(fm_R), coef_truth, tol = 1e-5)
- checkEqualsNumeric(coef(fm_C), coef_truth, tol = 1e-5)
-
- #type = "double"
- set.seed(123)
- y <- matrix(0:3, 5, 6)
- siteCovs <- data.frame(x = c(0,2,3,4,1))
- siteCovs[3,1] <- NA
- obsCovs <- data.frame(o1 = 1:20, o2 = exp(-5:4)/30)
- yrSiteCovs <- data.frame(yr=factor(rep(1:2, 5)))
-
- umf <- unmarkedFrameGMM(y = y, siteCovs = siteCovs, obsCovs = obsCovs,
- yearlySiteCovs = yrSiteCovs, type="double", numPrimary=2)
- fm_R <- gmultmix(~x, ~yr, ~o1 + o2, data = umf, K=23, engine="R")
- fm_C <- gmultmix(~x, ~yr, ~o1 + o2, data = umf, K=23, engine="C")
- coef_truth <- c(2.42178997506, 0.0790163156156549, -0.483051837753635,
- 0.0869555282843506,0.748689310997745, -0.0458486142792914,
- -0.374467809850705)
- checkEqualsNumeric(coef(fm_R), coef_truth, tol = 1e-5)
- checkEqualsNumeric(coef(fm_C), coef_truth, tol = 1e-5)
-
- #type = "depDouble"
- set.seed(123)
- y <- matrix(0:3, 5, 4)
- siteCovs <- data.frame(x = c(0,2,3,4,1))
- siteCovs[3,1] <- NA
- obsCovs <- data.frame(o1 = 1:20, o2 = exp(-5:4)/20)
- yrSiteCovs <- data.frame(yr=factor(rep(1:2, 5)))
-
- umf <- unmarkedFrameGMM(y = y, siteCovs = siteCovs, obsCovs = obsCovs,
- yearlySiteCovs = yrSiteCovs, type="depDouble", numPrimary=2)
-
- fm_R <- gmultmix(~x, ~yr, ~o1 + o2, data = umf, K=23, engine="R")
- fm_C <- gmultmix(~x, ~yr, ~o1 + o2, data = umf, K=23, engine="C")
- coef_truth <- c(2.50638554076642, 0.0622662713385639, 0.217878385786452,
- 6.46029769667278,-1.51885927831977, -0.0340937462852327,
- 0.434242947016337)
- checkEqualsNumeric(coef(fm_R), coef_truth, tol = 1e-5)
- checkEqualsNumeric(coef(fm_C), coef_truth, tol = 1e-5)
-}
-
-test.pifun.multinomPois <- function(){
-
- nSites <- 50
- lambda <- 10
- p1 <- 0.5
- p2 <- 0.3
- cp <- c(p1*(1-p2), p2*(1-p1), p1*p2)
- set.seed(9023)
- N <- rpois(nSites, lambda)
- y <- matrix(NA, nSites, 3)
- for(i in 1:nSites) {
- y[i,] <- rmultinom(1, N[i], c(cp, 1-sum(cp)))[1:3]
- }
-
- # incorrect type
- observer <- matrix(c('A','B'), nSites, 2, byrow=TRUE)
- #TODO: This should return a more informative error than it does
- checkException(unmarkedFrameMPois(y=y, obsCovs=list(observer=observer),
- type="fake"))
-
- #Type "double"
- umf <- unmarkedFrameMPois(y=y, obsCovs=list(observer=observer),
- type="double")
- fm_R <- multinomPois(~observer-1 ~1, umf, engine="R")
- fm_C <- multinomPois(~observer-1 ~1, umf, engine="C")
- coef_truth <- c(2.2586622, 0.1739752, -0.5685933)
- checkEqualsNumeric(coef(fm_R), coef_truth, tol = 1e-5)
- checkEqualsNumeric(coef(fm_C), coef_truth, tol = 1e-5)
-
- #Type "depDouble"
- nSites <- 50
- lambda <- 10
- p1 <- 0.5
- p2 <- 0.3
- cp <- c(p1, p2*(1-p1))
- set.seed(9023)
- N <- rpois(nSites, lambda)
- y <- matrix(NA, nSites, 2)
- for(i in 1:nSites) {
- y[i,] <- rmultinom(1, N[i], c(cp, 1-sum(cp)))[1:2]
- }
- # Fit model
- observer <- matrix(c('A','B'), nSites, 2, byrow=TRUE)
- umf <- unmarkedFrameMPois(y=y, obsCovs=list(observer=observer),
- type="depDouble")
- fm_R <- multinomPois(~observer-1 ~1, umf, engine="R")
- fm_C <- multinomPois(~observer-1 ~1, umf, engine="C")
- coef_truth <- c(2.0416086, 0.7430343, 0.4564236)
- checkEqualsNumeric(coef(fm_R), coef_truth, tol = 1e-5)
- checkEqualsNumeric(coef(fm_C), coef_truth, tol = 1e-5)
-
- #Type "removal"
- umf <- unmarkedFrameMPois(y=y, obsCovs=list(observer=observer),
- type="removal")
- fm_R <- multinomPois(~observer-1 ~1, umf, engine="R")
- fm_C <- multinomPois(~observer-1 ~1, umf, engine="C")
- coef_truth <- c(2.0416086, 0.7430343, 0.4564236)
- checkEqualsNumeric(coef(fm_R), coef_truth, tol = 1e-5)
- checkEqualsNumeric(coef(fm_C), coef_truth, tol = 1e-5)
-}
diff --git a/inst/unitTests/runit.predict.R b/inst/unitTests/runit.predict.R
deleted file mode 100644
index c821c1b..0000000
--- a/inst/unitTests/runit.predict.R
+++ /dev/null
@@ -1,193 +0,0 @@
-
-test.occu <- function() {
-
- if(!require(raster))
- stop("raster package required")
- set.seed(55)
- R <- 20
- J <- 4
- x1 <- rnorm(R)
- x2 <- factor(c(rep('A', R/2), rep('B', R/2)))
- x3 <- matrix(rnorm(R*J), R, J)
- z <- rbinom(R, 1, 0.5)
- y <- matrix(rbinom(R*J, 1, z*0.6), R, J)
- x1[1] <- NA
- x3[2,1] <- NA
- x3[3,] <- NA
- umf1 <- unmarkedFrameOccu(y=y, siteCovs=data.frame(x1=x1, x2=x2),
- obsCovs=list(x3=x3))
- fm1 <- occu(~x3 ~x1+x2, umf1)
- E1.1 <- predict(fm1, type="state")
- E1.2 <- predict(fm1, type="det")
-
- nd1.1 <- data.frame(x1=0, x2=factor('A', levels=c('A','B')))
- nd1.2 <- data.frame(x3=0)
- E1.3 <- predict(fm1, type="state", newdata=nd1.1, appendData=TRUE)
- E1.4 <- predict(fm1, type="det", newdata=nd1.2)
-
- r1 <- raster(matrix(rnorm(100), 10))
- checkException(predict(fm1, type="state", newdata=r1))
- s1 <- stack(r1)
- checkException(predict(fm1, type="state", newdata=s1))
- names(s1) <- c("x3")
- E1.5 <- predict(fm1, type="det", newdata=s1)
- E1.5 <- predict(fm1, type="det", newdata=s1, appendData=TRUE)
-
- E1.6 <- predict(fm1, type="state", level=0.9)
- checkEquals(as.numeric(E1.6[1,3:4]), c(0.01881844, 0.8538048))
-
-}
-
-
-
-test.pcount <- function() {
-
- set.seed(55)
- R <- 20
- J <- 4
- N <- rpois(R, 2)
- y <- matrix(rbinom(R*J, N, 0.7), R, J)
- umf1 <- unmarkedFramePCount(y=y)
-
- fm1 <- pcount(~1 ~1, umf1, K=40)
- E1.1 <- predict(fm1, type="state")
- E1.2 <- predict(fm1, type="det")
-
- fm2 <- pcount(~1 ~1, umf1, K=40, mixture="NB")
- E2.1 <- predict(fm2, type="state")
- checkException(predict(fm2, type="alpha"))
-
- fm3 <- pcount(~1 ~1, umf1, K=40, mixture="ZIP")
- E3.1 <- predict(fm3, type="state")
- checkException(predict(fm3, type="psi"))
- checkEquals(E3.1[1,1], 1.818512, tol=1e-6)
-
-}
-
-
-
-
-
-test.pcountOpen <- function() {
-
- set.seed(55)
- R <- 10
- J <- 4
- T <- 3
- N <- matrix(NA, R, T)
- N[,1] <- rpois(R, 4)
- N[,2] <- rbinom(R, N[,1], 0.8) + rpois(R, 1)
- N[,3] <- rbinom(R, N[,2], 0.8) + rpois(R, 1)
- y1 <- matrix(rbinom(R*J, N[,1], 0.7), R, J)
- y2 <- matrix(rbinom(R*J, N[,2], 0.7), R, J)
- y3 <- matrix(rbinom(R*J, N[,3], 0.7), R, J)
- umf1 <- unmarkedFramePCO(y=cbind(y1,y2,y3), numPrimary=T)
-
-# fm1 <- pcountOpen(~1, ~1, ~1, ~1, umf1, K=30)
-# E1.1 <- predict(fm1, type="lambda")
-# E1.2 <- predict(fm1, type="det")
-
- fm2 <- pcountOpen(~1, ~1, ~1, ~1, umf1, K=40, mixture="NB")
- checkException(predict(fm2, type="alpha"))
-
- fm3 <- pcountOpen(~1, ~1, ~1, ~1, umf1, K=40, mixture="ZIP")
- E3.1 <- predict(fm3, type="lambda")
- checkException(predict(fm3, type="psi"))
- checkEquals(E3.1[1,1], 2.472029, tol=1e-6)
-
- #With newdata
- siteCovs(umf1) <- data.frame(x=rnorm(10))
- fm4 <- pcountOpen(~x, ~1, ~1, ~1, umf1, K=40, mixture="NB")
- nd <- data.frame(x=1)
- checkEqualsNumeric(predict(fm4, "lambda", newdata=nd)$Predicted,
- 2.427701, tol=1e-6)
-
-}
-
-test.occuMulti <- function() {
-
- set.seed(123)
- N <- 10
- nspecies <- 2
- J <- 5
-
- occ_covs <- as.data.frame(matrix(rnorm(N * 3),ncol=3))
- names(occ_covs) <- paste('occ_cov',1:3,sep='')
-
- det_covs <- list()
- for (i in 1:nspecies){
- det_covs[[i]] <- matrix(rnorm(N*J),nrow=N)
- }
- names(det_covs) <- paste('det_cov',1:nspecies,sep='')
-
- #True vals
- beta <- c(0.5,0.2,0.4,0.5,-0.1,-0.3,0.2,0.1,-1,0.1)
- f1 <- beta[1] + beta[2]*occ_covs$occ_cov1
- f2 <- beta[3] + beta[4]*occ_covs$occ_cov2
- f3 <- beta[5] + beta[6]*occ_covs$occ_cov3
- f <- cbind(f1,f2,f3)
- z <- expand.grid(rep(list(1:0),nspecies))[,nspecies:1]
- colnames(z) <- paste('sp',1:nspecies,sep='')
- dm <- model.matrix(as.formula(paste0("~.^",nspecies,"-1")),z)
-
- psi <- exp(f %*% t(dm))
- psi <- psi/rowSums(psi)
-
- #True state
- ztruth <- matrix(NA,nrow=N,ncol=nspecies)
- for (i in 1:N){
- ztruth[i,] <- as.matrix(z[sample(4,1,prob=psi[i,]),])
- }
-
- p_true <- c(0.6,0.7)
-
- # fake y data
- y <- list()
-
- for (i in 1:nspecies){
- y[[i]] <- matrix(NA,N,J)
- for (j in 1:N){
- for (k in 1:J){
- y[[i]][j,k] <- rbinom(1,1,ztruth[j,i]*p_true[i])
- }
- }
- }
- names(y) <- c('coyote','tiger')
-
- #Create the unmarked data object
- data = unmarkedFrameOccuMulti(y=y,siteCovs=occ_covs,obsCovs=det_covs)
-
- occFormulas <- c('~occ_cov1','~occ_cov2','~occ_cov3')
- detFormulas <- c('~1','~1')
-
- fit <- occuMulti(detFormulas,occFormulas,data)
-
- pr_state <- predict(fit,'state')
- checkEqualsNumeric(pr_state$Predicted[1,],
- c(0.34936,0.18146,0.21590,0.25327),
- tol=1e-4)
- checkEqualsNumeric(pr_state$SE[1,],
- c(0.2023365,0.1334475,0.2009201,0.1551536),
- tol=1e-4)
- pr_det <- predict(fit,'det')
- checkEqualsNumeric(length(pr_det),nspecies)
- checkEqualsNumeric(sapply(pr_det,function(x) x[1,1]),c(0.59429,0.64731),tol=1e-4)
-
- #marginal occupancy
- pr_marg <- predict(fit,'state',species=2)
- checkEqualsNumeric(as.numeric(pr_marg[1,1:4]),
- c(0.56527,0.1937941,0.2380479,0.9207503),tol=1e-4)
-
- #conditional occupancy
- pr_cond <- predict(fit,'state',species=1,cond=2)
- checkEqualsNumeric(as.numeric(pr_cond[1,1:4]),
- c(0.61805,0.25368,0.089551,0.96615),tol=1e-4)
-
- #check newdata
- newdata <- data.frame(occ_cov1=rnorm(1),occ_cov2=rnorm(1),occ_cov3=rnorm(1))
- pr_new <- predict(fit,'state',newdata=newdata)
- checkEqualsNumeric(sapply(pr_new,function(x) x[1,1]),
- c(0.307815,0.221529,0.0264599,0.7406483),
- tol=1e-4)
-}
-
diff --git a/inst/unitTests/runit.ranef.R b/inst/unitTests/runit.ranef.R
deleted file mode 100644
index 65f32d8..0000000
--- a/inst/unitTests/runit.ranef.R
+++ /dev/null
@@ -1,618 +0,0 @@
-
-
-
-# ----------------------------- pcount ----------------------------------
-
-test.ranef.pcount <- function() {
-
- library(unmarked)
- set.seed(4564)
- R <- 10
- J <- 5
- N <- rpois(R, 3)
- y <- matrix(NA, R, J)
- y[] <- rbinom(R*J, N, 0.5)
- y[1,] <- NA
- y[2,1] <- NA
- K <- 15
-
- umf <- unmarkedFramePCount(y=y)
- fm <- pcount(~1 ~1, umf, K=K)
-
- re <- ranef(fm)
- modes <- bup(re, stat="mode")
- CI <- confint(re, level=0.9)
- checkEqualsNumeric(length(modes), R-1)
- checkEqualsNumeric(nrow(CI), R-1)
- checkEqualsNumeric(sum(modes), 42)
- checkEqualsNumeric(colSums(CI), c(33,60))
-
- df <- as(re, "data.frame")
- ar <- as(re, "array")
- checkEqualsNumeric(nrow(df), 144)
- checkEqualsNumeric(colSums(ar), c(
- 0.000000e+00, 0.000000e+00, 8.315871e-01, 1.337063e+00, 1.449232e+00,
- 1.804784e+00, 1.839209e+00, 1.137807e+00, 4.478077e-01, 1.226691e-01,
- 2.515083e-02, 4.076864e-03, 5.446213e-04, 6.189493e-05, 6.131061e-06,
- 5.391007e-07), tolerance=1e-6)
-
- fm.nb <- update(fm, mix="NB")
- fm.zip <- update(fm, mix="ZIP")
-
- ar.nb <- as(ranef(fm.nb), "array")
- ar.zip <- as(ranef(fm.zip), "array")
-
- checkEqualsNumeric(colSums(ar.nb), c(
- 0.000000e+00, 0.000000e+00, 8.316904e-01, 1.337039e+00, 1.449088e+00,
- 1.804499e+00, 1.839052e+00, 1.137951e+00, 4.480130e-01, 1.227798e-01,
- 2.518738e-02, 4.085472e-03, 5.461876e-04, 6.212684e-05, 6.160034e-06,
- 5.422348e-07), tolerance=1e-6)
-
- checkEqualsNumeric(colSums(ar.zip), c(
- 0.000000e+00, 0.000000e+00, 8.315404e-01, 1.337022e+00, 1.449214e+00,
- 1.804745e+00, 1.839218e+00, 1.137868e+00, 4.478556e-01, 1.226888e-01,
- 2.515613e-02, 4.077914e-03, 5.447851e-04, 6.191597e-05, 6.133365e-06,
- 5.393215e-07), tolerance=1e-6)
-
-
-}
-
-
-
-
-
-
-
-
-# ------------------------------- occu ----------------------------------
-
-
-
-test.ranef.occu <- function() {
- set.seed(4564)
- R <- 10
- J <- 5
- z <- rbinom(R, 1, 0.6)
- y <- matrix(NA, R, J)
- y[] <- rbinom(R*J, 1, z*0.7)
- y[1,] <- NA
- y[2,1] <- NA
-
- x <- y
- x[] <- rnorm(R*J)
- x[3,1] <- NA
-
- umf <- unmarkedFrameOccu(y=y, obsCovs=list(x=x))
- fm <- occu(~1 ~1, umf)
-
- re <- ranef(fm)
- modes <- bup(re, stat="mode")
- CI <- confint(re, level=0.95)
- checkEqualsNumeric(length(modes), R-1)
- checkEqualsNumeric(nrow(CI), R-1)
- checkEqualsNumeric(sum(modes), 3)
- checkEqualsNumeric(colSums(CI), c(3,3))
-
- df <- as(re, "data.frame")
- ar <- as(re, "array")
- checkEqualsNumeric(nrow(df), 18)
- checkEqualsNumeric(colSums(ar), c(5.993957, 3.006043), tolerance=1e-6)
-
- fmx <- occu(~x ~1, umf)
- arx <- as(ranef(fmx), "array")
- checkEqualsNumeric(colSums(arx), c(5.991553, 3.008447), tolerance=1e-6)
-
-}
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-# ------------------------------ distsamp -------------------------------
-
-
-
-test.distsamp.ranef <- function() {
-
- set.seed(344)
- lambda <- 10
- sigma <- 20
- npts <- 10
- radius <- 50
- breaks <- seq(0, 50, by=10)
- A <- (2*radius)^2 / 10000 # Area (ha) of square containing circle
- y <- matrix(0, npts, length(breaks)-1)
- N <- integer(npts)
- for(i in 1:npts) {
- M <- rpois(1, lambda * A) # Individuals within the square
- xy <- cbind(x=runif(M, -radius, radius),
- y=runif(M, -radius, radius))
- d <- apply(xy, 1, function(x) sqrt(x[1]^2 + x[2]^2))
- d <- d[d <= radius]
- N[i] <- length(d)
- if(length(d)) {
- p <- exp(-d^2 / (2 * sigma^2)) # half-normal
- d <- d[rbinom(length(d), 1, p) == 1]
- y[i,] <- table(cut(d, breaks, include.lowest=TRUE))
- }
- }
-
- umf1 <- unmarkedFrameDS(y = y, survey="point",
- dist.breaks=breaks, unitsIn="m")
- (m1 <- distsamp(~1 ~1, umf1, starts=c(log(5), log(20))))
- (m2 <- distsamp(~1 ~1, umf1, starts=c(log(5), log(20)),
- output="abund"))
-
- re1 <- ranef(m1, K=20)
- re2 <- ranef(m2, K=20)
-
- checkEquals(mode1 <- bup(re1, stat="mode"), bup(re2, "mode"))
- checkEquals(confint(re1), confint(re2))
-
- ar1 <- as(re1, "array")
-
-checkEqualsNumeric(colSums(ar1), c(
- 0.000000e+00, 2.334960e-01, 8.517322e-01, 1.524261e+00, 1.811577e+00,
- 1.691348e+00, 1.421738e+00, 1.085003e+00, 7.119743e-01, 3.898376e-01,
- 1.782052e-01, 6.895313e-02, 2.296231e-02, 6.685198e-03, 1.725009e-03,
- 3.991224e-04, 8.362689e-05, 1.600128e-05, 2.816112e-06, 4.586885e-07,
- 6.951721e-08), tolerance=1e-6)
-
-
-}
-
-
-
-
-
-
-
-
-
-
-
-# ------------------------------ multinomPois ----------------------------
-
-
-
-
-
-
-test.ranef.multinomPois <- function() {
-
- # Simulate independent double observer data
- nSites <- 10
- lambda <- 10
- p1 <- 0.5
- p2 <- 0.3
- cp <- c(p1*(1-p2), p2*(1-p1), p1*p2)
- set.seed(9023)
- N <- rpois(nSites, lambda)
- y <- matrix(NA, nSites, 3)
- for(i in 1:nSites) {
- y[i,] <- rmultinom(1, N[i], c(cp, 1-sum(cp)))[1:3]
- }
-
- # Fit model
- observer <- matrix(c('A','B'), nSites, 2, byrow=TRUE)
- umf <- unmarkedFrameMPois(y=y, obsCovs=list(observer=observer),
- type="double")
- fm <- multinomPois(~observer-1 ~1, umf)
-
- # Estimates of random effects
- re <- ranef(fm, K=20)
- ar <- as(re, "array")
-
-checkEqualsNumeric(colSums(ar), c(
- 0.0000000000, 0.0837789470, 0.2077360595, 0.3413273644, 0.5043850863,
- 0.6810201789, 0.9111517583, 1.2124489471, 1.4341939152, 1.3759825087,
- 1.0500832440, 0.7312585749, 0.5381253818, 0.4003005483, 0.2661348133,
- 0.1494032715, 0.0705242071, 0.0283773425, 0.0098973528, 0.0030385119,
- 0.0008319866), tolerance=1e-6)
-
-
-}
-
-
-
-
-
-# ---------------------------- gmultmix ---------------------------------
-
-
-library(unmarked)
-n <- 100 # number of sites
-T <- 4 # number of primary periods
-J <- 3 # number of secondary periods
-
-lam <- 3
-phi <- 0.5
-p <- 0.3
-
-#set.seed(26)
-y <- array(NA, c(n, T, J))
-M <- rpois(n, lam) # Local population size
-N <- matrix(NA, n, T) # Individuals available for detection
-
-for(i in 1:n) {
- N[i,] <- rbinom(T, M[i], phi)
- y[i,,1] <- rbinom(T, N[i,], p) # Observe some
- Nleft1 <- N[i,] - y[i,,1] # Remove them
- y[i,,2] <- rbinom(T, Nleft1, p) # ...
- Nleft2 <- Nleft1 - y[i,,2]
- y[i,,3] <- rbinom(T, Nleft2, p)
- }
-
-y.ijt <- cbind(y[,1,], y[,2,], y[,3,], y[,4,])
-umf1 <- unmarkedFrameGMM(y=y.ijt, numPrimary=T, type="removal")
-
-(m1 <- gmultmix(~1, ~1, ~1, data=umf1, K=30))
-
-re <- ranef(m1)
-plot(re, layout=c(5,5), xlim=c(-1,20), subset=site%in%1:25)
-
-
-
-
-# ---------------------------- gpcount ---------------------------------
-
-
-library(unmarked)
-test.ranef.gpcount <- function()
-{
- y <- matrix(c(1,1,1, 1,0,1, 2,2,2,
- 3,2,3, 2,2,2, 1,1,1,
- NA,0,0, 0,0,0, 0,0,0,
- 3,3,3, 3,2,3, 2,2,2,
- 0,0,0, 0,0,0, 0,0,0), 5, 9, byrow=TRUE)
- siteCovs <- data.frame(x = c(0,2,-1,4,-1))
- obsCovs <- list(o1 = matrix(seq(-3, 3, length=length(y)), 5, 9))
- obsCovs$o1[5,4:6] <- NA
- yrSiteCovs <- list(yr=matrix(c('1','2','2'), 5, 3, byrow=TRUE))
- yrSiteCovs$yr[4,2] <- NA
-
- umf <- unmarkedFrameGPC(y = y, siteCovs = siteCovs, obsCovs = obsCovs,
- yearlySiteCovs = yrSiteCovs, numPrimary=3)
- fm <- gpcount(~x, ~1, ~o1, data = umf, K=30)
- re <- ranef(fm)
- checkEqualsNumeric(bup(re, "mode"), c(2,3,0,4,0))
-
- fm0 <- gpcount(~1, ~1, ~1, data = umf, K=23)
- re0 <- ranef(fm0)
- checkEqualsNumeric(bup(re0, "mode"), c(2,3,0,3,0))
-}
-
-
-
-
-# ------------------------------ gdistsamp ------------------------------
-
-test.ranef.gdistsamp <- function() {
-
- set.seed(36837)
- R <- 10 # number of transects
- T <- 5 # number of replicates
- strip.width <- 50
- transect.length <- 60 # so that abund != density
- breaks <- seq(0, 50, by=10)
-
- lambda <- 10 # Abundance
- phi <- 0.6 # Availability
- sigma <- 30 # Half-normal shape parameter
-
- J <- length(breaks)-1
- y <- array(0, c(R, J, T))
- for(i in 1:R) {
- M <- rpois(1, lambda) # Individuals within the 1-ha strip
- for(t in 1:T) {
- # Distances from point
- d <- runif(M, 0, strip.width)
- # Detection process
- if(length(d)) {
- cp <- phi*exp(-d^2 / (2 * sigma^2)) # half-normal w/ g(0)<1
- d <- d[rbinom(length(d), 1, cp) == 1]
- y[i,,t] <- table(cut(d, breaks, include.lowest=TRUE))
- }
- }
- }
- y <- matrix(y, nrow=R) # convert array to matrix
- # Organize data
- umf <- unmarkedFrameGDS(y = y, survey="line", unitsIn="m",
- dist.breaks=breaks,
- tlength=rep(transect.length, R), numPrimary=T)
- # Fit the model
- m1 <- gdistsamp(~1, ~1, ~1, umf, output="abund", K=20)
- m2 <- gdistsamp(~1, ~1, ~1, umf, output="density", K=20)
-
- re1 <- ranef(m1)
- re2 <- ranef(m2)
-
- ar1 <- as(re1, "array")
- ar2 <- as(re2, "array")
-
- checkEquals(colSums(ar1), colSums(ar2), tol=1e-5)
-
- checkEqualsNumeric(colSums(ar1), c(
- 0.000000000, 0.000000000, 0.000000000, 0.118002086, 0.307044478,
- 0.310241436, 0.239886364, 0.448502098, 0.977448196, 1.436982755,
- 1.548430326, 1.359997401, 1.020206300, 0.655381337, 0.372519278,
- 0.233418189, 0.218220126, 0.242683228, 0.232040811, 0.174834734,
- 0.104160860), tolerance=1e-6)
-
-}
-
-# ----------------------------- colext ----------------------------------
-
-
-
-
-test.ranef.colext <- function() {
-
- set.seed(7)
- M <- 10
- J <- 3
- T <- 5
- psi <- 0.5
- gamma <- 0.4
- eps <- 0.6
- p <- 0.5
- z <- matrix(NA, M, T)
- y <- array(NA, c(M, J, T))
- z[,1] <- rbinom(M, 1, psi)
- y[,,1] <- rbinom(M*J, 1, z[,1]*p)
- for(t in 1:(T-1)) {
- mu <- ((1-z[,t])*gamma + z[,t]*(1-eps))
- z[,t+1] <- rbinom(M, 1, mu)
- y[,,t+1] <- rbinom(M*J, 1, z[,t+1]*p)
- }
-
- # Prepare data
- umf <- unmarkedMultFrame(y = matrix(y, M), numPrimary=T)
- summary(umf)
-
- # Fit model and backtransform
- (m1 <- colext(~1, ~1, ~1, ~1, umf))
-
- re1 <- ranef(m1)
-
- plot(re1, xlim=c(-1,2))
-
- ar1 <- as(re1, "array")
-
-
-checkEqualsNumeric(colSums(ar1), matrix(c(
- 7.587399, 3.711435, 3.138038, 4.677841, 3.121028,
- 2.412601, 6.288565, 6.861962, 5.322159, 6.878972), 2, byrow=TRUE),
- tol=1e-6)
-
-
-
-}
-
-
-
-
-
-
-
-
-# ----------------------------- pcountOpen -------------------------------
-
-
-
-test.ranef.pco <- function() {
-
- set.seed(7)
- M <- 10
- J <- 3
- T <- 5
- lambda <- 5
- gamma <- 0.4
- omega <- 0.6
- p <- 0.5
- N <- matrix(NA, M, T)
- y <- array(NA, c(M, J, T))
- S <- G <- matrix(NA, M, T-1)
- N[,1] <- rpois(M, lambda)
- y[,,1] <- rbinom(M*J, N[,1], p)
- for(t in 1:(T-1)) {
- S[,t] <- rbinom(M, N[,t], omega)
- G[,t] <- rpois(M, gamma)
- N[,t+1] <- S[,t] + G[,t]
- y[,,t+1] <- rbinom(M*J, N[,t+1], p)
- }
-
- # Prepare data
- umf <- unmarkedFramePCO(y = matrix(y, M), numPrimary=T)
- summary(umf)
-
- # Fit model and backtransform
- (m1 <- pcountOpen(~1, ~1, ~1, ~1, umf, K=20))
-
- re1 <- ranef(m1)
- ar1 <- as(re1, "array")
-
- #write.table( round(colSums(ar1),6), sep=",", row.names=FALSE,
- # col.names=FALSE)
-
- checkEqualsNumeric(colSums(ar1), matrix(c(
-0,0,0.819576,1.882332,0.989637,
-0.480739,2.960528,3.829933,2.832941,6.712276,
-2.288187,2.436992,1.751606,4.066047,2.111822,
-2.570878,2.156641,2.933849,1.144065,0.18163,
-1.250545,1.555231,0.618936,0.072798,0.00458,
-0.971742,0.714645,0.044551,0.001793,5.4e-05,
-0.926152,0.156831,0.001519,2.3e-05,0,
-0.855516,0.017955,2.9e-05,0,0,
-0.469365,0.001134,0,0,0,
-0.15106,4.2e-05,0,0,0,
-0.030947,1e-06,0,0,0,
-0.004375,0,0,0,0,
-0.000455,0,0,0,0,
-3.7e-05,0,0,0,0,
-2e-06,0,0,0,0,
-0,0,0,0,0,
-0,0,0,0,0,
-0,0,0,0,0,
-0,0,0,0,0,
-0,0,0,0,0,
-0,0,0,0,0), ncol=5, byrow=TRUE), tolerance=1e-6)
-
-
- m2 <- pcountOpen(~1, ~1, ~1, ~1, umf, K=20, dynamics="trend")
- re2 <- ranef(m2)
- checkEqualsNumeric(bup(re2, "mode")[1,], c(8, 5, 3, 1, 1))
-
-}
-
-test.ranef.occuMulti <- function(){
-
- set.seed(123)
- N <- 10
- nspecies <- 2
- J <- 5
-
- occ_covs <- as.data.frame(matrix(rnorm(N * 3),ncol=3))
- names(occ_covs) <- paste('occ_cov',1:3,sep='')
-
- det_covs <- list()
- for (i in 1:nspecies){
- det_covs[[i]] <- matrix(rnorm(N*J),nrow=N)
- }
- names(det_covs) <- paste('det_cov',1:nspecies,sep='')
-
- #True vals
- beta <- c(0.5,0.2,0.4,0.5,-0.1,-0.3,0.2,0.1,-1,0.1)
- f1 <- beta[1] + beta[2]*occ_covs$occ_cov1
- f2 <- beta[3] + beta[4]*occ_covs$occ_cov2
- f3 <- beta[5] + beta[6]*occ_covs$occ_cov3
- f <- cbind(f1,f2,f3)
- z <- expand.grid(rep(list(1:0),nspecies))[,nspecies:1]
- colnames(z) <- paste('sp',1:nspecies,sep='')
- dm <- model.matrix(as.formula(paste0("~.^",nspecies,"-1")),z)
-
- psi <- exp(f %*% t(dm))
- psi <- psi/rowSums(psi)
-
- #True state
- ztruth <- matrix(NA,nrow=N,ncol=nspecies)
- for (i in 1:N){
- ztruth[i,] <- as.matrix(z[sample(4,1,prob=psi[i,]),])
- }
-
- p_true <- c(0.6,0.7)
-
- # fake y data
- y <- list()
-
- for (i in 1:nspecies){
- y[[i]] <- matrix(NA,N,J)
- for (j in 1:N){
- for (k in 1:J){
- y[[i]][j,k] <- rbinom(1,1,ztruth[j,i]*p_true[i])
- }
- }
- }
- names(y) <- c('coyote','tiger')
-
- #Create the unmarked data object
- data = unmarkedFrameOccuMulti(y=y,siteCovs=occ_covs,obsCovs=det_covs)
-
- occFormulas <- c('~occ_cov1','~occ_cov2','~occ_cov3')
- detFormulas <- c('~1','~1')
-
- fit <- occuMulti(detFormulas,occFormulas,data)
-
- re <- ranef(fit,species=1)
- ar <- as(re, "array")
- checkEqualsNumeric(colSums(ar),c(3.94470,6.055303),tol=1e-4)
-}
-
-
-
-#--------------------- predict --------------------------------
-
-test.ranef.predict <- function(){
-
- #Single-season model
- set.seed(4564)
- R <- 10
- J <- 5
- N <- rpois(R, 3)
- y <- matrix(NA, R, J)
- y[] <- rbinom(R*J, N, 0.5)
- y[1,] <- NA
- y[2,1] <- NA
- K <- 15
-
- umf <- unmarkedFramePCount(y=y)
- fm <- pcount(~1 ~1, umf, K=K)
-
- re <- ranef(fm)
-
- ps <- posteriorSamples(re, nsim=10)
- checkTrue(inherits(ps, "unmarkedPostSamples"))
- #One is dropped bc of NA
- checkEqualsNumeric(dim(ps@samples), c(9,1,10))
-
- myfunc <- function(x){
- c(gr1=mean(x[1:4]), gr2=mean(x[5:9]))
- }
-
- pr <- predict(re, fun=myfunc, nsim=10)
- checkEqualsNumeric(dim(pr), c(2,10))
- checkEquals(rownames(pr), c("gr1","gr2"))
- checkEqualsNumeric(as.numeric(pr[1,1:3]), c(6.0,4.0,5.75))
-
- #Dynamic model
- set.seed(7)
- M <- 10
- J <- 3
- T <- 5
- lambda <- 5
- gamma <- 0.4
- omega <- 0.6
- p <- 0.5
- N <- matrix(NA, M, T)
- y <- array(NA, c(M, J, T))
- S <- G <- matrix(NA, M, T-1)
- N[,1] <- rpois(M, lambda)
- y[,,1] <- rbinom(M*J, N[,1], p)
- for(t in 1:(T-1)) {
- S[,t] <- rbinom(M, N[,t], omega)
- G[,t] <- rpois(M, gamma)
- N[,t+1] <- S[,t] + G[,t]
- y[,,t+1] <- rbinom(M*J, N[,t+1], p)
- }
-
- # Prepare data
- umf <- unmarkedFramePCO(y = matrix(y, M), numPrimary=T)
- summary(umf)
-
- # Fit model and backtransform
- m1 <- pcountOpen(~1, ~1, ~1, ~1, umf, K=20)
- re1 <- ranef(m1)
-
- ps <- posteriorSamples(re1, nsim=10)
- checkEqualsNumeric(dim(ps@samples), c(10,5,10))
- checkEqualsNumeric(ps@samples[1,,1],c(7,4,3,1,1))
-
- myfunc <- function(x){
- apply(x, 2, function(x) c(mean(x[1:4]), mean(x[5:9])))
- }
-
- pr <- predict(re1, fun=myfunc, nsim=10)
- checkEqualsNumeric(dim(pr), c(2,5,10))
- checkEqualsNumeric(pr[1,1:3,1], c(3.5,2.5,1.5))
-
-
-}
diff --git a/inst/unitTests/runit.simulate.R b/inst/unitTests/runit.simulate.R
deleted file mode 100644
index be77ba8..0000000
--- a/inst/unitTests/runit.simulate.R
+++ /dev/null
@@ -1,52 +0,0 @@
-test.simulate.GDS <- function(){
-
- set.seed(343)
- R <- 30
- T <- 3
- strip.width <- 50
- transect.length <- 200 #Area != 1
- breaks <- seq(0, 50, by=10)
-
- covs <- as.data.frame(matrix(rnorm(R*T),ncol=T))
- names(covs) <- paste0('par',1:3)
-
- beta <- c(0.4,0.3,0.6)
- lambda <- exp(1.3 + beta[1]*covs$par1)
- phi <- plogis(as.matrix(0.4 + beta[2]*covs))
- sigma <- exp(as.matrix(3 + beta[3]*covs))
- J <- length(breaks)-1
- y <- array(0, c(R, J, T))
- for(i in 1:R) {
- M <- rpois(1, lambda[i]) # Individuals within the 1-ha strip
- for(t in 1:T) {
- # Distances from point
- d <- runif(M, 0, strip.width)
- # Detection process
- if(length(d)) {
- cp <- phi[i,t]*exp(-d^2 / (2 * sigma[i,t]^2)) # half-normal w/ g(0)<1
- d <- d[rbinom(length(d), 1, cp) == 1]
- y[i,,t] <- table(cut(d, breaks, include.lowest=TRUE))
- }
- }
- }
- y <- matrix(y, nrow=R) # convert array to matrix
-
- covs$par1[2] <- NA
- umf <- unmarkedFrameGDS(y = y, siteCovs=covs, yearlySiteCovs=covs,
- survey="line", unitsIn="m",
- dist.breaks=breaks,
- tlength=rep(transect.length, R), numPrimary=T)
-
- fm <- gdistsamp(~par1, ~1, ~1, umf, se=FALSE, engine="C")
-
- #This used to error due to rmultinom not accepting size=NA
- s <- simulate(fm, nsim=2, na.rm=FALSE)
- checkEqualsNumeric(length(s), 2)
- checkEqualsNumeric(dim(s[[1]]), c(30,15))
- checkTrue(!any(is.na(s[[1]][1,])))
- checkTrue(all(is.na(s[[1]][2,])))
-
- pb <- parboot(fm, nsim=3)
- checkTrue(inherits(pb, "parboot"))
-
-}
diff --git a/inst/unitTests/runit.unmarkedFrame.R b/inst/unitTests/runit.unmarkedFrame.R
deleted file mode 100644
index 420d92e..0000000
--- a/inst/unitTests/runit.unmarkedFrame.R
+++ /dev/null
@@ -1,197 +0,0 @@
-test.emptyframe <- function() {
- checkException(umf <- unmarkedFrame())
-}
-
-test.frame <- function() {
- M <- 10
- J <- 3
- y <- matrix(rbinom(J * M, 1, 0.5), M, J)
- siteCovs <- data.frame(a = rnorm(M), b = factor(gl(2,5)))
- umf <- unmarkedFrame(y = y, siteCovs = siteCovs)
-}
-
-
-test.umfDS.args <- function() {
- y <- matrix(1, 1, 2)
- s <- "point"
- d <- 0:2
- uin <- "m"
- sc <- data.frame(1)
- oc <- matrix(1, 2)
- checkException(umf <- unmarkedFrameDS(y=y, siteCovs=sc, obsCovs=oc,
- survey=s, dist.breaks=d, unitsIn=uin))
- umf <- unmarkedFrameDS(y=y, siteCovs=sc, survey=s, dist.breaks=d,
- unitsIn=uin)
- checkException(obsCovs(umf) <- oc)
- checkException(umf <- unmarkedFrameDS(y=y, siteCovs=sc, survey=s,
- dist.breaks=d))
- checkException(umf <- unmarkedFrameDS(y=y, siteCovs=sc, dist.breaks=d,
- unitsIn=uin))
- checkException(umf <- unmarkedFrameDS(y=y, siteCovs=sc, survey=s,
- unitsIn=uin))
- checkException(umf <- unmarkedFrameDS(y=y, siteCovs=sc, survey=s,
- dist.breaks=0:3, unitsIn=uin))
- checkException(umf <- unmarkedFrameDS(y=y, siteCovs=sc, survey=s,
- dist.breaks=1:3, unitsIn=uin))
-
- }
-
-
-
-test.obsToY <- function() {
- y <- matrix(c(
- 1, 0, 0,
- 2, 1, 0,
- 1, 0, 1,
- 2, 1, 2,
- 1, 0, 3,
- 1, 1, 1), nrow=6, ncol=3, byrow=TRUE)
- oc <- matrix(c(
- 1, 0,
- 2, 1,
- 1, 1,
- NA, 0,
- 1, NA,
- NA, NA), nrow=6, ncol=2, byrow=TRUE)
- umf <- unmarkedFrameMPois(y = y, obsCovs = list(x=oc), type="double")
- o2y <- obsToY(umf)
-
- checkEquals(o2y, matrix(1, 2, 3))
- oc.na <- is.na(oc)
- oc.na %*% o2y
-
- }
-
-
-test.umf.yearlySiteCovs <- function() {
-
- n <- 50 # number of sites
- T <- 4 # number of primary periods
- J <- 3 # number of secondary periods
-
- site <- 1:50
- years <- data.frame(matrix(rep(2010:2013, each=n), n, T))
- years <- data.frame(lapply(years, as.factor))
- dummy <- matrix(rep(c('a','b','c','d'),n),nrow=n,byrow=T)
- occasions <- data.frame(matrix(rep(1:(J*T), each=n), n, J*T))
- y <- matrix(0:1, n, J*T)
-
- umf <- unmarkedMultFrame(y=y,
- siteCovs = data.frame(site=site),
- obsCovs=list(occasion=occasions),
- yearlySiteCovs=list(year=years,dummy=dummy),
- numPrimary=T)
-
- as_df <- as(umf,'data.frame')
-
- checkEqualsNumeric(dim(as_df),c(50,33))
- checkTrue(all(names(as_df)[13:22] == c('site','year.1','year.2','year.3',
- 'year.4','dummy.1','dummy.2','dummy.3',
- 'dummy.4','occasion.1')))
- checkTrue(all(as_df$year.1==2010))
- checkTrue(all(as_df$dummy.1=='a'))
-
-
- umf2 <- unmarkedMultFrame(y=y,
- siteCovs = data.frame(site=site),
- obsCovs=list(occasion=occasions),
- numPrimary=T)
-
- as_df2 <- as(umf2,'data.frame')
-
- checkEqualsNumeric(dim(as_df2),c(50,25))
-
-}
-
-test.umf.char.to.factor <- function(){
-
- n <- 50 # number of sites
- T <- 4 # number of primary periods
- J <- 3 # number of secondary periods
-
- y <- matrix(0:1, n, J*T)
-
- #Site covs
- sc <- data.frame(x=rnorm(n), y=sample(letters, 50, replace=TRUE))
- checkEquals(sapply(sc, class), c(x="numeric", y="character"))
-
- options(warn=2)
- checkException(umf <- unmarkedFrame(y, siteCovs=sc))
- options(warn=0)
- umf <- unmarkedFrame(y, siteCovs=sc)
- checkEquals(sapply(siteCovs(umf), class), c(x="numeric", y="factor"))
-
- #Already factor
- sc2 <- data.frame(x=rnorm(n), y=factor(sample(letters, 50, replace=TRUE)))
- umf <- unmarkedFrame(y, siteCovs=sc2)
- checkEquals(sapply(siteCovs(umf), class), c(x="numeric", y="factor"))
-
- #Obs covs
- oc <- data.frame(x=rnorm(n*J*T), y=sample(letters, n*J*T, replace=TRUE))
- checkEquals(sapply(oc, class), c(x="numeric", y="character"))
-
- options(warn=2)
- checkException(umf <- unmarkedFrame(y, obsCovs=oc))
- options(warn=0)
- umf <- unmarkedFrame(y, obsCovs=oc)
- checkEquals(sapply(obsCovs(umf), class), c(x="numeric", y="factor"))
- checkTrue(is.null(siteCovs(umf)))
-
- #as list
- oc <- list(x=matrix(oc$x, nrow=n), y=matrix(oc$y, nrow=n))
- options(warn=2)
- checkException(umf <- unmarkedFrameOccu(y, obsCovs=oc))
- options(warn=0)
- umf <- unmarkedFrameOccu(y, obsCovs=oc)
- checkEquals(sapply(obsCovs(umf), class), c(x="numeric", y="factor"))
- checkTrue(is.null(siteCovs(umf)))
-
- #Check conversion
- df <- as(umf, "data.frame")
- checkEqualsNumeric(dim(df), c(50,36))
-
- #Yearly site covs
- ysc <- list(x=matrix(rnorm(n*T), nrow=n),
- y=matrix(sample(letters, n*T, replace=TRUE), nrow=n))
- options(warn=2)
- checkException(umf <- unmarkedMultFrame(y, yearlySiteCovs=ysc, numPrimary=T))
- options(warn=0)
- umf <- unmarkedMultFrame(y, yearlySiteCovs=ysc, numPrimary=T)
- checkEquals(sapply(yearlySiteCovs(umf), class), c(x="numeric", y="factor"))
- checkTrue(is.null(siteCovs(umf)))
-
- #All
- options(warn=2)
- checkException(umf <- unmarkedMultFrame(y, yearlySiteCovs=ysc, obsCovs=oc,
- siteCovs=sc, numPrimary=T))
- options(warn=0)
- umf <- unmarkedMultFrame(y, yearlySiteCovs=ysc, obsCovs=oc,
- siteCovs=sc, numPrimary=T)
- checkEquals(sapply(yearlySiteCovs(umf), class), c(x="numeric", y="factor"))
- checkEquals(sapply(obsCovs(umf), class), c(x="numeric", y="factor"))
- checkEquals(sapply(obsCovs(umf), class), c(x="numeric", y="factor"))
-
- df <- as(umf, "data.frame")
- checkEqualsNumeric(dim(df), c(50,46))
-}
-
-test.unmarkedMultFrame.unequal.secondary.periods <- function()
-{
-
- nsites <- 6
- nyr <- 4
- nrep <- 2
- y <- matrix(c(
- 1,0, 1,1, 0,0, 0,0,
- 1,1, 0,0, 0,0, 0,0,
- 0,0, 0,0, 0,0, 0,0,
- 0,0, 1,1, 0,0, 0,0,
- 1,1, 1,0, 0,1, 0,0,
- 0,0, 0,0, 0,0, 1,1), nrow=nsites, ncol=nyr*nrep, byrow=TRUE)
-
- umf1 <- unmarkedMultFrame(y=y, numPrimary=4)
- checkTrue(inherits(umf1, "unmarkedMultFrame"))
-
- checkException(unmarkedMultFrame(y=y[,-1], numPrimary=4))
-
-}
diff --git a/inst/unitTests/runit.unmarkedMultFrame.R b/inst/unitTests/runit.unmarkedMultFrame.R
deleted file mode 100644
index 45a2133..0000000
--- a/inst/unitTests/runit.unmarkedMultFrame.R
+++ /dev/null
@@ -1,294 +0,0 @@
-test.umarkedMultFrame.crpifun <- function() {
-
-alfl <- read.csv(system.file("csv", "alfl.csv", package="unmarked"))
-alfl.covs <- read.csv(system.file("csv", "alflCovs.csv",package="unmarked"),
- row.names=1)
-alfl$captureHistory <- paste(alfl$interval1, alfl$interval2, alfl$interval3,
- sep="")
-alfl$captureHistory <- factor(alfl$captureHistory,
- levels=c("001", "010", "011", "100", "101", "110", "111"))
-alfl$id <- factor(alfl$id, levels=rownames(alfl.covs))
-
-alfl.v1 <- alfl[alfl$survey==1,]
-alfl.H1 <- table(alfl.v1$id, alfl.v1$captureHistory)
-alfl.v2 <- alfl[alfl$survey==2,]
-alfl.H2 <- table(alfl.v2$id, alfl.v2$captureHistory)
-alfl.v3 <- alfl[alfl$survey==3,]
-alfl.H3 <- table(alfl.v3$id, alfl.v3$captureHistory)
-
-
-Y<- array(NA, c(50, 3, 7))
-Y[1:50,1,1:7]<- alfl.H1
-Y[1:50,2,1:7]<- alfl.H2
-Y[1:50,3,1:7]<- alfl.H3
-
-crPiFun <- function(p) {
- p1 <- p[,1]
- p2 <- p[,2]
- p3 <- p[,3]
- cbind("001" = (1 - p1) * (1 - p2) * p3,
- "010" = (1 - p1) * p2 * (1 - p3),
- "011" = (1 - p1) * p2 * p3,
- "100" = p1 * (1 - p2) * (1 - p3),
- "101" = p1 * (1 - p2) * p3,
- "110" = p1 * p2 * (1 - p3),
- "111" = p1 * p2 * p3)
-}
-
-intervalMat <- matrix(c('1','2','3'), 50, 3, byrow=TRUE)
-class(alfl.H1) <- "matrix"
-o2y <- matrix(1, 3, 7)
-
-
-ywide<- as.matrix( cbind(alfl.H1, alfl.H2) )
-umf.cr1 <- unmarkedFrameGMM(y=ywide,
- obsCovs=NULL, yearlySiteCovs=NULL,
- obsToY=o2y, numPrimary=2, piFun="crPiFun")
-
-#(tmp <- gmultmix(~1, ~ 1, ~ 1, data=umf.cr1))
-#tmp@opt$par
-
-
- checkEquals(dim(umf.cr1@obsToY)[1] , 6)
- checkEquals(dim(umf.cr1@obsToY)[2] , 14)
-}
-
-
-
-test.umarkedMultFrame.subset <- function() {
-
- y <- matrix(1:27, 3)
- sc <- data.frame(x1 = 1:3)
- ysc <- list(x2 = matrix(1:9, 3))
- oc <- list(x3 = matrix(1:27, 3))
-
- umf1 <- unmarkedMultFrame(
- y = y,
- siteCovs = sc,
- yearlySiteCovs = ysc,
- obsCovs = oc,
- numPrimary = 3)
-
- dat <- as(umf1, "data.frame")
-
- umf1.obs1 <- umf1[,1]
- checkEquals(umf1.obs1@y, y[,1:3])
- checkEquals(umf1.obs1@siteCovs, sc)
- checkEqualsNumeric(unlist(umf1.obs1@obsCovs),
- as.numeric(t(oc[[1]][,1:3])))
- checkEqualsNumeric(unlist(umf1.obs1@yearlySiteCovs), ysc[[1]][,1])
- checkEquals(umf1.obs1@numPrimary, 1)
-
- umf1.obs1and3 <- umf1[,c(1,3)]
-
- umf1.site1 <- umf1[1,]
- checkEquals(umf1.site1@y, y[1,, drop=FALSE])
- checkEquals(umf1.site1@siteCovs, sc[1,, drop=FALSE])
- checkEqualsNumeric(unlist(umf1.site1@obsCovs), oc$x3[1,])
- checkEqualsNumeric(unlist(umf1.site1@yearlySiteCovs),
- ysc$x2[1,, drop=FALSE])
- checkEquals(umf1.site1@numPrimary, 3)
-
- umf1.sites1and3 <- umf1[c(1,3),]
-
- }
-
-
-
-
-
-
-test.umarkedFrameGMM.subset <- function() {
-
- y <- matrix(1:27, 3)
- sc <- data.frame(x1 = 1:3)
- ysc <- list(x2 = matrix(1:9, 3))
- oc <- list(x3 = matrix(1:27, 3))
-
- umf1 <- unmarkedFrameGMM(
- y = y,
- siteCovs = sc,
- yearlySiteCovs = ysc,
- obsCovs = oc,
- numPrimary = 3,
- type="removal")
-
- dat <- as(umf1, "data.frame")
-
- umf1.site1 <- umf1[1,]
- checkEquals(umf1.site1@y, y[1,, drop=FALSE])
- checkEquals(umf1.site1@siteCovs, sc[1,, drop=FALSE])
- checkEqualsNumeric(unlist(umf1.site1@obsCovs), oc$x3[1,])
- checkEqualsNumeric(unlist(umf1.site1@yearlySiteCovs),
- ysc$x2[1,, drop=FALSE])
- checkEquals(umf1.site1@numPrimary, 3)
-
- umf1.sites1and3 <- umf1[c(1,3),]
-
- checkEquals(class(umf1.site1)[1], "unmarkedFrameGMM")
-
- umf1.sites1and1 <- umf1[c(1,1),]
-
- umf1.obs1and2 <- umf1[,c(1,2)]
-
- checkEqualsNumeric(dim(getY(umf1.obs1and2)), c(3,6))
- checkEqualsNumeric(dim(siteCovs(umf1.obs1and2)), c(3,1))
- checkEqualsNumeric(dim(obsCovs(umf1.obs1and2)), c(18,1))
-
- umf1.sites1and2.obs1and2 <- umf1[c(1,2),c(1,2)]
- checkEqualsNumeric(dim(getY(umf1.sites1and2.obs1and2)), c(2,6))
- checkEqualsNumeric(dim(siteCovs(umf1.sites1and2.obs1and2)), c(2,1))
- checkEqualsNumeric(dim(obsCovs(umf1.sites1and2.obs1and2)), c(12,1))
-
- # THis doesn't work
- umf1.sites1and1.obs1and1 <- umf1[c(1,1),c(1,1)]
-
-
- }
-
-
-
-
-test.umarkedFrameGDS.subset <- function() {
-
- y <- matrix(1:27, 3)
- sc <- data.frame(x1 = 1:3)
- ysc <- list(x2 = matrix(1:9, 3))
-
- umf1 <- unmarkedFrameGDS(
- y = y,
- siteCovs = sc,
- yearlySiteCovs = ysc,
- numPrimary = 3,
- survey="point",
- dist.breaks=c(0, 10, 20, 30),
- unitsIn="m")
-
- dat <- as(umf1, "data.frame")
- checkEquals(nrow(dat), nrow(y))
-
- umf1.site1 <- umf1[1,]
- checkEquals(umf1.site1@y, y[1,, drop=FALSE])
- checkEquals(umf1.site1@siteCovs, sc[1,, drop=FALSE])
- checkEqualsNumeric(unlist(umf1.site1@yearlySiteCovs),
- ysc$x2[1,, drop=FALSE])
- checkEquals(umf1.site1@numPrimary, 3)
- checkEquals(umf1.site1@survey, "point")
-
- umf1.sites1and3 <- umf1[c(1,3),]
-
-
- umf2 <- unmarkedFrameGDS(
- y = y,
- siteCovs = sc,
- yearlySiteCovs = ysc,
- numPrimary = 3,
- survey="line",
- dist.breaks=c(0, 10, 20, 30),
- tlength=rep(1,nrow(y)),
- unitsIn="m")
-
- dat <- as(umf2, "data.frame")
-
- umf2.site1 <- umf2[1,]
- checkEquals(umf2.site1@y, y[1,, drop=FALSE])
- checkEquals(umf2.site1@siteCovs, sc[1,, drop=FALSE])
- checkEqualsNumeric(unlist(umf2.site1@yearlySiteCovs),
- ysc$x2[1,, drop=FALSE])
- checkEquals(umf2.site1@numPrimary, 3)
- checkEquals(umf2.site1@survey, "line")
-
- umf2.sites1and3 <- umf2[c(1,3),]
-
- }
-
-
-
-
-
-
-
-
-
-test.umarkedFrameGPC.subset <- function() {
-
- y <- matrix(1:27, 3)
- sc <- data.frame(x1 = 1:3)
- ysc <- list(x2 = matrix(1:9, 3))
- oc <- list(x3 = matrix(1:27, 3))
-
- umf1 <- unmarkedFrameGPC(
- y = y,
- siteCovs = sc,
- yearlySiteCovs = ysc,
- obsCovs = oc,
- numPrimary = 3)
-
- dat <- as(umf1, "data.frame")
-
- umf1.site1 <- umf1[1,]
- checkEquals(umf1.site1@y, y[1,, drop=FALSE])
- checkEquals(umf1.site1@siteCovs, sc[1,, drop=FALSE])
- checkEqualsNumeric(unlist(umf1.site1@obsCovs), oc$x3[1,])
- checkEqualsNumeric(unlist(umf1.site1@yearlySiteCovs),
- ysc$x2[1,, drop=FALSE])
- checkEquals(umf1.site1@numPrimary, 3)
-
- umf1.sites1and3 <- umf1[c(1,3),]
-
- checkEquals(class(umf1.site1)[1], "unmarkedFrameGPC")
-
- umf1.sites1and1 <- umf1[c(1,1),]
-
- umf1.obs1and2 <- umf1[,c(1,2)]
-
- checkEqualsNumeric(dim(getY(umf1.obs1and2)), c(3,6))
- checkEqualsNumeric(dim(siteCovs(umf1.obs1and2)), c(3,1))
- checkEqualsNumeric(dim(obsCovs(umf1.obs1and2)), c(18,1))
-
- umf1.sites1and2.obs1and2 <- umf1[c(1,2),c(1,2)]
- checkEquals(class(umf1.sites1and2.obs1and2)[1], "unmarkedFrameGPC")
- checkEqualsNumeric(dim(getY(umf1.sites1and2.obs1and2)), c(2,6))
- checkEqualsNumeric(dim(siteCovs(umf1.sites1and2.obs1and2)), c(2,1))
- checkEqualsNumeric(dim(obsCovs(umf1.sites1and2.obs1and2)), c(12,1))
-
- # THis doesn't work
- umf1.sites1and1.obs1and1 <- umf1[c(1,1),c(1,1)]
-
-
- }
-
-
-
-
-
-
-
-test.umarkedFramePCO.subset <- function() {
-
- y <- matrix(1:27, 3)
- sc <- data.frame(x1 = 1:3)
- ysc <- list(x2 = matrix(1:9, 3))
- oc <- list(x3 = matrix(1:27, 3))
-
- umf1 <- unmarkedFramePCO(
- y = y,
- siteCovs = sc,
- yearlySiteCovs = ysc,
- obsCovs = oc,
- numPrimary = 3)
-
- dat <- as(umf1, "data.frame")
-
- umf1.site1 <- umf1[1,]
- checkEquals(umf1.site1@y, y[1,, drop=FALSE])
- checkEquals(umf1.site1@siteCovs, sc[1,, drop=FALSE])
- checkEqualsNumeric(unlist(umf1.site1@obsCovs), oc$x3[1,])
- checkEqualsNumeric(unlist(umf1.site1@yearlySiteCovs),
- ysc$x2[1,, drop=FALSE])
- checkEquals(umf1.site1@numPrimary, 3)
- checkEquals(class(umf1.site1)[1], "unmarkedFramePCO")
-
- umf1.sites1and3 <- umf1[c(1,3),]
-
- }
diff --git a/inst/unitTests/sim.colext.R b/inst/unitTests/sim.colext.R
deleted file mode 100644
index adfabe5..0000000
--- a/inst/unitTests/sim.colext.R
+++ /dev/null
@@ -1,253 +0,0 @@
-
-library(unmarked)
-library(RUnit)
-
-
-# ----------------------------- simulate ---------------------------------
-
-
-sim <- function(nSites=100, nReps=5, nYears=5, psi=0.5, gamma=0.2,
- epsilon=0.8, p=0.4)
-{
-
- y <- array(NA, c(nSites, nReps, nYears))
- Z <- matrix(NA, nSites, nYears)
-
- phi <- 1-epsilon
-
- Z[,1] <- rbinom(nSites, 1, psi)
- for(t in 2:nYears) {
- muZ <- Z[,t-1] * phi + (1 - Z[,t-1]) * gamma
- Z[,t] <- rbinom(nSites, 1, muZ)
- }
- for(j in 1:nReps)
- for(t in 1:nYears)
- y[,j,t] <- rbinom(nSites, 1, Z[,t]*p)
-
- y <- matrix(y, nSites, nReps*nYears)
- return(y)
-}
-
-# sim()
-
-
-# ------------------------------- unmarked -------------------------------
-
-
-library(unmarked)
-library(RUnit)
-
-set.seed(3)
-nYears <- 5
-sim1 <- sim(nYears=nYears)
-umf <- unmarkedMultFrame(y = sim1, numPrimary = nYears)
-
-(m <- colext(~1, ~1, ~1, ~1, umf, control=list(trace=T, REPORT=1)))
-
-backTransform(m, type="psi")
-backTransform(m, type="col")
-backTransform(m, type="ext")
-backTransform(m, type="det")
-
-checkEqualsNumeric(coef(m),
- c(-0.1047112, -1.3000613, 1.5203993, -0.3634747),
- tol=1e-5)
-
-
-
-
-
-
-
-
-
-# Covariates
-
-library(unmarked)
-
-nSites <- 100
-nReps <- 4
-nYears <- 5
-
-set.seed(3454)
-x1 <- rnorm(nSites)
-x2 <- matrix(rnorm(nSites*nYears), nSites, nYears)
-
-psi <- plogis(-1 + 1*x1)
-epsilon <- plogis(-2 + 1*x2)
-phi <- 1-epsilon
-gamma <- 0.4
-p <- 0.3
-
-y <- array(NA, c(nSites, nReps, nYears))
-Z <- matrix(NA, nSites, nYears)
-
-Z[,1] <- rbinom(nSites, 1, psi)
-for(t in 2:nYears) {
- muZ <- Z[,t-1] * phi[,t-1] + (1 - Z[,t-1]) * gamma
- Z[,t] <- rbinom(nSites, 1, muZ)
-}
-for(j in 1:nReps)
- for(t in 1:nYears)
- y[,j,t] <- rbinom(nSites, 1, Z[,t]*p)
-
-y <- matrix(y, nSites, nReps*nYears)
-
-#x1[1] <- NA
-#x2[1,2] <- NA
-#y[1,1:4] <- NA
-
-umf <- unmarkedMultFrame(y=y, siteCovs=data.frame(x1=x1),
- yearlySiteCovs=list(x2=x2),
- numPrimary=nYears)
-
-summary(umf)
-
-(m2 <- colext(~x1, ~1, ~x2, ~1, umf))
-
-checkEqualsNumeric(coef(m2), c(-0.7440136, 0.9246523, -0.1577932,
- -1.9102425, 1.2321186, -0.6352266),
- tol=1e-6)
-
-
-
-
-
-
-
-
-
-
-
-
-# Missing values, no covariates
-
-
-
-
-
-
-set.seed(3)
-nYears <- 5
-sim3 <- sim(nYears=nYears, psi=0.5, gamma=0.2, epsilon=0.8, p=0.4)
-sim3[1,1] <- NA
-sim3[2,1:5] <- NA
-sim3[3,6:10] <- NA
-umf3 <- unmarkedMultFrame(y = sim3, numPrimary = nYears)
-
-(m3 <- colext(~1, ~1, ~1, ~1, umf3, control=list(trace=T, REPORT=1)))
-
-backTransform(m3, type="psi")
-backTransform(m3, type="col")
-backTransform(m3, type="ext")
-backTransform(m3, type="det")
-
-checkEqualsNumeric(coef(m),
- c(-0.1047112, -1.3000613, 1.5203993, -0.3634747),
- tol=1e-5)
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-# Missing values and Covariates
-
-library(unmarked)
-
-nSites <- 100
-nReps <- 4
-nYears <- 5
-
-set.seed(3454)
-x1 <- rnorm(nSites)
-x2 <- matrix(rnorm(nSites*nYears), nSites, nYears)
-
-psi <- plogis(-1 + 1*x1)
-epsilon <- plogis(-2 + 1*x2)
-phi <- 1-epsilon
-gamma <- 0.4
-p <- 0.3
-
-y <- array(NA, c(nSites, nReps, nYears))
-Z <- matrix(NA, nSites, nYears)
-
-Z[,1] <- rbinom(nSites, 1, psi)
-for(t in 2:nYears) {
- muZ <- Z[,t-1] * phi[,t-1] + (1 - Z[,t-1]) * gamma
- Z[,t] <- rbinom(nSites, 1, muZ)
-}
-for(j in 1:nReps)
- for(t in 1:nYears)
- y[,j,t] <- rbinom(nSites, 1, Z[,t]*p)
-
-y <- matrix(y, nSites, nReps*nYears)
-
-
-
-y[1,1] <- NA
-y[2,1:5] <- NA
-y[3,6:10] <- NA
-
-x1[c(4,6)] <- NA
-
-x2[7,1] <- NA
-x2[8,3] <- NA
-
-umf4 <- unmarkedMultFrame(y=y, siteCovs=data.frame(x1=x1),
- yearlySiteCovs=list(x2=x2),
- numPrimary=nYears)
-
-summary(umf4)
-
-(m4 <- colext(~x1, ~1, ~x2, ~1, umf4))
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-trace(unmarked:::handleNA, browser, browser, signature="unmarkedMultFrame")
-untrace(unmarked:::handleNA, signature="unmarkedMultFrame")
-
-trace(unmarked:::getDesign, browser, browser,
- signature="unmarkedMultFrame")
-untrace(unmarked:::getDesign, signature="unmarkedMultFrame")
-
-
-debugonce(unmarked:::colext.fit)
diff --git a/inst/unitTests/sim.distsamp.R b/inst/unitTests/sim.distsamp.R
deleted file mode 100644
index 189eb22..0000000
--- a/inst/unitTests/sim.distsamp.R
+++ /dev/null
@@ -1,383 +0,0 @@
-
-
-
-
-# Simulate with half-normal detection function
-
-simPt <- function(lambda=5, sigma=20, npts=100, radius=50,
- breaks=seq(0, 50, by=10))
-{
- A <- (2*radius)^2 / 10000 # Area (ha) of square containing circle
- y <- matrix(0, npts, length(breaks)-1)
- for(i in 1:npts) {
- M <- rpois(1, lambda * A) # Individuals within the square
- # coordinates of each individual
- xy <- cbind(x=runif(M, -radius, radius), y=runif(M, -radius, radius))
-
- # Distances from each point
- d <- apply(xy, 1, function(x) sqrt(x[1]^2 + x[2]^2))
- d <- d[d <= radius]
-
- # Detection process
- if(length(d)) {
- p <- exp(-d^2 / (2 * sigma^2)) # half-normal
- d <- d[rbinom(length(d), 1, p) == 1]
- y[i,] <- table(cut(d, breaks, include.lowest=TRUE))
- }
- }
- return(y)
-}
-
-colSums(simPt())
-
-set.seed(3)
-umf1 <- unmarkedFrameDS(y = simPt(), survey="point",
- dist.breaks=seq(0, 50, by=10), unitsIn="m")
-(m1 <- distsamp(~1 ~1, umf1, starts=c(log(5), log(20))))
-(m2 <- distsamp(~1 ~1, umf1, starts=c(log(5), log(20)), output="abund"))
-
-
-checkEqualsNumeric(coef(m1), c(1.813819, 2.893771), tol=1e-5)
-checkEquals(exp(coef(m1, type="state")),
- exp(coef(m2, type="state")) / (pi * 50^2 / 10000), tol=0.01)
-
-
-set.seed(11)
-nsims <- 50
-simout1 <- matrix(NA, nsims, 2)
-lam <- 20
-sig <- 30
-for(i in 1:nsims) {
- cat("sim", i, "\n")
- umf <- unmarkedFrameDS(y = simPt(lambda=lam, sigma=sig), survey="point",
- dist.breaks=seq(0, 50, by=10), unitsIn="m")
- m <- distsamp(~1 ~1, umf, starts=c(log(lam), log(sig)),
- output="abund")
- simout1[i,] <- exp(coef(m))
- }
-hist(simout1[,1]); abline(v=lam*pi*50^2/10000, lwd=2, col=3)
-hist(simout1[,2]); abline(v=sig, lwd=2, col=3)
-
-
-
-
-
-
-integrate(unmarked:::grhn, 0, 10, sigma=1000)$value * 2 * pi
-integrate(unmarked:::grhn, 10, 20, sigma=1000)$value * 2 * pi
-
-
-fitstats <- function(fm) {
- observed <- getY(fm@data)
- expected <- fitted(fm)
- resids <- residuals(fm)
- sse <- sum(resids^2)
- chisq <- sum((observed - expected)^2 / expected)
- freeTuke <- sum((sqrt(observed) - sqrt(expected))^2)
- out <- c(SSE=sse, Chisq=chisq, freemanTukey=freeTuke)
- return(out)
- }
-pb <- parboot(m1, statistic=fitstats, nsim=200, report=1)
-
-
-
-
-
-
-
-
-
-
-simLine <- function(lambda=5, sigma=20, npts=100,
- breaks=seq(0, 50, by=10))
-{
- W <- max(breaks)
- A <- 2*W*100/10000 # Area (ha) of rectangle containing 100m line
- y <- matrix(0, npts, length(breaks)-1)
- for(i in 1:npts) {
- N <- rpois(1, lambda * A) # Individuals within the square
- # distance from the line
- d <- runif(N, 0, W)
-
- # Detection process
- if(length(d) > 0) {
- p <- exp(-d^2 / (2 * sigma^2)) # half-normal
- d <- d[rbinom(length(d), 1, p) == 1]
- y[i,] <- table(cut(d, breaks, include.lowest=TRUE))
- }
- }
- return(y)
-}
-
-simLine()
-
-
-
-
-set.seed(7)
-nsims <- 100
-simout2 <- matrix(NA, nsims, 2)
-lam <- 20
-sig <- 30
-for(i in 1:nsims) {
- cat("sim", i, "\n"); flush.console()
- y.sim <- simLine(lambda=lam, sigma=sig)
- umf <- unmarkedFrameDS(y = y.sim, survey="line",
- dist.breaks=seq(0, 50, by=10), unitsIn="m",
- tlength=rep(100, nrow(y.sim)))
- m <- distsamp(~1 ~1, umf, starts=c(log(lam), log(sig)), rel.tol=1e-3)
- simout2[i,] <- exp(coef(m))
- }
-hist(simout2[,1]); abline(v=lam, lwd=2, col=3)
-hist(simout2[,2]); abline(v=sig, lwd=2, col=3)
-
-
-
-
-
-
-
-
-
-
-
-
-
-# Integrate fails if function is flat over most of its range
-
-
-grhaz <- unmarked:::grhaz
-curve(grhaz(x, shape=100, scale=10), 0, 50)
-curve(grhaz(x, shape=1, scale=1), 0, 50)
-
-str(integrate(grhaz, 0, 50, shape=1, scale=1, abs.tol=1e-4, stop.on.error=F))
-str(integrate(grhaz, 0, Inf, shape=1, scale=1, abs.tol=1e-1, stop.on.error=F))
-
-
-curve(grhaz(x, shape=0.1, scale=1), 400, 450)
-
-str(integrate(grhaz, 400, 450, shape=0.1, scale=1, abs.tol=1e-4,
- stop.on.error=F))
-str(integrate(grhaz, 300, Inf, shape=0.1, scale=1, abs.tol=1e-1,
- stop.on.error=F))
-
-
-
-str(integrate(grhaz, 400, 450, shape=10, scale=10, abs.tol=1e-4,
- stop.on.error=F))
-
-
-curve(gxhaz(x, shape=5, scale=1), 0, 50)
-integrate(gxhaz, 0, 20, shape=5, scale=1)$value
-
-increment <- 2
-sum(gxhaz(seq(0, 20, by=increment), shape=5, scale=1) * increment)
-
-increment <- 1
-sum(gxhaz(seq(0, 20, by=increment), shape=5, scale=1) * increment)
-
-increment <- 0.2
-sum(gxhaz(seq(0, 20, by=increment), shape=5, scale=1) * increment)
-
-increment <- 0.001
-sum(gxhaz(seq(0, 20, by=increment), shape=5, scale=1) * increment)
-
-
-
-
-
-
-
-
-
-# numeric vs analytic integration
-
-# ------------------------------ Point transects ----------------------
-
-# Half-normal
-
-sigma <- 30
-br <- seq(0, 50, 10)
-
-# numeric
-hn1 <- integrate(grhn, br[1], br[2], sigma=sigma)$value
-a1 <- pi*br[2]^2
-p1 <- 2*pi*hn1/(a1)
-for(i in 2:(length(br)-1)) {
- hn1[i] <- integrate(grhn, br[i], br[i+1], sigma=sigma)$value
- a1[i] <- (pi*br[i+1]^2) - sum(a1[1:(i-1)])
- p1[i] <- 2*pi*hn1[i]/a1[i]
-}
-p1
-
-
-# analytical
-hn2 <- sigma^2*(1 - exp(-br[2]^2/(2*sigma^2))) -
- sigma^2*(1 - exp(-br[1]^2/(2*sigma^2)))
-a2 <- pi*br[2]^2
-p2 <- 2*pi*hn2/(a2)
-for(i in 2:(length(br)-1)) {
- hn2[i] <- integrate(grhn, br[i], br[i+1], sigma=sigma)$value
- a2[i] <- (pi*br[i+1]^2) - sum(a2[1:(i-1)])
- p2[i] <- 2*pi*hn2[i]/a2[i]
-}
-p2
-
-p1
-
-
-
-
-
-
-# Negative exponential
-
-rate <- 30
-br <- seq(0, 50, 10)
-a <- pi*br[2]^2
-
-# numeric
-nexp1 <- integrate(unmarked:::grexp, br[1], br[2], rate=rate)$value
-p1 <- 2*pi*nexp1/a
-for(i in 2:(length(br)-1)) {
- nexp1[i] <- integrate(unmarked:::grexp, br[i], br[i+1],
- rate=rate)$value
- a[i] <- (pi*br[i+1]^2) - sum(a[1:(i-1)])
- p1[i] <- 2*pi*nexp1[i]/a[i]
-}
-p1
-
-
-# analytical
-
-f <- function(x, a) exp(x*a)*x
-f(10, a=-1/30)
-grexp(10, 30)
-
-f(-10, a=1/30)
-grexp(10, 30)
-
-fp <- function(x, a) (x/a - 1/a^2)*exp(x*a)
-fp(10, a=-1/30)
-
-fp(10, a=.5)
-integrate(f, 0, 10, a=0.5)$value
-
-fp(10, a=-.5)
-integrate(f, 0, 10, a=-0.5)$value
-fp2 <- function(x, a) (a*x - 1)*exp(a*x) / a^2
-fp2(10, a=-.5)
-
-
-# Integral of exp(x*a)*x
-# f=exp(x*a)
-# F=x*(1-exp(x*a))
-# g=x
-# gp=x^2/2
-# rate*(1 - exp(-br[2]/rate))
-fp <- function(x, a) {
- g <- x
- gp <- x^2/2
- F <- x*(1-exp(x*a))
- F*g - 0.5*3*x^2#F*g - \int F*gp
-}
-
-
-fp2 <- function(x, a) (x/abs(a) - 1/a^2)*exp(x*abs(a))
-fp2(10, a=-.5)
-
-exp(r*(-1/rate))*r
-
-(10/(1/rate) - 1/(1/rate)^2)*exp(10*(-1/rate))
-
-(nexp2 <- rate^2*(1 - exp(-br[2]^2/(rate))) -
- rate^2*(1 - exp(-br[1]^2/(rate))))
-p2 <- 2*pi*nexp2/a
-for(i in 2:(length(br)-1)) {
- nexp2[i] <- integrate(grhn, br[i], br[i+1], rate=rate)$value
- p2[i] <- 2*pi*nexp2[i]/a[i]
-}
-p2
-
-p1
-
-nexp1
-nexp2
-
-
-30^2*(1-exp(-10/30)) - 0.5*3*30^2*(1-exp(-10/30))
-
-
-# ------------------------------ Line transects ----------------------
-
-
-
-# Half-normal
-
-sigma <- 30
-br <- seq(0, 50, 10)
-a <- br[2]
-
-# numeric
-hn1 <- integrate(gxhn, br[1], br[2], sigma=sigma)$value
-p1 <- hn1/a
-for(i in 2:(length(br)-1)) {
- hn1[i] <- integrate(gxhn, br[i], br[i+1], sigma=sigma)$value
- a[i] <- br[i+1] - sum(a[1:(i-1)])
- p1[i] <- hn1[i]/a[i]
-}
-p1
-
-
-# analytical
-hn2 <- sigma^2*(1 - exp(-br[2]^2/(2*sigma^2))) -
- sigma^2*(1 - exp(-br[1]^2/(2*sigma^2)))
-p2 <- hn2/a
-for(i in 2:(length(br)-1)) {
- hn2[i] <- sigma*(1 - exp(-br[i+1]/sigma)) -
- sigma*(1 - exp(-br[i]/sigma))
- p2[i] <- hn2[i]/a
-}
-p2
-
-p1
-
-hn1
-hn2
-
-
-
-
-
-# Negative exponential
-
-rate <- 30
-br <- seq(0, 50, 10)
-a <- br[2]
-
-# numeric
-nexp1 <- integrate(gxexp, br[1], br[2], rate=rate)$value
-p1 <- nexp1/a
-for(i in 2:(length(br)-1)) {
- nexp1[i] <- integrate(gxexp, br[i], br[i+1], rate=rate)$value
- a[i] <- br[i+1] - sum(a[1:(i-1)])
- p1[i] <- nexp1[i]/a[i]
-}
-p1
-
-
-# analytical
-nexp2 <- rate*(1 - exp(-br[2]/rate)) -
- rate*(1 - exp(-br[1]/rate))
-p2 <- nexp2/a
-for(i in 2:(length(br)-1)) {
- nexp2[i] <- rate*(1 - exp(-br[i+1]/rate)) -
- rate*(1 - exp(-br[i]/rate))
- p2[i] <- nexp2[i]/a
-}
-p2
-
-p1
-
-nexp1
-nexp2
diff --git a/inst/unitTests/sim.distsampOpen.R b/inst/unitTests/sim.distsampOpen.R
deleted file mode 100644
index 86aa3e8..0000000
--- a/inst/unitTests/sim.distsampOpen.R
+++ /dev/null
@@ -1,129 +0,0 @@
-
-sim7 <- function(lambda=1, gamma=0.5, omega=0.8, sigma=40, scale=NULL, M=100, T=5,
- J=4, type="line", keyfun="halfnorm") {
- keyfun <- "halfnorm" ## FIXME!!!
- y <- array(NA, c(M, J, T))
- N <- matrix(NA, M, T)
- S <- G <- matrix(NA, M, T-1)
- db <- c(0, 25, 50, 75, 100)
- w <- diff(db) ## rbc added
- if(length(db)-1 != J)
- stop("hey, what")
- if(keyfun=="halfnorm"){
- if(type=="point")
- g <- function(x, sig) exp(-x^2/(2*sig^2))*x
- if(type=="line")
- g <- function(x, sig) exp(-x^2/(2*sig^2))
- }
-
- cp <- u <- a <- numeric(J)
- if(type=="point"){
- a[1] <- pi*db[2]^2
- cp[1] <- integrate(g, db[1], db[2], sig=sigma)$value * 2 * pi
- for(j in 2:J) {
- a[j] <- pi*db[j+1]^2 - sum(a[1:j])
- cp[j] <- integrate(g, db[j], db[j+1], sig=sigma)$value * 2*pi
- }
- }
- if(type=="line"){
- L <- 1
- a[1] <- L*db[2]
- cp[1] <- integrate(g, db[1], db[2], sig=sigma)$value #/ w[1]
- for(j in 2:J) {
- a[j] <- db[j+1] - sum(a[1:j])
- cp[j] <- integrate(g, db[j], db[j+1], sig=sigma)$value #/ w[j]
- }
- }
- u <- a / sum(a)
- cp <- cp / a * u
- cp[j+1] <- 1-sum(cp)
-
- for(i in 1:M) {
- N[i,1] <- rpois(1, lambda)
- y[i,1:J,1] <- rmultinom(1, N[i,1], cp)[1:J]
- for(t in 1:(T-1)) {
- S[i,t] <- rbinom(1, N[i,t], omega)
- G[i,t] <- rpois(1, gamma)
- N[i,t+1] <- S[i,t] + G[i,t]
- y[i,1:J,t+1] <- rmultinom(1, N[i,t+1], cp)[1:J]
- }
- }
- cp <- array(cp, c(J, M, T))
- cp <- matrix(aperm(cp, c(2,1,3)), M)
- cat("max(N) =", max(N), "\n")
- return(list(y=matrix(y, M),N=N, cp=cp))
-}
-
-library(unmarked)
-set.seed(711)
-lambda <- 4
-gamma <- 2
-omega <- 0.5
-sigma <- 30
-T <- 10
-
-
-out7 <- sim7(lambda, gamma, omega, sigma=50, M=200, T=T,type="line", keyfun="halfnorm")
-
-cbind(out7$y[,1:4], out7$N[,1])
-
-cbind(rowSums(out7$y[,1:4]), out7$N[,1])
-
-cbind(out7$y[,5:8], out7$N[,2])
-
-cbind(rowSums(out7$y[,5:8]), out7$N[,2])
-
-colSums(out7$y)
-
-y.sim7 <- sim7(lambda, gamma, omega, sigma=sigma, M=50, T=T,type="line",
- keyfun="halfnorm")$y
-umf7b <- unmarkedFrameDSO(y = y.sim7, numPrimary=T,
- dist.breaks = c(0, 25, 50, 75, 100), survey="line", unitsIn="m",tlength=rep(1, 200))
-fm <- distsampOpen(~1, ~1, ~1, ~1, data = umf7b, K=120,keyfun="half",
-## starts=c(log(c(lambda, gamma)),plogis(omega), log(sigma)),
- starts=c(0, 0, 0, 3), method="BFGS",
- se=FALSE, nintervals=5, control=list(trace=TRUE, REPORT=1, maxit=100))
-
-exp(coef(fm)[c(1,2,4)])
-plogis(coef(fm)[3])
-
-
-
-y.sim7 <- sim7(lambda, gamma, omega, sigma=sigma, M=50, T=T,type="point",
- keyfun="halfnorm")$y
-umf7b <- unmarkedFrameDSO(y = y.sim7, numPrimary=T,
- dist.breaks = c(0, 25, 50, 75, 100), survey="point", unitsIn="m")
-fm <- distsampOpen(~1, ~1, ~1, ~1, data = umf7b, K=120,keyfun="half",
-## starts=c(log(c(lambda, gamma)),plogis(omega), log(sigma)),
- starts=c(0, 0, 0, 3),
- se=FALSE, nintervals=5, control=list(trace=TRUE, REPORT=1))
-
-
-
-
-
-y.sim7 <- sim7(lambda, gamma, omega, sigma=25, M=200, T=T,type="line", keyfun="exp")$y
-umf7b <- unmarkedFrameDSO(y = y.sim7, numPrimary=T,
- dist.breaks = c(0, 25, 50, 75, 100), survey="line", unitsIn="m",tlength=rep(1, 200))
-fm2 <- distsampOpen(~1, ~1, ~1, ~1, data = umf7b, K=60,keyfun="exp",
- starts=rnorm(4,0,.1)+c(log(c(lambda, gamma)),plogis(omega), log(sigma)),
- se=FALSE, nintervals=8)
-
-
-y.sim7 <- sim7(lambda, gamma, omega, sigma=NULL, M=200, T=T,type="line", keyfun="uniform", scale=1)$y
-umf7b <- unmarkedFrameDSO(y = y.sim7, numPrimary=T,
- dist.breaks = c(0, 25, 50, 75, 100), survey="line", unitsIn="m",tlength=rep(1, 200))
-fm3 <- distsampOpen(~1, ~1, ~1, ~1, data = umf7b, K=60,keyfun="uniform",
- starts=c(log(c(lambda, gamma)),plogis(omega), log(sigma)),
- se=FALSE, nintervals=8)
-
-
-
-y.sim7 <- sim7(lambda, gamma, omega, sigma=20, scale = 1, M=200, T=T,type="line", keyfun="hazard")$y
-umf7b <- unmarkedFrameDSO(y = y.sim7, numPrimary=T,
- dist.breaks = c(0, 25, 50, 75, 100), survey="line", unitsIn="m",tlength=rep(1, 200))
-fm4 <- distsampOpen(~1, ~1, ~1, ~1, data = umf7b, K=50,keyfun="hazard", method="Nelder-Mead",
- control=list(trace=2),
- starts=rnorm(5,
- 0.8*c(log(c(lambda, gamma)),plogis(omega), log(sigma), 0),0),
- se=FALSE, nintervals=8)
diff --git a/inst/unitTests/sim.gdistsamp.R b/inst/unitTests/sim.gdistsamp.R
deleted file mode 100644
index d0f83c6..0000000
--- a/inst/unitTests/sim.gdistsamp.R
+++ /dev/null
@@ -1,404 +0,0 @@
-
-
-library(unmarked)
-
-
-sim1 <- function(lambda=5, phi=0.5, shape=20, scale=10, R=100, T=3,
- breaks=seq(0, 50, by=10), survey="pt", detfun="hn")
-{
- nb <- length(breaks)
- J <- nb-1
- maxDist <- max(breaks)
- tlength <- 1000
- switch(survey,
- pt = A <- (2*maxDist)^2 / 10000, # Area (ha) of square
- line = A <- maxDist*2*100 / 10000 # Area (ha) 100m transect
- )
- a <- pi*breaks[2]^2
- for(j in 2:J) {
- a[j] <- pi*breaks[j+1]^2 - sum(a[1:(j-1)])
- }
- u <- a / sum(a)
- y <- array(0, c(R, J, T))
- for(i in 1:R) {
- M <- rpois(1, lambda * A) # Individuals within the rectangle
- if(identical(survey, "pt")) {
- X <- runif(M, -maxDist, maxDist)
- Y <- runif(M, -maxDist, maxDist)
- d <- sqrt(X^2+Y^2)
- d <- d[d<=maxDist]
- M <- length(d)
- }
- else if(identical(survey, "line"))
- d <- runif(M, -maxDist, maxDist)
- else
- stop("survey must be either 'point' or 'line'")
- if(length(d) > 0) {
- switch(detfun,
- hn = p <- exp(-d^2 / (2 * shape^2)),
- exp = p <- exp(-d/shape),
- haz = p <- 1-exp(-(d/shape)^-scale),
- unif = p <- 1
- )
- cp <- p * phi
- } else next
- for(t in 1:T) {
- # Detection process
- d1 <- d[rbinom(length(d), 1, cp) == 1]
- y[i,,t] <- table(cut(d1, breaks, include.lowest=TRUE))
- }
- }
- y <- matrix(y, nrow=R)
- return(y)
-}
-
-
-
-sim2 <- function(lambda=5, phi=0.5, shape=20, scale=10, R=100, T=3,
- breaks=seq(0, 50, by=10), survey="pt", detfun="hn")
-{
- nb <- length(breaks)
- J <- nb-1
- maxDist <- max(breaks)
- tlength <- 1000
- switch(survey,
- pt = A <- pi*maxDist^2 / 10000, # Area (ha) of circle
- line = A <- maxDist*2*100 / 10000 # Area (ha) 100m transect
- )
- a <- pi*breaks[2]^2
- for(j in 2:J) {
- a[j] <- pi*breaks[j+1]^2 - sum(a[1:(j-1)])
- }
- u <- a / sum(a)
- y <- array(0, c(R, J, T))
- for(i in 1:R) {
- M <- rpois(1, lambda * A) # Super-population
- for(t in 1:T) {
- switch(survey,
- pt = {
- z <- 2*pi*runif(M)
- u <- runif(M) + runif(M)
- r <- ifelse(u>1, 2-u, u)
- X <- maxDist*r*cos(z)
- Y <- maxDist*r*sin(z)
- d <- sqrt(X^2+Y^2)
- d <- d[d<=maxDist]
- d <- d
- },
- line = {
- d <- runif(M, 0, maxDist)
- })
-
- # Detection process
- if(length(d) > 0) {
- switch(detfun,
- hn = p <- exp(-d^2 / (2 * shape^2)),
- exp = p <- exp(-d/shape),
- haz = p <- 1-exp(-(d/shape)^-scale),
- unif = p <- 1
- )
- cp <- p * phi
- d1 <- d[rbinom(length(d), 1, cp) == 1]
- y[i,,t] <- table(cut(d1, breaks, include.lowest=TRUE))
- }
- }
- }
- y <- matrix(y, nrow=R)
- return(y)
-}
-
-
-
-
-
-
-
-library(unmarked)
-
-set.seed(3)
-
-breaks <- seq(0, 50, by=10)
-T <- 5
-umf <- unmarkedFrameGDS(y = sim2(lambda=30, shape=50, phi=0.7,
- T=T, breaks=breaks),
- survey="point", unitsIn="m",
- dist.breaks=breaks, numPrimary=T)
-summary(umf)
-
-system.time(m <- gdistsamp(~1, ~1, ~1, umf, K=200, output="density",
- starts=c(3, 0, 3))) # 28s
-
-backTransform(m, type="lambda")
-backTransform(m, type="phi")
-backTransform(m, type="det")
-
-
-
-# Point-transect, half-normal
-nsim1 <- 2
-simout1 <- matrix(NA, nsim1, 3)
-colnames(simout1) <- c('lambda', 'phi', 'sigma')
-set.seed(4059)
-for(i in 1:nsim1) {
- cat("sim1", i, "\n")
- breaks <- seq(0, 50, by=10)
- T <- 5
- y1 <- sim2(lambda=30, shape=50, phi=0.7, R=100, T=T, breaks=breaks)
- umf1 <- unmarkedFrameGDS(y = y1, survey="point",
- unitsIn="m", dist.breaks=breaks, numPrimary=T)
- m1 <- gdistsamp(~1, ~1, ~1, umf1, output="density", K=100,
- control=list(trace=TRUE, REPORT=1),
-# lower=c(-Inf,-5,-Inf), upper=c(Inf, 5, Inf),
- starts=c(3,0.5,3), se=FALSE)
- e <- coef(m1)
- simout1[i,] <- c(exp(e[1]), plogis(e[2]), exp(e[3]))
- cat("\tbeta.hat =", simout1[i,], "\n")
- }
-
-par(mfrow=c(3, 1))
-hist(simout1[,1], xlab=expression(lambda), main="")
-abline(v=30, col=4)
-hist(simout1[,2], xlab=expression(phi), main=""); abline(v=0.7, col=4)
-hist(simout1[,3], xlab=expression(sigma), main=""); abline(v=50, col=4)
-
-
-
-# Point-transect, neg exp
-nsim2 <- 10
-simout2 <- matrix(NA, nsim2, 3)
-colnames(simout2) <- c('lambda', 'phi', 'rate')
-for(i in 1:nsim2) {
- cat("sim2", i, "\n"); flush.console()
- breaks <- seq(0, 50, by=10)
- T <- 5
- y2 <- sim2(lambda=30, phi=0.7, shape=50, R=100, T=T, breaks=breaks,
- detfun="exp")
- umf2 <- unmarkedFrameGDS(y = y2, survey="point",
- unitsIn="m", dist.breaks=breaks, numPrimary=T)
- m2 <- gdistsamp(~1,~1,~1, umf2, keyfun="exp", output="density", K=100,
- starts=c(3,0,3), se=FALSE)
- e <- coef(m2)
- simout2[i,] <- c(exp(e[1]), plogis(e[2]), exp(e[3]))
- cat("\tbeta.hat =", simout2[i,], "\n")
- }
-
-par(mfrow=c(3, 1))
-hist(simout2[,1], xlab=expression(lambda), main="")
-abline(v=30, col=4, lwd=2)
-hist(simout2[,2], xlab=expression(phi), main="")
-abline(v=0.7, col=4, lwd=2)
-hist(simout2[,3], xlab=expression(rate), main="")
-abline(v=50, col=4, lwd=2)
-
-
-
-
-# Point-transect, hazard
-nsim <- 10
-simout <- matrix(NA, nsim, 4)
-colnames(simout) <- c('lambda', 'phi', 'shape', 'scale')
-for(i in 1:nsim) {
- cat("sim", i, "\n"); flush.console()
- breaks <- seq(0, 50, by=10)
- T <- 5
- y <- sim2(lambda=30, phi=0.7, shape=30, scale=5, R=100, T=T,
- breaks=breaks, detfun="haz")
- umf <- unmarkedFrameGDS(y = y, survey="point",
- unitsIn="m", dist.breaks=breaks, numPrimary=T)
- m <- gdistsamp(~1, ~1, ~1, umf, keyfun="hazard", output="density",
- K=100, starts=c(3, 0, 2, 1), se=FALSE)
- e <- coef(m)
- simout[i,] <- c(exp(e[1]), plogis(e[2]), exp(e[3:4]))
- cat(" beta.hat =", simout[i,], "\n")
- }
-
-par(mfrow=c(3, 1))
-hist(simout[,1], xlab=expression(lambda), main="")
-abline(v=30, col=4)
-hist(simout[,2], xlab=expression(phi), main=""); abline(v=0.7, col=4)
-hist(simout[,3], xlab=expression(sigma), main=""); abline(v=30, col=4)
-
-
-
-
-# Point-transect, uniform
-nsim4 <- 10
-simout4 <- matrix(NA, nsim4, 2)
-colnames(simout4) <- c('lambda', 'phi')
-for(i in 1:nsim4) {
- cat("sim4", i, "\n"); flush.console()
- breaks <- seq(0, 50, by=10)
- T <- 5
- y4 <- sim2(lambda=20, phi=0.6, R=100, T=T, breaks=breaks,
- detfun="unif",
- survey="pt")
- umf4 <- unmarkedFrameGDS(y = y4, survey="point",
- unitsIn="m", dist.breaks=breaks, numPrimary=T)
- m4 <- gdistsamp(~1, ~1, ~1, umf4, keyfun="uniform", output="density",
- K=100, unitsOut="ha", se=FALSE)
- e <- coef(m4)
- simout4[i,] <- c(exp(e[1]), plogis(e[2]))
- cat("\tbeta.hat =", simout4[i,], "\n")
- }
-
-par(mfrow=c(2, 1))
-hist(simout4[,1], xlab=expression(lambda), main="")
-abline(v=20, col=4)
-hist(simout4[,2], xlab=expression(phi), main=""); abline(v=0.6, col=4)
-
-
-
-
-
-
-
-
-
-
-# Line-transect, half-normal
-nsim5 <- 10
-simout5 <- matrix(NA, nsim5, 3)
-colnames(simout5) <- c('lambda', 'phi', 'sigma')
-for(i in 1:nsim5) {
- cat("sim5", i, "\n")
- breaks <- seq(0, 50, by=10)
- T <- 5
- y5 <- sim2(lambda=30, phi=0.7, shape=50, R=100, T=T, breaks=breaks,
- survey="line")
- umf5 <- unmarkedFrameGDS(y = y5, survey="line", tlength=rep(100,100),
- unitsIn="m", dist.breaks=breaks, numPrimary=T)
- m5 <- gdistsamp(~1, ~1, ~1, umf5, output="density", K=100,
- se=FALSE, starts=c(3, 0, 3))
- e <- coef(m5)
- simout5[i,] <- c(exp(e[1]), plogis(e[2]), exp(e[3]))
- cat(" beta.hat =", simout5[i,], "\n")
- }
-
-par(mfrow=c(3, 1))
-hist(simout5[,1], xlab=expression(lambda), main="")
-abline(v=30, col=4)
-hist(simout5[,2], xlab=expression(phi), main=""); abline(v=0.7, col=4)
-hist(simout5[,3], xlab=expression(sigma), main=""); abline(v=50, col=4)
-
-
-
-# Line-transect, neg exp
-nsim6 <- 10
-simout6 <- matrix(NA, nsim6, 3)
-colnames(simout6) <- c('lambda', 'phi', 'rate')
-for(i in 1:nsim6) {
- cat("sim6", i, "\n"); flush.console()
- breaks <- seq(0, 50, by=10)
- T <- 5
- y6 <- sim2(lambda=30, phi=0.7, shape=30, R=100, T=T, breaks=breaks,
- detfun="exp", survey="line")
- umf6 <- unmarkedFrameGDS(y = y6, survey="line", tlength=rep(100,100),
- unitsIn="m", dist.breaks=breaks, numPrimary=T)
- m6 <- gdistsamp(~1, ~1, ~1, umf6, keyfun="exp", output="density",
- K=100, se=FALSE, starts=c(3,0,3))
- e <- coef(m6)
- simout6[i,] <- c(exp(e[1]), plogis(e[2]), exp(e[3]))
- cat("\tbeta.hat =", simout6[i,], "\n")
- }
-
-par(mfrow=c(3, 1))
-hist(simout6[,1], xlab=expression(lambda), main="")
-abline(v=30, col=4)
-hist(simout6[,2], xlab=expression(phi), main=""); abline(v=0.7, col=4)
-hist(simout6[,3], xlab=expression(sigma), main=""); abline(v=30, col=4)
-
-
-
-
-# Line-transect, hazard
-nsim7 <- 10
-simout7 <- matrix(NA, nsim7, 4)
-colnames(simout7) <- c('lambda', 'phi', 'shape', 'scale')
-for(i in 1:nsim7) {
- cat("sim7", i, "\n"); flush.console()
- breaks <- seq(0, 50, by=10)
- T <- 5
- y7 <- sim2(lambda=30, phi=0.7, shape=30, scale=5, R=100, T=T,
- breaks=breaks, detfun="haz", survey="line")
- umf7 <- unmarkedFrameGDS(y = y7, survey="line", tlength=rep(100,100),
- unitsIn="m", dist.breaks=breaks, numPrimary=T)
- m7 <- gdistsamp(~1, ~1, ~1, umf7, keyfun="hazard", K=100,
- starts=c(1.5, 0.5, 3, 0), output="density")
- e <- coef(m7)
- simout7[i,] <- c(exp(e[1]), plogis(e[2]), exp(e[3:4]))
- cat("\tbeta.hat =", simout7[i,], "\n")
- }
-
-par(mfrow=c(3, 1))
-hist(simout7[,1], xlab=expression(lambda), main="")
-abline(v=20, col=4)
-hist(simout7[,2], xlab=expression(phi), main=""); abline(v=0.7, col=4)
-hist(simout7[,3], xlab=expression(sigma), main=""); abline(v=20, col=4)
-
-
-
-
-# Line-transect, uniform
-nsim8 <- 10
-simout8 <- matrix(NA, nsim8, 2)
-colnames(simout8) <- c('lambda', 'phi')
-for(i in 1:nsim8) {
- cat("sim8", i, "\n"); flush.console()
- breaks <- seq(0, 50, by=10)
- T <- 5
- y8 <- sim2(lambda=20, phi=0.7, R=100, T=T, breaks=breaks,
- detfun="unif",
- survey="line")
- umf8 <- unmarkedFrameGDS(y = y8, survey="line", tlength=rep(100,100),
- unitsIn="m", dist.breaks=breaks, numPrimary=T)
- m8 <- gdistsamp(~1, ~1, ~1, umf8, keyfun="uniform", output="density",
- K=100, se=FALSE)
- e <- coef(m8)
- simout8[i,] <- c(exp(e[1]), plogis(e[2]))
- }
-
-par(mfrow=c(2, 1))
-hist(simout8[,1], xlab=expression(lambda), main="")
-abline(v=20, col=4)
-hist(simout8[,2], xlab=expression(phi), main=""); abline(v=0.7, col=4)
-
-
-
-
-
-
-
-
-
-
-
-
-rcirc <- function(n, R) {
- a <- a2 <- runif(n)
- b <- b2 <- runif(n)
- bla <- b < a
- b2[bla] <- a[bla]
- a2[bla] <- b[bla]
- stopifnot(all(b2 >= a2))
- cbind(b2*R*cos(2*pi*a2/b2), b2*R*sin(2*pi*a2/b2))
-}
-
-plot(0,type="n", xlim=c(-55,55), asp=1)
-points(rc1 <- rcirc(1000, 50))
-
-rcirc <- function(n, R) {
- t <- 2*pi*runif(n, 0, 1)
- u <- runif(n) + runif(n)
- r <- ifelse(u>1, 2-u, u)
- cbind(R*r*cos(t), R*r*sin(t))
-}
-
-plot(0,type="n", xlim=c(-55,55), asp=1)
-points(rc1 <- rcirc(1000, 50))
-
-
-
-f <- function(r, R=50) 2*r/R^2
-u <- runif(10000, 0, 50)
-d <- sample(u, 100, replace=TRUE, prob=f(u))
-hist(d)
diff --git a/inst/unitTests/sim.gmultmix.R b/inst/unitTests/sim.gmultmix.R
deleted file mode 100644
index 4bb5ccf..0000000
--- a/inst/unitTests/sim.gmultmix.R
+++ /dev/null
@@ -1,375 +0,0 @@
-
-# -------------------------- Null Poisson removal model ------------------
-
-set.seed(26)
-
-n <- 50 # number of sites
-T <- 4 # number of primary periods
-J <- 3 # number of secondary periods
-
-lam <- 3
-phi <- 0.5
-p <- 0.3
-
-y <- array(NA, c(n, T, J))
-M <- rpois(n, lam) # Local population size
-N <- matrix(NA, n, T) # Individuals availabe for detection
-
-for(i in 1:n) {
- N[i,] <- rbinom(T, M[i], phi)
- y[i,,1] <- rbinom(T, N[i,], p)
- Nleft1 <- N[i,] - y[i,,1]
- y[i,,2] <- rbinom(T, Nleft1, p)
- Nleft2 <- Nleft1 - y[i,,2]
- y[i,,3] <- rbinom(T, Nleft2, p)
- }
-
-y.ijt <- cbind(y[,1,], y[,2,], y[,3,], y[,4,])
-umf1 <- unmarkedFrameGMM(y=y.ijt, numPrimary=T, type="removal")
-
-
-system.time(m1 <- gmultmix(~1, ~1, ~1, data=umf1)) #2.3
-
-# Test 1
-checkEqualsNumeric(coef(m1), c(1.3923561, -0.3183231, -0.7864098),
- tolerance=1e-5)
-
-SSE(m1)
-
-(pb1 <- parboot(m1, nsim=50, report=5))
-plot(pb1)
-
-
-
-
-# -------------------------- Null NegBin removal model -------------------
-
-set.seed(73)
-
-n <- 50 # number of sites
-T <- 4 # number of primary periods
-J <- 3 # number of secondary periods
-
-lam <- 3
-phi <- 0.5
-p <- 0.3
-alpha <- 2
-
-y <- array(NA, c(n, T, J))
-M <- rnbinom(n, mu=lam, size=alpha) # Local population size
-N <- matrix(NA, n, T) # Individuals availabe for detection
-
-for(i in 1:n) {
- N[i,] <- rbinom(T, M[i], phi)
- y[i,,1] <- rbinom(T, N[i,], p)
- Nleft1 <- N[i,] - y[i,,1]
- y[i,,2] <- rbinom(T, Nleft1, p)
- Nleft2 <- Nleft1 - y[i,,2]
- y[i,,3] <- rbinom(T, Nleft2, p)
- }
-
-y.ijt <- cbind(y[,1,], y[,2,], y[,3,], y[,4,])
-umf2 <- unmarkedFrameGMM(y=y.ijt, numPrimary=T, type="removal")
-
-system.time(m2 <- gmultmix(~1, ~1, ~1, data=umf2, mixture="NB")) #2.3
-
-backTransform(m2, type="alpha")
-
-# Test
-checkEqualsNumeric(coef(m2), c(1.118504, 1.414340, -1.394736, 1.056084),
- tol=1e-5)
-
-(pb2 <- parboot(m2, nsim=50, report=5))
-plot(pb2)
-
-
-
-
-
-
-
-
-# --------------------- Poisson removal model w/ covariates --------------
-
-set.seed(37)
-
-n <- 50 # number of sites
-T <- 4 # number of primary periods
-J <- 3 # number of secondary periods
-
-sc <- rnorm(n)
-ysc <- rnorm(n*T)
-ysc <- matrix(ysc, n, T)
-yr <- factor(rep(1:T, n))
-oc <- rnorm(n*J*T)
-oc <- array(oc, c(n, J, T))
-int <- matrix(1:(T*J), nrow=n, ncol=T*J, byrow=TRUE)
-pi <- array(NA, c(n, J, T))
-
-lam <- exp(-1 + 1*sc)
-phi <- plogis(2 + -2*ysc)
-p <- plogis(1 + -1*oc)
-
-y <- array(NA, c(n,J,T))
-M <- rpois(n, lam)
-N <- matrix(NA, n, T)
-
-for(i in 1:n) {
- N[i,] <- rbinom(T, M[i], phi[i,])
- y[i,1,] <- rbinom(T, N[i,], p[i,1,])
- Nleft1 <- N[i,] - y[i,1,]
- y[i,2,] <- rbinom(T, Nleft1, p[i,2,])
- Nleft2 <- Nleft1 - y[i,2,]
- y[i,3,] <- rbinom(T, Nleft2, p[i,3,])
- }
-
-umf3 <- unmarkedFrameGMM(y=matrix(y, nrow=n),
- siteCovs = data.frame(sc=sc),
- obsCovs=list(oc=matrix(oc, nrow=n), int=int),
- yearlySiteCovs=data.frame(ysc=as.numeric(t(ysc)), yr=yr),
- numPrimary=T, type="removal")
-
-(m3 <- gmultmix(~sc, ~ysc, ~oc, umf3))
-#system.time(m3 <- gmultmix(~sc, ~ysc, ~oc, umf3)) # 4.8
-
-# Test
-checkEqualsNumeric(coef(m3), c(-1.2513974, 1.3585940, 2.2889517, -2.1197854,
- 1.0450782, -0.8627125), tol=1e-5)
-
-(pb3 <- parboot(m3, nsim=50, report=5))
-
-
-
-
-umf4 <- unmarkedFrameGMM(y=matrix(y, nrow=n),
- siteCovs = data.frame(sc=sc),
- obsCovs=list(oc=matrix(oc, nrow=n), int=int),
- yearlySiteCovs=list(ysc=ysc),
- numPrimary=T, type="removal")
-
-
-
-
-
-
-
-
-
-
-# ------------------------- independent double observer ------------------
-
-
-
-sim.doub <- function(nSites=200, nReps=2, lambda=1, phi=0.6,
- pA=0.8, pB=0.6, alpha=0.5)
-{
-
- N <- matrix(NA, nSites, nReps)
- y <- array(NA, c(nSites, 3, nReps))
-
- # Abundance at each site (quadrat)
- M <- rnbinom(nSites, size=alpha, mu=lambda)
-
- # Number available during each rep (pass)
- for(i in 1:nSites) {
- N[i,] <- rbinom(nReps, M[i], phi)
- }
-
- # Number observed
- for(i in 1:nSites) {
- for(t in 1:nReps) {
- cp <- c(pA * (1 - pB), pB * (1 - pA), pA * pB)
- cp[4] <- 1 - sum(cp)
- y[i,,t] <- c(rmultinom(1, N[i,t], cp)[1:3])
- }
- }
- return(matrix(y, nSites))
-}
-
-str(sim.doub())
-
-# Fit the model
-
-set.seed(4)
-y.sim <- sim.doub()
-T <- ncol(y.sim) / 3
-observer <- matrix(c("A", "B"), 200, T*2, byrow=TRUE)
-umf <- unmarkedFrameGMM(y = y.sim,
- obsCovs = list(observer=observer),
- numPrimary=2, type="double")
-summary(umf)
-
-m4 <- gmultmix(~1, ~1, ~observer, umf, mixture="NB")
-m4
-
-checkEqualsNumeric(coef(m4), c(-0.06998556, 0.77150482, 1.31340048,
- -0.94099309, -1.14215950), tol=1e-5)
-
-backTransform(m4, type="lambda") # Average abundance per site
-backTransform(m4, type="phi") # Availability
-backTransform(linearComb(m4, c(1,0), type="det")) # obsA detection prob
-backTransform(linearComb(m4, c(1,1), type="det")) # obsB detection prob
-backTransform(m4, type="alpha") # Over-dispersion
-
-# Total pop size
-coef(backTransform(m4, type="lambda")) * nrow(y.sim)
-
-
-pb4 <- parboot(m4, nsim=5, report=1)
-
-
-
-nsim <- 500
-simout <- matrix(NA, nsim, 5)
-colnames(simout) <- c("lambda", "phi", "pA", "pB", "alpha")
-for(i in 1:nsim) {
- cat("sim", i, "\n"); flush.console()
- y.sim <- sim.doub()
- T <- ncol(y.sim)/3
- observer <- matrix(c("A", "B"), nrow(y.sim), T*2, byrow=TRUE)
- umf <- unmarkedFrameGMM(y = y.sim, obsCovs=list(observer=observer),
- type="double", numPrimary=T)
- m.sim4 <- gmultmix(~1, ~1, ~observer, umf, mixture="NB")
- e <- coef(m.sim4)
- simout[i,] <- c(exp(e[1]), plogis(e[2:3]), plogis(sum(e[3:4])), exp(e[5]))
- }
-
-hist(simout[,1]); abline(v=1, col=4)
-hist(simout[,2]); abline(v=0.6, col=4)
-hist(simout[,3]); abline(v=0.8, col=4)
-hist(simout[,4]); abline(v=0.6, col=4)
-hist(simout[,5]); abline(v=0.5, col=4)
-
-
-
-
-
-
-
-
-
-
-
-
-# ------------------------- dependent double observer ------------------
-
-
-
-sim.dep.double <- function(nSites=200, numPrimary=2, lambda=1, phi=0.6,
- pA=0.8, pB=0.6, obsmat, alpha=0.5)
-{
- if(numPrimary==1 & phi<1) {
- phi <- 1
- warning("phi has been set to 1 because it can't be estimated when numPrimary=1")
- }
-
- N <- matrix(NA, nSites, numPrimary)
- y <- array(NA, c(nSites, 2, numPrimary))
-
- # Abundance at each site
- M <- rnbinom(nSites, size=alpha, mu=lambda)
-
- # Number available during each rep
- for(i in 1:nSites) {
- N[i,] <- rbinom(numPrimary, M[i], phi)
- }
-
- if(!all(names(table(obsmat)) == c("A", "B")))
- stop("This function assumes that 'obsmat' is a matrix of A's and B's")
- obsmat <- array(obsmat, c(nSites, 2, numPrimary))
-
- # Number observed
- for(i in 1:nSites) {
- for(t in 1:numPrimary) {
- if(obsmat[i,1,t]=="A") {
- cp <- c(pA, pB * (1 - pA))
- cp[3] <- 1 - sum(cp)
- }
- if(obsmat[i,1,t]=="B") {
- cp <- c(pB, pA * (1 - pB))
- cp[3] <- 1 - sum(cp)
- }
- y[i,,t] <- c(rmultinom(1, N[i,t], cp)[1:2])
- }
- }
- return(matrix(y, nSites))
-}
-
-
-
-# piFun
-
-depDoubPiFun <- function(p) {
- M <- nrow(p)
- pi <- matrix(NA, M, 2)
- pi[,1] <- p[,1]
- pi[,2] <- p[,2]*(1-p[,1])
- return(pi)
-}
-
-obsToY <- matrix(1, 2, 2)
-numPrimary <- 2
-obsToY <- kronecker(diag(numPrimary), obsToY)
-
-
-
-# Fit the model
-
-set.seed(4)
-nSites <- 200
-T <- 1
-observer <- matrix(c("A", "B", "B", "A"), nSites, T*2, byrow=TRUE)
-y.sim <- sim.dep.double(nSites=nSites, numPrimary=T, lambda=3,
- pA=0.8, pB=0.6, obsmat=observer)
-obsToY <- matrix(1, 2, 2)
-obsToY <- kronecker(diag(T), obsToY)
-umf <- unmarkedFrameGMM(y = y.sim,
- obsCovs = list(observer=observer),
- numPrimary=T, obsToY=obsToY, piFun="depDoubPiFun")
-summary(umf)
-
-m5 <- gmultmix(~1, ~1, ~observer-1, umf, mixture="NB")
-m5
-m6 <- gmultmix(~1, ~1, ~1, umf, mixture="NB")
-m6
-
-(pAhat <- plogis(coef(m5, type="det")[1]))
-(pBhat <- plogis(coef(m5, type="det")[2]))
-1 - (1-pAhat)*(1-pBhat)
-
-plogis(coef(m6, type="det"))
-
-# export data for DOBSERV
-dataout <- data.frame(obs1=ifelse(observer[,1]=="A", 1, 2),
- Species="MALL", y.sim)
-head(dataout)
-write.csv(dataout, "C:/R/dobserv/simdata.csv", row.names=FALSE)
-
-
-
-
-nsim <- 50
-simout <- matrix(NA, nsim, 4)
-colnames(simout) <- c("lambda", "phi", "pA", "pB")
-for(i in 1:nsim) {
- cat("sim", i, "\n")
- T <- 5
- observer <- matrix(c("A", "B", "B", "A"), nSites, T*2, byrow=TRUE)
- y.sim <- sim.dep.double(nSites=200, alpha=1000, numPrimary=T,
- obsmat=observer)
- obsToY <- matrix(1, 2, 2)
- obsToY <- kronecker(diag(T), obsToY)
- umf <- unmarkedFrameGMM(y = y.sim, obsCovs=list(observer=observer),
- numPrimary=T, obsToY=obsToY, piFun="depDoubPiFun")
- m.sim5 <- gmultmix(~1, ~1, ~observer-1, umf, mixture="P", se=FALSE)
- e <- coef(m.sim5)
- simout[i,] <- c(exp(e[1]), plogis(e[2:4]))
- cat(" mle =", simout[i,], "\n")
- }
-
-par(mfrow=c(2,2), mai=c(0.8,0.8,0.2,0.2))
-hist(simout[,1]); abline(v=1, col=4, lwd=2)
-hist(simout[,2]); abline(v=0.6, col=4, lwd=2)
-hist(simout[,3]); abline(v=0.8, col=4, lwd=2)
-hist(simout[,4]); abline(v=0.6, col=4, lwd=2)
-
diff --git a/inst/unitTests/sim.gpcount.R b/inst/unitTests/sim.gpcount.R
deleted file mode 100644
index 08f9c32..0000000
--- a/inst/unitTests/sim.gpcount.R
+++ /dev/null
@@ -1,149 +0,0 @@
-library(unmarked)
-
-
-sim1 <- function(R=50, J=3, K=3, lambda=5, phi=0.6, p=0.4) {
- M <- rpois(R, lambda) # super-population size
- N <- matrix(NA, R, J) # Population available
- y <- array(NA, c(R, K, J)) # Detected
- for(i in 1:R) {
- for(j in 1:J) {
- N[i,j] <- rbinom(1, M[i], phi)
- y[i,,j] <- rbinom(K, N[i,j], p)
- }
- }
- y <- matrix(y, R)
- return(list(y=y, N=N))
-}
-
-set.seed(348)
-y1 <- sim1()$y
-
-y1[1,] <- NA
-y1[2, 1:3] <- NA
-y1[3, 4:6] <- NA
-umf <- unmarkedFrameGPC(y=y1, numPrimary=3)
-
-fm1.1 <- gpcount(~1, ~1, ~1, umf, K=40, control=list(trace=TRUE, REPORT=1))
-fm1.1r <- gpcount(~1, ~1, ~1, umf, K=40, engine="R",
- control=list(trace=TRUE, REPORT=1))
-fm1.2 <- gpcount(~1, ~1, ~1, umf, K=40, mixture="NB",
- control=list(trace=TRUE, REPORT=1))
-
-
-nsim1 <- 10
-simout1 <- matrix(NA, nsim1, 3)
-lam1 <- 5
-phi1 <- 0.5
-p1 <- 0.4
-nPrimary1 <- 3
-set.seed(404)
-for(i in 1:nsim1) {
- cat("doing", i, "\n")
- sim1.i <- sim1(lambda=lam1, phi=phi1, p=p1, J=nPrimary1)$y
- umf1.i <- unmarkedFrameGPC(y=sim1.i, numPrimary=nPrimary1)
- fm1.i <- gpcount(~1, ~1, ~1, umf1.i, K=50, engine="C", se=FALSE)
- mle1.i <- coef(fm1.i)
- simout1[i,] <- c(exp(mle1.i[1]), plogis(mle1.i[2:3]))
- cat(" mle =", simout1[i,], "\n")
-}
-
-op <- par(mfrow=c(3,1), mai=c(0.5,0.5,0.1,0.1))
-hist(simout1[,1]); abline(v=lam1, lwd=2, col=4)
-hist(simout1[,2]); abline(v=phi1, lwd=2, col=4)
-hist(simout1[,3]); abline(v=p1, lwd=2, col=4)
-par(op)
-
-
-
-
-
-
-
-
-
-
-
-
-
-# Covariates
-
-set.seed(568)
-R <- 50
-J <- 4
-K <- 3
-x1 <- rnorm(R)
-x2 <- matrix(rnorm(R*J), R, J)
-x3 <- matrix(rnorm(R*K*J), R, K*J)
-x1[2] <- NA
-x2[3,] <- NA
-x2[4,2] <- NA
-x3[5,1:K] <- NA
-
-sim2 <- function(x1, x2, x3,
- lam0=0, lam1=1, phi0=1, phi1=1, p0=0, p1=1) {
- R <- length(x1)
- J <- ncol(x2)
- K <- ncol(x3)/J
- lambda <- exp(lam0 + lam1*x1)
- phi <- plogis(phi0 + phi1*x2)
- p <- plogis(p0 + p1*x3)
- p <- array(p, c(R, K, J))
- M <- rpois(R, lambda) # super-population size
- N <- matrix(NA, R, J) # Population available
- y <- array(NA, c(R, K, J)) # Detected
- for(i in 1:R) {
- for(j in 1:J) {
- N[i,j] <- rbinom(1, M[i], phi[i,j])
- y[i,,j] <- rbinom(K, N[i,j], p[i,,j])
- }
- }
- y <- matrix(y, R)
- return(list(y=y, N=N))
-}
-
-y2 <- sim2(x1, x2, x3)$y
-umf2 <- unmarkedFrameGPC(y=y2,
- siteCovs=data.frame(x1),
- yearlySiteCovs=list(x2=x2),
- obsCovs = list(x3=x3), numPrimary=J)
-summary(umf2)
-
-fm2.1 <- gpcount(~x1, ~x2, ~x3, umf2, K=40, engine="C",
- control=list(trace=TRUE, REPORT=1))
-fm2.1r <- gpcount(~x1, ~x2, ~x3, umf2, K=40, engine="R",
- control=list(trace=TRUE, REPORT=1))
-
-
-
-nsim2 <- 5
-simout2 <- matrix(NA, nsim2, 6)
-nPrimary2 <- 4
-lam0 <- 0
-lam1 <- 1
-phi0 <- 1
-phi1 <- 1
-p0 <- 0
-p1 <- 1
-set.seed(3434)
-for(i in 1:nsim2) {
-# if(i %% 1 == 5)
- cat("doing", i, "\n")
- sim2.i <- sim2(x1, x2, x3, lam0, lam1, phi0, phi1, p0, p1)$y
- umf2.i <- unmarkedFrameGPC(y=sim2.i, siteCovs=data.frame(x1),
- obsCovs=list(x3=x3),
- yearlySiteCovs=list(x2=x2),
- numPrimary=nPrimary2)
- fm2.i <- gpcount(~x1, ~x2, ~x3, umf2.i, K=50, engine="C", se=FALSE)
- mle2.i <- coef(fm2.i)
- simout2[i,] <- mle2.i
- cat(" mle =", mle2.i, "\n")
-}
-
-op <- par(mfrow=c(3,2), mai=c(0.5,0.5,0.1,0.1))
-hist(simout2[,1]); abline(v=lam0, lwd=2, col=4)
-hist(simout2[,2]); abline(v=lam1, lwd=2, col=4)
-hist(simout2[,3]); abline(v=phi0, lwd=2, col=4)
-hist(simout2[,4]); abline(v=phi1, lwd=2, col=4)
-hist(simout2[,5]); abline(v=p0, lwd=2, col=4)
-hist(simout2[,6]); abline(v=p1, lwd=2, col=4)
-par(op)
diff --git a/inst/unitTests/sim.pcount.R b/inst/unitTests/sim.pcount.R
deleted file mode 100644
index a241811..0000000
--- a/inst/unitTests/sim.pcount.R
+++ /dev/null
@@ -1,58 +0,0 @@
-
-
-
-sim1 <- function(R=100, J=5, lambda=2, p=0.3, mix="P", disp=1) {
- y <- matrix(NA, R, J)
- switch(mix,
- P = N <- rpois(R, lambda),
- NB = N <- rnbinom(R, mu=lambda, size=disp)
- )
- for(i in 1:R) {
- y[i,] <- rbinom(J, N[i], p)
- }
- return(y)
- }
-
-set.seed(7)
-
-
-
-set.seed(11)
-nsims <- 50
-simout1 <- matrix(NA, nsims, 2)
-lam <- 4
-p <- 0.4
-for(i in 1:nsims) {
- cat("sim", i, "\n"); flush.console()
- y.sim1 <- sim1(R=50, J=5, lambda=lam, p=p, mix="P")
- umf <- unmarkedFramePCount(y = y.sim1)
- m <- pcount(~1 ~1, umf, starts=c(log(lam), plogis(p)), K=30)
- e <- coef(m)
- simout1[i,] <- c(exp(e[1]), plogis(e[2]))
- }
-
-hist(simout1[,1]); abline(v=lam, lwd=2, col=3)
-hist(simout1[,2]); abline(v=p, lwd=2, col=3)
-
-
-
-
-
-umf1 <- unmarkedFramePCount(y=sim1(mix="NB", disp=0.7))
-m1 <- pcount(~1 ~1, umf1, K=10)
-coef(m1)
-
-m2 <- pcount(~1 ~1, umf1, K=100)
-coef(m2)
-
-
-m3 <- pcount(~1 ~1, umf1, K=10, mixture="NB")
-coef(m3)
-
-m4 <- pcount(~1 ~1, umf1, K=100, mixture="NB")
-coef(m4)
-
-m5 <- pcount(~1 ~1, umf1, K=500, mixture="NB")
-coef(m5)
-
-
diff --git a/inst/unitTests/sim.pcountOpen.r b/inst/unitTests/sim.pcountOpen.r
deleted file mode 100644
index 408afc0..0000000
--- a/inst/unitTests/sim.pcountOpen.r
+++ /dev/null
@@ -1,987 +0,0 @@
-
-library(unmarked)
-
-## Simulate no covariates, constant sampling period intervals,
-## no secondary samples
-
-sim1 <- function(lambda=1, gamma=0.5, omega=0.8, p=0.7, M=100, T=5)
-{
- y <- N <- matrix(NA, M, T)
- S <- G <- matrix(NA, M, T-1)
- N[,1] <- rpois(M, lambda)
- for(t in 1:(T-1)) {
- S[,t] <- rbinom(M, N[,t], omega)
- G[,t] <- rpois(M, gamma)
- N[,t+1] <- S[,t] + G[,t]
- }
- y[] <- rbinom(M*T, N, p)
- return(y)
-}
-
-
-
-
-
-set.seed(3223)
-nsim1 <- 100
-simout1 <- matrix(NA, nsim1, 4)
-colnames(simout1) <- c('lambda', 'gamma', 'omega', 'p')
-for(i in 1:nsim1) {
- cat("sim1:", i, "\n"); flush.console()
- lambda <- 1
- gamma <- 0.5
- omega <- 0.8
- p <- 0.7
- y.sim1 <- sim1(lambda, gamma, omega, p)
- umf1 <- unmarkedFramePCO(y = y.sim1, numPrimary=5)
- m1 <- pcountOpen(~1, ~1, ~1, ~1, umf1, K=15,
- starts=c(log(lambda), log(gamma), plogis(omega), plogis(p)),
- se=FALSE)
- e <- coef(m1)
- simout1[i, 1:2] <- exp(e[1:2])
- simout1[i, 3:4] <- plogis(e[3:4])
- cat(" mle =", simout1[i,], "\n")
- }
-
-#png("pcountOpenSim1.png", width=6, height=6, units="in", res=360)
-par(mfrow=c(2,2))
-hist(simout1[,1], xlab=expression(lambda)); abline(v=lambda, lwd=2, col=4)
-hist(simout1[,2], xlab=expression(gamma)); abline(v=gamma, lwd=2, col=4)
-hist(simout1[,3], xlab=expression(omega)); abline(v=omega, lwd=2, col=4)
-hist(simout1[,4], xlab=expression(p)); abline(v=p, lwd=2, col=4)
-#dev.off()
-
-
-
-
-
-## Simulate covariate model with constant intervals
-
-
-
-sim2 <- function(lam=c(0,1), gam=c(-1,-1), om=c(2,-1), p=c(-1,1), M=100,
- T=5)
-{
- y <- gamma <- omega <- det <- N <- matrix(NA, M, T)
- S <- G <- matrix(NA, M, T-1)
- veght <- rnorm(M)
- isolation <- matrix(rnorm(M*T), M, T)
- time <- matrix(rnorm(M*T, 1), M, T)
- lambda <- exp(lam[1] + lam[2]*veght)
- gamma[] <- exp(gam[1] + gam[2]*isolation)
- omega[] <- plogis(om[1] + om[2]*isolation)
- det[] <- plogis(p[1] + p[2]*time)
-
- N[,1] <- rpois(M, lambda)
- for(t in 1:(T-1)) {
- S[,t] <- rbinom(M, N[,t], omega[,t])
- G[,t] <- rpois(M, gamma[,t])
- N[,t+1] <- S[,t] + G[,t]
- }
- y[] <- rbinom(M*T, N, det)
- return(list(y=y, covs=data.frame(veght=veght,
- isolation=isolation, time=time)))
-}
-
-
-
-
-
-nsim2 <- 20
-simout2 <- matrix(NA, nsim2, 8)
-colnames(simout2) <- c('lam0', 'lam1', 'gam0', 'gam1', 'om0', 'om1',
- 'p0', 'p1')
-for(i in 1:nsim2) {
- cat("sim2:", i, "\n")
- lam <- c(-2, 1)
- gam <- c(-1, -1)
- om <- c(0, -1)
- p <- c(-1, 1)
- T <- 5
- sim2out <- sim2(lam, gam, om, p, T=T, M=50)
- y.sim2 <- sim2out$y
- covs <- sim2out$covs
- cn <- colnames(covs)
- siteCovs <- covs[,grep("veght", cn), drop=FALSE]
- yearlySiteCovs <- list(isolation = covs[,grep("isolation", cn)])
- obsCovs <- list(time = covs[,grep("time", cn)])
- umf2 <- unmarkedFramePCO(y = y.sim2, siteCovs=siteCovs,
- yearlySiteCovs=yearlySiteCovs, obsCovs=obsCovs, numPrimary=T)
- m2 <- pcountOpen(~veght, ~isolation, ~isolation, ~time, umf2,
- K=40, se=FALSE, starts=c(lam, gam, om, p),
- control=list(trace=TRUE, REPORT=1))
- e <- coef(m2)
- simout2[i, ] <- e
- cat(" mle =", e, "\n")
- }
-
-#png("pcountOpenSim2.png", width=6, height=8, units="in", res=360)
-par(mfrow=c(4,2))
-hist(simout2[,1], xlab=expression(lambda)); abline(v=lam[1], lwd=2, col=4)
-hist(simout2[,2], xlab=expression(lambda)); abline(v=lam[2], lwd=2, col=4)
-hist(simout2[,3], xlab=expression(gamma)); abline(v=gam[1], lwd=2, col=4)
-hist(simout2[,4], xlab=expression(gamma)); abline(v=gam[2], lwd=2, col=4)
-hist(simout2[,5], xlab=expression(omega)); abline(v=om[1], lwd=2, col=4)
-hist(simout2[,6], xlab=expression(omega)); abline(v=om[2], lwd=2, col=4)
-hist(simout2[,7], xlab=expression(p)); abline(v=p[1], lwd=2, col=4)
-hist(simout2[,8], xlab=expression(p)); abline(v=p[2], lwd=2, col=4)
-dev.off()
-
-
-
-
-
-
-
-
-
-
-
-
-
-## Simulate uneven sampling period intervals with all dates[i,1]==1
-
-sim3 <- function(lambda=4, gamma=0.1, omega=0.8, p=0.7, M=100, T=5)
-{
- y <- N <- date <- matrix(NA, M, T)
- S <- G <- matrix(NA, M, T-1)
- N[,1] <- rpois(M, lambda)
- date[,1] <- 1
- for(i in 1:M) {
- for(t in 2:T) {
- delta <- max(rpois(1, 5), 1)
- date[i, t] <- date[i, t-1] + delta
- S[i, t-1] <- rbinom(1, N[i, t-1], omega)
- G[i, t-1] <- rpois(1, gamma)
- N[i, t] <- S[i, t-1] + G[i, t-1]
- if(delta > 1) {
- for(d in 2:delta) {
- S[i, t-1] <- rbinom(1, N[i, t], omega)
- G[i, t-1] <- rpois(1, gamma)
- N[i, t] <- S[i, t-1] + G[i, t-1]
- }
- }
- }}
- y[] <- rbinom(M*T, N, p)
- mode(date) <- "integer"
- return(list(y=y, dates=date))
-}
-
-
-
-
-
-
-
-
-
-set.seed(373)
-nsim3 <- 100
-simout3 <- matrix(NA, nsim3, 4)
-colnames(simout3) <- c('lambda', 'gamma', 'omega', 'p')
-for(i in 1:nsim3) {
- cat("sim3:", i, "\n"); flush.console()
- lambda <- 4
- gamma <- 0.3
- omega <- 0.7
- p <- 0.7
- T <- 5
- yd <- sim3(lambda, gamma, omega, p, M=100, T=5)
- y.sim3 <- yd$y
- dates3 <- yd$dates
- umf3 <- unmarkedFramePCO(y = y.sim3, primaryPeriod=dates3,
- numPrimary=T)
- m3 <- pcountOpen(~1, ~1, ~1, ~1, umf3, K=20,
- starts=c(log(lambda), log(gamma), plogis(omega), plogis(p)),
- se=FALSE)
- e <- coef(m3)
- simout3[i, 1:2] <- exp(e[1:2])
- simout3[i, 3:4] <- plogis(e[3:4])
- cat(" mle =", simout3[i,], "\n")
- }
-
-
-
-#png("pcountOpenSim3.png", width=6, height=6, units="in", res=360)
-par(mfrow=c(2,2))
-hist(simout3[,1], xlab=expression(lambda)); abline(v=lambda, lwd=2, col=4)
-hist(simout3[,2], xlab=expression(gamma)); abline(v=gamma, lwd=2, col=4)
-hist(simout3[,3], xlab=expression(omega)); abline(v=omega, lwd=2, col=4)
-hist(simout3[,4], xlab=expression(p)); abline(v=p, lwd=2, col=4)
-dev.off()
-
-
-
-
-
-
-
-
-
-
-
-# Auto-regressive model
-
-
-
-
-sim4 <- function(lambda=1, gamma=0.5, omega=0.8, p=0.7, M=100, T=5)
-{
- y <- N <- matrix(NA, M, T)
- S <- G <- matrix(NA, M, T-1)
- N[,1] <- rpois(M, lambda)
- for(t in 1:(T-1)) {
- S[,t] <- rbinom(M, N[,t], omega)
- G[,t] <- rpois(M, gamma*N[,t])
- N[,t+1] <- S[,t] + G[,t]
- }
- y[] <- rbinom(M*T, N, p)
- return(y)
-}
-
-
-
-set.seed(3223)
-nsim4 <- 100
-simout4 <- matrix(NA, nsim4, 4)
-colnames(simout4) <- c('lambda', 'gamma', 'omega', 'p')
-for(i in 1:nsim4) {
- cat("sim4:", i, "\n")
- lambda <- 1
- gamma <- 0.5
- omega <- 0.7
- p <- 0.7
- T <- 5
- y.sim4 <- sim4(lambda, gamma, omega, p, T=T)
- umf4 <- unmarkedFramePCO(y = y.sim4, numPrimary=T)
- m4 <- pcountOpen(~1, ~1, ~1, ~1, umf4, K=30, dynamics="autoreg",
- starts=c(log(lambda), log(gamma), plogis(omega),
- plogis(p)), se=FALSE)
- e <- coef(m4)
- simout4[i, 1:2] <- exp(e[1:2])
- simout4[i, 3:4] <- plogis(e[3:4])
- cat(" mle =", simout4[i,], "\n")
- }
-
-#png("pcountOpenSim4.png", width=6, height=6, units="in", res=360)
-par(mfrow=c(2,2))
-hist(simout4[,1], xlab=expression(lambda)); abline(v=lambda, lwd=2, col=4)
-hist(simout4[,2], xlab=expression(gamma)); abline(v=gamma, lwd=2, col=4)
-hist(simout4[,3], xlab=expression(omega)); abline(v=omega, lwd=2, col=4)
-hist(simout4[,4], xlab=expression(p)); abline(v=p, lwd=2, col=4)
-dev.off()
-
-
-
-
-
-
-
-
-
-
-# No trend model
-
-
-
-
-sim5 <- function(lambda=1, omega=0.8, p=0.7, M=100, T=5)
-{
- y <- N <- matrix(NA, M, T)
- S <- G <- matrix(NA, M, T-1)
- N[,1] <- rpois(M, lambda)
- gamma <- (1-omega)*lambda
- for(t in 1:(T-1)) {
- S[,t] <- rbinom(M, N[,t], omega)
- G[,t] <- rpois(M, gamma)
- N[,t+1] <- S[,t] + G[,t]
- }
- y[] <- rbinom(M*T, N, p)
- return(y)
-}
-
-
-
-set.seed(3223)
-nsim5 <- 100
-simout5 <- matrix(NA, nsim5, 3)
-colnames(simout5) <- c('lambda', 'omega', 'p')
-for(i in 1:nsim5) {
- cat("sim5:", i, "\n"); flush.console()
- lambda <- 1
- omega <- 0.7
- p <- 0.7
- T <- 5
- y.sim5 <- sim5(lambda, omega, p, T=T)
- umf5 <- unmarkedFramePCO(y = y.sim5, numPrimary=T)
- m5 <- pcountOpen(~1, ~1, ~1, ~1, umf5, K=20, dynamics="notrend",
- starts=c(log(lambda), plogis(omega), plogis(p)), se=FALSE)
- e <- coef(m5)
- simout5[i, 1] <- exp(e[1])
- simout5[i, 2:3] <- plogis(e[2:3])
- cat(" mle =", simout5[i,], "\n")
- }
-
-#png("pcountOpenSim5.png", width=6, height=6, units="in", res=360)
-par(mfrow=c(2,2))
-hist(simout5[,1], xlab=expression(lambda)); abline(v=lambda, lwd=2, col=4)
-hist(simout5[,2], xlab=expression(omega)); abline(v=omega, lwd=2, col=4)
-hist(simout5[,3], xlab=expression(p)); abline(v=p, lwd=2, col=4)
-#dev.off()
-
-
-
-
-
-
-
-
-
-
-
-
-## Simulate data with some dates[i,1] > 1
-
-
-sim6 <- function(lambda=4, gamma=0.1, omega=0.8, p=0.7, M=100, T=5)
-{
- y <- N <- date <- matrix(NA, M, T)
- S <- G <- matrix(NA, M, T-1)
- N[,1] <- rpois(M, lambda)
- date[,1] <- pmax(rpois(M, 5), 1)
-
- for(i in 1:M) {
- if(date[i,1] > 1) {
- for(d in 2:date[i, 1]) {
- S1 <- rbinom(1, N[i, 1], omega)
- G1 <- rpois(1, gamma)
- N[i, 1] <- S1 + G1
- }
- }
- for(t in 2:T) {
- date[i, t] <- date[i, t-1] + 1
- S[i, t-1] <- rbinom(1, N[i, t-1], omega)
- G[i, t-1] <- rpois(1, gamma)
- N[i, t] <- S[i, t-1] + G[i, t-1]
- }}
- y[] <- rbinom(M*T, N, p)
- mode(date) <- "integer"
- return(list(y=y, dates=date))
-}
-
-
-
-
-set.seed(3223)
-nsim6 <- 100
-simout6 <- matrix(NA, nsim6, 4)
-colnames(simout6) <- c('lambda', 'gamma', 'omega', 'p')
-for(i in 1:nsim6) {
- cat("sim6:", i, "\n")
- lambda <- 1
- gamma <- 0.5
- omega <- 0.8
- p <- 0.7
- T <- 5
- yd <- sim6(lambda, gamma, omega, p, M=100, T=T)
- y.sim6 <- yd$y
- dates6 <- yd$dates
- umf6 <- unmarkedFramePCO(y = y.sim6, primaryPeriod=dates6,
- numPrimary=T)
- m6 <- pcountOpen(~1, ~1, ~1, ~1, umf6, K=25,
- starts=c(log(lambda), log(gamma), plogis(omega), plogis(p)),
- se=FALSE)
- e <- coef(m6)
- simout6[i, 1:2] <- exp(e[1:2])
- simout6[i, 3:4] <- plogis(e[3:4])
- cat(" mle =", simout6[i,], "\n")
- }
-
-
-
-#png("pcountOpenSim6.png", width=6, height=6, units="in", res=360)
-par(mfrow=c(2,2))
-hist(simout6[,1], xlab=expression(lambda)); abline(v=lambda, lwd=2, col=4)
-hist(simout6[,2], xlab=expression(gamma)); abline(v=gamma, lwd=2, col=4)
-hist(simout6[,3], xlab=expression(omega)); abline(v=omega, lwd=2, col=4)
-hist(simout6[,4], xlab=expression(p)); abline(v=p, lwd=2, col=4)
-#dev.off()
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-## Simulate no covariates, constant sampling period intervals,
-## WITH secondary samples
-
-sim7 <- function(lambda=1, gamma=0.5, omega=0.8, p=0.7, M=100, T=5, J=3)
-{
- y <- matrix(NA, M, J*T)
- N <- matrix(NA, M, T)
- S <- G <- matrix(NA, M, T-1)
- N[,1] <- rpois(M, lambda)
- for(t in 1:(T-1)) {
- S[,t] <- rbinom(M, N[,t], omega)
- G[,t] <- rpois(M, gamma)
- N[,t+1] <- S[,t] + G[,t]
- }
- N <- N[,rep(1:T, each=J)]
- y[] <- rbinom(M*J*T, N, p)
- return(y)
-}
-
-
-
-library(unmarked)
-set.seed(3223)
-nsim7 <- 100
-simout7 <- matrix(NA, nsim7, 4)
-colnames(simout7) <- c('lambda', 'gamma', 'omega', 'p')
-for(i in 1:nsim7) {
- cat("sim7:", i, "\n")
- lambda <- 1
- gamma <- 0.5
- omega <- 0.8
- p <- 0.7
- T <- 5
- y.sim7 <- sim7(lambda, gamma, omega, p, T=T)
- umf7 <- unmarkedFramePCO(y = y.sim7, numPrimary=T)
- m7 <- pcountOpen(~1, ~1, ~1, ~1, umf7, K=15,
- starts=c(log(lambda), log(gamma), plogis(omega), plogis(p)),
- se=FALSE)
- e <- coef(m7)
- simout7[i, 1:2] <- exp(e[1:2])
- simout7[i, 3:4] <- plogis(e[3:4])
- cat("mle = ", simout7[i,], "\n")
- }
-
-#png("pcountOpenSim7.png", width=6, height=6, units="in", res=360)
-par(mfrow=c(2,2))
-hist(simout7[,1], xlab=expression(lambda)); abline(v=lambda, lwd=2, col=4)
-hist(simout7[,2], xlab=expression(gamma)); abline(v=gamma, lwd=2, col=4)
-hist(simout7[,3], xlab=expression(omega)); abline(v=omega, lwd=2, col=4)
-hist(simout7[,4], xlab=expression(p)); abline(v=p, lwd=2, col=4)
-#dev.off()
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-## Simulate covariate model with constant intervals and secondary samples
-
-
-
-sim8 <- function(lam=c(0,1), gam=c(-1,-1), om=c(2,-1), p=c(-1,1), M=100,
- T=5, J=3)
-{
- y <- det <- matrix(NA, M, J*T)
- gamma <- omega <- N <- matrix(NA, M, T)
- S <- G <- matrix(NA, M, T-1)
- veght <- rnorm(M)
- isolation <- matrix(rnorm(M*T), M, T)
- time <- matrix(rnorm(M*J*T, 1), M, J*T)
- lambda <- exp(lam[1] + lam[2]*veght)
- gamma[] <- exp(gam[1] + gam[2]*isolation)
- omega[] <- plogis(om[1] + om[2]*isolation)
- det[] <- plogis(p[1] + p[2]*time)
-
- N[,1] <- rpois(M, lambda)
- for(t in 1:(T-1)) {
- S[,t] <- rbinom(M, N[,t], omega[,t])
- G[,t] <- rpois(M, gamma[,t])
- N[,t+1] <- S[,t] + G[,t]
- }
- N <- N[,rep(1:T, each=J)]
- y[] <- rbinom(M*J*T, N, det)
- return(list(y=y, covs=data.frame(veght=veght,
- isolation=isolation, time=time)))
-}
-
-
-
-
-
-nsim8 <- 100
-simout8 <- matrix(NA, nsim8, 8)
-colnames(simout8) <- c('lam0', 'lam1', 'gam0', 'gam1', 'om0', 'om1', 'p0', 'p1')
-for(i in 1:nsim8) {
- cat("sim8:", i, "\n"); flush.console()
- lam <- c(-2, 1)
- gam <- c(-1, -1)
- om <- c(0, -1)
- p <- c(-1, 1)
- T <- 5
- sim8out <- sim8(lam, gam, om, p, T=T)
- y.sim8 <- sim8out$y
- covs <- sim8out$covs
- cn <- colnames(covs)
- siteCovs <- covs[,grep("veght", cn), drop=FALSE]
- yearlySiteCovs <- list(isolation=covs[,grep("isolation", cn)])
- obsCovs <- list(time = covs[,grep("time", cn)])
- umf8 <- unmarkedFramePCO(y = y.sim8, siteCovs=siteCovs,
- yearlySiteCovs=yearlySiteCovs, obsCovs=obsCovs, numPrimary=T)
- m8 <- pcountOpen(~veght, ~isolation, ~isolation, ~time, umf8, K=30,
- se=F, starts=c(lam, gam, om, p))
- e <- coef(m8)
- simout8[i, ] <- e
- cat(" mle=", e, "\n")
- }
-
-#png("pcountOpenSim8.png", width=6, height=8, units="in", res=360)
-par(mfrow=c(4,2))
-hist(simout8[,1], xlab=expression(lambda)); abline(v=lam[1], lwd=2, col=4)
-hist(simout8[,2], xlab=expression(lambda)); abline(v=lam[2], lwd=2, col=4)
-hist(simout8[,3], xlab=expression(gamma)); abline(v=gam[1], lwd=2, col=4)
-hist(simout8[,4], xlab=expression(gamma)); abline(v=gam[2], lwd=2, col=4)
-hist(simout8[,5], xlab=expression(omega)); abline(v=om[1], lwd=2, col=4)
-hist(simout8[,6], xlab=expression(omega)); abline(v=om[2], lwd=2, col=4)
-hist(simout8[,7], xlab=expression(p)); abline(v=p[1], lwd=2, col=4)
-hist(simout8[,8], xlab=expression(p)); abline(v=p[2], lwd=2, col=4)
-#dev.off()
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-## Simulate no covariates, constant sampling period intervals,
-## WITH secondary samples and missing values
-
-sim9 <- function(lambda=1, gamma=0.5, omega=0.8, p=0.7, M=100, T=5, J=3,
- nMissing=50)
-{
- y <- matrix(NA, M, J*T)
- N <- matrix(NA, M, T)
- S <- G <- matrix(NA, M, T-1)
- N[,1] <- rpois(M, lambda)
- for(t in 1:(T-1)) {
- S[,t] <- rbinom(M, N[,t], omega)
- G[,t] <- rpois(M, gamma)
- N[,t+1] <- S[,t] + G[,t]
- }
- N <- N[,rep(1:T, each=J)]
- y[] <- rbinom(M*J*T, N, p)
- y[sample.int(M*J*T, nMissing)] <- NA
- return(y)
-}
-
-
-
-library(unmarked)
-set.seed(3223)
-nsim9 <- 100
-simout9 <- matrix(NA, nsim9, 4)
-colnames(simout9) <- c('lambda', 'gamma', 'omega', 'p')
-for(i in 1:nsim9) {
- cat("sim9:", i, "\n")
- lambda <- 1
- gamma <- 0.5
- omega <- 0.8
- p <- 0.7
- T <- 5
- y.sim9 <- sim9(lambda, gamma, omega, p, T=T, nMissing=100)
- umf9 <- unmarkedFramePCO(y = y.sim9, numPrimary=T)
- m9 <- pcountOpen(~1, ~1, ~1, ~1, umf9, K=15,
- starts=c(log(lambda), log(gamma), plogis(omega), plogis(p)),
- se=FALSE)
- e <- coef(m9)
- simout9[i, 1:2] <- exp(e[1:2])
- simout9[i, 3:4] <- plogis(e[3:4])
- cat("mle = ", simout9[i,], "\n")
- }
-
-#png("pcountOpenSim9.png", width=6, height=6, units="in", res=360)
-par(mfrow=c(2,2))
-hist(simout9[,1], xlab=expression(lambda)); abline(v=lambda, lwd=2, col=4)
-hist(simout9[,2], xlab=expression(gamma)); abline(v=gamma, lwd=2, col=4)
-hist(simout9[,3], xlab=expression(omega)); abline(v=omega, lwd=2, col=4)
-hist(simout9[,4], xlab=expression(p)); abline(v=p, lwd=2, col=4)
-#dev.off()
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-## Simulate covariate model with secondary samples and missing values
-
-
-
-sim10 <- function(lam=c(0,1), gam=c(-1,-1), om=c(2,-1), p=c(-1,1), M=100,
- T=5, J=3, nMissing=50)
-{
- y <- det <- matrix(NA, M, J*T)
- gamma <- omega <- N <- matrix(NA, M, T)
- S <- G <- matrix(NA, M, T-1)
- veght <- rnorm(M)
- isolation <- matrix(rnorm(M*T), M, T)
- time <- matrix(rnorm(M*J*T, 1), M, J*T)
- lambda <- exp(lam[1] + lam[2]*veght)
- gamma[] <- exp(gam[1] + gam[2]*isolation)
- omega[] <- plogis(om[1] + om[2]*isolation)
- det[] <- plogis(p[1] + p[2]*time)
-
- N[,1] <- rpois(M, lambda)
- for(t in 1:(T-1)) {
- S[,t] <- rbinom(M, N[,t], omega[,t])
- G[,t] <- rpois(M, gamma[,t])
- N[,t+1] <- S[,t] + G[,t]
- }
- N <- N[,rep(1:T, each=J)]
- y[] <- rbinom(M*J*T, N, det)
- na.ind <- sample.int(M*J*T, nMissing)
- veght[na.ind<=M] <- NA
- isolation[na.ind<=(M*T)] <- NA
- time[na.ind] <- NA
- covs <- data.frame(veght=veght, isolation=isolation, time=time)
- y[na.ind] <- NA
- return(list(y=y, covs=covs))
-}
-
-
-
-
-set.seed(4483499)
-nsim10 <- 100
-simout10 <- matrix(NA, nsim10, 7)
-colnames(simout10) <- c('lam0', 'lam1', 'gam0', 'gam1', 'om0', #'om1',
- 'p0', 'p1')
-for(i in 1:nsim10) {
- cat("sim10", i, "\n"); flush.console()
- lam <- c(-2, 1)
- gam <- c(-1, -1)
- om <- c(0, 0)
- p <- c(-1, 1)
- T <- 5
- sim10out <- sim10(lam, gam, om, p, T=T)
- y.sim10 <- sim10out$y
- covs <- sim10out$covs
- cn <- colnames(covs)
- siteCovs <- covs[,grep("veght", cn), drop=FALSE]
- yearlySiteCovs <- list(isolation=covs[,grep("isolation", cn)])
- obsCovs <- list(time = covs[,grep("time", cn)])
- umf10 <- unmarkedFramePCO(y = y.sim10, siteCovs=siteCovs,
- yearlySiteCovs=yearlySiteCovs, obsCovs=obsCovs, numPrimary=T)
- m10 <- pcountOpen(~veght, ~isolation, ~1, ~time, umf10, K=30,
- se=F, starts=c(lam, gam, 0, p),
- control=list(trace=F, REPORT=1))
- e <- coef(m10)
- simout10[i, ] <- e
- cat(" mle=", e, "\n")
- }
-
-#png("pcountOpenSim10.png", width=6, height=10, units="in", res=360)
-par(mfrow=c(4,2))
-hist(simout10[,1], xlab=expression(lambda)); abline(v=lam[1], lwd=2, col=4)
-hist(simout10[,2], xlab=expression(lambda)); abline(v=lam[2], lwd=2, col=4)
-hist(simout10[,3], xlab=expression(gamma)); abline(v=gam[1], lwd=2, col=4)
-hist(simout10[,4], xlab=expression(gamma)); abline(v=gam[2], lwd=2, col=4)
-hist(simout10[,5], xlab=expression(omega)); abline(v=om[1], lwd=2, col=4)
-hist(simout10[,6], xlab=expression(omega)); abline(v=om[2], lwd=2, col=4)
-hist(simout10[,7], xlab=expression(p)); abline(v=p[1], lwd=2, col=4)
-hist(simout10[,8], xlab=expression(p)); abline(v=p[2], lwd=2, col=4)
-#dev.off()
-
-
-m10 <- pcountOpen(~veght, ~1, ~1, ~time, umf10, K=30,
- se=F, #starts=c(0, 0, 0, p),
- control=list(trace=TRUE, REPORT=1))
-
-
-
-
-trace(unmarked:::handleNA, browser, browser, signature="unmarkedFramePCO")
-untrace(unmarked:::handleNA, signature="unmarkedFramePCO")
-
-
-debugonce(pcountOpen)
-
-
-
-## Simulate "trend model", no covariates, constant intervals,
-## no secondary samples
-
-sim11 <- function(lambda=1, gamma=0.5, p=0.7, M=100, T=5)
-{
- y <- N <- matrix(NA, M, T)
- S <- G <- matrix(NA, M, T-1)
- N[,1] <- rpois(M, lambda)
- for(t in 2:T) {
- N[,t] <- rpois(M, gamma*N[,t-1])
- }
- y[] <- rbinom(M*T, N, p)
- return(y)
-}
-
-
-
-
-
-set.seed(3223)
-nsim11 <- 100
-simout11 <- matrix(NA, nsim11, 3)
-colnames(simout11) <- c('lambda', 'gamma', 'p')
-for(i in 1:nsim11) {
- cat("sim11:", i, "\n"); flush.console()
- lambda <- 2
- gamma <- 0.5
- p <- 0.7
- y.sim11 <- sim11(lambda, gamma, p)
- umf11 <- unmarkedFramePCO(y = y.sim11, numPrimary=5)
- m11 <- pcountOpen(~1, ~1, ~1, ~1, umf11, K=40, dynamics="trend",
- starts=c(log(lambda), log(gamma), plogis(p)),
- se=FALSE)
- e <- coef(m11)
- simout11[i, 1:2] <- exp(e[1:2])
- simout11[i, 3] <- plogis(e[3])
- cat(" mle =", simout11[i,], "\n")
- }
-
-#png("pcountOpenSim1.png", width=6, height=6, units="in", res=360)
-par(mfrow=c(2,2))
-hist(simout11[,1], xlab=expression(lambda)); abline(v=lambda, lwd=2, col=4)
-hist(simout11[,2], xlab=expression(gamma)); abline(v=gamma, lwd=2, col=4)
-hist(simout11[,3], xlab=expression(p)); abline(v=p, lwd=2, col=4)
-#dev.off()
-
-
-
-
-
-
-
-
-
-
-
-## Simulate trend model with ZIP dist
-
-sim12 <- function(lambda=1, gamma=0.5, p=0.7, psi=0.3, M=100, T=5)
-{
- y <- N <- matrix(NA, M, T)
- S <- G <- matrix(NA, M, T-1)
- N[,1] <- rpois(M, lambda)
- N[runif(M) < psi, 1] <- 0
- for(t in 2:T) {
- N[,t] <- rpois(M, gamma*N[,t-1])
- }
- y[] <- rbinom(M*T, N, p)
- return(y)
-}
-
-
-
-
-
-set.seed(3223)
-nsim12 <- 100
-simout12 <- matrix(NA, nsim12, 4)
-colnames(simout12) <- c('lambda', 'gamma', 'p', 'psi')
-for(i in 1:nsim12) {
- cat("sim12:", i, "\n")
- lambda <- 2
- gamma <- 0.5
- p <- 0.7
- psi <- 0.3
- y.sim12 <- sim12(lambda, gamma, p, psi)
- umf12 <- unmarkedFramePCO(y = y.sim12, numPrimary=5)
- m12 <- pcountOpen(~1, ~1, ~1, ~1, umf12, K=40, dynamics="trend",
- mixture="ZIP",
- starts=c(log(lambda), log(gamma), plogis(p), plogis(psi)),
- se=FALSE)
- e <- coef(m12)
- simout12[i, 1:2] <- exp(e[1:2])
- simout12[i, 3:4] <- plogis(e[3:4])
- cat(" mle =", simout12[i,], "\n")
- }
-
-#png("pcountOpenSim1.png", width=6, height=6, units="in", res=360)
-par(mfrow=c(2,2))
-hist(simout12[,1], xlab=expression(lambda)); abline(v=lambda, lwd=2, col=4)
-hist(simout12[,2], xlab=expression(gamma)); abline(v=gamma, lwd=2, col=4)
-hist(simout12[,3], xlab=expression(p)); abline(v=p, lwd=2, col=4)
-hist(simout12[,4], xlab=expression(psi)); abline(v=psi, lwd=2, col=4)
-#dev.off()
-
-
-
-## Simulate Ricker model
-
-sim13 <- function(lambda=1, gamma=0.1, omega=1.5, p=0.7, M=100, T=5)
-{
- y <- N <- matrix(NA, M, T)
- N[,1] <- rpois(M, lambda)
- for(t in 2:T) {
- N[,t] <- rpois(M, N[,t-1]*exp(gamma*(1-N[,t-1]/omega)))
- }
- y[] <- rbinom(M*T, N, p)
- return(y)
-}
-
-
-
-
-
-set.seed(3223)
-nsim13 <- 100
-simout13 <- matrix(NA, nsim13, 4)
-colnames(simout13) <- c('lambda', 'gamma', 'omega', 'p')
-for(i in 1:nsim13) {
- cat("sim13:", i, "\n")
- lambda <- 2
- gamma <- 0.25
- omega <- 2.3
- p <- 0.7
- y.sim13 <- sim13(lambda, gamma, omega, p)
- umf13 <- unmarkedFramePCO(y = y.sim13, numPrimary=5)
- m13 <- pcountOpen(~1, ~1, ~1, ~1, umf13, K=40, dynamics="ricker",
- starts=c(log(lambda), log(gamma), log(omega), plogis(p)),
- se=FALSE)
- e <- coef(m13)
- simout13[i, 1:3] <- exp(e[1:3])
- simout13[i, 4] <- plogis(e[4])
- cat(" mle =", simout13[i,], "\n")
- }
-
-#png("pcountOpenSim1.png", width=6, height=6, units="in", res=360)
-par(mfrow=c(2,2))
-hist(simout13[,1], xlab=expression(lambda)); abline(v=lambda, lwd=2, col=4)
-hist(simout13[,2], xlab=expression(gamma)); abline(v=gamma, lwd=2, col=4)
-hist(simout13[,3], xlab=expression(omega)); abline(v=omega, lwd=2, col=4)
-hist(simout13[,4], xlab=expression(p)); abline(v=p, lwd=2, col=4)
-#dev.off()
-
-
-
-## Simulate Gompertz model
-
-sim14 <- function(lambda=1, gamma=0.1, omega=1.5, p=0.7, M=100, T=5)
-{
- y <- N <- matrix(NA, M, T)
- N[,1] <- rpois(M, lambda)
- for(t in 2:T) {
- N[,t] <- rpois(M, N[,t-1]*exp(gamma*(1-log(N[,t-1]+1)/log(omega+1))))
- }
- y[] <- rbinom(M*T, N, p)
- return(y)
-}
-
-set.seed(3223)
-nsim14 <- 100
-simout14 <- matrix(NA, nsim14, 4)
-colnames(simout14) <- c('lambda', 'gamma', 'omega', 'p')
-for(i in 1:nsim14) {
- cat("sim14:", i, "\n")
- lambda <- 2
- gamma <- 0.25
- omega <- 2.3
- p <- 0.7
- y.sim14 <- sim14(lambda, gamma, omega, p)
- umf14 <- unmarkedFramePCO(y = y.sim14, numPrimary=5)
- m14 <- pcountOpen(~1, ~1, ~1, ~1, umf14, K=40, dynamics="gompertz",
- starts=c(log(lambda), log(gamma), log(omega), plogis(p)),
- se=FALSE)
- e <- coef(m14)
- simout14[i, 1:3] <- exp(e[1:3])
- simout14[i, 4] <- plogis(e[4])
- cat(" mle =", simout14[i,], "\n")
- }
-
-#png("pcountOpenSim1.png", width=6, height=6, units="in", res=360)
-par(mfrow=c(2,2))
-hist(simout14[,1], xlab=expression(lambda)); abline(v=lambda, lwd=2, col=4)
-hist(simout14[,2], xlab=expression(gamma)); abline(v=gamma, lwd=2, col=4)
-hist(simout14[,3], xlab=expression(omega)); abline(v=omega, lwd=2, col=4)
-hist(simout14[,4], xlab=expression(p)); abline(v=p, lwd=2, col=4)
-#dev.off()
-
-
-
-## Simulate trend + immigration model
-
-sim15 <- function(lambda=1, gamma=0.5, iota=1, p=0.7, M=100, T=5)
-{
- y <- N <- matrix(NA, M, T)
- N[,1] <- rpois(M, lambda)
- for(t in 2:T) {
- N[,t] <- rpois(M, gamma*N[,t-1] + iota)
- }
- y[] <- rbinom(M*T, N, p)
- return(y)
-}
-
-set.seed(3223)
-nsim15 <- 100
-simout15 <- matrix(NA, nsim15, 4)
-colnames(simout15) <- c('lambda', 'gamma', 'iota', 'p')
-for(i in 1:nsim15) {
- cat("sim15:", i, "\n")
- lambda <- 2
- gamma <- 0.25
- iota <- 0.5
- p <- 0.7
- y.sim15 <- sim15(lambda, gamma, iota, p)
- umf15 <- unmarkedFramePCO(y = y.sim15, numPrimary=5)
- m15 <- pcountOpen(~1, ~1, ~1, ~1, umf15, K=40, dynamics="trend",
- starts=c(log(lambda), log(gamma), plogis(p), log(iota)),
- se=TRUE, immigration=TRUE, iotaformula=~1)
- e <- coef(m15)
- simout15[i, 1:3] <- exp(e[c(1:2,4)])
- simout15[i, 4] <- plogis(e[3])
- cat(" mle =", simout15[i,], "\n")
- }
-
-#png("pcountOpenSim1.png", width=6, height=6, units="in", res=360)
-par(mfrow=c(2,2))
-hist(simout15[,1], xlab=expression(lambda)); abline(v=lambda, lwd=2, col=4)
-hist(simout15[,2], xlab=expression(gamma)); abline(v=gamma, lwd=2, col=4)
-hist(simout15[,3], xlab=expression(iota)); abline(v=iota, lwd=2, col=4)
-hist(simout15[,4], xlab=expression(p)); abline(v=p, lwd=2, col=4)
-dev.off()
-
-
-
-
-
-
-
-
diff --git a/inst/unitTests/sim.ranef.R b/inst/unitTests/sim.ranef.R
deleted file mode 100644
index c2f635e..0000000
--- a/inst/unitTests/sim.ranef.R
+++ /dev/null
@@ -1,518 +0,0 @@
-
-
-# Evaluate bias of BUPs
-
-# ----------------------------- pcount ----------------------------------
-
-
-library(unmarked)
-
-sim.nmix <- function(R=100, J=5, lambda=5, p=0.7) {
- N <- rpois(R, lambda)
- y <- matrix(NA, R, J)
- y[] <- rbinom(R*J, N, p)
- return(list(y=y, N=N))
-}
-
-
-nsim <- 100
-out.nmix <- matrix(NA, nsim, 3)
-set.seed(83145)
-for(i in 1:nsim) {
- lambda <- 5
- sim.i <- sim.nmix(J=5, lambda=lambda, p=0.5)
- umf <- unmarkedFramePCount(y=sim.i$y)
- K <- 50
- fm <- pcount(~1 ~1, umf, K=K, se=FALSE)
- lam.hat <- exp(coef(fm, type="state"))
- re <- ranef(fm)
- N <- sim.i$N
- N.hat1 <- bup(re, stat="mean")
- N.hat2 <- bup(re, stat="mode")
- bias1 <- mean(N.hat1 - N)
- bias2 <- mean(N.hat2 - N)
- ci <- confint(re)
- cover <- mean(N >= ci[,1] & N <= ci[,2])
- out.nmix[i,] <- c(bias1, bias2, cover)
- cat("sim", i, "\n")
-# cat(" bias =", mean(modes)-lambda, "\n")
-}
-
-hist(out.nmix[,1], breaks=20)
-
-colMeans(out.nmix)
-
-plot(re, layout=c(5,5))
-
-plot(N.hat1, N); abline(0,1)
-plot(N.hat2, N); abline(0,1)
-
-
-
-
-
-# ------------------------------- occu ----------------------------------
-
-library(unmarked)
-
-
-
-
-sim.occu <- function(R=100, J=5, psi=0.5, p=0.4) {
- z <- rbinom(R, 1, psi)
- y <- matrix(NA, R, J)
- y[] <- rbinom(R*J, 1, z*p)
- return(list(y=y, z=z))
-}
-
-
-nsim <- 200
-out.occu <- matrix(NA, nsim, 3)
-set.seed(38845)
-for(i in 1:nsim) {
- cat("sim", i, "\n")
- sim.i <- sim.occu(psi=0.8, p=0.4)
- umf <- unmarkedFrameOccu(y=sim.i$y)
- fm <- occu(~1 ~1, umf, se=FALSE)
- re <- ranef(fm)
- z <- sim.i$z
- z.hat1 <- bup(re, stat="mean")
- z.hat2 <- bup(re, stat="mode")
- bias1 <- mean(z.hat1 - z)
- bias2 <- mean(z.hat2 - z)
- ci <- confint(re)
- cover <- mean(z >= ci[,1] & z <= ci[,2])
- out.occu[i,] <- c(bias1, bias2, cover)
-}
-
-hist(out.occu[,1])
-
-colMeans(out.occu)
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-# ------------------------------ distsamp -------------------------------
-
-
-
-
-
-
-
-sim.ds <- function(lambda=5, shape=20, scale=10, R=100,
- breaks=seq(0, 50, by=10), survey="point", detfun="hn",
- output="density")
-{
- nb <- length(breaks)
- J <- nb-1
- maxDist <- max(breaks)
- tlength <- 1000
- if(output=="density") {
- switch(survey,
- point = A <- pi*maxDist^2 / 10000, # Area (ha) of circle
- line = A <- maxDist*2*100 / 10000 # Area (ha) 100m transect
- )
- } else A <- 1
- a <- pi*breaks[2]^2
- for(j in 2:J) {
- a[j] <- pi*breaks[j+1]^2 - sum(a[1:(j-1)])
- }
- u <- a / sum(a)
- y <- matrix(0, R, J)
- N <- rpois(R, lambda*A)
- for(i in 1:R) {
- switch(survey,
- point = {
- z <- 2*pi*runif(N[i])
- u <- runif(N[i]) + runif(N[i])
- r <- ifelse(u>1, 2-u, u)
- X <- maxDist*r*cos(z)
- Y <- maxDist*r*sin(z)
- d <- sqrt(X^2+Y^2)
- d <- d[d<=maxDist]
- d <- d
- },
- line = {
- d <- runif(N[i], 0, maxDist)
- })
-
- # Detection process
- if(length(d) > 0) {
- switch(detfun,
- hn = p <- exp(-d^2 / (2 * shape^2)),
- exp = p <- exp(-d/shape),
- haz = p <- 1-exp(-(d/shape)^-scale),
- unif = p <- 1
- )
- cp <- p #* phi
- d1 <- d[rbinom(length(d), 1, cp) == 1]
- y[i,] <- table(cut(d1, breaks, include.lowest=TRUE))
- }
- }
- return(list(y=y, N=N))
-}
-
-
-
-
-
-nsim <- 100
-out.ds <- matrix(NA, nsim, 3)
-set.seed(38845)
-for(i in 1:nsim) {
- cat("sim", i, "\n")
- br <- seq(0, 50, by=10)
- sur <- "point"
- ot <- "density"
- lambda <- 20
- sim.i <- sim.ds(lambda=lambda, R=50, breaks=br, survey=sur, output=ot)
- umf <- unmarkedFrameDS(y=sim.i$y, dist.breaks=br, survey=sur,
- unitsIn="m")
- fm <- distsamp(~1 ~1, umf, output="density", se=FALSE)
- re <- ranef(fm, K=50)
- N <- sim.i$N
- N.hat1 <- bup(re, stat="mean")
- N.hat2 <- bup(re, stat="mode")
- bias1 <- mean(N.hat1 - N)
- bias2 <- mean(N.hat2 - N)
- ci <- confint(re)
- cover <- mean(N >= ci[,1] & N <= ci[,2])
- out.ds[i,] <- c(bias1, bias2, cover)
-}
-
-colMeans(out.ds)
-
-
-plot(N.hat1, N); abline(0,1)
-plot(N.hat2, N); abline(0,1)
-
-
-
-fmia <- update(fm, output="abund")
-
-re1 <- ranef(fm, K=50)
-re2 <- ranef(fmia, K=50)
-
-all.equal(bup(re1), bup(re2), tol=1e-4)
-
-
-
-# ------------------------------ multinomPois ----------------------------
-
-
-
-
-
-
-# Simulate independent double observer
-sim.mn <- function(nSites=50, lambda=10, p1=0.5, p2=0.3) {
- cp <- c(p1*(1-p2), p2*(1-p1), p1*p2)
- N <- rpois(nSites, lambda)
- y <- matrix(NA, nSites, 3)
- for(i in 1:nSites) {
- y[i,] <- rmultinom(1, N[i], c(cp, 1-sum(cp)))[1:3]
- }
- return(list(y=y, N=N))
-}
-
-
-
-nsim <- 500
-out.mn <- matrix(NA, nsim, 3)
-set.seed(83145)
-for(i in 1:nsim) {
- lambda <- 5
- sim.i <- sim.mn(lambda=lambda)
- umf <- unmarkedFrameMPois(y=sim.i$y, type="double")
- fm <- multinomPois(~1 ~1, umf, se=FALSE)
- lam.hat <- exp(coef(fm, type="state"))
- re <- ranef(fm, K=50)
- N <- sim.i$N
- N.hat1 <- bup(re, stat="mean")
- N.hat2 <- bup(re, stat="mode")
- bias1 <- mean(N.hat1 - N)
- bias2 <- mean(N.hat2 - N)
- ci <- confint(re)
- cover <- mean(N >= ci[,1] & N <= ci[,2])
- out.mn[i,] <- c(bias1, bias2, cover)
- if(i %% 10 == 0) cat("sim", i, "\n")
-}
-
-hist(out.nmix[,1], breaks=20)
-
-colMeans(out.nmix)
-
-plot(re, layout=c(5,5))
-
-plot(N.hat1, N); abline(0,1)
-plot(N.hat2, N); abline(0,1)
-
-
-
-
-
-
-
-
-
-# ---------------------------- gmultmix ---------------------------------
-
-
-
-sim.gmn <- function(R=50, T, lam=5, phi=0.5, p=0.3) {
- y <- array(NA, c(R, 3, T))
- M <- rpois(R, lam) # Local population size
- N <- matrix(NA, R, T) # Individuals available for detection
- for(i in 1:R) {
- N[i,] <- rbinom(T, M[i], phi)
- y[i,1,] <- rbinom(T, N[i,], p) # Observe some
- Nleft1 <- N[i,] - y[i,1,] # Remove them
- y[i,2,] <- rbinom(T, Nleft1, p) # ...
- Nleft2 <- Nleft1 - y[i,2,]
- y[i,3,] <- rbinom(T, Nleft2, p)
- }
- return(list(y=matrix(y,R), M=M))
-}
-
-
-
-
-
-
-nsim <- 100
-out.gmn <- matrix(NA, nsim, 3)
-set.seed(831455)
-for(i in 1:nsim) {
- R <- 50
- lambda <- 5
- T <- 5
- sim.i <- sim.gmn(R=R, lam=lambda, T=T, p=0.4)
- umf <- unmarkedFrameGMM(y=sim.i$y, numPrimary=T, type="removal")
- fm <- gmultmix(~1, ~1, ~1, umf, se=FALSE, K=40)
- re <- ranef(fm)
- M <- sim.i$M
- M.hat1 <- bup(re, stat="mean")
- M.hat2 <- bup(re, stat="mode")
- bias1 <- mean(M.hat1 - M)
- bias2 <- mean(M.hat2 - M)
- ci <- confint(re)
- cover <- mean(M >= ci[,1] & M <= ci[,2])
- out.gmn[i,] <- c(bias1, bias2, cover)
- if(i %% 1 == 0) {
- cat("sim", i, "\n")
- cat(" lambda =", exp(coef(fm)[1]), "\n")
- cat(" bias1 =", bias1, "\n")
- }
-}
-
-hist(out.gmn[,1], breaks=20)
-
-colMeans(out.gmn)
-
-plot(re, layout=c(5,5), subset=site %in% 1:25)
-
-plot(M.hat1, M); abline(0,1)
-plot(M.hat2, M); abline(0,1)
-
-
-
-
-
-umf1 <- unmarkedFrameGMM(y=y.ijt, numPrimary=T, type="removal")
-
-(m1 <- gmultmix(~1, ~1, ~1, data=umf1, K=30))
-
-re <- ranef(m1)
-plot(re, layout=c(5,5), xlim=c(-1,20), subset=site%in%1:25)
-
-
-plot(bup(re, "mode"), M)
-
-
-
-
-# ------------------------------ gdistsamp ------------------------------
-
-set.seed(36837)
-R <- 50 # number of transects
-T <- 5 # number of replicates
-strip.width <- 50
-transect.length <- 60 # so that abund != density
-breaks <- seq(0, 50, by=10)
-
-lambda <- 10 # Abundance
-phi <- 0.6 # Availability
-sigma <- 30 # Half-normal shape parameter
-
-J <- length(breaks)-1
-y <- array(0, c(R, J, T))
-for(i in 1:R) {
- M <- rpois(1, lambda) # Individuals within the 1-ha strip
- for(t in 1:T) {
- # Distances from point
- d <- runif(M, 0, strip.width)
- # Detection process
- if(length(d)) {
- cp <- phi*exp(-d^2 / (2 * sigma^2)) # half-normal w/ g(0)<1
- d <- d[rbinom(length(d), 1, cp) == 1]
- y[i,,t] <- table(cut(d, breaks, include.lowest=TRUE))
- }
- }
- }
-y <- matrix(y, nrow=R) # convert array to matrix
-
-# Organize data
-umf <- unmarkedFrameGDS(y = y, survey="line", unitsIn="m",
- dist.breaks=breaks, tlength=rep(transect.length, R), numPrimary=T)
-summary(umf)
-
-# Fit the model
-m1 <- gdistsamp(~1, ~1, ~1, umf, output="abund", K=50)
-summary(m1)
-m2 <- gdistsamp(~1, ~1, ~1, umf, output="density", K=50)
-summary(m2)
-
-
-re1 <- ranef(m1)
-plot(re1, xlim=c(-1, 30))
-re2 <- ranef(m2)
-plot(re2, xlim=c(-1, 30))
-
-all.equal(bup(re1), bup(re2), tol=1e-4)
-all(confint(re1) == confint(re2))
-
-cbind(bup(re1), bup(re2))
-
-
-# ----------------------------- colext ----------------------------------
-
-
-
-sim.colext <- function(R=50, J=3, T=5, psi=0.5, gamma=0.4, eps=0.6,
- p=0.5) {
- z <- matrix(NA, R, T)
- y <- array(NA, c(R, J, T))
- z[,1] <- rbinom(R, 1, psi)
- y[,,1] <- rbinom(R*J, 1, z[,1]*p)
- for(t in 1:(T-1)) {
- mu <- ((1-z[,t])*gamma + z[,t]*(1-eps))
- z[,t+1] <- rbinom(R, 1, mu)
- y[,,t+1] <- rbinom(R*J, 1, z[,t+1]*p)
- }
- return(list(y=matrix(y,R), z=z))
-}
-
-
-
-nsim <- 100
-out.colext <- matrix(NA, nsim, 3)
-set.seed(83145)
-for(i in 1:nsim) {
- R <- 50
- T <- 10
- sim.i <- sim.colext(R=R, T=T)
- umf <- unmarkedMultFrame(y=sim.i$y, numPrimary=T)
- fm <- colext(~1, ~1, ~1, ~1, umf, se=FALSE)
- re <- ranef(fm)
- z <- sim.i$z
- z.hat1 <- bup(re, stat="mean")
- z.hat2 <- bup(re, stat="mode")
- bias1 <- mean(z.hat1 - z)
- bias2 <- mean(z.hat2 - z)
- ci <- confint(re)
- cover <- mean(z >= ci[,1,] & z <= ci[,2,])
- out.colext[i,] <- c(bias1, bias2, cover)
- if(i %% 1 == 0) cat("sim", i, "\n")
-}
-
-hist(out.colext[,1], breaks=20)
-
-colMeans(out.colext)
-
-plot(re, layout=c(5,5), xlim=c(-2,3))
-
-plot(z.hat1, z); abline(0,1)
-plot(z.hat2, z); abline(0,1)
-
-
-
-
-# ----------------------------- pcountOpen -------------------------------
-
-
-
-
-library(unmarked)
-set.seed(7)
-
-sim.pco <- function(R=100, J=3, T=10, lambda=5, gamma=0.4, omega=0.9,
- p=0.5) {
- N <- matrix(NA, R, T)
- y <- array(NA, c(R, J, T))
- S <- G <- matrix(NA, R, T-1)
- N[,1] <- rpois(R, lambda)
- y[,,1] <- rbinom(R*J, N[,1], p)
- for(t in 1:(T-1)) {
- S[,t] <- rbinom(R, N[,t], omega)
- G[,t] <- rpois(R, gamma)
- N[,t+1] <- S[,t] + G[,t]
- y[,,t+1] <- rbinom(R*J, N[,t+1], p)
- }
- return(list(y=matrix(y,R), N=N))
-}
-
-
-nsim <- 10
-out.pco <- matrix(NA, nsim, 3)
-set.seed(83145)
-for(i in 1:nsim) {
- R <- 50
- lambda <- 5
- T <- 10
- sim.i <- sim.pco(R=R, lambda=lambda, T=T)
- umf <- unmarkedFramePCO(y=sim.i$y, numPrimary=T)
- fm <- pcountOpen(~1, ~1, ~1, ~1, umf, se=FALSE, K=20)
- re <- ranef(fm) # really slow
- N <- sim.i$N
- N.hat1 <- bup(re, stat="mean")
- N.hat2 <- bup(re, stat="mode")
- bias1 <- mean(N.hat1 - N)
- bias2 <- mean(N.hat2 - N)
- ci <- confint(re)
- cover <- mean(N >= ci[,1,] & N <= ci[,2,])
- out.pco[i,] <- c(bias1, bias2, cover)
- if(i %% 1 == 0) cat("sim", i, "\n")
-}
-
-hist(out.nmix[,1], breaks=20)
-
-colMeans(out.nmix)
-
-plot(re, layout=c(5,5))
-
-plot(N.hat1, N); abline(0,1)
-plot(N.hat2, N); abline(0,1)
-
-
-
-(fm.nt <- update(fm, dynamics="notrend"))
-
-re <- ranef(fm.nt)
-
-plot(re, layout=c(5,5), subset = site %in% 1:25, xlim=c(-1,10))
-
-
diff --git a/man/MesoCarnivores.Rd b/man/MesoCarnivores.Rd
new file mode 100644
index 0000000..c51e06f
--- /dev/null
+++ b/man/MesoCarnivores.Rd
@@ -0,0 +1,41 @@
+\name{MesoCarnivores}
+\alias{MesoCarnivores}
+\docType{data}
+\title{
+ Occupancy data for coyote, red fox, and bobcat
+}
+\description{
+ Occupancy data and site covariates for coyote, red fox, and bobcat from 1437 camera trap sites sampled 3 times. Each sampling period represents one week. This data is a simplified form of the dataset used by Rota et al. (2016).
+}
+
+\usage{data(MesoCarnivores)}
+
+\format{
+ A list with four elements:
+ \describe{
+ \item{\code{bobcat}}{A 1437x3 occupancy matrix for bobcat}
+ \item{\code{coyote}}{A 1437x3 occupancy matrix for coyote}
+ \item{\code{redfox}}{A 1437x3 occupancy matrix for red fox}
+ \item{\code{sitecovs}}{A data frame containing covariates for the 1437 sites, with the following columns:
+ \itemize{
+ \item{\code{Dist_5km}{Proportion of disturbed land in 5 km radius}}
+ \item{\code{HDens_5km}{Housing density in 5 km radius}}
+ \item{\code{Latitude}{Latitude / 100}}
+ \item{\code{Longitude}{Longitude / 100}}
+ \item{\code{People_site}{Number of photos of people at site / 1000}}
+ \item{\code{Trail}{1 if camera was on trail, 0 if not}}
+ }
+ }
+ }
+}
+
+\source{
+ Used with permission of Roland Kays and Arielle Parsons at North Carolina State University and the North Carolina Museum of Natural Sciences.
+}
+
+\references{
+Rota, C.T., et al. 2016. A multi-species occupancy model for two or more
+ interacting species. Methods in Ecology and Evolution 7: 1164-1173.
+}
+
+\keyword{datasets}
diff --git a/man/Switzerland.Rd b/man/Switzerland.Rd
index d1275f2..e868192 100644
--- a/man/Switzerland.Rd
+++ b/man/Switzerland.Rd
@@ -37,6 +37,7 @@ permission must be obtained from the Swiss Federal Statistical Office
Swiss Federal Statistical Office (http://www.bfs.admin.ch)
}
\examples{
+library(lattice)
data(Switzerland)
str(Switzerland)
diff --git a/man/crossVal.Rd b/man/crossVal.Rd
index 62af9b1..584a264 100644
--- a/man/crossVal.Rd
+++ b/man/crossVal.Rd
@@ -18,10 +18,10 @@
\usage{
\S4method{crossVal}{unmarkedFit}(
object, method=c("Kfold","holdout","leaveOneOut"),
- folds=10, holdoutPct=0.25, statistic=RMSE_MAE, parallel=FALSE, ...)
+ folds=10, holdoutPct=0.25, statistic=RMSE_MAE, parallel=FALSE, ncores, ...)
\S4method{crossVal}{unmarkedFitList}(
object, method=c("Kfold","holdout","leaveOneOut"),
- folds=10, holdoutPct=0.25, statistic=RMSE_MAE, parallel=FALSE,
+ folds=10, holdoutPct=0.25, statistic=RMSE_MAE, parallel=FALSE, ncores,
sort = c("none", "increasing", "decreasing"), ...)
}
@@ -42,6 +42,7 @@
\item{parallel}{If \code{TRUE}, run folds in parallel. This may speed up
cross-validation if the unmarked model takes a long time to fit or you have
a large number of sites and are using leave-one-out cross-validation.}
+ \item{ncores}{Number of parallel cores to use.}
\item{sort}{If doing cross-validation on a \code{fitList}, you can optionally
sort the resulting table(s) of statistic values for each model.}
\item{...}{Other arguments passed to the statistic function.}
diff --git a/man/cruz.Rd b/man/cruz.Rd
index 1cb3b07..e2a73a7 100644
--- a/man/cruz.Rd
+++ b/man/cruz.Rd
@@ -46,6 +46,8 @@ Sillett, S. and Chandler, R.B. and Royle, J.A. and Kery, M. and
endemic. \emph{Ecological Applications}
}
\examples{
+\dontrun{
+library(lattice)
data(cruz)
str(cruz)
@@ -58,6 +60,7 @@ elev <- rasterFromXYZ(cruz[,1:3],
elev
plot(elev)
}
+}
diff --git a/man/fitted-methods.Rd b/man/fitted-methods.Rd
index d253a7b..a06b930 100644
--- a/man/fitted-methods.Rd
+++ b/man/fitted-methods.Rd
@@ -12,10 +12,9 @@
\alias{fitted,unmarkedFitNmixTTD-method}
\alias{fitted,unmarkedFitPCount-method}
\alias{fitted,unmarkedFitDS-method}
-\alias{fitted,unmarkedFitPCO-method}
\alias{fitted,unmarkedFitGMM-method}
-\alias{fitted,unmarkedFitDSO-method}
\alias{fitted,unmarkedFitGDR-method}
+\alias{fitted,unmarkedFitDailMadsen-method}
\title{Methods for Function fitted in Package `unmarked'}
\description{Extracted fitted values from a fitted model.
}
diff --git a/man/formatDistData.Rd b/man/formatDistData.Rd
index e4b1b66..f5aaa83 100644
--- a/man/formatDistData.Rd
+++ b/man/formatDistData.Rd
@@ -19,7 +19,7 @@ transect names.}
than once, this can be used to format data for \code{gdistsamp}. It is
the name of the column in distData that contains the occasion
numbers. The occasion column should be a factor.}
-\item{effortMatrix}{optional matrix of 1 and 0s that is M * J in size and will allow for the insertion of NAs where the matrix = 0, indicating that a survey was not completed. When not supplied a matrix of all 1s is created since it is assumed all surveys were completed.}
+\item{effortMatrix}{optional matrix of 1 and 0s that is M * T in size and will allow for the insertion of NAs where the matrix = 0, indicating that a survey was not completed. When not supplied a matrix of all 1s is created since it is assumed all surveys were completed.}
}
\details{This function creates a site (M) by distance interval (J) response
matrix from a data.frame containing the detection distances for each
diff --git a/man/gdistremoval.Rd b/man/gdistremoval.Rd
index f47fcce..d232847 100644
--- a/man/gdistremoval.Rd
+++ b/man/gdistremoval.Rd
@@ -57,11 +57,4 @@ gdistremoval(lambdaformula=~1, phiformula=~1, removalformula=~1,
\seealso{\code{\link{unmarkedFrameGDR}}, \code{\link{gdistsamp}}, \code{\link{gmultmix}}}
-\examples{
-
-\dontrun{
-# More here later
-}
-}
-
\keyword{models}
diff --git a/man/nonparboot-methods.Rd b/man/nonparboot-methods.Rd
index 7338caf..720f241 100644
--- a/man/nonparboot-methods.Rd
+++ b/man/nonparboot-methods.Rd
@@ -13,11 +13,11 @@
\alias{nonparboot,unmarkedFitPCount-method}
\alias{nonparboot,unmarkedFitGDS-method}
\alias{nonparboot,unmarkedFitGMM-method}
-\alias{nonparboot,unmarkedFitPCO-method}
\alias{nonparboot,unmarkedFitOccuTTD-method}
\alias{nonparboot,unmarkedFitOccuMulti-method}
\alias{nonparboot,unmarkedFitNmixTTD-method}
\alias{nonparboot,unmarkedFitGDR-method}
+\alias{nonparboot,unmarkedFitDailMadsen-method}
\title{ Nonparametric bootstrapping in unmarked }
\description{
diff --git a/man/parboot.Rd b/man/parboot.Rd
index 2d95b33..6b6493f 100644
--- a/man/parboot.Rd
+++ b/man/parboot.Rd
@@ -54,16 +54,16 @@ ltUMF <- with(linetran, {
(fm <- distsamp(~area ~habitat, ltUMF))
# Function returning three fit-statistics.
-fitstats <- function(fm) {
+fitstats <- function(fm, na.rm=TRUE) {
observed <- getY(fm@data)
expected <- fitted(fm)
resids <- residuals(fm)
- sse <- sum(resids^2)
- chisq <- sum((observed - expected)^2 / expected)
- freeTuke <- sum((sqrt(observed) - sqrt(expected))^2)
+ sse <- sum(resids^2, na.rm=na.rm)
+ chisq <- sum((observed - expected)^2 / expected, na.rm=na.rm)
+ freeTuke <- sum((sqrt(observed) - sqrt(expected))^2, na.rm=na.rm)
out <- c(SSE=sse, Chisq=chisq, freemanTukey=freeTuke)
return(out)
- }
+}
(pb <- parboot(fm, fitstats, nsim=25, report=1))
plot(pb, main="")
@@ -84,4 +84,4 @@ colSums(confint(ranef(fm, K=50)))
-} \ No newline at end of file
+}
diff --git a/man/powerAnalysis.Rd b/man/powerAnalysis.Rd
new file mode 100644
index 0000000..c5c672f
--- /dev/null
+++ b/man/powerAnalysis.Rd
@@ -0,0 +1,105 @@
+\name{powerAnalysis}
+\alias{powerAnalysis}
+
+\title{Conduct a power analysis on an unmarked model}
+
+\description{
+This function uses a simulation-based approach to estimate power for parameters
+in unmarked models. At a minimum, users must provide a fitted \code{unmarked} model object
+(preferably fit with simulated data) which ensures the model has been properly
+specified, a list of effect sizes for each parameter in the model (\code{coefs}),
+and the desired Type I error (\code{alpha}). It is also possible to get power
+for a range of other sample sizes besides the sample size in the fitted
+model object using the \code{design} argument to subsample within the
+provided dataset. See the \code{unmarkedPower} vignette for more details and
+examples.
+}
+
+\usage{
+ powerAnalysis(object, coefs=NULL, design=NULL, alpha=0.05, nulls=list(),
+ datalist=NULL,
+ nsim=ifelse(is.null(datalist), 100, length(datalist)),
+ parallel=FALSE)
+}
+
+\arguments{
+ \item{object}{A fitted model inheriting class \code{unmarkedFit}. This
+ could potentially be fit using real data, but ideally you would simulate
+ an appropriate dataset using \code{simulate}}
+ \item{coefs}{A list containing the desired effect sizes for which you want
+ to estimate power. This list must follow a specific format. There is one
+ named entry in the list per submodel (e.g., occupancy, detection). To
+ get the required submodel names call \code{names(object)} on your fitted model.
+ Then, each list entry is a named vector with the names corresponding to the
+ parameter names for that submodel, and the values corresponding to the
+ desired effect sizes. It may be easier to leave \code{coefs=NULL}, which
+ will generate an error message with a template that you can fill in.
+ }
+ \item{design}{An optional list of design/sample size parameters containing
+ at a minimum two named elements: \code{M}, the number of sites, and \code{J}
+ the number of observations per site. If this list is provided, \code{unmarked}
+ will subsample the provided dataset to the specified number of sites and
+ observations, allowing you to test power for different designs. If
+ your model has multiple primary periods you must also include \code{T},
+ the number of periods, in the list.
+ }
+ \item{alpha}{Desired Type I error rate}
+ \item{nulls}{If provided, a list matching the structure of \code{coefs} which
+ defines the null hypothesis value for each parameter. By default the null
+ is 0 for all parameters.
+ }
+ \item{datalist}{An optional list of previously-simulated datasets, in the form
+ of \code{unmarkedFrames} matching the model type of \code{object}, which
+ will be used for the power analysis simulations.
+ }
+ \item{nsim}{Number of simulations to conduct}
+ \item{parallel}{If \code{TRUE}, run folds in parallel. This may speed up
+ the power analysis in some situations
+ }
+}
+
+\value{\code{unmarkedPower} object containing the results of the power analysis}
+
+\author{Ken Kellner \email{contact@kenkellner.com}}
+
+\seealso{
+ \code{\link{unmarkedPowerList}}
+}
+
+\examples{
+
+\dontrun{
+
+# Simulate an occupancy dataset
+# Covariates to include in simulation
+forms <- list(state=~elev, det=~1)
+
+# Covariate effects and intercept values
+coefs <- list(state=c(intercept=0, elev=-0.4), det=c(intercept=0))
+
+# Study design
+design <- list(M=300, J=8) # 300 sites, 8 occasions per site
+
+# Simulate an unmarkedFrameOccu
+occu_umf <- simulate("occu", formulas=forms, coefs=coefs, design=design)
+
+# Fit occupancy model to simulated data
+# This will contain all the model structure info powerAnalysis needs
+# The estimates from the model aren't used
+template_model <- occu(~1~elev, occu_umf)
+
+# If we run powerAnalysis without specifying coefs we'll get a template list
+powerAnalysis(template_model)
+
+# Set desired effect sizes to pass to coefs
+effect_sizes <- list(state=c(intercept=0, elev=-0.4), det=c(intercept=0))
+
+# Run power analysis and look at summary
+(pa <- powerAnalysis(template_model, coefs=effect_sizes, alpha=0.05))
+
+# Try a smaller sample size in the study design
+(pa2 <- powerAnalysis(template_model, coefs=effect_sizes, alpha=0.05,
+ design=list(M=100, J=2)))
+
+}
+}
diff --git a/man/ranef-methods.Rd b/man/ranef-methods.Rd
index d9dd916..abf0c68 100644
--- a/man/ranef-methods.Rd
+++ b/man/ranef-methods.Rd
@@ -18,9 +18,8 @@
\alias{ranef,unmarkedFitPCO-method}
\alias{ranef,unmarkedFitOccuTTD-method}
\alias{ranef,unmarkedFitNmixTTD-method}
-\alias{ranef,unmarkedFitDSO-method}
-\alias{ranef,unmarkedFitMMO-method}
\alias{ranef,unmarkedFitGDR-method}
+\alias{ranef,unmarkedFitDailMadsen-method}
\title{ Methods for Function \code{ranef} in Package \pkg{unmarked} }
\description{
Estimate posterior distributions of the random variables (latent
diff --git a/man/shinyPower.Rd b/man/shinyPower.Rd
new file mode 100644
index 0000000..ef338aa
--- /dev/null
+++ b/man/shinyPower.Rd
@@ -0,0 +1,16 @@
+\name{shinyPower}
+\alias{shinyPower}
+\title{Launch a Shiny app to help with power analysis}
+\description{
+ Launch a Shiny app to test power under various scenarios. Requires the Shiny
+ package to be installed.
+}
+\usage{
+shinyPower(object, ...)
+}
+\arguments{
+ \item{object}{A template \code{unmarkedFit} object; see
+ documentation for \code{powerAnalysis} for details on how to create this}
+ \item{...}{Currently ignored}
+}
+\value{No return value, called for its side effects.}
diff --git a/man/simulate-methods.Rd b/man/simulate-methods.Rd
index 38b4fe6..67d942d 100644
--- a/man/simulate-methods.Rd
+++ b/man/simulate-methods.Rd
@@ -16,9 +16,9 @@
\alias{simulate,unmarkedFitGMM-method}
\alias{simulate,unmarkedFitGDS-method}
\alias{simulate,unmarkedFitGPC-method}
-\alias{simulate,unmarkedFitDSO-method}
-\alias{simulate,unmarkedFitMMO-method}
\alias{simulate,unmarkedFitGDR-method}
+\alias{simulate,unmarkedFitDailMadsen-method}
+\alias{simulate,character-method}
\title{Methods for Function simulate in Package `unmarked'}
\description{
Simulate data from a fitted model.
@@ -30,13 +30,49 @@ Simulate data from a fitted model.
\S4method{simulate}{unmarkedFitOccu}(object, nsim, seed, na.rm)
\S4method{simulate}{unmarkedFitOccuRN}(object, nsim, seed, na.rm)
\S4method{simulate}{unmarkedFitPCount}(object, nsim, seed, na.rm)
+\S4method{simulate}{character}(object, nsim=1, seed=NULL, formulas, coefs=NULL,
+ design, guide=NULL, ...)
}
+
\arguments{
\item{object}{Fitted model of appropriate S4 class}
\item{nsim}{Number of simulations}
\item{seed}{Seed for random number generator. Not currently implemented}
\item{na.rm}{Logical, should missing values be removed?}
+\item{formulas}{
+ A named list of formulas, one per submodel (e.g. a formula for occupancy
+ \code{"state"} and a formula for detection \code{"det"}). To get the correct
+ submodel names for a given model, fit an example for that model, and then
+ call \code{names(fitted_model)}
+}
+\item{coefs}{
+ A named list of vectors of coefficients associated with the regression
+ intercepts and slopes for each submodel. List should be named as with
+ \code{formulas} above. Each element of the list should be a named vector,
+ where the names correspond to the names of the parameters in the model
+ (intercept and covariates). If you are not sure how to structure this list,
+ just run \code{simulate} with \code{coefs=NULL}; this will generate
+ a template list you can copy and fill in.
+}
+\item{design}{
+ A named list of components of the study design. Must include at least \code{M},
+ the number of sites, and \code{J} the number of observations per site. If you
+ are fitting a model with multiple primary periods you must also provide
+ \code{T}, the number of primary periods.
+}
+\item{guide}{
+ An optional list defining the format (continuous or categorical/factor) and distribution,
+ if continuous, of covariates you want to simulate. By default all covariates
+ are simulated from a standard normal. See example below for an example of
+ how to specify entries in the \code{guide} list.
+}
+\item{...}{
+ Additional arguments that are needed to fully specify the simulated dataset
+ for a particular model. For example, \code{mixture} for \code{pcount} models
+ or \code{keyfun} for \code{distsamp} models.
+}
}
+
\section{Methods}{
\describe{
\item{object = "unmarkedFitColExt"}{A model fit by \code{\link{colext}}}
@@ -45,6 +81,57 @@ Simulate data from a fitted model.
\item{object = "unmarkedFitOccu"}{A model fit by \code{\link{occu}}}
\item{object = "unmarkedFitOccuRN"}{A model fit by \code{\link{occuRN}}}
\item{object = "unmarkedFitPCount"}{A model fit by \code{\link{pcount}}}
+\item{object = "character"}{An \code{unmarkedFrame} of the appropriate type}
}}
\keyword{methods}
+\examples{
+
+\dontrun{
+
+# Simulation of an occupancy dataset from scratch
+
+# Formulas for each submodel
+# occupancy is a function of elevation, detection is intercept-only
+forms <- list(state=~elev, det=~1)
+
+# Specify list of coefficients - there must be a value for each
+# covariate plus an intercept for each submodel
+coefs <- list(state=c(intercept=0, elev=-0.4), det=c(intercept=0))
+
+# Study design
+design <- list(M=300, J=8) # 300 sites, 8 occasions per site
+
+# If we don't specify coefs, unmarked will generate a template you can copy and use
+simulate("occu", formulas=forms, design=design)
+
+# Generate unmarkedFrameOccu
+occu_umf <- simulate("occu", formulas=forms, coefs=coefs, design=design)
+head(occu_umf) # note one covariate, elev
+
+# What if we wanted to add a categorical/factor covariate or
+# customize the distribution of elev?
+# Use the guide argument
+
+# Updated formulas with new covariate
+forms2 <- list(state=~elev+landcover, det=~1)
+
+# Guide
+# landcover is factor, you must provide the levels
+guide <- list(landcover=factor(levels=c("forest","grass")),
+ elev=list(dist=rnorm, mean=2, sd=0.5)) # custom distribution
+
+# Updated coefficients list
+coefs2 <- list(state=c(intercept=0, elev=-0.4, landcovergrass=0.2), det=c(intercept=0))
+
+# Simulate new dataset
+head(simulate("occu", formulas=forms2, coefs=coefs2, design=design, guide=guide))
+# Note new categorical covariate
+
+# For some models you may want to specify other arguments, such as 'mixture'
+# for pcount or 'keyfun' for distsamp
+# See the documentation for the associated fitting function and unmarkedFrame
+# for what arguments are possible to include for a given model
+head(simulate("pcount", formulas=forms, coefs=coefs, design=design, mixture="NB"))
+}
+}
diff --git a/man/unmarkedFit-class.Rd b/man/unmarkedFit-class.Rd
index 4380327..91e1723 100644
--- a/man/unmarkedFit-class.Rd
+++ b/man/unmarkedFit-class.Rd
@@ -28,13 +28,13 @@
\alias{residuals,unmarkedFitGDR-method}
\alias{update,unmarkedFit-method}
\alias{update,unmarkedFitColExt-method}
-\alias{update,unmarkedFitPCOorDSO-method}
\alias{update,unmarkedFitGMM-method}
\alias{update,unmarkedFitOccuMulti-method}
\alias{update,unmarkedFitOccuMS-method}
\alias{update,unmarkedFitOccuTTD-method}
\alias{update,unmarkedFitNmixTTD-method}
\alias{update,unmarkedFitGDR-method}
+\alias{update,unmarkedFitDailMadsen-method}
\alias{sampleSize}
\alias{sampleSize,unmarkedFit-method}
\alias{unmarkedFitOccu-class}
diff --git a/man/unmarkedFrame-class.Rd b/man/unmarkedFrame-class.Rd
index 68d207d..9df4157 100644
--- a/man/unmarkedFrame-class.Rd
+++ b/man/unmarkedFrame-class.Rd
@@ -27,8 +27,6 @@
\alias{plot,unmarkedFrame,missing-method}
\alias{plot,unmarkedFrameOccuMulti,missing-method}
\alias{plot,unmarkedFrameOccuTTD,missing-method}
-\alias{powerAnalysis}
-\alias{powerAnalysis,formula,unmarkedFramePCount,numeric-method}
\alias{projection,unmarkedFrame-method}
\alias{projection}
\alias{siteCovs,unmarkedFrame-method}
diff --git a/man/unmarkedFrameGDR.Rd b/man/unmarkedFrameGDR.Rd
index 99e5d07..dd18550 100644
--- a/man/unmarkedFrameGDR.Rd
+++ b/man/unmarkedFrameGDR.Rd
@@ -59,9 +59,3 @@
\seealso{\code{\link{unmarkedFrame-class}}, \code{\link{unmarkedFrame}},
\code{\link{gdistremoval}}}
-
-\examples{
-
-# More here later
-
-}
diff --git a/man/unmarkedPower-class.Rd b/man/unmarkedPower-class.Rd
new file mode 100644
index 0000000..3df4d77
--- /dev/null
+++ b/man/unmarkedPower-class.Rd
@@ -0,0 +1,63 @@
+\name{unmarkedPower-methods}
+\alias{unmarkedPower-methods}
+\alias{unmarkedPower-class}
+\alias{show,unmarkedPower-method}
+\alias{summary,unmarkedPower-method}
+\alias{update,unmarkedPower-method}
+
+\title{Methods for unmarkedPower objects}
+
+\description{Various functions to summarize and update unmarkedPower objects}
+
+\usage{
+\S4method{show}{unmarkedPower}(object)
+\S4method{summary}{unmarkedPower}(object, ...)
+\S4method{update}{unmarkedPower}(object, ...)
+}
+
+\arguments{
+ \item{object}{An object of class \code{unmarkedPower} created with the
+ \code{powerAnalysis} function}
+ \item{...}{For \code{update}, arguments to change in the updated power analysis.
+ Not used by \code{summary}}
+}
+
+\value{
+ For \code{show} and \code{summary}, summary output is printed to the console.
+ For \code{update}, a new \code{powerAnalysis} object corresponding to the
+ new arguments provided.
+}
+
+\author{Ken Kellner \email{contact@kenkellner.com}}
+
+\seealso{
+ \code{\link{powerAnalysis}}
+}
+
+\examples{
+
+\dontrun{
+
+# Simulate an occupancy dataset
+forms <- list(state=~elev, det=~1)
+coefs <- list(state=c(intercept=0, elev=-0.4), det=c(intercept=0))
+design <- list(M=300, J=8) # 300 sites, 8 occasions per site
+occu_umf <- simulate("occu", formulas=forms, coefs=coefs, design=design)
+
+# Fit occupancy model to simulated data
+template_model <- occu(~1~elev, occu_umf)
+
+# Set desired effect sizes to pass to coefs
+effect_sizes <- list(state=c(intercept=0, elev=-0.4), det=c(intercept=0))
+
+# Run power analysis
+pa <- powerAnalysis(template_model, coefs=effect_sizes, alpha=0.05)
+
+# Look at summary
+summary(pa)
+
+# Update the analysis with new arguments
+(pa2 <- update(pa, alpha=0.01))
+
+}
+}
diff --git a/man/unmarkedPowerList.Rd b/man/unmarkedPowerList.Rd
new file mode 100644
index 0000000..3dbbcf1
--- /dev/null
+++ b/man/unmarkedPowerList.Rd
@@ -0,0 +1,95 @@
+\name{unmarkedPowerList}
+\alias{unmarkedPowerList}
+\alias{unmarkedPowerList,list-method}
+\alias{unmarkedPowerList,unmarkedFit-method}
+\alias{unmarkedPowerList-class}
+\alias{unmarkedPowerList-methods}
+\alias{show,unmarkedPowerList-method}
+\alias{summary,unmarkedPowerList-method}
+\alias{plot,unmarkedPowerList,ANY-method}
+
+\title{Create or summarize a series of unmarked power analyses}
+
+\description{
+ A list of power analyses created with \code{powerAnalysis} can be combined
+ using \code{unmarkedPowerList}, allowing comparison e.g. between different
+ study designs/sample sizes. Additionally an \code{unmarkedPowerList} can be
+ created directly from an \code{unmarkedFit} template model by specifying
+ a series of study designs (number of sites, number of observations)
+ as a \code{data.frame}. A series of methods for \code{unmarkedPowerList}
+ objects are available including a \code{plot} method.
+}
+
+\usage{
+\S4method{unmarkedPowerList}{list}(object, ...)
+\S4method{unmarkedPowerList}{unmarkedFit}(object, coefs, design, alpha=0.05,
+ nulls=list(), nsim=100, parallel=FALSE, ...)
+\S4method{show}{unmarkedPowerList}(object)
+\S4method{summary}{unmarkedPowerList}(object, ...)
+\S4method{plot}{unmarkedPowerList,ANY}(x, power=NULL, param=NULL, ...)
+}
+
+\arguments{
+ \item{object,x}{A \code{list} of \code{unmarkedPower} objects, a fitted model
+ inheriting class \code{unmarkedFit}, or an \code{unmarkedPowerList} object,
+ depending on the method
+ }
+ \item{coefs}{A named list of effect sizes, see documentation for
+ \code{powerAnalysis}}
+ \item{design}{A \code{data.frame} with one row per study design to test, and
+ at least 2 named columns: \code{M} for number of sites and \code{J} for
+ number of observations. If you have >1 primary period a \code{T} column
+ must also be provided}
+ \item{alpha}{Type I error rate}
+ \item{nulls}{If provided, a list matching the structure of \code{coefs} which
+ defines the null hypothesis value for each parameter. By default the null
+ is 0 for all parameters.
+ }
+ \item{nsim}{The number of simulations to run for each scenario/study design}
+ \item{parallel}{If \code{TRUE}, run simulations in parallel}
+ \item{power}{When plotting, the target power. Draws a horizontal line
+ at a given value of power on the plot}
+ \item{param}{When plotting, the model parameter to plot power vs. sample size for.
+ By default this is the first parameter (which is usually an intercept,
+ so not very interesting)}
+ \item{...}{Not used}
+}
+
+\value{A \code{unmarkedPowerList} object, a summary of the object in the console,
+ or a summary plot, depending on the method}
+
+\author{Ken Kellner \email{contact@kenkellner.com}}
+
+\seealso{
+ \code{\link{powerAnalysis}}
+}
+
+\examples{
+
+\dontrun{
+
+# Simulate an occupancy dataset and build template model
+forms <- list(state=~elev, det=~1)
+coefs <- list(state=c(intercept=0, elev=-0.4), det=c(intercept=0))
+design <- list(M=300, J=8) # 300 sites, 8 occasions per site
+occu_umf <- simulate("occu", formulas=forms, coefs=coefs, design=design)
+template_model <- occu(~1~elev, occu_umf)
+
+# Generate two power analysis
+effect_sizes <- list(state=c(intercept=0, elev=-0.4), det=c(intercept=0))
+pa <- powerAnalysis(template_model, coefs=effect_sizes, alpha=0.05)
+pa2 <- powerAnalysis(template_model, effect_sizes, design=list(M=100,J=2))
+
+# Build unmarkedPowerList and look at summary
+(pl <- unmarkedPowerList(list(pa,pa2)))
+
+# Run a bunch of power analyses for different scenarios all at once
+scenarios <- expand.grid(M=c(50,200,400),
+ J=c(3,5,8))
+(pl2 <- unmarkedPowerList(template_model, effect_sizes, design=scenarios, nsim=20))
+
+# Look at summary plot for elev effect
+plot(pl2, power=0.8, param='elev')
+
+}
+}
diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp
index a698018..8af3b75 100644
--- a/src/RcppExports.cpp
+++ b/src/RcppExports.cpp
@@ -199,7 +199,7 @@ RcppExport SEXP getSingleDetVec(SEXP, SEXP, SEXP);
RcppExport SEXP nll_distsamp(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP);
RcppExport SEXP nll_distsampOpen(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP);
RcppExport SEXP nll_multinomPois(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP);
-RcppExport SEXP nll_multmixOpen(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP);
+RcppExport SEXP nll_multmixOpen(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP);
RcppExport SEXP nll_occu(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP);
RcppExport SEXP nll_occuMS(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP);
RcppExport SEXP nll_occuMulti(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP);
@@ -222,7 +222,7 @@ static const R_CallMethodDef CallEntries[] = {
{"nll_distsamp", (DL_FUNC) &nll_distsamp, 11},
{"nll_distsampOpen", (DL_FUNC) &nll_distsampOpen, 42},
{"nll_multinomPois", (DL_FUNC) &nll_multinomPois, 10},
- {"nll_multmixOpen", (DL_FUNC) &nll_multmixOpen, 38},
+ {"nll_multmixOpen", (DL_FUNC) &nll_multmixOpen, 39},
{"nll_occu", (DL_FUNC) &nll_occu, 11},
{"nll_occuMS", (DL_FUNC) &nll_occuMS, 15},
{"nll_occuMulti", (DL_FUNC) &nll_occuMulti, 16},
diff --git a/src/TMB/compile.R b/src/TMB/compile.R
index aa59e7c..c442187 100644
--- a/src/TMB/compile.R
+++ b/src/TMB/compile.R
@@ -6,6 +6,7 @@ if(file.exists(paste0(tmb_name, ".cpp"))) {
TMB::compile(file = paste0(tmb_name, ".cpp"),
#PKG_CXXFLAGS = tmb_flags,
#openmp = TRUE,
+ openmp = FALSE,
safebounds = FALSE, safeunload = FALSE)
file.copy(from = paste0(tmb_name, .Platform$dynlib.ext),
to = "..", overwrite = TRUE)
diff --git a/src/TMB/tmb_distsamp.hpp b/src/TMB/tmb_distsamp.hpp
index 7dd4c92..3117599 100644
--- a/src/TMB/tmb_distsamp.hpp
+++ b/src/TMB/tmb_distsamp.hpp
@@ -40,8 +40,7 @@ Type tmb_distsamp(objective_function<Type>* obj) {
Type scale = 0; // If not hazard this is ignored later
if(keyfun_type == 3) scale = exp(beta_scale(0)); // If hazard
- //Define the log likelihood so that it can be calculated in parallel over sites
- parallel_accumulator<Type> loglik(obj);
+ Type loglik = 0.0;
int M = y.rows(); // # of sites
int J = y.cols(); // # of distance categories per site
diff --git a/src/TMB/tmb_gdistremoval.hpp b/src/TMB/tmb_gdistremoval.hpp
index d414036..ddbded9 100644
--- a/src/TMB/tmb_gdistremoval.hpp
+++ b/src/TMB/tmb_gdistremoval.hpp
@@ -67,9 +67,7 @@ Type tmb_gdistremoval(objective_function<Type>* obj) {
PARAMETER_VECTOR(b_rem);
PARAMETER_VECTOR(lsigma_rem);
- //Define the log likelihood so that it can be calculated in parallel over sites
- parallel_accumulator<Type> loglik(obj);
-
+ Type loglik = 0.0;
int M = X_lambda.rows(); // # of sites
int Rdist = y_dist.size() / M;
int Jdist = Rdist / T;
diff --git a/src/TMB/tmb_keyfun.hpp b/src/TMB/tmb_keyfun.hpp
index 619dc74..8ab5569 100644
--- a/src/TMB/tmb_keyfun.hpp
+++ b/src/TMB/tmb_keyfun.hpp
@@ -69,26 +69,22 @@ vector<Type> key_halfnorm(Type sigma, int survey_type, vector<Type> db,
int J = db.size() - 1;
vector<Type> p(J);
+ Type p1, p2;
if(survey_type == 0){
Type f0 = 2 * dnorm(Type(0.0), Type(0.0), sigma, false);
- int L = db.size();
- vector<Type> p1(L-1);
- vector<Type> p2(L-1);
- for(int l=1; l<L; l++){
- p1(l-1) = pnorm(db(l), Type(0.0), sigma);
- p2(l-1) = pnorm(db(l-1), Type(0.0), sigma);
+ for (int j=0; j<J; j++){
+ p1 = pnorm(db(j+1), Type(0.0), sigma);
+ p2 = pnorm(db(j), Type(0.0), sigma);
+ p(j) = 2 * (p1 - p2) / f0 / w(j);
}
- vector<Type> int_ = 2 * (p1 - p2);
- p = int_ / f0 / w;
} else if(survey_type == 1){
+ Type s2 = pow(sigma, 2);
for (int j=0; j<J; j++){
- Type s2 = pow(sigma,2);
- Type p1 = 1 - exp(-pow(db(j+1),2) / (2 * s2));
- Type p2 = 1 - exp(-pow(db(j),2) / (2 * s2));
- Type int_ = s2 * p1 - s2 * p2;
- p(j) = int_ * 2 * M_PI / a(j);
+ p1 = 1 - exp(-pow(db(j+1),2) / (2 * s2));
+ p2 = 1 - exp(-pow(db(j),2) / (2 * s2));
+ p(j) = (s2 * p1 - s2 * p2) * 2 * M_PI / a(j);
}
}
return(p);
diff --git a/src/TMB/tmb_multinomPois.hpp b/src/TMB/tmb_multinomPois.hpp
index 66e8dfc..36a5c40 100644
--- a/src/TMB/tmb_multinomPois.hpp
+++ b/src/TMB/tmb_multinomPois.hpp
@@ -30,7 +30,7 @@ Type tmb_multinomPois(objective_function<Type>* obj) {
PARAMETER_VECTOR(lsigma_det);
//Define the log likelihood so that it can be calculated in parallel over sites
- parallel_accumulator<Type> loglik(obj);
+ Type loglik = 0.0;
int M = y.rows(); // # of sites
int J = y.cols(); // # of obs per site
diff --git a/src/TMB/tmb_occu.hpp b/src/TMB/tmb_occu.hpp
index 4e76e53..0fef715 100644
--- a/src/TMB/tmb_occu.hpp
+++ b/src/TMB/tmb_occu.hpp
@@ -30,8 +30,7 @@ Type tmb_occu(objective_function<Type>* obj) {
PARAMETER_VECTOR(b_det);
PARAMETER_VECTOR(lsigma_det);
- //Define the log likelihood so that it can be calculated in parallel over sites
- parallel_accumulator<Type> loglik(obj);
+ Type loglik = 0.0;
int M = y.rows(); //# of sites
int J = y.cols(); //# of observations per site
diff --git a/src/TMB/tmb_pcount.hpp b/src/TMB/tmb_pcount.hpp
index 8a2a1ac..43ed083 100644
--- a/src/TMB/tmb_pcount.hpp
+++ b/src/TMB/tmb_pcount.hpp
@@ -65,9 +65,7 @@ Type tmb_pcount(objective_function<Type>* obj) {
Type scale = 0;
if(mixture > 1) scale = beta_scale(0);
- //Define the log likelihood so that it can be calculated in parallel over sites
- parallel_accumulator<Type> loglik(obj);
-
+ Type loglik = 0.0;
int M = y.rows(); //# of sites
int J = y.cols(); //# of observations per site
diff --git a/src/TMB/tmb_utils.hpp b/src/TMB/tmb_utils.hpp
index 6c6c42f..024f4bc 100644
--- a/src/TMB/tmb_utils.hpp
+++ b/src/TMB/tmb_utils.hpp
@@ -9,7 +9,7 @@ vector<Type> cloglog(vector<Type> inp) {
}
template<class Type>
-vector<Type> add_ranef(vector<Type> par, parallel_accumulator<Type>& loglik,
+vector<Type> add_ranef(vector<Type> par, Type& loglik,
vector<Type> b, Eigen::SparseMatrix<Type> Z,
vector<Type> lsigma, int n_group_vars, vector<int> n_grouplevels) {
diff --git a/src/TMB/unmarked_TMBExports.cpp b/src/TMB/unmarked_TMBExports.cpp
index faec05a..5c1bfea 100644
--- a/src/TMB/unmarked_TMBExports.cpp
+++ b/src/TMB/unmarked_TMBExports.cpp
@@ -1,6 +1,6 @@
#define TMB_LIB_INIT R_init_unmarked_TMBExports
-#include <TMB.hpp>
#include <float.h>
+#include <TMB.hpp>
#include "tmb_utils.hpp"
#include "tmb_pifun.hpp"
#include "tmb_keyfun.hpp"
diff --git a/src/distprob.cpp b/src/distprob.cpp
index 61aa346..4e6890e 100644
--- a/src/distprob.cpp
+++ b/src/distprob.cpp
@@ -3,37 +3,33 @@
using namespace Rcpp;
using namespace arma;
-vec p_halfnorm(const double& sigma, const std::string& survey,
+vec p_halfnorm(const double& sigma, const std::string& survey,
const vec& db, const vec& w, const rowvec& a){
-
+
int J = db.size() - 1;
vec p(J);
+ double p1, p2;
if(survey == "line"){
double f0 = 2 * R::dnorm(0.0, 0.0, sigma, 0);
- int L = db.size();
- vec p1(L-1);
- vec p2(L-1);
- for(int l=1; l<L; l++){
- p1(l-1) = R::pnorm(db(l), 0.0, sigma, 1, 0);
- p2(l-1) = R::pnorm(db(l-1), 0.0, sigma, 1, 0);
+ for (int j=0; j<J; j++){
+ p1 = R::pnorm(db(j+1), 0.0, sigma, 1, 0);
+ p2 = R::pnorm(db(j), 0.0, sigma, 1, 0);
+ p(j) = 2 * (p1 - p2) / f0 / w(j);
}
- vec int_ = 2 * (p1 - p2);
- p = int_ / f0 / w;
} else if(survey == "point"){
+ double s2 = pow(sigma, 2);
for (int j=0; j<J; j++){
- double s2 = pow(sigma,2);
- double p1 = 1 - exp(-pow(db(j+1),2) / (2 * s2));
- double p2 = 1 - exp(-pow(db(j),2) / (2 * s2));
- double int_ = s2 * p1 - s2 * p2;
- p(j) = int_ * 2 * M_PI / a(j);
+ p1 = 1 - exp(-pow(db(j+1),2) / (2 * s2));
+ p2 = 1 - exp(-pow(db(j),2) / (2 * s2));
+ p(j) = (s2 * p1 - s2 * p2) * 2 * M_PI / a(j);
}
}
return(p);
}
-vec p_exp(const double& rate, const std::string& survey, const vec& db,
+vec p_exp(const double& rate, const std::string& survey, const vec& db,
const vec& w, const rowvec& a, double& rel_tol){
int J = db.size() - 1;
@@ -55,7 +51,7 @@ vec p_exp(const double& rate, const std::string& survey, const vec& db,
return(p);
}
-vec p_hazard(const double& shape, const double& scale, const std::string& survey,
+vec p_hazard(const double& shape, const double& scale, const std::string& survey,
const vec& db, const vec& w, const rowvec& a, double& rel_tol){
int J = db.size() - 1;
@@ -78,15 +74,15 @@ vec p_hazard(const double& shape, const double& scale, const std::string& survey
return(p);
}
-vec distprob(const std::string& keyfun, const double param1,
+vec distprob(const std::string& keyfun, const double param1,
const double param2, const std::string& survey, const vec& db,
const vec& w, const rowvec& a){
-
+
int J = db.size() - 1;
double rel_tol = 0.0; //might use in future
vec p(J);
if(keyfun == "uniform"){
- p = ones(J);
+ p = ones(J);
} else if (keyfun == "halfnorm"){
//param1 is sigma
p = p_halfnorm(param1, survey, db, w, a);
diff --git a/src/nll_distsamp.cpp b/src/nll_distsamp.cpp
index 07a9972..2cdd3d7 100644
--- a/src/nll_distsamp.cpp
+++ b/src/nll_distsamp.cpp
@@ -24,9 +24,9 @@ SEXP nll_distsamp( SEXP y_, SEXP lam_, SEXP sig_, SEXP scale_, SEXP a_, SEXP u_,
double f0 = 0.0;
for(int i=0; i<R; i++) {
- if((survey=="line") & (keyfun=="halfnorm"))
+ if((survey=="line") && (keyfun=="halfnorm"))
f0 = Rf_dnorm4(0.0, 0.0, sig[i], false);
- if((survey=="line") & (keyfun=="exp"))
+ if((survey=="line") && (keyfun=="exp"))
f0 = Rf_dexp(0.0, 1/sig[i], false);
for(int j=0; j<J; j++) {
double cp = 0.0;
diff --git a/src/nll_gdistremoval.cpp b/src/nll_gdistremoval.cpp
index 9177a2d..8a04471 100644
--- a/src/nll_gdistremoval.cpp
+++ b/src/nll_gdistremoval.cpp
@@ -83,7 +83,7 @@ double nll_gdistremoval(arma::vec beta, arma::uvec n_param, arma::vec yDistance,
uvec nmd = find_finite(yd_sub);
uvec nmr = find_finite(yr_sub);
- if((nmd.size() == Jdist) & (nmr.size() == Jrem)){
+ if((nmd.size() == Jdist) && (nmr.size() == Jrem)){
cpd = distprob(keyfun, dist_param(t_ind), scale, "point",
db, w, a.row(i)) % u.col(i);
diff --git a/src/nll_multmixOpen.cpp b/src/nll_multmixOpen.cpp
index b993ad8..2e4c480 100644
--- a/src/nll_multmixOpen.cpp
+++ b/src/nll_multmixOpen.cpp
@@ -10,7 +10,7 @@ SEXP nll_multmixOpen( SEXP y_, SEXP yt_, SEXP Xlam_, SEXP Xgam_, SEXP Xom_,
SEXP Xgam_offset_, SEXP Xom_offset_, SEXP Xp_offset_, SEXP Xiota_offset_,
SEXP ytna_, SEXP yna_, SEXP lk_, SEXP mixture_,
SEXP first_, SEXP last_, SEXP first1_,
- SEXP M_, SEXP T_, SEXP J_, SEXP delta_, SEXP dynamics_,
+ SEXP M_, SEXP T_, SEXP J_, SEXP R_, SEXP delta_, SEXP dynamics_,
SEXP fix_, SEXP go_dims_, SEXP immigration_,
SEXP I_, SEXP I1_, SEXP Ib_, SEXP Ip_, SEXP pi_fun_,
SEXP lfac_k_, SEXP kmyt_, SEXP lfac_kmyt_, SEXP fin_) {
@@ -21,6 +21,7 @@ SEXP nll_multmixOpen( SEXP y_, SEXP yt_, SEXP Xlam_, SEXP Xgam_, SEXP Xom_,
int M = as<int>(M_);
int T = as<int>(T_);
int J = as<int>(J_);
+ int R = as<int>(R_);
ucube y = as<ucube>(y_);
imat yt = as<imat>(yt_);
Rcpp::IntegerVector first(first_);
@@ -110,7 +111,7 @@ SEXP nll_multmixOpen( SEXP y_, SEXP yt_, SEXP Xlam_, SEXP Xgam_, SEXP Xom_,
vec beta_p = beta.subvec(bi(3,0), bi(3,1));
vec pv = inv_logit(Xp * beta_p + Xp_offset);
//Transform into cube (J x M x T)
- cube p((const double*) pv.begin(), J, M, T);
+ cube p((const double*) pv.begin(), R, M, T);
//Immigration
mat iota = zeros(M,T-1);
diff --git a/src/nll_multmixOpen.h b/src/nll_multmixOpen.h
index c710a46..50fc2f1 100644
--- a/src/nll_multmixOpen.h
+++ b/src/nll_multmixOpen.h
@@ -15,7 +15,7 @@ RcppExport SEXP nll_multmixOpen( SEXP y_, SEXP yt_, SEXP Xlam_, SEXP Xgam_, SEXP
SEXP Xgam_offset_, SEXP Xom_offset_, SEXP Xp_offset_, SEXP Xiota_offset_,
SEXP ytna_, SEXP yna_, SEXP lk_, SEXP mixture_,
SEXP first_, SEXP last_, SEXP first1_,
- SEXP M_, SEXP T_, SEXP J_, SEXP delta_, SEXP dynamics_,
+ SEXP M_, SEXP T_, SEXP J_, SEXP R_, SEXP delta_, SEXP dynamics_,
SEXP fix_, SEXP go_dims_, SEXP immigration_,
SEXP I_, SEXP I1_, SEXP Ib_, SEXP Ip_, SEXP pi_fun_,
SEXP lfac_k_, SEXP kmyt_, SEXP lfac_kmyt_, SEXP fin_) ;
diff --git a/tests/testthat.R b/tests/testthat.R
new file mode 100644
index 0000000..b34044c
--- /dev/null
+++ b/tests/testthat.R
@@ -0,0 +1,3 @@
+library(testthat)
+library(unmarked)
+test_check("unmarked")
diff --git a/tests/testthat/test_colext.R b/tests/testthat/test_colext.R
new file mode 100644
index 0000000..882c7fd
--- /dev/null
+++ b/tests/testthat/test_colext.R
@@ -0,0 +1,140 @@
+context("colext fitting function")
+skip_on_cran()
+
+# Simulate data
+set.seed(123)
+nsites <- 6
+nyr <- 4
+nrep <- 2
+y <- matrix(c(
+ 1,0, 1,1, 0,0, 0,0,
+ 1,1, 0,0, 0,0, 0,0,
+ 0,0, 0,0, 0,0, 0,0,
+ 0,0, 1,1, 0,0, 0,0,
+ 1,1, 1,0, 0,1, 0,0,
+ 0,0, 0,0, 0,0, 1,1), nrow=nsites, ncol=nyr*nrep, byrow=TRUE)
+
+sc <- data.frame(sc1 = rnorm(nsites))
+oc <- matrix(rnorm(nsites*nyr*nrep), nsites, nyr*nrep)
+ysc <- matrix(rnorm(nsites*nyr), nsites, nyr)
+
+test_that("unmarkedMultFrame construction works",{
+
+ umf1 <- unmarkedMultFrame(y=y, siteCovs=sc, yearlySiteCovs=list(ysc=ysc),
+ obsCovs=list(oc=oc), numPrimary=4)
+ expect_is(umf1, "unmarkedMultFrame")
+
+ expect_error(unmarkedMultFrame(y=y, siteCovs=sc, obsCovs=list(oc=oc[1:5,]), numPrimary=4))
+
+ expect_error(unmarkedMultFrame(y=y, siteCovs=sc, yearlySiteCovs=list(ysc=ysc),
+ obsCovs=list(oc=oc), numPrimary=3))
+
+ plot(umf1)
+})
+
+
+test_that("colext model fitting works", {
+
+ umf1 <- unmarkedMultFrame(y=y, siteCovs=sc, obsCovs=list(oc=oc),
+ yearlySiteCovs=list(ysc=ysc), numPrimary=nyr)
+
+ fm1 <- colext(~1, ~1, ~1, ~1, umf1)
+ expect_equivalent(coef(fm1),
+ c(0.1422577, -1.4950576, 0.2100365, 1.1998444),
+ tol=1e-6)
+
+ # With site covs
+ fm2 <- colext(~sc1, ~1, ~1, ~1, umf1)
+ expect_equivalent(coef(fm2), c(1.3423, -6.2788,-1.5831,0.1413,1.1638),
+ tol=1e-4)
+
+ # With obs covs
+ fm3 <- colext(~1, ~1, ~1, ~oc, umf1)
+ expect_equivalent(coef(fm3),
+ c(0.1433,-1.4975,0.2082,1.2002,-0.03822),
+ tol=1e-4)
+
+ # With yearly site covs
+ fm4 <- colext(~1, ~ysc, ~ysc, ~1, umf1)
+ expect_equivalent(coef(fm4),
+ c(0.2662,-2.0534,-1.0579,0.2165,0.6877,1.10342), tol=1e-4)
+
+ # ranef
+ r <- ranef(fm4)
+ expect_equal(dim(r@post), c(nsites, nrep, nyr))
+ expect_equal(dim(bup(r)), c(nsites, nyr))
+
+})
+
+test_that("colext handles missing values",{
+
+ umf1 <- unmarkedMultFrame(y=y, siteCovs=sc, obsCovs=list(oc=oc),
+ yearlySiteCovs=list(ysc=ysc), numPrimary=nyr)
+
+ umf2 <- umf1
+ umf2@y[1,3] <- NA
+
+ fm1 <- colext(~1, ~1, ~1, ~1, umf2)
+ expect_is(fm1, "unmarkedFitColExt")
+
+ umf3 <- umf1
+ umf3@y[1,] <- NA
+ expect_warning(fm2 <- colext(~1, ~1, ~1, ~1, umf3))
+ expect_is(fm2, "unmarkedFitColExt")
+ expect_equal(fm2@sitesRemoved, 1)
+
+ umf4 <- umf1
+ umf4@y[1,3:4] <- NA
+ fm3 <- colext(~1, ~1, ~1, ~1, umf4)
+ expect_is(fm3, "unmarkedFitColExt")
+
+ umf5 <- umf1
+ umf5@siteCovs$sc1[1] <- NA
+ expect_warning(fm4 <- colext(~sc1, ~1, ~1, ~1, umf5))
+ expect_warning(pr <- predict(fm4, 'psi'))
+ expect_equal(nrow(pr), 5)
+
+umf5 <- umf1
+ umf5@obsCovs$oc[1] <- NA
+ expect_warning(fm4 <- colext(~1, ~1, ~1, ~oc, umf5))
+ expect_warning(pr <- predict(fm4, 'det'))
+ expect_equal(nrow(pr), nsites*nyr*nrep)
+ expect_true(all(is.na(pr[1,])))
+
+ umf5 <- umf1
+ umf5@yearlySiteCovs$ysc[1] <- NA
+ # This should work, right?
+ expect_error(expect_warning(fm4 <- colext(~1, ~1, ~ysc, ~1, umf5)))
+
+})
+
+test_that("colext errors when random effects are in formula",{
+ umf1 <- unmarkedMultFrame(y=y, siteCovs=sc, obsCovs=list(oc=oc),
+ yearlySiteCovs=list(ysc=ysc), numPrimary=nyr)
+ expect_error(colext(~(1|dummy), ~1, ~ysc, ~1, umf1))
+})
+
+test_that("colext methods work",{
+
+ umf1 <- unmarkedMultFrame(y=y, siteCovs=sc, obsCovs=list(oc=oc),
+ yearlySiteCovs=list(ysc=ysc), numPrimary=nyr)
+ fm1 <- colext(~sc1, ~1, ~ysc, ~oc, umf1)
+
+ pdf(NULL)
+ plot(fm1)
+ dev.off()
+ res <- residuals(fm1)
+ expect_equal(dim(res), c(6,8))
+ r <- ranef(fm1)
+ expect_equal(dim(r@post), c(nsites, nrep, nyr))
+ pr1 <- predict(fm1, 'psi')
+ expect_equal(nrow(pr1), 6)
+ pr2 <- predict(fm1, 'col')
+ expect_equal(nrow(pr2), nsites*nyr)
+ pr3 <- predict(fm1, 'det')
+ expect_equal(nrow(pr3), nsites*nyr*nrep)
+
+ nd <- data.frame(sc1=c(0,1))
+ pr4 <- predict(fm1, 'psi', newdata=nd)
+ expect_equal(nrow(pr4), 2)
+})
diff --git a/tests/testthat/test_crossVal.R b/tests/testthat/test_crossVal.R
new file mode 100644
index 0000000..1d122ae
--- /dev/null
+++ b/tests/testthat/test_crossVal.R
@@ -0,0 +1,90 @@
+context("crossVal method")
+skip_on_cran()
+
+set.seed(123)
+data(frogs)
+pferUMF <- unmarkedFrameOccu(pfer.bin)
+siteCovs(pferUMF) <- data.frame(sitevar1 = rnorm(numSites(pferUMF)))
+obsCovs(pferUMF) <- data.frame(obsvar1 = rnorm(numSites(pferUMF) * obsNum(pferUMF)))
+
+fm <- occu(~ obsvar1 ~ 1, pferUMF[1:20,])
+
+
+test_that("crossVal works with occu models",{
+ set.seed(123)
+ kfold <- crossVal(fm, method='Kfold', folds=10)
+
+ expect_equal(nrow(kfold@stats),10)
+
+ expect_equal(as.numeric(kfold@stats[1,]),
+ c(0.3790110,0.3014053), tolerance=1e-4)
+
+ holdout <- crossVal(fm, method='holdout', holdoutPct=0.25)
+
+ expect_equal(as.numeric(holdout@stats[1,]),
+ c(0.296829,0.262929), tolerance=1e-4)
+
+ leave <- crossVal(fm, method='leaveOneOut')
+
+ expect_equal(nrow(leave@stats),20)
+ expect_equal(as.numeric(leave@stats[1,]),
+ c(0.5985,0.5012), tolerance=1e-4)
+
+ show_output <- capture.output(leave)
+ expect_equal(show_output[1], "Method: leave-one-out")
+
+})
+
+test_that("crossVal works in parallel",{
+ skip_on_cran()
+ skip_on_ci()
+
+ set.seed(123)
+ kfold <- crossVal(fm, method='Kfold', folds=10)
+ set.seed(123)
+ kfold_par <- crossVal(fm, method='Kfold', folds=10, parallel=TRUE, ncores=2)
+ expect_equal(kfold@stats, kfold_par@stats)
+
+
+})
+
+test_that("custom statistics functions work",{
+
+ expect_error(crossVal(fm, statistic=function(x) "fake"))
+
+ new_stat <- function(object){
+ c(mean_res = mean(residuals(object),na.rm=T))
+ }
+
+ kfold_custom <- crossVal(fm, statistic=new_stat)
+ expect_equal(length(kfold_custom@stats[,1]), 10)
+})
+
+test_that("crossValList can be constructed",{
+
+ fm <- occu(~ obsvar1 ~ 1, pferUMF[1:20,])
+ fm2 <- occu(~1 ~1, pferUMF[1:20,])
+
+ fl <- fitList(fm2=fm2,fm=fm)
+ cvlist <- crossVal(fl, method='Kfold')
+
+ expect_is(cvlist, "unmarkedCrossValList")
+ expect_equal(length(cvlist@stats_list),2)
+ show_output <- capture.output(cvlist)
+ expect_equal(show_output[1], "Method: k-fold (10 folds)")
+})
+
+test_that("crossVal works with multinomPois",{
+
+ set.seed(123)
+ data(ovendata)
+ ovenFrame <- unmarkedFrameMPois(ovendata.list$data,
+ siteCovs=as.data.frame(scale(ovendata.list$covariates[,-1])),
+ type = "removal")
+ fm1 <- multinomPois(~ 1 ~ ufc + trba, ovenFrame[1:20,])
+
+ mout <- crossVal(fm1, method='Kfold')
+ expect_equal(as.numeric(mout@stats[1,]),
+ c(0.25859,0.17974), tolerance=1e-4)
+
+})
diff --git a/tests/testthat/test_distsamp.R b/tests/testthat/test_distsamp.R
new file mode 100644
index 0000000..9d6fe04
--- /dev/null
+++ b/tests/testthat/test_distsamp.R
@@ -0,0 +1,311 @@
+context("distsamp fitting function")
+skip_on_cran()
+
+y <- matrix(rep(4:1, 10)[1:10], 5, 2, byrow=TRUE)
+siteCovs <- data.frame(x = c(0, 2, 3, 4, 1))
+
+test_that("unmarkedFrameDS identifies problems with inputs",{
+ #Check error thrown when length(tlength!=nrow(y))
+ expect_error(unmarkedFrameDS(y = y, siteCovs = siteCovs,
+ dist.breaks=c(0, 5, 10)/1000, survey="line", tlength=rep(1, (5-1)),
+ unitsIn="km"))
+ #Check error thrown when length(dist.breaks) != J+1
+ expect_error(unmarkedFrameDS(y = y, siteCovs = siteCovs,
+ dist.breaks=c(5,10)/1000, survey="line", tlength=rep(1, 5),
+ unitsIn="km"))
+
+ #Check error when obs covs are provided
+ oc <- data.frame(z=rnorm(10))
+ expect_error(unmarkedFrameDS(y=y, siteCovs=siteCovs, obsCovs=oc))
+
+ umf <- unmarkedFrameDS(y = y, siteCovs = siteCovs,
+ dist.breaks=c(0, 5, 10)/1000, survey="line", tlength=rep(1, 5),
+ unitsIn="km")
+ expect_is(umf, "unmarkedFrameDS")
+ s <- capture.output(summary(umf))
+ expect_equal(s[1], "unmarkedFrameDS Object")
+
+ expect_error(obsCovs(umf) <- oc)
+
+ # histogram
+ pdf(NULL)
+ pl <- hist(umf)
+ expect_is(pl, "histogram")
+ dev.off()
+
+})
+
+test_that("distsamp works with covariates", {
+ umf <- unmarkedFrameDS(y = y, siteCovs = siteCovs,
+ dist.breaks=c(0, 5, 10)/1000, survey="line", tlength=rep(1, 5),
+ unitsIn="km")
+ fm <- distsamp(~ x ~ x, data = umf)
+
+ lam <- fm['state']
+ det <- fm['det']
+
+ expect_equivalent(coef(lam), c(1.4340999, -0.1102387), tolerance = 1e-4)
+ expect_equivalent(coef(det), c(-4.64686395, -0.09337832), tolerance = 1e-4)
+
+ lam.lc <- linearComb(fm, type = 'state', c(1, 2))
+ det.lc <- linearComb(fm, type = 'det', c(1, 2))
+
+ expect_equivalent(coef(lam.lc), 1.213623, tol = 1e-4)
+ expect_equivalent(coef(det.lc), -4.833621, tol = 1e-4)
+
+ expect_equivalent(coef(backTransform(lam.lc)), 3.365655, tol = 1e-4)
+ expect_equivalent(coef(backTransform(det.lc)), 0.007957658, tol = 1e-4)
+
+})
+
+test_that("distsamp methods work",{
+
+ umf <- unmarkedFrameDS(y = y, siteCovs = siteCovs,
+ dist.breaks=c(0, 5, 10)/1000, survey="line", tlength=rep(1, 5),
+ unitsIn="km")
+ fm <- distsamp(~ x ~ x, data = umf)
+
+ pr <- predict(fm, 'state')
+ expect_equal(dim(pr), c(5,4))
+ expect_equal(pr[1,1], 4.19586, tol=1e-4)
+
+ pr <- predict(fm, 'det')
+ expect_equal(dim(pr), c(5,4))
+ expect_equal(pr[1,1], 0.00959, tol=1e-4)
+
+ nd <- data.frame(x=c(0,1))
+ pr <- predict(fm, 'state', newdata=nd)
+ expect_equal(dim(pr), c(2,4))
+
+ res <- residuals(fm)
+ expect_equal(dim(res), dim(y))
+ expect_equal(res[1,1], -0.01333, tol=1e-4)
+
+ r <- ranef(fm, K=50)
+ expect_is(r, "unmarkedRanef")
+ expect_equal(dim(r@post), c(5,51,1))
+
+ expect_error(hist(fm))
+
+ pdf(NULL)
+ plot(fm)
+ dev.off()
+})
+
+test_that("distsamp ranef method works",{
+
+ set.seed(344)
+ lambda <- 10
+ sigma <- 20
+ npts <- 10
+ radius <- 50
+ breaks <- seq(0, 50, by=10)
+ A <- (2*radius)^2 / 10000 # Area (ha) of square containing circle
+ y <- matrix(0, npts, length(breaks)-1)
+ N <- integer(npts)
+ for(i in 1:npts) {
+ M <- rpois(1, lambda * A) # Individuals within the square
+ xy <- cbind(x=runif(M, -radius, radius),
+ y=runif(M, -radius, radius))
+ d <- apply(xy, 1, function(x) sqrt(x[1]^2 + x[2]^2))
+ d <- d[d <= radius]
+ N[i] <- length(d)
+ if(length(d)) {
+ p <- exp(-d^2 / (2 * sigma^2)) # half-normal
+ d <- d[rbinom(length(d), 1, p) == 1]
+ y[i,] <- table(cut(d, breaks, include.lowest=TRUE))
+ }
+ }
+
+ umf1 <- unmarkedFrameDS(y = y, survey="point",
+ dist.breaks=breaks, unitsIn="m")
+ m1 <- distsamp(~1 ~1, umf1, starts=c(log(5), log(20)))
+ m2 <- distsamp(~1 ~1, umf1, starts=c(log(5), log(20)),
+ output="abund")
+
+ re1 <- ranef(m1, K=20)
+ re2 <- ranef(m2, K=20)
+
+ expect_equal(mode1 <- bup(re1, stat="mode"), bup(re2, "mode"))
+ expect_equal(confint(re1), confint(re2))
+
+ ar1 <- as(re1, "array")
+
+ expect_equivalent(colSums(ar1), c(
+ 0.000000e+00, 2.334960e-01, 8.517322e-01, 1.524261e+00, 1.811577e+00,
+ 1.691348e+00, 1.421738e+00, 1.085003e+00, 7.119743e-01, 3.898376e-01,
+ 1.782052e-01, 6.895313e-02, 2.296231e-02, 6.685198e-03, 1.725009e-03,
+ 3.991224e-04, 8.362689e-05, 1.600128e-05, 2.816112e-06, 4.586885e-07,
+ 6.951721e-08), tolerance=1e-6)
+})
+
+test_that("distsamp line keyfunctions work",{
+ y <- structure(c(7, 7, 12, 9, 9, 11, 9, 5, 7, 6, 25, 26, 30, 26, 23,
+ 24, 20, 33, 26, 32, 5, 3, 8, 7, 1, 4, 4, 7, 7, 6, 3, 1, 1, 4,
+ 4, 4, 3, 6, 2, 3), .Dim = c(10L, 4L))
+ umf <- unmarkedFrameDS(y = y, dist.breaks=c(0, 3, 15, 18, 20),
+ survey="line", unitsIn="m", tlength=rep(100, nrow(y)))
+
+ fm.halfnorm <- distsamp(~1~1, umf)
+ D <- backTransform(fm.halfnorm, type="state")
+ S <- backTransform(fm.halfnorm, type="det")
+ expect_equivalent(coef(D), 129.5509, tol=1e-4)
+ expect_equivalent(SE(D), 9.446125, tol=1e-4)
+ expect_equivalent(coef(S), 18.15386, tol=1e-4)
+ expect_equivalent(SE(S), 2.893362, tol=1e-4)
+
+ fm.exp <- distsamp(~1~1, umf, keyfun="exp", starts=c(4, 0))
+ D <- backTransform(fm.exp, type="state")
+ S <- backTransform(fm.exp, type="det")
+ expect_equivalent(coef(D), 144.8802, tol=1e-4)
+ expect_equivalent(SE(D), 14.31655, tol=1e-4)
+ expect_equivalent(coef(S), 31.75738, tol=1e-4)
+ expect_equivalent(SE(S), 9.711254, tol=1e-4)
+
+ fm.haz <- distsamp(~1~1, umf, keyfun="hazard", starts=c(4, 3, 1))
+ D <- backTransform(fm.haz, type="state")
+ Sh <- backTransform(fm.haz, type="det")
+ Sc <- backTransform(fm.haz, type="scale")
+ expect_equivalent(coef(D), 137.0375, tol=1e-4)
+ expect_equivalent(SE(D), 16.82505, tol=1e-4)
+ expect_equivalent(coef(Sh), 15.90262, tol=1e-4)
+ expect_equivalent(SE(Sh), 5.099981, tol=1e-4)
+ expect_equivalent(coef(Sc), 0.8315524, tol=1e-4)
+ expect_equivalent(SE(Sc), 0.4753275, tol=1e-4)
+
+ fm.unif <- distsamp(~1~1, umf, keyfun="uniform")
+ D <- backTransform(fm.unif, type="state")
+ expect_equivalent(coef(D), 107.5000, tol=1e-4)
+
+ expect_equivalent(coef(fm.halfnorm),
+ coef(update(fm.halfnorm, engine="R")))
+ expect_equivalent(coef(fm.exp),
+ coef(update(fm.exp, engine="R")))
+ expect_equivalent(coef(fm.halfnorm),
+ coef(update(fm.halfnorm, engine="R")))
+ expect_equivalent(coef(fm.halfnorm),
+ coef(update(fm.halfnorm, engine="R")))
+ expect_equivalent(coef(fm.unif), coef(update(fm.unif, engine="R")))
+ expect_equivalent(coef(fm.haz), coef(update(fm.haz, engine="R")), tol=1e-5)
+
+})
+
+test_that("distsamp point keyfunctions work",{
+ y <- structure(c(1, 0, 0, 0, 0, 0, 3, 1, 1, 0, 16, 15, 18, 14, 22,
+ 24, 12, 20, 20, 21, 10, 9, 9, 5, 6, 6, 6, 9, 5, 6, 6, 6, 4, 2,
+ 6, 3, 3, 3, 1, 4), .Dim = c(10L, 4L))
+
+ umf <- unmarkedFrameDS(y = y, dist.breaks=c(0, 3, 15, 18, 20),
+ survey="point", unitsIn="m", tlength=rep(100, 20))
+
+ fm.halfnorm <- distsamp(~1~1, umf)
+ D <- backTransform(fm.halfnorm, type="state")
+ S <- backTransform(fm.halfnorm, type="det")
+ expect_equivalent(coef(D), 316.1711, tol=1e-4)
+ expect_equivalent(SE(D), 37.08797, tol=1e-4)
+ expect_equivalent(coef(S), 18.05958, tol=1e-4)
+ expect_equivalent(SE(S), 3.341798, tol=1e-4)
+
+ fm.exp <- distsamp(~1~1, umf, keyfun="exp", starts=c(6, 0))
+ D <- backTransform(fm.exp, type="state")
+ S <- backTransform(fm.exp, type="det")
+ expect_equivalent(coef(D), 369.7526, tol=1e-4)
+ expect_equivalent(SE(D), 68.11901, tol=1e-4)
+ expect_equivalent(coef(S), 28.90848, tol=1e-4)
+ expect_equivalent(SE(S), 11.66219, tol=1e-4)
+
+ fm.haz <- distsamp(~1~1, umf, keyfun="hazard", starts=c(5, 3, 1))
+ D <- backTransform(fm.haz, type="state")
+ Sh <- backTransform(fm.haz, type="det")
+ Sc <- backTransform(fm.haz, type="scale")
+ expect_equivalent(coef(D), 266.3911, tol=1e-4)
+ expect_equivalent(SE(D), 20.45144, tol=1e-4)
+ expect_equivalent(coef(Sh), 18.69351, tol=1e-4)
+ expect_equivalent(SE(Sh), 0.8950444, tol=1e-4)
+ expect_equivalent(coef(Sc), 5.797366, tol=1e-4)
+ expect_equivalent(SE(Sc), 4.054381, tol=1e-4)
+
+ fm.unif <- distsamp(~1~1, umf, keyfun="uniform")
+ D <- backTransform(fm.unif, type="state")
+ expect_equivalent(coef(D), 236.3451, tol=1e-4)
+
+ expect_equivalent(coef(fm.halfnorm),
+ coef(update(fm.halfnorm, engine="R")))
+ expect_equivalent(coef(fm.exp),
+ coef(update(fm.exp, engine="R")),tol=1e-5)
+ expect_equivalent(coef(fm.halfnorm),
+ coef(update(fm.halfnorm, engine="R")))
+ expect_equivalent(coef(fm.halfnorm),
+ coef(update(fm.halfnorm, engine="R")))
+
+})
+
+test_that("getP works with distsamp",{
+
+ data(issj)
+ jayumf <- unmarkedFrameDS(y=as.matrix(
+ issj[,1:3]),
+ siteCovs=data.frame(scale(issj[,c("elevation","forest","chaparral")])),
+ dist.breaks=c(0,100,200,300), unitsIn="m", survey="point")
+
+ hn <- distsamp(~1 ~1, jayumf)
+ neg <- distsamp(~1 ~1, jayumf,keyfun="exp")
+ unif <- distsamp(~1 ~1, jayumf, keyfun="unif")
+ haz <- distsamp(~1 ~1, jayumf[1:100,], keyfun="hazard")
+
+ expect_equivalent(getP(hn)[1,], c(0.08634098, 0.09873522, 0.02369782),
+ tol=1e-5)
+ expect_equivalent(getP(neg)[1,], c(0.1111111, 0.3333333, 0.5555556),
+ tol=1e-5)
+ expect_equivalent(getP(unif)[1,], c(0.1111111, 0.3333333, 0.5555556),
+ tol=1e-5)
+ expect_equivalent(getP(haz)[1,], c(0.0702,0.2107,0.35117),
+ tol=1e-3)
+})
+
+test_that("distsamp works with random effects",{
+
+ set.seed(123)
+ data(linetran)
+ umf <- unmarkedFrameDS(y=as.matrix(linetran[,1:4]), siteCovs=linetran[,6:7],
+ survey="line", tlength=linetran$Length, unitsIn='m',
+ dist.breaks=c(0,10,20,30,40))
+
+ hn <- distsamp(~1~area+(1|habitat), umf)
+ ex <- distsamp(~1~area+(1|habitat), umf, keyfun="exp")
+ hz <- distsamp(~1~area+(1|habitat), umf, keyfun="hazard")
+ un <- distsamp(~1~area+(1|habitat), umf, keyfun="uniform")
+ mods <- list(hn=hn, ex=ex, hz=hz, un=un)
+ expect_true(all(sapply(mods, function(x) is.list(x@TMB))))
+
+ sigs <- sapply(mods, function(x) sigma(x)$sigma)
+ expect_true(all(sigs < 0.01) & all(sigs > 0.0001))
+
+ pr <- lapply(mods, function(x) predict(x, "state"))
+ expect_true(all(sapply(pr, inherits, "data.frame")))
+
+ data(pointtran)
+ umf <- unmarkedFrameDS(y=as.matrix(pointtran[,1:4]), siteCovs=pointtran[,6:7],
+ survey="point", unitsIn='m',
+ dist.breaks=c(0,10,20,30,40))
+
+ hn <- distsamp(~1~area+(1|habitat), umf)
+ ex <- distsamp(~1~area+(1|habitat), umf, keyfun="exp")
+ hz <- distsamp(~1~area+(1|habitat), umf, keyfun="hazard")
+ un <- distsamp(~1~area+(1|habitat), umf, keyfun="uniform")
+ mods <- list(hn=hn, ex=ex, hz=hz, un=un)
+ expect_true(all(sapply(mods, function(x) is.list(x@TMB))))
+
+ sigs <- sapply(mods, function(x) sigma(x)$sigma)
+ expect_true(all(sigs < 0.01) & all(sigs > 0.0001))
+
+ pr <- lapply(mods, function(x) predict(x, "state"))
+ expect_true(all(sapply(pr, inherits, "data.frame")))
+
+ # Make sure simulate accounts for random effects
+ s <- simulate(hn, nsim=30)
+ avg <- apply(sapply(s, function(x) apply(x,1,sum)),1, mean)
+ # average first count and predicted abundance should be highly correlated
+ pr <- predict(hn, 'state')
+ expect_true(cor(avg, pr$Predicted) > 0.7)
+})
diff --git a/inst/unitTests/runit.distsampOpen.R b/tests/testthat/test_distsampOpen.R
index 29deedd..bd25e8b 100644
--- a/inst/unitTests/runit.distsampOpen.R
+++ b/tests/testthat/test_distsampOpen.R
@@ -1,3 +1,6 @@
+context("distsampOpen fitting function")
+skip_on_cran()
+
simData <- function(lambda=1, gamma=0.5, omega=0.8, sigma=40, scale=NULL,
M=100, T=5, J=4,type="line", keyfun="halfnorm")
{
@@ -96,204 +99,214 @@ if(type=="line"){
return(list(y=matrix(y, M),N=N,cp=cp))
}
-test.unmarkedFrameDSO <- function(){
+test_that("unmarkedFrameDSO build properly", {
y <- simData(lambda=4, gamma=2, omega=0.5, sigma=25, M=100, T=15,type="line",
keyfun="halfnorm")$y
umf <- unmarkedFrameDSO(y = y, numPrimary=15,
siteCovs=data.frame(x1=rnorm(100)),
dist.breaks = c(0, 25, 50, 75, 100), survey="line",
unitsIn="m",tlength=rep(1, 100))
- checkException(unmarkedFrameDSO(y=y,numPrimary=15,
+ expect_error(unmarkedFrameDSO(y=y,numPrimary=15,
dist.breaks=c(0,25,50,75,100), survey="line", tlength=c(1,1)))
- checkException(unmarkedFrameDSO(y=y,numPrimary=15,
+ expect_error(unmarkedFrameDSO(y=y,numPrimary=15,
dist.breaks=c(0,25,50,75,100), survey="point",
tlength=rep(1,100)))
- checkException(unmarkedFrameDSO(y=y, numPrimary=15, dist.breaks=c(25,50,75,100),
+ expect_error(unmarkedFrameDSO(y=y, numPrimary=15, dist.breaks=c(25,50,75,100),
survey='line', unitsIn='m', tlength=rep(1,100)))
-}
-test.distsampOpen.halfnormal <- function()
-{
+ # subset sites
+ umf_sub <- umf[1:3,]
+ expect_equal(nrow(umf_sub@y), 3)
+})
+
+test_that("dso halfnorm key function works",{
set.seed(456)
- y <- simData(lambda=4, gamma=2, omega=0.5, sigma=25, M=100, T=15,type="line",
+ y <- simData(lambda=4, gamma=2, omega=0.5, sigma=25, M=50, T=7,type="line",
keyfun="halfnorm")$y
- umf <- unmarkedFrameDSO(y = y, numPrimary=15,
- siteCovs=data.frame(x1=rnorm(100)),
+ umf <- unmarkedFrameDSO(y = y, numPrimary=7,
+ siteCovs=data.frame(x1=rnorm(50)),
dist.breaks = c(0, 25, 50, 75, 100), survey="line",
- unitsIn="m",tlength=rep(1, 100))
+ unitsIn="m",tlength=rep(1, 50))
+
+ # Check K that is too small
+ expect_error(distsampOpen(~1, ~1, ~1, ~x1, data = umf, K=5,keyfun="halfnorm"))
- fm <- distsampOpen(~1, ~1, ~1, ~x1, data = umf, K=30,keyfun="halfnorm")
+ fm <- distsampOpen(~1, ~1, ~1, ~x1, data = umf, K=10,keyfun="halfnorm")
- checkEqualsNumeric(coef(fm), c(1.38017,0.69961,0.053022,3.17838,0.0043299),
- tol=1e-5)
+ expect_equivalent(coef(fm), c(1.4185,1.0471,-0.8275,3.1969,-0.0790),
+ tol=1e-4)
pr <- predict(fm, type='lambda')
- checkEqualsNumeric(as.numeric(pr[1,]),
- c(3.9756,0.3474,3.3497,4.7183), tol=1e-4)
+ expect_equal(as.numeric(pr[1,]),
+ c(4.1308,0.4965,3.2622,5.2306), tol=1e-4)
pval <- getP(fm)
- checkEqualsNumeric(dim(pval), dim(y))
- checkEqualsNumeric(pval[1,1:4], c(0.211395,0.078579,0.0107615,0.0005353),
- tol=1e-5)
+ expect_equal(dim(pval), dim(y))
+ expect_equal(pval[1,1:4], c(0.2110,0.0776,0.0104,0.0005),
+ tol=1e-4)
r <- residuals(fm)
- checkEqualsNumeric(dim(r), dim(y))
- checkEqualsNumeric(r[1,1:4], c(-0.84042,-0.31240,-0.042783,-0.0021283),tol=1e-4)
+ expect_equal(dim(r), dim(y))
+ expect_equal(r[1,1:2], c(-0.8717,-0.3207),tol=1e-4)
ran <- ranef(fm)
- checkEqualsNumeric(bup(ran)[1,1], 2.777855, tol=1e-5)
+ expect_equal(bup(ran)[1,1], 2.8916, tol=1e-4)
set.seed(123)
sim <- simulate(fm, nsim=2)
- checkEqualsNumeric(length(sim), 2)
- checkEqualsNumeric(sim[[1]][1,1:3], c(1,0,0))
+ expect_equal(length(sim), 2)
+ expect_equal(sum(sim[[1]]), 442)
fm2 <- update(fm, pformula=~1)
- checkEqualsNumeric(length(coef(fm2)), 4)
+ expect_equal(length(coef(fm2)), 4)
+
+ fm <- distsampOpen(~1, ~1, ~1, ~x1, data = umf, K=10,keyfun="halfnorm",
+ mixture="ZIP")
+ expect_warning(pr <- predict(fm, 'lambda'))
+ expect_is(pr, "data.frame")
+ expect_equal(as.numeric(pr[1,]), c(4.0742, NA,NA,NA), tol=1e-4)
#Point
set.seed(123)
- y <- simData(lambda=4, gamma=2, omega=0.5, sigma=25, M=100, T=15,type="point",
+ y <- simData(lambda=4, gamma=2, omega=0.5, sigma=25, M=50, T=7,type="point",
keyfun="halfnorm")$y
- umf <- unmarkedFrameDSO(y = y, numPrimary=15,
- siteCovs=data.frame(x1=rnorm(100)),
+ umf <- unmarkedFrameDSO(y = y, numPrimary=7,
+ siteCovs=data.frame(x1=rnorm(50)),
dist.breaks = c(0, 25, 50, 75, 100), survey="point",
unitsIn="m")
- fm <- distsampOpen(~1, ~1, ~1, ~x1, data = umf, K=30,keyfun="halfnorm")
- checkEqualsNumeric(coef(fm), c(1.43259,0.82993,-0.295220,3.205348,-0.000132),
+ fm <- distsampOpen(~1, ~1, ~1, ~x1, data = umf, K=10,keyfun="halfnorm")
+ expect_equivalent(coef(fm), c(1.2766,0.4651,0.23799,3.24919,0.00821),
tol=1e-4)
#Check error with random effects in formula
- checkException(distsampOpen(~(1|dummy), ~1, ~1, ~1, data=umf, K=30))
-}
+ expect_error(distsampOpen(~(1|dummy), ~1, ~1, ~1, data=umf, K=30))
+})
-test.distsampOpen.NA <- function(){
+test_that("distsampOpen works with NAs", {
set.seed(456)
- y <- simData(lambda=4, gamma=2, omega=0.5, sigma=25, M=30, T=5,type="line",
+ y <- simData(lambda=4, gamma=2, omega=0.5, sigma=25, M=15, T=2,type="line",
keyfun="halfnorm")$y
y[5,1:4] <- NA
y[2,1] <- NA
- sc = data.frame(x1=rnorm(30))
+ sc = data.frame(x1=rnorm(15))
sc$x1[3] <- NA
- ysc = data.frame(x2=rnorm(30*5))
- ysc$x2[46] <- NA
+ ysc = data.frame(x2=rnorm(15*2))
+ ysc$x2[1] <- NA
- umf <- unmarkedFrameDSO(y = y, numPrimary=5,
+ umf <- unmarkedFrameDSO(y = y, numPrimary=2,
siteCovs=sc,
yearlySiteCovs=ysc,
dist.breaks = c(0, 25, 50, 75, 100), survey="line",
- unitsIn="m",tlength=rep(1, 30))
+ unitsIn="m",tlength=rep(1, 15))
- fm <- distsampOpen(~x1, ~x2, ~1, ~1, data=umf, K=25, keyfun="halfnorm")
- checkEqualsNumeric(coef(fm), c(1.497405,-0.0826876,-0.662144,
- 0.651976,2.054032,3.1728838), tol=1e-4)
+ expect_warning(fm <- distsampOpen(~x1, ~x2, ~1, ~1, data=umf, K=7, keyfun="halfnorm"))
+ expect_equivalent(coef(fm), c(1.3058,-0.2966,-7.9133,-7.9281,8.6582,3.3108), tol=1e-4)
set.seed(123)
- ysim <- simData(lambda=5, gamma=2, omega=0.5, sigma=40, M=300, T=5,type="line",
+ ysim <- simData(lambda=5, gamma=2, omega=0.5, sigma=40, M=50, T=5,type="line",
keyfun="halfnorm")
y <- ysim$y
y[2,1] <- NA
umf <- unmarkedFrameDSO(y = y, numPrimary=5,
dist.breaks = c(0, 25, 50, 75, 100), survey="line",
- unitsIn="m",tlength=rep(1, 300))
+ unitsIn="m",tlength=rep(1, 50))
- fm <- distsampOpen(~1, ~1, ~1, ~1, data=umf, K=25, keyfun="halfnorm")
+ fm <- distsampOpen(~1, ~1, ~1, ~1, data=umf, K=10, keyfun="halfnorm")
- r <- ranef(fm)
- checkEqualsNumeric(cor(bup(r)[,1],ysim$N[,1]), 0.71089, tol=1e-4)
+ expect_warning(r <- ranef(fm))
+ expect_equal(cor(bup(r)[,1],ysim$N[,1]), 0.6593, tol=1e-4)
-}
+})
-test.distsampOpen.exp <- function(){
+test_that("distsampOpen exp keyfunction works", {
set.seed(123)
- y <- simData(lambda=4, gamma=2, omega=0.5, sigma=25, M=100, T=10,type="line",
+ y <- simData(lambda=4, gamma=2, omega=0.5, sigma=25, M=50, T=5,type="line",
keyfun="exp")$y
- umf <- unmarkedFrameDSO(y = y, numPrimary=10,
- siteCovs=data.frame(x1=rnorm(100)),
+ umf <- unmarkedFrameDSO(y = y, numPrimary=5,
+ siteCovs=data.frame(x1=rnorm(50)),
dist.breaks = c(0, 25, 50, 75, 100), survey="line",
- unitsIn="m",tlength=rep(1, 100))
+ unitsIn="m",tlength=rep(1, 50))
- fm <- distsampOpen(~1, ~1, ~1, ~x1, data = umf, K=25,keyfun="exp")
- checkEqualsNumeric(coef(fm), c(1.34009,0.69997,-0.11887,3.17950,0.029042),
+ fm <- distsampOpen(~1, ~1, ~1, ~x1, data = umf, K=10,keyfun="exp")
+ expect_equivalent(coef(fm), c(1.47976,0.38259,0.15922,3.2837,-0.01028),
tol=1e-4)
#Point
- set.seed(456)
- y <- simData(lambda=4, gamma=2, omega=0.5, sigma=25, M=100, T=10,type="point",
+ set.seed(123)
+ y <- simData(lambda=4, gamma=2, omega=0.5, sigma=25, M=30, T=3,type="point",
keyfun="exp")$y
- umf <- unmarkedFrameDSO(y = y, numPrimary=10,
- siteCovs=data.frame(x1=rnorm(100)),
+ umf <- unmarkedFrameDSO(y = y, numPrimary=3,
+ siteCovs=data.frame(x1=rnorm(30)),
dist.breaks = c(0, 25, 50, 75, 100), survey="point",
unitsIn="m")
- fm <- distsampOpen(~1, ~1, ~1, ~x1, data = umf, K=25,keyfun="exp")
- checkEqualsNumeric(coef(fm), c(1.39598,0.64463,0.053240,3.23198,0.012271),
+ fm <- distsampOpen(~1, ~1, ~1, ~x1, data = umf, K=10,keyfun="exp")
+ expect_equivalent(coef(fm), c(1.5032,-3.6228,9.25622,3.09501,0.05183),
tol=1e-4)
-}
+})
-test.distsampOpen.unif <- function(){
+test_that("distsampOpen uniform keyfun works", {
set.seed(123)
- y <- simData(lambda=4, gamma=2, omega=0.5, sigma=25, M=100, T=10,type="line",
+ y <- simData(lambda=4, gamma=2, omega=0.5, sigma=25, M=50, T=5,type="line",
keyfun="uniform")$y
- umf <- unmarkedFrameDSO(y = y, numPrimary=10,
- siteCovs=data.frame(x1=rnorm(100)),
+ umf <- unmarkedFrameDSO(y = y, numPrimary=5,
+ siteCovs=data.frame(x1=rnorm(50)),
dist.breaks = c(0, 25, 50, 75, 100), survey="line",
- unitsIn="m",tlength=rep(1, 100))
+ unitsIn="m",tlength=rep(1, 50))
- fm <- distsampOpen(~1, ~1, ~1, data = umf, K=25,keyfun="unif")
- checkEqualsNumeric(coef(fm), c(1.47853,0.7475,-0.115096),
+ fm <- distsampOpen(~1, ~1, ~1, data = umf, K=15,keyfun="unif")
+ expect_equivalent(coef(fm), c(1.4586,0.7262,-0.05239),
tol=1e-4)
set.seed(123)
- y <- simData(lambda=4, gamma=2, omega=0.5, sigma=25, M=100, T=10,type="point",
+ y <- simData(lambda=4, gamma=2, omega=0.5, sigma=25, M=50, T=5,type="point",
keyfun="uniform")$y
- umf <- unmarkedFrameDSO(y = y, numPrimary=10,
- siteCovs=data.frame(x1=rnorm(100)),
+ umf <- unmarkedFrameDSO(y = y, numPrimary=5,
+ siteCovs=data.frame(x1=rnorm(50)),
dist.breaks = c(0, 25, 50, 75, 100), survey="point",
unitsIn="m")
- fm <- distsampOpen(~1, ~1, ~1, data = umf, K=25,keyfun="unif")
- checkEqualsNumeric(coef(fm), c(1.36098,0.69191,-0.03537),
+ fm <- distsampOpen(~1, ~1, ~1, data = umf, K=15,keyfun="unif")
+ expect_equivalent(coef(fm), c(1.4730,0.6887,-0.1756),
tol=1e-4)
-}
+})
-test.distsampOpen.hazard <- function(){
+test_that("distsampOpen hazard keyfun works", {
set.seed(123)
y <- simData(lambda=4, gamma=2, omega=0.5, sigma=25, scale=1,
- M=100, T=10,type="line", keyfun="hazard")$y
- umf <- unmarkedFrameDSO(y = y, numPrimary=10,
- siteCovs=data.frame(x1=rnorm(100)),
+ M=30, T=3,type="line", keyfun="hazard")$y
+ umf <- unmarkedFrameDSO(y = y, numPrimary=3,
+ siteCovs=data.frame(x1=rnorm(30)),
dist.breaks = c(0, 25, 50, 75, 100), survey="line",
- unitsIn="m",tlength=rep(1, 100))
+ unitsIn="m",tlength=rep(1, 30))
- fm <- distsampOpen(~1, ~1, ~1, ~x1, data = umf, K=25,keyfun="hazard")
- checkEqualsNumeric(coef(fm), c(1.40843,0.64105,-0.010841,3.297099,-0.02168,0.07719),
+ fm <- distsampOpen(~1, ~1, ~1, ~x1, data = umf, K=30,keyfun="hazard")
+ expect_equivalent(coef(fm), c(1.2671,0.6878,-1.715,4.0409,0.00578,-0.08012),
tol=1e-4)
-}
+})
-test.distsampOpen.NB <- function(){
+test_that("distsampOpen NB abundance model works",{
set.seed(123)
- y <- simData(lambda=4, gamma=2, omega=0.5, sigma=25, M=100, T=10,type="line",
+ y <- simData(lambda=4, gamma=2, omega=0.5, sigma=25, M=30, T=3,type="line",
keyfun="exp")$y
- umf <- unmarkedFrameDSO(y = y, numPrimary=10,
- siteCovs=data.frame(x1=rnorm(100)),
+ umf <- unmarkedFrameDSO(y = y, numPrimary=3,
+ siteCovs=data.frame(x1=rnorm(30)),
dist.breaks = c(0, 25, 50, 75, 100), survey="line",
- unitsIn="m",tlength=rep(1, 100))
+ unitsIn="m",tlength=rep(1, 30))
- fm <- distsampOpen(~1, ~1, ~1, ~x1, data = umf, K=25,keyfun="exp",
+ fm <- distsampOpen(~1, ~1, ~1, ~x1, data = umf, K=10,keyfun="exp",
mixture="NB")
- checkEqualsNumeric(coef(fm), c(1.34009,0.699979,-0.118878,3.179589,
- 0.0290938,9.238497), tol=1e-4)
+ expect_equivalent(coef(fm), c(1.0517,0.5117,0.01159,3.34406,0.14606,8.23921), tol=1e-4)
-}
+})
-test.distsampOpen.dynamics <- function(){
+test_that("distsampOpen dynamics models work",{
set.seed(123)
y <- simData(lambda=4, gamma=2, omega=0.5, sigma=25, M=100, T=10,type="line",
keyfun="uniform")$y
@@ -304,23 +317,23 @@ test.distsampOpen.dynamics <- function(){
fm <- distsampOpen(~1, ~1, ~1, data = umf, K=25,keyfun="unif",
dynamics="notrend")
- checkEqualsNumeric(coef(fm), c(1.4080889, -0.1006024), tol=1e-5)
+ expect_equivalent(coef(fm), c(1.4080889, -0.1006024), tol=1e-5)
fm <- distsampOpen(~1, ~1, ~1, data = umf, K=25, keyfun="unif",
dynamics="trend")
- checkEqualsNumeric(coef(fm), c(1.518695, -0.0143889), tol=1e-5)
+ expect_equivalent(coef(fm), c(1.518695, -0.0143889), tol=1e-5)
fm <- distsampOpen(~1, ~1, ~1, data = umf, K=25, keyfun="unif",
dynamics="autoreg")
- checkEqualsNumeric(coef(fm), c(1.518686, -0.018026, -5.628779), tol=1e-5)
+ expect_equivalent(coef(fm), c(1.518686, -0.018026, -5.628779), tol=1e-5)
#Sketchy estimates
#Maybe just because data were simulated using a different process?
#Leaving these in for now just to make sure they run without errors
- fm <- distsampOpen(~1, ~1, ~1, data = umf, K=25, keyfun="unif",
- dynamics="gompertz")
+ expect_warning(fm <- distsampOpen(~1, ~1, ~1, data = umf, K=25, keyfun="unif",
+ dynamics="gompertz"))
- fm <- distsampOpen(~1, ~1, ~1, data = umf, K=25, keyfun="unif",
- dynamics="ricker")
+ expect_warning(fm <- distsampOpen(~1, ~1, ~1, data = umf, K=25, keyfun="unif",
+ dynamics="ricker"))
-}
+})
diff --git a/tests/testthat/test_fitList.R b/tests/testthat/test_fitList.R
new file mode 100644
index 0000000..c33c03d
--- /dev/null
+++ b/tests/testthat/test_fitList.R
@@ -0,0 +1,41 @@
+context("fitLists")
+
+skip_on_cran()
+
+y <- matrix(rep(0:1,10)[1:10],5,2)
+siteCovs <- data.frame(x = c(0,2,3,4,1))
+obsCovs <- data.frame(o1 = 1:10, o2 = exp(-5:4)/10)
+umf <- unmarkedFrameOccu(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
+fm <- occu(~ o1 + o2 ~ x, data = umf)
+fm2 <- occu(~1~x, data=umf)
+
+test_that("fitList operations work",{
+
+ fl <- fitList(fm=fm, fm2=fm2)
+ expect_is(fl, "unmarkedFitList")
+
+ out <- capture.output(summary(fl))
+ expect_equal(out[c(2,23)], rep("Call:", 2))
+
+ cf <- coef(fl)
+ expect_equal(dim(cf), c(2,5))
+ expect_equivalent(cf[,1], c(8.590737, 10.887214), tol=1e-4)
+ expect_true(all(is.na(cf[2,4:5])))
+
+ se <- SE(fl)
+ expect_equal(dim(se), c(2,5))
+ expect_true(all(is.na(se[2,4:5])))
+ expect_equivalent(se[1,1], SE(fm)[1])
+
+ pr <- predict(fl, type='state')
+ expect_is(pr, "data.frame")
+ expect_equal(dim(pr), c(5,4))
+
+ mt <- modSel(fl)
+ out <- capture.output(mt)
+ expect_equal(out[1], " nPars AIC delta AICwt cumltvWt")
+
+ se <- SE(mt)
+ expect_equal(dim(se), c(2,5))
+
+})
diff --git a/inst/unitTests/runit.utils.R b/tests/testthat/test_formatInputs.R
index a271f32..7f8526b 100644
--- a/inst/unitTests/runit.utils.R
+++ b/tests/testthat/test_formatInputs.R
@@ -1,4 +1,50 @@
-test.formatLong <- function() {
+context("input formatting functions")
+
+test_that("formatDistData function works",{
+ dat <- data.frame(distance=1:100, site=gl(5, 20),
+ visit=factor(rep(1:4, each=5)))
+ cutpt <- seq(0, 100, by=25)
+ y <- formatDistData(dat, "distance", "site", cutpt)
+ expect_equivalent(y, matrix(c(20, 0, 0, 0,
+ 5, 15, 0, 0,
+ 0, 10, 10, 0,
+ 0, 0, 15, 5,
+ 0, 0, 0, 20), 5, 4, byrow=TRUE))
+ dat.bad <- dat
+ dat.bad$distance <- as.character(dat$distance)
+ expect_error(formatDistData(dat.bad, "distance", "site", cutpt))
+
+ dat.bad <- dat
+ dat.bad$site <- as.character(dat$site)
+ y2 <- expect_warning(formatDistData(dat.bad, "distance", "site", cutpt))
+ expect_equivalent(y2, matrix(c(20, 0, 0, 0,
+ 5, 15, 0, 0,
+ 0, 10, 10, 0,
+ 0, 0, 15, 5,
+ 0, 0, 0, 20), 5, 4, byrow=TRUE))
+
+ y3 <- formatDistData(dat, "distance", "site", cutpt, "visit")
+ expect_equivalent(y3, matrix(c(
+5, 0, 0, 0, 5, 0, 0, 0, 5, 0, 0, 0, 5, 0, 0, 0,
+5, 0, 0, 0, 0, 5, 0, 0, 0, 5, 0, 0, 0, 5, 0, 0,
+0, 5, 0, 0, 0, 5, 0, 0, 0, 0, 5, 0, 0, 0, 5, 0,
+0, 0, 5, 0, 0, 0, 5, 0, 0, 0, 5, 0, 0, 0, 0, 5,
+0, 0, 0, 5, 0, 0, 0, 5, 0, 0, 0, 5, 0, 0, 0, 5), 5, 16, byrow=TRUE))
+
+ effortMatrix <- matrix(ncol=4, nrow=5,c(1,0))
+ y4 <- formatDistData(dat, "distance","site",cutpt, "visit",effortMatrix)
+ expect_equivalent(y4, matrix(c(
+ 5, 0, 0, 0, NA,NA,NA,NA, 5, 0, 0, 0, NA,NA,NA,NA,
+ NA,NA,NA,NA, 0, 5, 0, 0, NA,NA,NA,NA, 0, 5, 0, 0,
+ 0, 5, 0, 0, NA,NA,NA,NA, 0, 0, 5, 0, NA,NA,NA,NA,
+ NA,NA,NA,NA, 0, 0, 5, 0, NA,NA,NA,NA, 0, 0, 0, 5,
+ 0, 0, 0, 5, NA,NA,NA,NA, 0, 0, 0, 5, NA,NA,NA,NA), 5, 16, byrow=TRUE))
+
+ effortMatrix <- matrix(ncol=4, nrow=5,"a")
+ expect_error(formatDistData(dat, "distance","site",cutpt, "visit",effortMatrix))
+})
+
+test_that("formatLong works correctly",{
df <- read.csv(system.file("csv","frog2001pcru.csv", package = "unmarked"),
stringsAsFactors=TRUE)
umf <- formatLong(df, type = "unmarkedFrameOccu")
@@ -14,7 +60,7 @@ test.formatLong <- function() {
})
withdate <- formatLong(test, type = "unmarkedFrameOccu")
- checkEquals(withdate,
+ expect_equal(withdate,
new("unmarkedFrameOccu", y = structure(c(1L, 0L, 1L, 1L), .Dim = c(2L, 2L)),
obsCovs = structure(list(JulianDate = structure(c(17262, 17267, 17262, 17267),
class = "Date")),
@@ -38,12 +84,12 @@ test.formatLong <- function() {
withfac <- formatLong(test, type = "unmarkedFrameOccu")
- checkEquals(withfac,
+ expect_equal(withfac,
new("unmarkedFrameOccu",
y = structure(c(1L, 0L, 1L, 0L, 1L, 1L, 0L, 0L, 0L, 1L, 1L, 0L), .Dim = 4:3),
obsCovs = structure(list(ocov = c(1.51, -0.09, 2.02, -0.06, 1.3, 2.29, -1.39, -0.28,
-0.13, 0.64, -0.28, -2.66),
- obsfac = structure(c(1L, 1L, 1L, 1L, 2L, 2L, 2L,
+ obsfac = structure(c(1L, 1L, 1L, 1L, 2L, 2L, 2L,
2L, 1L, 2L, 1L, 2L),
.Label = c("A", "B"), class = "factor"),
JulianDate = c(13, 20, 26, 13, 20, 26, 13, 20, 26, 13, 20, 26)),
@@ -72,8 +118,8 @@ test.formatLong <- function() {
'd','b','a',
'a','a','c',
'a','b','a')), nrow=R, ncol=J, byrow=TRUE))
- umf <- unmarkedFramePCount(y=y, siteCovs=site.covs,
- obsCovs=obs.covs) # organize data
+ expect_warning(umf <- unmarkedFramePCount(y=y, siteCovs=site.covs,
+ obsCovs=obs.covs)) # organize data
# Corresponding long data.frame
pcdf <- data.frame(site = rep(seq(R), each = J),
occasion = rep(1:J, R),
@@ -82,12 +128,12 @@ test.formatLong <- function() {
x2 = factor(rep(c('A','B', 'A', 'B'), each = J)),
x3 = as.vector(t(obs.covs$x3)),
x4 = as.vector(t(obs.covs$x4)))
- umf1 <- formatLong(pcdf, type = "unmarkedFramePCount")
+ expect_warning(umf1 <- formatLong(pcdf, type = "unmarkedFramePCount"))
# formatLong tacks on JulianDate to obsCovs, so ignore this difference
- checkEquals(umf@y, umf1@y)
- checkEquals(umf@siteCovs, umf1@siteCovs)
- checkEquals(umf@obsCovs, umf1@obsCovs[, c("x3", "x4")])
- checkEquals(umf@obsToY, umf1@obsToY)
+ expect_equal(umf@y, umf1@y)
+ expect_equal(umf@siteCovs, umf1@siteCovs)
+ expect_equal(umf@obsCovs, umf1@obsCovs[, c("x3", "x4")])
+ expect_equal(umf@obsToY, umf1@obsToY)
# Compare manual and automatic open point count frame
y1 <- matrix(c(
@@ -112,8 +158,8 @@ test.formatLong <- function() {
1, 3, 5, 6, 7)), nrow=4, ncol=5, byrow=TRUE)
# Create the unmarkedFrame
- umf1 <- unmarkedFramePCO(y=y1, siteCovs=sc1, obsCovs=oc1, numPrimary=5,
- primaryPeriod=primaryPeriod1)
+ expect_warning(umf1 <- unmarkedFramePCO(y=y1, siteCovs=sc1, obsCovs=oc1, numPrimary=5,
+ primaryPeriod=primaryPeriod1))
test <- data.frame(site = rep(1:4, each = 5),
obsnum = 1:5,
@@ -122,14 +168,14 @@ test.formatLong <- function() {
x2 = factor(rep(c('A','A','B','B'), each = 5)),
x3 = 1:5,
x4 = letters[1:5])
- umf2 <- formatLong(test, type = "unmarkedFramePCO", numPrimary = 5,
- primaryPeriod = primaryPeriod1)
+ expect_warning(umf2 <- formatLong(test, type = "unmarkedFramePCO", numPrimary = 5,
+ primaryPeriod = primaryPeriod1))
# formatLong tacks on JulianDate to obsCovs, so ignore this difference
- checkEquals(umf1@y, umf2@y)
- checkEquals(umf1@siteCovs, umf2@siteCovs)
- checkEquals(umf1@obsCovs, umf2@obsCovs[, c("x3", "x4")])
- checkEquals(umf1@obsToY, umf2@obsToY)
- checkEquals(umf1@primaryPeriod, umf2@primaryPeriod)
+ expect_equal(umf1@y, umf2@y)
+ expect_equal(umf1@siteCovs, umf2@siteCovs)
+ expect_equal(umf1@obsCovs, umf2@obsCovs[, c("x3", "x4")])
+ expect_equal(umf1@obsToY, umf2@obsToY)
+ expect_equal(umf1@primaryPeriod, umf2@primaryPeriod)
# Compare manual and automatic unmarkedFrameDS object
# Manual creation from help
@@ -152,12 +198,12 @@ test.formatLong <- function() {
x2 = factor(rep(c('A','B', 'A', 'B'), each = J)))
umf1 <- formatLong(dsdf, type = "unmarkedFrameDS", dist.breaks = db,
survey = "point", unitsIn = "m")
- checkEquals(umf, umf1)
+ expect_equal(umf, umf1)
-}
+})
-test.formatMult <- function() {
+test_that("formatMult works correctly",{
test <- expand.grid(site = LETTERS[1:4], visit = 1:3, year = 2015:2016)
test <- test[with(test, order(site, year, visit)), ]
test <- test[, c("year", "site", "visit")]
@@ -175,7 +221,7 @@ test.formatMult <- function() {
withfac <- formatMult(test)
- checkEquals(withfac,
+ expect_equal(withfac,
new("unmarkedMultFrame",
numPrimary = 2L,
yearlySiteCovs = structure(list(ysfac = structure(c(1L, 1L, 1L, 2L, 1L, 2L, 1L, 2L),
@@ -201,52 +247,21 @@ test.formatMult <- function() {
obsToY = structure(c(1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0,
0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0,
0, 0, 0, 0, 1), .Dim = c(6L, 6L))))
-}
-
-test.invertHessian <- function(){
-
- a <- 4; b <- 7; c <- 2; d <- 6
- mat <- matrix(c(a,b,c,d), nrow=2, byrow=T)
- mat_det <- a*d-b*c
- inv_mat <- 1/mat_det * matrix(c(d, -b, -c, a), nrow=2, byrow=T)
-
- fake_opt <- list(hessian=mat)
-
- #Successful inversion
- checkEqualsNumeric(unmarked:::invertHessian(fake_opt, nrow(mat), TRUE),
- inv_mat)
-
- #When se=F
- checkEqualsNumeric(unmarked:::invertHessian(fake_opt, nrow(mat), FALSE),
- matrix(rep(NA,4), nrow=2))
-
- #When matrix is not invertible
- bad_opt <- list(hessian=matrix(c(1, -2, -3, 6), nrow=2, byrow=T))
- checkException(solve(bad_opt$hessian))
-
- #Should generate warning
- options(warn=2)
- checkException(unmarked:::invertHessian(bad_opt, nrow(bad_opt$hessian), TRUE))
- options(warn=0)
-
- #Should result in matrix of NAs
- checkEqualsNumeric(unmarked:::invertHessian(bad_opt, nrow(bad_opt$hessian), FALSE),
- matrix(rep(NA,4), nrow=2))
-}
-
-test.csvToUMF <- function(){
-
- options(warn=2)
- checkException(umf <- csvToUMF(system.file("csv","csv_factor_test.csv",
+})
+
+test_that("csvToUMF function works",{
+
+
+ expect_warning(umf <- csvToUMF(system.file("csv","csv_factor_test.csv",
package = "unmarked"), type="unmarkedFrameOccu"))
- options(warn=0)
- umf <- csvToUMF(system.file("csv","csv_factor_test.csv",
- package = "unmarked"), type="unmarkedFrameOccu")
- checkEquals(sapply(siteCovs(umf), class), c(elev="numeric", forest="factor"))
- checkEquals(sapply(obsCovs(umf), class), c(wind="numeric", rain="factor"))
-
+ expect_warning(umf <- csvToUMF(system.file("csv","csv_factor_test.csv",
+ package = "unmarked"), type="unmarkedFrameOccu"))
+
+ expect_equal(sapply(siteCovs(umf), class), c(elev="numeric", forest="factor"))
+ expect_equal(sapply(obsCovs(umf), class), c(wind="numeric", rain="factor"))
+
df <- as(umf, "data.frame")
- checkEqualsNumeric(dim(df), c(20,11))
-}
+ expect_equivalent(dim(df), c(20,11))
+})
diff --git a/inst/unitTests/runit.gdistremoval.R b/tests/testthat/test_gdistremoval.R
index 21f6ba8..8f453a5 100644
--- a/inst/unitTests/runit.gdistremoval.R
+++ b/tests/testthat/test_gdistremoval.R
@@ -1,4 +1,5 @@
-# Simulation function
+context("gdistremoval fitting function")
+skip_on_cran()
simData <- function(lambda=1, sigma=40, scale=NULL, remP=0.4, remJ=4,
M=100, J=4,type="point", keyfun="halfnorm", T=1, phi=1)
@@ -203,7 +204,7 @@ cp <- u <- a <- numeric(J)
return(list(y=y,N=N,yRem=yRem,group=group,group_eff=group_eff))
}
-test.gdistremoval.frame <- function(){
+test_that("unmarkedFrameGDR is constructed correctly",{
set.seed(123)
# Single primary period
@@ -214,30 +215,30 @@ test.gdistremoval.frame <- function(){
umf <- unmarkedFrameGDR(simdat$y, simdat$yRem, siteCovs=sc,
obsCovs=oc, dist.breaks=c(0,10,20,30,40),
unitsIn='m')
- checkTrue(inherits(umf, "unmarkedFrameGDR"))
+ expect_true(inherits(umf, "unmarkedFrameGDR"))
# Check subsetting
umf_sub <- umf[1:3,]
- checkTrue(inherits(umf_sub, "unmarkedFrameGDR"))
- checkEqualsNumeric(numSites(umf_sub), 3)
- checkException(umf[,1:2])
+ expect_true(inherits(umf_sub, "unmarkedFrameGDR"))
+ expect_equivalent(numSites(umf_sub), 3)
+ expect_error(umf[,1:2])
# Input mistake handling
# Wrong number of dist.breaks
- checkException(unmarkedFrameGDR(simdat$y, simdat$yRem, siteCovs=sc,
+ expect_error(unmarkedFrameGDR(simdat$y, simdat$yRem, siteCovs=sc,
obsCovs=oc, dist.breaks=c(0,10,20,30),
unitsIn='m'))
# Wrong number of period.lengths
- checkException(unmarkedFrameGDR(simdat$y, simdat$yRem, siteCovs=sc,
+ expect_error(unmarkedFrameGDR(simdat$y, simdat$yRem, siteCovs=sc,
obsCovs=oc, dist.breaks=c(0,10,20,30,40),
unitsIn='m', period.lengths=c(1,1,1)))
# row sums of yDistance and yRemoval don't match
yRem_bad <- simdat$yRem
yRem_bad[which(yRem_bad>0)[1]] <- 0
- checkException(unmarkedFrameGDR(simdat$y, yRem_bad, siteCovs=sc,
+ expect_error(unmarkedFrameGDR(simdat$y, yRem_bad, siteCovs=sc,
obsCovs=oc, dist.breaks=c(0,10,20,30,40),
unitsIn='m'))
@@ -253,34 +254,33 @@ test.gdistremoval.frame <- function(){
# Check subsetting
umf_sub <- umf2[1:3,]
- checkTrue(inherits(umf_sub, "unmarkedFrameGDR"))
- checkEqualsNumeric(numSites(umf_sub), 3)
- checkEqualsNumeric(nrow(siteCovs(umf_sub)), 3)
- checkEqualsNumeric(nrow(obsCovs(umf_sub)), 3*15)
- checkEqualsNumeric(nrow(yearlySiteCovs(umf_sub)), 3*3)
+ expect_true(inherits(umf_sub, "unmarkedFrameGDR"))
+ expect_equivalent(numSites(umf_sub), 3)
+ expect_equivalent(nrow(siteCovs(umf_sub)), 3)
+ expect_equivalent(nrow(obsCovs(umf_sub)), 3*15)
+ expect_equivalent(nrow(yearlySiteCovs(umf_sub)), 3*3)
umf_sub <- umf2[,1:2]
- checkEqualsNumeric(ncol(umf_sub@yRemoval), 10)
- checkEqualsNumeric(ncol(umf_sub@yDistance), 8)
- checkEqualsNumeric(nrow(umf_sub@obsCovs), 10*100)
- checkEqualsNumeric(nrow(umf_sub@yearlySiteCovs), 2*100)
- checkEqualsNumeric(umf_sub@numPrimary, 2)
-
-}
-
-test.gdistremoval <- function(){
+ expect_equivalent(ncol(umf_sub@yRemoval), 10)
+ expect_equivalent(ncol(umf_sub@yDistance), 8)
+ expect_equivalent(nrow(umf_sub@obsCovs), 10*100)
+ expect_equivalent(nrow(umf_sub@yearlySiteCovs), 2*100)
+ expect_equivalent(umf_sub@numPrimary, 2)
+})
+
+test_that("gdistremoval can fit models",{
set.seed(123)
- sc <- data.frame(sc1=rnorm(300))
- oc <- data.frame(oc1=rnorm(5*300))
+ sc <- data.frame(sc1=rnorm(50))
+ oc <- data.frame(oc1=rnorm(5*50))
# Half-normal
- dat <- simData(lambda=5, sigma=50, M=300, J=4, remP=0.2, remJ=5)
+ dat <- simData(lambda=5, sigma=50, M=50, J=4, remP=0.2, remJ=5)
umf <- unmarkedFrameGDR(dat$y, dat$yRem, siteCovs=sc, obsCovs=oc,
dist.breaks=c(0,25,50,75,100), unitsIn='m')
fit <- gdistremoval(~sc1,removalformula=~oc1,distanceformula=~1, data=umf)
- checkTrue(inherits(fit, "unmarkedFitGDR"))
- checkEqualsNumeric(coef(fit), c(1.7759, 0.0491, 3.8030, -1.4560, 0.0731), tol=1e-3)
+ expect_is(fit, "unmarkedFitGDR")
+ expect_equivalent(coef(fit), c(1.4571,0.3374,4.0404,-1.65389,0.16789), tol=1e-3)
# With unequal period lengths
umf2 <- unmarkedFrameGDR(dat$y, dat$yRem, siteCovs=sc, obsCovs=oc,
@@ -288,102 +288,108 @@ test.gdistremoval <- function(){
period.lengths=c(1,5,1,1,1))
fit2 <- gdistremoval(~sc1,removalformula=~oc1,distanceformula=~1, data=umf2)
- checkEqualsNumeric(coef(fit2), c(3.24070,0.04638,3.8045,-4.00957,0.09266), tol=1e-3)
+ expect_equivalent(coef(fit2), c(2.7732,0.3241,4.0477,-3.9774,0.1418), tol=1e-3)
# With negative binomial
fit3 <- gdistremoval(~sc1,removalformula=~oc1,distanceformula=~1, data=umf,
mixture="NB")
- checkEqualsNumeric(coef(fit3), c(1.7771,0.0491,6.061,3.8032,-1.4585,0.0730), tol=1e-3)
+ expect_equivalent(coef(fit3), c(1.4571,0.33742,8.3535,4.0404,-1.6539,0.1679), tol=1e-3)
# With exponential
set.seed(123)
- dat <- simData(lambda=5, sigma=50, M=300, J=4, remP=0.2, remJ=5, keyfun="exp")
+ dat <- simData(lambda=5, sigma=50, M=50, J=4, remP=0.2, remJ=5, keyfun="exp")
umf4 <- unmarkedFrameGDR(dat$y, dat$yRem, siteCovs=sc, obsCovs=oc,
dist.breaks=c(0,25,50,75,100), unitsIn='m')
fit4 <- gdistremoval(~sc1,removalformula=~oc1,distanceformula=~1, data=umf4,
keyfun="exp")
- checkEqualsNumeric(coef(fit4), c(1.5876,-0.0194,3.9263,-1.3335,-0.03879), tol=1e-3)
+ expect_equivalent(coef(fit4), c(1.54527,0.0045,4.2135,-1.8776,-0.27996), tol=1e-3)
# With hazard
set.seed(123)
- dat <- simData(lambda=5, sigma=50, M=300, J=4, remP=0.2, remJ=5)
+ dat <- simData(lambda=5, sigma=50, M=50, J=4, remP=0.2, remJ=5)
umf5 <- unmarkedFrameGDR(dat$y, dat$yRem, siteCovs=sc, obsCovs=oc,
dist.breaks=c(0,25,50,75,100), unitsIn='m')
fit5 <- gdistremoval(~sc1,removalformula=~oc1,distanceformula=~1, data=umf5,
keyfun="hazard")
- checkEqualsNumeric(coef(fit5), c(1.3710,0.04585,4.0143,0.9900,-1.2050,-0.06878), tol=1e-3)
+ expect_equivalent(coef(fit5), c(1.4477,0.0569,4.10349,1.39400,-1.419985,-0.08351), tol=1e-3)
# With uniform
set.seed(123)
- dat <- simData(lambda=5, sigma=50, M=300, J=4, remP=0.2, remJ=5)
+ dat <- simData(lambda=5, sigma=50, M=50, J=4, remP=0.2, remJ=5)
umf6 <- unmarkedFrameGDR(dat$y, dat$yRem, siteCovs=sc, obsCovs=oc,
dist.breaks=c(0,25,50,75,100), unitsIn='m')
fit6 <- gdistremoval(~sc1,removalformula=~oc1,distanceformula=~1, data=umf6,
keyfun="uniform")
- checkEqualsNumeric(coef(fit6), c(0.6838,0.0459,-1.207,-0.0687), tol=1e-3)
+ expect_equivalent(coef(fit6), c(0.7887,0.0569,-1.4197,-0.083708), tol=1e-3)
# Methods
gp <- getP(fit)
- checkEqualsNumeric(dim(gp$dist), c(300,4,1))
- checkEqualsNumeric(dim(gp$rem), c(300,5,1))
+ expect_equivalent(dim(gp$dist), c(50,4,1))
+ expect_equivalent(dim(gp$rem), c(50,5,1))
s <- simulate(fit, 2)
- checkEqualsNumeric(length(s), 2)
- checkEqualsNumeric(dim(s[[1]]$yDistance), dim(fit@data@yDistance))
- checkEqualsNumeric(dim(s[[1]]$yRemoval), dim(fit@data@yRemoval))
+ expect_equivalent(length(s), 2)
+ expect_equivalent(dim(s[[1]]$yDistance), dim(fit@data@yDistance))
+ expect_equivalent(dim(s[[1]]$yRemoval), dim(fit@data@yRemoval))
r <- ranef(fit)
- checkEqualsNumeric(length(bup(r)), 300)
+ expect_equivalent(length(bup(r)), 50)
pb <- parboot(fit, nsim=2)
- checkTrue(inherits(pb, "parboot"))
+ expect_is(pb, "parboot")
-}
+ # Fit list construction
+ fl <- fitList(fits=list(fit1=fit, fit2=fit))
+ expect_is(fl, "unmarkedFitList")
+ ms <- modSel(fl)
+ expect_is(ms, "unmarkedModSel")
+})
-test.gdistremoval.predict <- function(){
- set.seed(123)
+test_that("gdistremoval predict method works",{
- sc <- data.frame(sc1=rnorm(300), sc2=sample(letters[1:5],300,replace=T))
- oc <- data.frame(oc1=rnorm(5*300))
+ set.seed(123)
+
+ sc <- data.frame(sc1=rnorm(50), sc2=sample(letters[1:5],50,replace=T))
+ oc <- data.frame(oc1=rnorm(5*50))
# Half-normal
- dat <- simData(lambda=5, sigma=50, M=300, J=4, remP=0.2, remJ=5)
- umf <- unmarkedFrameGDR(dat$y, dat$yRem, siteCovs=sc, obsCovs=oc,
- dist.breaks=c(0,25,50,75,100), unitsIn='m')
+ dat <- simData(lambda=5, sigma=50, M=50, J=4, remP=0.2, remJ=5)
+ umf <- expect_warning(unmarkedFrameGDR(dat$y, dat$yRem, siteCovs=sc, obsCovs=oc,
+ dist.breaks=c(0,25,50,75,100), unitsIn='m'))
fit <- gdistremoval(~sc1+sc2,removalformula=~oc1+sc1,distanceformula=~1, data=umf)
pr <- predict(fit, 'lambda')
- checkEqualsNumeric(dim(pr), c(300,4))
+ expect_equivalent(dim(pr), c(50,4))
nd <- data.frame(sc1=c(0,1), sc2='a')
pr <- predict(fit, 'lambda', newdata=nd)
- checkEqualsNumeric(dim(pr), c(2,4))
+ expect_equivalent(dim(pr), c(2,4))
nd <- data.frame(sc1=c(0,1), sc2=letters[6])
- checkException(predict(fit, 'lambda', newdata=nd))
+ expect_error(predict(fit, 'lambda', newdata=nd))
pr <- predict(fit, 'rem')
- checkEqualsNumeric(dim(pr), c(5*300,4))
+ expect_equivalent(dim(pr), c(5*50,4))
nd <- data.frame(oc1=c(0,1))
- checkException(predict(fit, 'lambda', newdata=nd))
+ expect_error(predict(fit, 'lambda', newdata=nd))
nd <- data.frame(oc1=c(0,1), sc1=c(0,1))
pr <- predict(fit, 'rem', newdata=nd)
- checkEqualsNumeric(dim(pr), c(2,4))
+ expect_equivalent(dim(pr), c(2,4))
pr <- predict(fit, 'dist')
- checkEqualsNumeric(dim(pr), c(300,4))
+ expect_equivalent(dim(pr), c(50,4))
- checkException(predict(fit, 'test'))
-}
+ expect_error(predict(fit, 'test'))
+})
-test.gdistremoval.na <- function(){
+test_that("gdistremoval handles NAs",{
set.seed(123)
- sc <- data.frame(sc1=rnorm(300), sc2=sample(letters[1:5],300,replace=T))
- oc <- data.frame(oc1=rnorm(5*300))
+ sc <- data.frame(sc1=rnorm(50), sc2=sample(letters[1:5],50,replace=T))
+ oc <- data.frame(oc1=rnorm(5*50))
# Half-normal
- dat <- simData(lambda=5, sigma=50, M=300, J=4, remP=0.2, remJ=5)
+ dat <- simData(lambda=5, sigma=50, M=50, J=4, remP=0.2, remJ=5)
yDist <- dat$y
yDist[1,1] <- NA
@@ -393,72 +399,72 @@ test.gdistremoval.na <- function(){
yRem[3,1] <- NA
yRem[2,] <- NA
- umf <- unmarkedFrameGDR(yDist, yRem, siteCovs=sc, obsCovs=oc,
- dist.breaks=c(0,25,50,75,100), unitsIn='m')
+ expect_warning(umf <- unmarkedFrameGDR(yDist, yRem, siteCovs=sc, obsCovs=oc,
+ dist.breaks=c(0,25,50,75,100), unitsIn='m'))
fit <- gdistremoval(~1,removalformula=~1,distanceformula=~1, data=umf)
- checkEqualsNumeric(coef(fit), c(1.7084,3.81973,-1.4819), tol=1e-3)
+ expect_equivalent(coef(fit), c(2.0675,3.908,-2.1433), tol=1e-3)
umf2 <- umf
umf2@siteCovs$sc1[1] <- NA
- checkException(gdistremoval(~sc1,removalformula=~1,distanceformula=~1, data=umf2))
-}
+ expect_error(gdistremoval(~sc1,removalformula=~1,distanceformula=~1, data=umf2))
+})
-test.gdistremoval.multiperiod <- function(){
+test_that("multi-period data works with gdistremoval",{
set.seed(123)
- sc <- data.frame(sc1=rnorm(300))
- oc <- data.frame(oc1=rnorm(5*300*10))
- ysc <- data.frame(ysc1=rnorm(300*10))
+ sc <- data.frame(sc1=rnorm(30))
+ oc <- data.frame(oc1=rnorm(5*30*5))
+ ysc <- data.frame(ysc1=rnorm(30*5))
- dat <- simData(lambda=5, sigma=30, M=300, T=10, J=4, remP=0.2, remJ=5, phi=0.5)
+ dat <- simData(lambda=5, sigma=30, M=30, T=5, J=4, remP=0.2, remJ=5, phi=0.5)
umf <- unmarkedFrameGDR(dat$y, dat$yRem, siteCovs=sc, obsCovs=oc, yearlySiteCovs=ysc,
- dist.breaks=c(0,25,50,75,100), unitsIn='m', numPrimary=10)
+ dist.breaks=c(0,25,50,75,100), unitsIn='m', numPrimary=5)
fit <- gdistremoval(~sc1,phiformula=~ysc1, removalformula=~oc1,distanceformula=~1, data=umf)
- checkEqualsNumeric(coef(fit),
- c(1.6884,-0.0156,0.05479,0.00021,3.39992,-1.5703,0.01918),
+ expect_equivalent(coef(fit),
+ c(2.1013,-0.1142,-1.3187,-0.1483,3.3981,-0.5142,0.233678),
tol=1e-3)
# Predict
pr <- predict(fit, 'phi')
- checkEqualsNumeric(dim(pr), c(300*10,4))
- checkEqualsNumeric(as.numeric(pr[1,]), c(0.5145,0.1225,0.2884,0.7348), tol=1e-3)
+ expect_equal(dim(pr), c(30*5,4))
+ expect_equal(as.numeric(pr[1,1]), c(0.1916), tol=1e-3)
# getP
gp <- getP(fit)
- checkEqualsNumeric(lapply(gp, dim)$phi, c(300,10))
+ expect_equal(lapply(gp, dim)$phi, c(30,5))
# ranef
r <- ranef(fit)
- checkEqualsNumeric(dim(bup(r)), c(300,10))
+ expect_equal(dim(bup(r)), c(30,5))
-}
+})
-test.gdistremoval.random <- function(){
+test_that("gdistremoval works with random effects",{
set.seed(123)
- dat <- simDataRand(lambda=5, lam_sd=0.4, groups=10, sigma=50, M=500, J=4, remP=0.2, remJ=5) #
- sc <- data.frame(sc1=rnorm(500), group=dat$group)
- oc <- data.frame(oc1=rnorm(5*500))
- umf <- unmarkedFrameGDR(dat$y, dat$yRem, siteCovs=sc, obsCovs=oc,
- dist.breaks=c(0,25,50,75,100), unitsIn='m')
+ dat <- simDataRand(lambda=5, lam_sd=0.4, groups=10, sigma=50, M=50, J=4, remP=0.2, remJ=5) #
+ sc <- data.frame(sc1=rnorm(50), group=dat$group)
+ oc <- data.frame(oc1=rnorm(5*50))
+ umf <- expect_warning(unmarkedFrameGDR(dat$y, dat$yRem, siteCovs=sc, obsCovs=oc,
+ dist.breaks=c(0,25,50,75,100), unitsIn='m'))
fit <- gdistremoval(~sc1+(1|group),removalformula=~oc1,distanceformula=~1, data=umf)
- checkEqualsNumeric(coef(fit), c(1.5854, -0.0452, 3.8999, -1.2795, 0.08595),
+ expect_equivalent(coef(fit), c(1.50680,0.07968,3.9373,-1.2148,0.09809),
tol=1e-4)
- checkEqualsNumeric(sigma(fit)$sigma, 0.4080, tol=1e-4)
+ expect_equal(sigma(fit)$sigma, 0.2866, tol=1e-4)
pr <- predict(fit, "lambda")
- checkTrue(inherits(pr, "data.frame"))
+ expect_is(pr, "data.frame")
pr <- predict(fit, "lambda", newdata=umf@siteCovs[1:2,])
- checkTrue(inherits(pr, "data.frame"))
+ expect_is(pr, "data.frame")
s <- simulate(fit, 2)
- checkTrue(inherits(s, "list"))
+ expect_is(s, "list")
- pb <- parboot(fit, nsim=2)
- checkTrue(inherits(pb, "parboot"))
+ pb <- parboot(fit, nsim=1)
+ expect_is(pb, "parboot")
-}
+})
diff --git a/inst/unitTests/runit.gdistsamp.R b/tests/testthat/test_gdistsamp.R
index f169158..f215d90 100644
--- a/inst/unitTests/runit.gdistsamp.R
+++ b/tests/testthat/test_gdistsamp.R
@@ -1,59 +1,58 @@
-test.gdistsamp.covs <- function() {
- set.seed(343)
- R <- 30 # number of transects
- T <- 3 # number of replicates
- strip.width <- 50
- transect.length <- 100
- breaks <- seq(0, 50, by=10)
-
- lambda <- 5 # Abundance
- phi <- 0.6 # Availability
- sigma <- 30 # Half-normal shape parameter
-
- J <- length(breaks)-1
- y <- array(0, c(R, J, T))
- for(i in 1:R) {
- M <- rpois(1, lambda) # Individuals within the 1-ha strip
- for(t in 1:T) {
- # Distances from point
- d <- runif(M, 0, strip.width)
- # Detection process
- if(length(d)) {
- cp <- phi*exp(-d^2 / (2 * sigma^2)) # half-normal w/ g(0)<1
- d <- d[rbinom(length(d), 1, cp) == 1]
- y[i,,t] <- table(cut(d, breaks, include.lowest=TRUE))
- }
- }
- }
- y <- matrix(y, nrow=R) # convert array to matrix
-
- #Check that error thrown when length(tlength)!=nrow(y)
- checkException(unmarkedFrameGDS(y = y, survey="line", unitsIn="m",
- dist.breaks=breaks,
- tlength=rep(transect.length, (R-1)), numPrimary=T))
- # Throw error when length(distbreaks) != J+1
- checkException(unmarkedFrameGDS(y = y, survey="line", unitsIn="m",
- dist.breaks=breaks[-1],
- tlength=rep(transect.length, R), numPrimary=T))
-
- # Organize data
- umf <- unmarkedFrameGDS(y = y, survey="line", unitsIn="m",
- dist.breaks=breaks,
- tlength=rep(transect.length, R), numPrimary=T)
-
- # Fit the model
- fm1 <- gdistsamp(~1, ~1, ~1, umf, output="density", se=FALSE)
-
- checkEqualsNumeric(coef(fm1), c( 1.71894803, -0.03744387, 3.54452329))
-
- re1 <- ranef(fm1)
- checkEqualsNumeric(bup(re1, "mode")[1:7], c(3,5,3,5,5,2,5))
-
- # Check error when formula has random effects
- checkException(gdistsamp(~(1|dummy), ~1, ~1, umf))
-}
-
-test.gdistsamp.halfnorm <- function(){
+context("gdistsamp fitting function")
+skip_on_cran()
+
+test_that("unmarkedFrameGDS subset works",{
+ y <- matrix(1:27, 3)
+ sc <- data.frame(x1 = 1:3)
+ ysc <- list(x2 = matrix(1:9, 3))
+
+ umf1 <- unmarkedFrameGDS(
+ y = y,
+ siteCovs = sc,
+ yearlySiteCovs = ysc,
+ numPrimary = 3,
+ survey="point",
+ dist.breaks=c(0, 10, 20, 30),
+ unitsIn="m")
+
+ dat <- as(umf1, "data.frame")
+ expect_equal(nrow(dat), nrow(y))
+
+ umf1.site1 <- umf1[1,]
+ expect_equal(umf1.site1@y, y[1,, drop=FALSE])
+ expect_equal(umf1.site1@siteCovs, sc[1,, drop=FALSE])
+ expect_equivalent(unlist(umf1.site1@yearlySiteCovs),
+ ysc$x2[1,, drop=FALSE])
+ expect_equal(umf1.site1@numPrimary, 3)
+ expect_equal(umf1.site1@survey, "point")
+
+ umf1.sites1and3 <- umf1[c(1,3),]
+
+
+ umf2 <- unmarkedFrameGDS(
+ y = y,
+ siteCovs = sc,
+ yearlySiteCovs = ysc,
+ numPrimary = 3,
+ survey="line",
+ dist.breaks=c(0, 10, 20, 30),
+ tlength=rep(1,nrow(y)),
+ unitsIn="m")
+
+ dat <- as(umf2, "data.frame")
+
+ umf2.site1 <- umf2[1,]
+ expect_equal(umf2.site1@y, y[1,, drop=FALSE])
+ expect_equal(umf2.site1@siteCovs, sc[1,, drop=FALSE])
+ expect_equivalent(unlist(umf2.site1@yearlySiteCovs),
+ ysc$x2[1,, drop=FALSE])
+ expect_equal(umf2.site1@numPrimary, 3)
+ expect_equal(umf2.site1@survey, "line")
+
+ umf2.sites1and3 <- umf2[c(1,3),]
+})
+
+test_that("gdistsamp with halfnorm keyfunction works",{
#Line
set.seed(343)
R <- 30
@@ -90,19 +89,26 @@ test.gdistsamp.halfnorm <- function(){
dist.breaks=breaks,
tlength=rep(transect.length, R), numPrimary=T)
+ # R and C give same result
+ fm_R <- gdistsamp(~1, ~1, ~1, umf, output="density", se=FALSE, engine="R",
+ control=list(maxit=1))
+ fm_C <- gdistsamp(~1, ~1, ~1, umf, output="density", se=FALSE, engine="C",
+ control=list(maxit=1))
+ expect_equal(coef(fm_R), coef(fm_C))
+
#When output = density
- fm_R <- gdistsamp(~1, ~1, ~1, umf, output="density", se=FALSE, engine="R")
+ #fm_R <- gdistsamp(~1, ~1, ~1, umf, output="density", se=FALSE, engine="R")
fm_C <- gdistsamp(~1, ~1, ~1, umf, output="density", se=FALSE, engine="C")
- checkEqualsNumeric(coef(fm_R),c(0.6584008,-0.4440278,3.4817094),tol=1e-4)
- checkEqualsNumeric(coef(fm_R),coef(fm_C),tol=1e-4)
+ expect_equivalent(coef(fm_C),c(0.6584008,-0.4440278,3.4817094),tol=1e-4)
+ #expect_equivalent(coef(fm_R),coef(fm_C),tol=1e-4)
#When output = abundance
- fm_R <- gdistsamp(~1, ~1, ~1, umf, output="abund", se=FALSE, engine="R")
+ #fm_R <- gdistsamp(~1, ~1, ~1, umf, output="abund", se=FALSE, engine="R")
fm_C <- gdistsamp(~1, ~1, ~1, umf, output="abund", se=FALSE, engine="C")
- checkEqualsNumeric(coef(fm_R),c(1.35067,-0.44262,3.48149),tol=1e-4)
- checkEqualsNumeric(coef(fm_R),coef(fm_C),tol=1e-4)
+ expect_equivalent(coef(fm_C),c(1.35067,-0.44262,3.48149),tol=1e-4)
+ #expect_equivalent(coef(fm_R),coef(fm_C),tol=1e-4)
#With covariates
umf <- unmarkedFrameGDS(y = y, siteCovs=covs, yearlySiteCovs=covs,
@@ -110,25 +116,35 @@ test.gdistsamp.halfnorm <- function(){
dist.breaks=breaks,
tlength=rep(transect.length, R), numPrimary=T)
- fm_R <- gdistsamp(~par1, ~par2, ~par3, umf, output="density", se=FALSE, engine="R")
+ #fm_R <- gdistsamp(~par1, ~par2, ~par3, umf, output="density", se=FALSE, engine="R")
fm_C <- gdistsamp(~par1, ~par2, ~par3, umf, output="density", se=FALSE, engine="C")
- checkEqualsNumeric(coef(fm_R),c(1.24510,0.54419,-1.28146,-0.109737,
+ expect_equivalent(coef(fm_C),c(1.24510,0.54419,-1.28146,-0.109737,
3.46295,-0.13228),tol=1e-4)
- checkEqualsNumeric(coef(fm_R),coef(fm_C),tol=1e-4)
-
- #Predict
-
+ #expect_equivalent(coef(fm_R),coef(fm_C),tol=1e-4)
+
+ # methods
+ res <- residuals(fm_C)
+ expect_equal(dim(res), c(30,15))
+ expect_equal(res[1,1], -0.07133, tol=1e-4)
+ r <- ranef(fm_C)
+ expect_equal(dim(r@post), c(30,108,1))
+ expect_equal(bup(r)[1], 1.94300, tol=1e-5)
+ s <- simulate(fm_C, 2)
+ expect_is(s, "list")
+ expect_equal(length(s), 2)
+ pb <- parboot(fm_C, nsim=1)
+ expect_is(pb, "parboot")
#Negative binomial
- fm_R <- gdistsamp(~par1, ~par2, ~par3, umf, output="density", se=FALSE,
- mixture="NB", engine="R")
+ #fm_R <- gdistsamp(~par1, ~par2, ~par3, umf, output="density", se=FALSE,
+ # mixture="NB", engine="R")
fm_C <- gdistsamp(~par1, ~par2, ~par3, umf, output="density", se=FALSE,
mixture="NB", engine="C")
- checkEqualsNumeric(coef(fm_R),c(1.41241,0.52442,-1.49024,-0.10546,
+ expect_equivalent(coef(fm_C),c(1.41241,0.52442,-1.49024,-0.10546,
3.46284,-0.129831,3.16892),tol=1e-4)
- checkEqualsNumeric(coef(fm_R),coef(fm_C),tol=1e-4)
+ #expect_equivalent(coef(fm_R),coef(fm_C),tol=1e-4)
#With missing values
yna <- y
@@ -138,14 +154,14 @@ test.gdistsamp.halfnorm <- function(){
dist.breaks=breaks,
tlength=rep(transect.length, R), numPrimary=T)
- fm_R <- gdistsamp(~par1, ~par2, ~par3, umf, output="density",
- se=FALSE, engine="R")
+ #fm_R <- gdistsamp(~par1, ~par2, ~par3, umf, output="density",
+ # se=FALSE, engine="R")
fm_C <- gdistsamp(~par1, ~par2, ~par3, umf, output="density",
se=FALSE, engine="C")
- checkEqualsNumeric(coef(fm_R),c(1.35065,0.52558,-1.39758,-0.10675,
+ expect_equivalent(coef(fm_C),c(1.35065,0.52558,-1.39758,-0.10675,
3.46283,-0.136344),tol=1e-4)
- checkEqualsNumeric(coef(fm_R),coef(fm_C),tol=1e-4)
+ #expect_equivalent(coef(fm_R),coef(fm_C),tol=1e-4)
#With an entire session missing
yna <- y
@@ -155,22 +171,22 @@ test.gdistsamp.halfnorm <- function(){
dist.breaks=breaks,
tlength=rep(transect.length, R), numPrimary=T)
- fm_R <- gdistsamp(~par1, ~par2, ~par3, umf, output="density",
- se=FALSE, engine="R")
+ #fm_R <- gdistsamp(~par1, ~par2, ~par3, umf, output="density",
+ # se=FALSE, engine="R")
fm_C <- gdistsamp(~par1, ~par2, ~par3, umf, output="density",
se=FALSE, engine="C")
- checkEqualsNumeric(coef(fm_R),c(1.30815,0.53527,-1.35387,-0.11038,
+ expect_equivalent(coef(fm_C),c(1.30815,0.53527,-1.35387,-0.11038,
3.46293,-0.13458),tol=1e-4)
- checkEqualsNumeric(coef(fm_R),coef(fm_C),tol=1e-4)
+ #expect_equivalent(coef(fm_R),coef(fm_C),tol=1e-4)
#Point
set.seed(123)
data(issj)
- covs <- issj[,c("elevation","forest","chaparral")]
+ covs <- issj[1:100,c("elevation","forest","chaparral")]
area <- pi*300^2 / 100^2
# Area in ha
- jayumf <- unmarkedFrameGDS(y=as.matrix(issj[,1:3]),
+ jayumf <- unmarkedFrameGDS(y=as.matrix(issj[1:100,1:3]),
siteCovs=data.frame(covs, area),
yearlySiteCovs=data.frame(covs),
numPrimary=1,
@@ -180,16 +196,28 @@ test.gdistsamp.halfnorm <- function(){
sc.s <- scale(sc)
sc.s[,"area"] <- pi*300^2 / 10000 # Don't standardize area
covs <- siteCovs(jayumf) <- sc.s
- fm_R <- gdistsamp(~elevation, ~1, ~chaparral, jayumf, output='density',
- engine="R", se=F)
+ #fm_R <- gdistsamp(~elevation, ~1, ~chaparral, jayumf, output='density',
+ # engine="R", se=F)
fm_C <- gdistsamp(~elevation, ~1, ~chaparral, jayumf, output='density',
engine="C", se=F)
- checkEqualsNumeric(coef(fm_R),c(-2.42178,-0.17874,4.38373,0.62425),tol=1e-4)
- checkEqualsNumeric(coef(fm_R),coef(fm_C),tol=1e-4)
-}
+ expect_equivalent(coef(fm_C),c(-4.1009,-0.2363,3.5557,8.7543),tol=1e-4)
+ #expect_equivalent(coef(fm_R),coef(fm_C),tol=1e-4)
+
+ # Check error when formula has random effects
+ expect_error(gdistsamp(~(1|dummy), ~1, ~1, umf))
+
+ # R and C engines return same result
+ fm_C <- gdistsamp(~elevation, ~1, ~chaparral, jayumf, output='density',
+ engine="C", se=F, control=list(maxit=1))
+ fm_R <- gdistsamp(~elevation, ~1, ~chaparral, jayumf, output='density',
+ engine="R", se=F, control=list(maxit=1))
+ expect_equal(coef(fm_C), coef(fm_R))
+
+
+})
-test.gdistsamp.uniform <- function(){
+test_that("gdistsamp with uniform keyfunction works",{
#Line
set.seed(343)
R <- 30
@@ -227,13 +255,20 @@ test.gdistsamp.uniform <- function(){
dist.breaks=breaks,
tlength=rep(transect.length, R), numPrimary=T)
+ # R and C engines return same result
fm_R <- gdistsamp(~par1, ~par2, ~1, umf, output="density",
- keyfun="uniform", se=FALSE, engine="R")
+ keyfun="uniform", se=FALSE, engine="C", control=list(maxit=1))
+ fm_C <- gdistsamp(~par1, ~par2, ~1, umf, output="density",
+ keyfun="uniform", se=FALSE, engine="R", control=list(maxit=1))
+ expect_equal(coef(fm_R), coef(fm_C))
+
+ #fm_R <- gdistsamp(~par1, ~par2, ~1, umf, output="density",
+ # keyfun="uniform", se=FALSE, engine="R")
fm_C <- gdistsamp(~par1, ~par2, ~1, umf, output="density",
keyfun="uniform", se=FALSE, engine="C")
- checkEqualsNumeric(coef(fm_R),c(1.17120,0.54748,-1.60963,-0.13009),tol=1e-4)
- checkEqualsNumeric(coef(fm_R),coef(fm_C),tol=1e-4)
+ expect_equivalent(coef(fm_C),c(1.17120,0.54748,-1.60963,-0.13009),tol=1e-4)
+ #expect_equivalent(coef(fm_R),coef(fm_C),tol=1e-4)
#Point: doesn't work with this dataset, find another one?
#OR maybe uniform just doesn't work with point?
@@ -252,14 +287,14 @@ test.gdistsamp.uniform <- function(){
sc.s <- scale(sc)
sc.s[,"area"] <- pi*300^2 / 10000 # Don't standardize area
covs <- siteCovs(jayumf) <- sc.s
- checkException(gdistsamp(~1, ~1, ~1, jayumf, output='density',
+ expect_error(gdistsamp(~1, ~1, ~1, jayumf, output='density',
keyfun='uniform', engine="R", se=F))
- checkException(gdistsamp(~elevation, ~1, ~1, jayumf, output='density',
+ expect_error(gdistsamp(~elevation, ~1, ~1, jayumf, output='density',
keyfun='uniform', engine="C", se=F))
-}
+})
-test.gdistsamp.exp <- function(){
+test_that("gdistsamp with exp keyfunction works",{
#Line
set.seed(343)
R <- 30
@@ -298,22 +333,29 @@ test.gdistsamp.exp <- function(){
dist.breaks=breaks,
tlength=rep(transect.length, R), numPrimary=T)
+ # R and C engines return same result
+ fm_C <- gdistsamp(~par1, ~par2, ~par3, umf, output="density", se=FALSE,
+ keyfun="exp",engine="C", control=list(maxit=1))
fm_R <- gdistsamp(~par1, ~par2, ~par3, umf, output="density", se=FALSE,
- keyfun="exp",engine="R")
+ keyfun="exp",engine="R", control=list(maxit=1))
+ expect_equal(fm_C@AIC, fm_R@AIC)
+
+ #fm_R <- gdistsamp(~par1, ~par2, ~par3, umf, output="density", se=FALSE,
+ # keyfun="exp",engine="R")
fm_C <- gdistsamp(~par1, ~par2, ~par3, umf, output="density", se=FALSE,
keyfun="exp",engine="C")
- checkEqualsNumeric(coef(fm_R),c(1.28243,0.54312,-1.16608,-0.101122,
+ expect_equivalent(coef(fm_C),c(1.28243,0.54312,-1.16608,-0.101122,
3.86666,-0.2492846),tol=1e-4)
- checkEqualsNumeric(coef(fm_R),coef(fm_C),tol=1e-4)
+ #expect_equivalent(coef(fm_R),coef(fm_C),tol=1e-4)
#Point
set.seed(123)
data(issj)
- covs <- issj[,c("elevation","forest","chaparral")]
+ covs <- issj[1:100,c("elevation","forest","chaparral")]
area <- pi*300^2 / 100^2
# Area in ha
- jayumf <- unmarkedFrameGDS(y=as.matrix(issj[,1:3]),
+ jayumf <- unmarkedFrameGDS(y=as.matrix(issj[1:100,1:3]),
siteCovs=data.frame(covs, area),
yearlySiteCovs=data.frame(covs),
numPrimary=1,
@@ -323,17 +365,23 @@ test.gdistsamp.exp <- function(){
sc.s <- scale(sc)
sc.s[,"area"] <- pi*300^2 / 10000 # Don't standardize area
covs <- siteCovs(jayumf) <- sc.s
- fm_R <- gdistsamp(~elevation, ~1, ~chaparral, jayumf, output='density',
- keyfun="exp",engine="R", se=F)
+ #fm_R <- gdistsamp(~elevation, ~1, ~chaparral, jayumf, output='density',
+ # keyfun="exp",engine="R", se=F)
fm_C <- gdistsamp(~elevation, ~1, ~chaparral, jayumf, output='density',
keyfun="exp",engine="C", se=F)
- checkEqualsNumeric(coef(fm_R),c(-1.531876,-0.2037537,3.870335,
- 0.89988),tol=1e-4)
- checkEqualsNumeric(coef(fm_R),coef(fm_C),tol=1e-4)
-}
+ expect_equivalent(coef(fm_C),c(-3.1952,-0.1244,3.7986,3.6574),tol=1e-4)
+ #expect_equivalent(coef(fm_R),coef(fm_C),tol=1e-4)
+
+ fm_C <- gdistsamp(~elevation, ~1, ~chaparral, jayumf, output='density',
+ keyfun="exp",engine="C", se=F,control=list(maxit=1))
+ fm_R <- gdistsamp(~elevation, ~1, ~chaparral, jayumf, output='density',
+ keyfun="exp",engine="R", se=F, control=list(maxit=1))
+ expect_equal(fm_C@AIC, fm_R@AIC, tol=1e-5)
+
+})
-test.gdistsamp.hazard <- function(){
+test_that("gdistsamp with hazard keyfunction works",{
#Line
set.seed(343)
R <- 30
@@ -372,22 +420,29 @@ test.gdistsamp.hazard <- function(){
dist.breaks=breaks,
tlength=rep(transect.length, R), numPrimary=T)
+ # R and C engines give same result
+ fm_C <- gdistsamp(~par1, ~par2, ~par3, umf, output="density", se=FALSE,
+ keyfun="hazard",engine="C", control=list(maxit=1))
fm_R <- gdistsamp(~par1, ~par2, ~par3, umf, output="density", se=FALSE,
- keyfun="hazard",engine="R")
+ keyfun="hazard",engine="R", control=list(maxit=1))
+ expect_equal(fm_C@AIC, fm_R@AIC, tol=1e-5)
+
+ #fm_R <- gdistsamp(~par1, ~par2, ~par3, umf, output="density", se=FALSE,
+ # keyfun="hazard",engine="R")
fm_C <- gdistsamp(~par1, ~par2, ~par3, umf, output="density", se=FALSE,
keyfun="hazard",engine="C")
- checkEqualsNumeric(coef(fm_R),c(1.29425,0.54233,-1.41658,-0.09267,
+ expect_equivalent(coef(fm_C),c(1.29425,0.54233,-1.41658,-0.09267,
3.45436,-0.19978,0.8270215),tol=1e-4)
- checkEqualsNumeric(coef(fm_R),coef(fm_C),tol=1e-4)
+ #expect_equivalent(coef(fm_R),coef(fm_C),tol=1e-4)
#Point
set.seed(123)
data(issj)
- covs <- issj[,c("elevation","forest","chaparral")]
+ covs <- issj[1:100,c("elevation","forest","chaparral")]
area <- pi*300^2 / 100^2
# Area in ha
- jayumf <- unmarkedFrameGDS(y=as.matrix(issj[,1:3]),
+ jayumf <- unmarkedFrameGDS(y=as.matrix(issj[1:100,1:3]),
siteCovs=data.frame(covs, area),
yearlySiteCovs=data.frame(covs),
numPrimary=1,
@@ -397,17 +452,22 @@ test.gdistsamp.hazard <- function(){
sc.s <- scale(sc)
sc.s[,"area"] <- pi*300^2 / 10000 # Don't standardize area
covs <- siteCovs(jayumf) <- sc.s
- fm_R <- gdistsamp(~elevation, ~1, ~chaparral, jayumf, output='density',
- keyfun="hazard",engine="R", se=F)
+ #fm_R <- gdistsamp(~elevation, ~1, ~chaparral, jayumf, output='density',
+ # keyfun="hazard",engine="R", se=F)
fm_C <- gdistsamp(~elevation, ~1, ~chaparral, jayumf, output='density',
keyfun="hazard",engine="C", se=F)
- checkEqualsNumeric(coef(fm_R),c(0.70099,-0.23473,1.38888,
- 1.40786,0.44896),tol=1e-4)
- checkEqualsNumeric(coef(fm_R),coef(fm_C),tol=1e-3)
-}
+ expect_equivalent(coef(fm_C),c(0.8584,-0.04336,-0.70738,3.2762,0.1807),tol=1e-4)
+ #expect_equivalent(coef(fm_R),coef(fm_C),tol=1e-3)
-test.gdistsamp.predict <- function(){
+ fm_C <- gdistsamp(~elevation, ~1, ~chaparral, jayumf, output='density',
+ keyfun="hazard",engine="C", se=F,control=list(maxit=1))
+ fm_R <- gdistsamp(~elevation, ~1, ~chaparral, jayumf, output='density',
+ keyfun="hazard",engine="R", se=F, control=list(maxit=1))
+ expect_equal(fm_C@AIC, fm_R@AIC, tol=1e-3)
+})
+
+test_that("predict works for gdistsamp",{
set.seed(343)
R <- 30
T <- 3
@@ -451,41 +511,41 @@ test.gdistsamp.predict <- function(){
#lambda
pr <- predict(fm_C, "lambda")
- checkTrue(inherits(pr, "data.frame"))
- checkEqualsNumeric(dim(pr), c(30,4))
- checkEqualsNumeric(pr[1,1], 3.767935, tol=1e-5)
+
+ expect_equivalent(dim(pr), c(30,4))
+ expect_equivalent(pr[1,1], 3.767935, tol=1e-5)
nd <- data.frame(par1=0)
pr2 <- predict(fm_C, type='lambda', newdata=nd)
- checkTrue(inherits(pr2, "data.frame"))
- checkEqualsNumeric(dim(pr2), c(1,4))
- checkEqualsNumeric(pr2[1,1], 3.767935, tol=1e-5)
+
+ expect_equivalent(dim(pr2), c(1,4))
+ expect_equivalent(pr2[1,1], 3.767935, tol=1e-5)
#phi
pr <- predict(fm_C, "phi")
- checkTrue(inherits(pr, "data.frame"))
- checkEqualsNumeric(dim(pr), c(90,4))
- checkEqualsNumeric(pr[1,1], 0.4461197, tol=1e-5)
+
+ expect_equivalent(dim(pr), c(90,4))
+ expect_equivalent(pr[1,1], 0.4461197, tol=1e-5)
nd <- data.frame(fac_cov=factor(letters[1:3]))
pr2 <- predict(fm_C, type="phi", newdata=nd)
- checkTrue(inherits(pr2, "data.frame"))
- checkEqualsNumeric(dim(pr2), c(3,4))
- checkEqualsNumeric(pr2[1,1], 0.4461197, tol=1e-5)
+
+ expect_equivalent(dim(pr2), c(3,4))
+ expect_equivalent(pr2[1,1], 0.4461197, tol=1e-5)
#sigma
pr <- predict(fm_C, "det")
- checkTrue(inherits(pr, "data.frame"))
- checkEqualsNumeric(dim(pr), c(90,4))
- checkEqualsNumeric(pr[1,1], 32.51537, tol=1e-5)
+
+ expect_equivalent(dim(pr), c(90,4))
+ expect_equivalent(pr[1,1], 32.51537, tol=1e-5)
nd <- data.frame(par3=0)
pr2 <- predict(fm_C, type='det', newdata=nd)
- checkTrue(inherits(pr2, "data.frame"))
- checkEqualsNumeric(dim(pr2), c(1,4))
- checkEqualsNumeric(pr2[1,1], 32.51537, tol=1e-5)
-}
-test.gdistsamp.na <- function(){
+ expect_equivalent(dim(pr2), c(1,4))
+ expect_equivalent(pr2[1,1], 32.51537, tol=1e-5)
+})
+
+test_that("gdistsamp handles NAs",{
set.seed(343)
R <- 30 # number of transects
T <- 3 # number of replicates
@@ -524,9 +584,63 @@ test.gdistsamp.na <- function(){
tlength=rep(transect.length, R), numPrimary=T)
# Fit the model
- fm1 <- gdistsamp(~1, ~1, ~cov1, umf, keyfun="exp", output="density", se=FALSE)
+ expect_warning(fm1 <- gdistsamp(~1, ~1, ~cov1, umf, keyfun="exp", output="density", se=FALSE))
# Check that getP works
- gp <- getP(fm1)
- checkEqualsNumeric(dim(gp), c(R, T*J))
-}
+ expect_warning(gp <- getP(fm1))
+ expect_equivalent(dim(gp), c(R, T*J))
+})
+
+test_that("gdistsamp simulate method works",{
+
+ set.seed(343)
+ R <- 30
+ T <- 3
+ strip.width <- 50
+ transect.length <- 200 #Area != 1
+ breaks <- seq(0, 50, by=10)
+
+ covs <- as.data.frame(matrix(rnorm(R*T),ncol=T))
+ names(covs) <- paste0('par',1:3)
+
+ beta <- c(0.4,0.3,0.6)
+ lambda <- exp(1.3 + beta[1]*covs$par1)
+ phi <- plogis(as.matrix(0.4 + beta[2]*covs))
+ sigma <- exp(as.matrix(3 + beta[3]*covs))
+ J <- length(breaks)-1
+ y <- array(0, c(R, J, T))
+ for(i in 1:R) {
+ M <- rpois(1, lambda[i]) # Individuals within the 1-ha strip
+ for(t in 1:T) {
+ # Distances from point
+ d <- runif(M, 0, strip.width)
+ # Detection process
+ if(length(d)) {
+ cp <- phi[i,t]*exp(-d^2 / (2 * sigma[i,t]^2)) # half-normal w/ g(0)<1
+ d <- d[rbinom(length(d), 1, cp) == 1]
+ y[i,,t] <- table(cut(d, breaks, include.lowest=TRUE))
+ }
+ }
+ }
+ y <- matrix(y, nrow=R) # convert array to matrix
+
+ covs$par1[2] <- NA
+ umf <- unmarkedFrameGDS(y = y, siteCovs=covs, yearlySiteCovs=covs,
+ survey="line", unitsIn="m",
+ dist.breaks=breaks,
+ tlength=rep(transect.length, R), numPrimary=T)
+
+ expect_warning(fm <- gdistsamp(~par1, ~1, ~1, umf, se=FALSE, K=15, engine="C"))
+
+ #This used to error due to rmultinom not accepting size=NA
+ expect_warning(s <- simulate(fm, nsim=2, na.rm=FALSE))
+ expect_equivalent(length(s), 2)
+ expect_equivalent(dim(s[[1]]), c(30,15))
+ expect_true(!any(is.na(s[[1]][1,])))
+ expect_true(all(is.na(s[[1]][2,])))
+
+ expect_warning(pb <- parboot(fm, nsim=1))
+ expect_is(pb, "parboot")
+
+})
+
diff --git a/tests/testthat/test_gmultmix.R b/tests/testthat/test_gmultmix.R
new file mode 100644
index 0000000..8389b66
--- /dev/null
+++ b/tests/testthat/test_gmultmix.R
@@ -0,0 +1,289 @@
+context("gmultmix fitting function")
+skip_on_cran()
+
+test_that("unmarkedFrameGMM construction works",{
+
+ y <- matrix(0:3, 5, 4)
+ siteCovs <- data.frame(x = c(0,2,3,4,1))
+ siteCovs[3,1] <- NA
+ obsCovs <- data.frame(o1 = 1:20, o2 = exp(-5:4)/20)
+ yrSiteCovs <- data.frame(yr=factor(rep(1:2, 5)))
+
+ umf <- unmarkedFrameGMM(y = y, siteCovs = siteCovs, obsCovs = obsCovs,
+ yearlySiteCovs = yrSiteCovs, type="removal", numPrimary=2)
+ expect_is(umf, "unmarkedFrameGMM")
+
+ expect_error(unmarkedFrameGMM(y = y, siteCovs = siteCovs, obsCovs = obsCovs,
+ yearlySiteCovs = yrSiteCovs, type="fake", numPrimary=2))
+
+ # error when >2 sampling occasions per primary period and type depDouble
+ y2 <- cbind(y, y[,1:2])
+ expect_error(unmarkedFrameGMM(y = y2, siteCovs = siteCovs, obsCovs = obsCovs,
+ yearlySiteCovs = yrSiteCovs, type="depDouble", numPrimary=2))
+
+})
+
+test_that("unmarkedFrameGMM subset works",{
+ y <- matrix(1:27, 3)
+ sc <- data.frame(x1 = 1:3)
+ ysc <- list(x2 = matrix(1:9, 3))
+ oc <- list(x3 = matrix(1:27, 3))
+
+ umf1 <- unmarkedFrameGMM(
+ y = y,
+ siteCovs = sc,
+ yearlySiteCovs = ysc,
+ obsCovs = oc,
+ numPrimary = 3,
+ type="removal")
+
+ dat <- as(umf1, "data.frame")
+
+ umf1.site1 <- umf1[1,]
+ expect_equal(umf1.site1@y, y[1,, drop=FALSE])
+ expect_equal(umf1.site1@siteCovs, sc[1,, drop=FALSE])
+ expect_equivalent(unlist(umf1.site1@obsCovs), oc$x3[1,])
+ expect_equivalent(unlist(umf1.site1@yearlySiteCovs),
+ ysc$x2[1,, drop=FALSE])
+ expect_equal(umf1.site1@numPrimary, 3)
+
+ umf1.sites1and3 <- umf1[c(1,3),]
+ expect_equal(class(umf1.site1)[1], "unmarkedFrameGMM")
+
+ umf1.sites1and1 <- umf1[c(1,1),]
+ umf1.obs1and2 <- umf1[,c(1,2)]
+
+ expect_equivalent(dim(getY(umf1.obs1and2)), c(3,6))
+ expect_equivalent(dim(siteCovs(umf1.obs1and2)), c(3,1))
+ expect_equivalent(dim(obsCovs(umf1.obs1and2)), c(18,1))
+
+ umf1.sites1and2.obs1and2 <- umf1[c(1,2),c(1,2)]
+ expect_equivalent(dim(getY(umf1.sites1and2.obs1and2)), c(2,6))
+ expect_equivalent(dim(siteCovs(umf1.sites1and2.obs1and2)), c(2,1))
+ expect_equivalent(dim(obsCovs(umf1.sites1and2.obs1and2)), c(12,1))
+
+ # THis doesn't work
+ umf1.sites1and1.obs1and1 <- umf1[c(1,1),c(1,1)]
+})
+
+test_that("gmultmix removal model works",{
+ y <- matrix(0:3, 5, 4)
+ siteCovs <- data.frame(x = c(0,2,3,4,1))
+ siteCovs[3,1] <- NA
+ obsCovs <- data.frame(o1 = 1:20, o2 = exp(-5:4)/20)
+ yrSiteCovs <- data.frame(yr=factor(rep(1:2, 5)))
+
+ umf <- unmarkedFrameGMM(y = y, siteCovs = siteCovs, obsCovs = obsCovs,
+ yearlySiteCovs = yrSiteCovs, type="removal", numPrimary=2)
+ #fm_R <- gmultmix(~x, ~yr, ~o1 + o2, data = umf, K=23, engine="R")
+ expect_warning(fm_C <- gmultmix(~x, ~yr, ~o1 + o2, data = umf, K=23, engine="C"))
+
+ expect_equal(fm_C@sitesRemoved, 3)
+ coef_truth <- c(2.50638554, 0.06226627, 0.21787839, 6.46029769, -1.51885928,
+ -0.03409375, 0.43424295)
+ #checkEqualsNumeric(coef(fm_R), coef_truth, tol = 1e-5)
+ expect_equivalent(coef(fm_C), coef_truth, tol = 1e-5)
+
+ # NAs in obsCovs
+ obsCovs[10,2] <- NA
+ umf <- unmarkedFrameGMM(y = y, siteCovs = siteCovs, obsCovs = obsCovs,
+ yearlySiteCovs = yrSiteCovs, type="removal", numPrimary=2)
+ #fm_R <- gmultmix(~x, ~yr, ~o1 + o2, data = umf, K=23, engine="R")
+ expect_warning(fm_C <- gmultmix(~x, ~yr, ~o1 + o2, data = umf, K=23, engine="C"))
+
+ expect_equal(fm_C@sitesRemoved, 3)
+ #checkEqualsNumeric(coef(fm_R), coef_truth, tol = 1e-5)
+ expect_equivalent(coef(fm_C), coef_truth, tol = 1e-5)
+
+ # NAs in ysc
+ yrSiteCovs[2, 1] <- NA
+ umf <- unmarkedFrameGMM(y = y, siteCovs = siteCovs, obsCovs = obsCovs,
+ yearlySiteCovs = yrSiteCovs, type="removal", numPrimary=2)
+ #fm_R <- gmultmix(~x, ~yr, ~o1 + o2, data = umf, K=23, engine="R")
+ expect_warning(fm_C <- gmultmix(~x, ~yr, ~o1 + o2, data = umf, K=23, engine="C"))
+
+ coef_truth <- c(1.17280104, 0.37694710, 2.38249795, 2.87354955, -0.83875134,
+ -0.08446507, 1.88056826)
+ #checkEqualsNumeric(coef(fm_R), coef_truth, tol = 1e-5)
+ expect_equivalent(coef(fm_C), coef_truth, tol = 1e-5)
+
+ #Negative binomial
+ #fm_R <- gmultmix(~x, ~yr, ~o1 + o2, data = umf, mixture="NB", K=23, engine="R")
+ expect_warning(fm_C <- gmultmix(~x, ~yr, ~o1 + o2, data = umf, mixture="NB",
+ K=23, engine="C"))
+ expect_equivalent(coef(fm_C), c(1.1819, 0.3738,2.4571,4.3633,-0.8734,-0.08211,
+ 1.86049,9.38619), tol=1e-4)
+
+ #Check methods
+ expect_warning(gp <- getP(fm_C))
+ expect_equal(dim(gp), c(4,4)) # missing site dropped
+
+ expect_warning(pr <- predict(fm_C, 'lambda'))
+ expect_equal(dim(pr), c(4,4))
+
+ nd <- data.frame(x=c(0,1))
+ pr <- predict(fm_C, 'lambda', newdata=nd)
+ expect_equal(dim(pr), c(2,4))
+
+ res <- residuals(fm_C)
+ expect_equal(dim(res), dim(y))
+
+ expect_warning(r <- ranef(fm_C))
+ expect_equal(dim(r@post), c(4,24,1))
+
+ expect_warning(s <- simulate(fm_C, 2))
+ expect_equal(length(s), 2)
+
+ expect_warning(pb <- parboot(fm_C, nsim=1))
+ expect_is(pb, "parboot")
+
+ expect_error(gmultmix(~(1|dummy),~1,~1,umf))
+
+})
+
+test_that("gmultmix double model works",{
+ # Simulate independent double observer data
+ nSites <- 50
+ lambda <- 10
+ p1 <- 0.5
+ p2 <- 0.3
+ cp <- c(p1*(1-p2), p2*(1-p1), p1*p2)
+ set.seed(9023)
+ N <- rpois(nSites, lambda)
+ y <- matrix(NA, nSites, 3)
+ for(i in 1:nSites) {
+ y[i,] <- rmultinom(1, N[i], c(cp, 1-sum(cp)))[1:3]
+ }
+
+ # Fit model
+ observer <- matrix(c('A','B'), nSites, 2, byrow=TRUE)
+ expect_warning(umf <- unmarkedFrameGMM(y=y, obsCovs=list(observer=observer),
+ type="double",numPrimary=1))
+
+ # check subset
+ umf2 <- umf[1:5,]
+ expect_equal(numSites(umf2), 5)
+
+ fm <- gmultmix(~1,~1,~observer, umf)
+ expect_equivalent(coef(fm), c(2.2586,0.17385,-0.7425), tol=1e-4)
+
+ gp <- getP(fm)
+ expect_equal(dim(gp), c(nSites, 3))
+
+})
+
+test_that("gmultmix dependent double model works",{
+ # Simulate independent double observer data
+ nSites <- 50
+ lambda <- 10
+ p1 <- 0.5
+ p2 <- 0.3
+ cp <- c(p1*(1-p2), p2*(1-p1), p1*p2)
+ set.seed(9023)
+ N <- rpois(nSites, lambda)
+ y <- matrix(NA, nSites, 3)
+ for(i in 1:nSites) {
+ y[i,] <- rmultinom(1, N[i], c(cp, 1-sum(cp)))[1:3]
+ }
+
+ # Fit model
+ observer <- matrix(c('A','B'), nSites, 2, byrow=TRUE)
+
+ #expect_error(umf <- unmarkedFrameGMM(y=y, obsCovs=list(observer=observer),
+ # type="depDouble",numPrimary=1))
+
+ expect_warning(umf <- unmarkedFrameGMM(y=y[,1:2], obsCovs=list(observer=observer),
+ type="depDouble",numPrimary=1))
+
+ fm <- gmultmix(~1,~1,~observer, umf)
+ expect_equivalent(coef(fm), c(1.7762,0.2493,0.2008), tol=1e-4)
+
+ gp <- getP(fm)
+ expect_equal(dim(gp), c(nSites, 2))
+
+})
+
+test_that("MRR custom piFun works",{
+
+ alfl <- read.csv(system.file("csv", "alfl.csv", package="unmarked"))
+ alfl.covs <- read.csv(system.file("csv", "alflCovs.csv",package="unmarked"),
+ row.names=1)
+ alfl$captureHistory <- paste(alfl$interval1, alfl$interval2, alfl$interval3,
+ sep="")
+ alfl$captureHistory <- factor(alfl$captureHistory,
+ levels=c("001", "010", "011", "100", "101", "110", "111"))
+ alfl$id <- factor(alfl$id, levels=rownames(alfl.covs))
+
+ alfl.v1 <- alfl[alfl$survey==1,]
+ alfl.H1 <- table(alfl.v1$id, alfl.v1$captureHistory)
+ alfl.v2 <- alfl[alfl$survey==2,]
+ alfl.H2 <- table(alfl.v2$id, alfl.v2$captureHistory)
+ alfl.v3 <- alfl[alfl$survey==3,]
+ alfl.H3 <- table(alfl.v3$id, alfl.v3$captureHistory)
+
+
+ Y<- array(NA, c(50, 3, 7))
+ Y[1:50,1,1:7]<- alfl.H1
+ Y[1:50,2,1:7]<- alfl.H2
+ Y[1:50,3,1:7]<- alfl.H3
+
+ crPiFun <- function(p) {
+ p1 <- p[,1]
+ p2 <- p[,2]
+ p3 <- p[,3]
+ cbind("001" = (1 - p1) * (1 - p2) * p3,
+ "010" = (1 - p1) * p2 * (1 - p3),
+ "011" = (1 - p1) * p2 * p3,
+ "100" = p1 * (1 - p2) * (1 - p3),
+ "101" = p1 * (1 - p2) * p3,
+ "110" = p1 * p2 * (1 - p3),
+ "111" = p1 * p2 * p3)
+ }
+
+ intervalMat <- matrix(c('1','2','3'), 50, 3, byrow=TRUE)
+ class(alfl.H1) <- "matrix"
+ o2y <- matrix(1, 3, 7)
+
+ ywide<- as.matrix( cbind(alfl.H1, alfl.H2) )
+ umf.cr1 <- unmarkedFrameGMM(y=ywide,
+ obsCovs=NULL, yearlySiteCovs=NULL,
+ obsToY=o2y, numPrimary=2, piFun="crPiFun")
+
+ expect_equal(dim(umf.cr1@obsToY)[1] , 6)
+ expect_equal(dim(umf.cr1@obsToY)[2] , 14)
+})
+
+test_that("R and C++ engines give identical results",{
+ y <- matrix(0:3, 5, 4)
+ siteCovs <- data.frame(x = c(0,2,3,4,1))
+ siteCovs[3,1] <- NA
+ obsCovs <- data.frame(o1 = 1:20, o2 = exp(-5:4)/20)
+ yrSiteCovs <- data.frame(yr=factor(rep(1:2, 5)))
+
+ umf <- unmarkedFrameGMM(y = y, siteCovs = siteCovs, obsCovs = obsCovs,
+ yearlySiteCovs = yrSiteCovs, type="removal", numPrimary=2)
+ expect_warning(fm_R <- gmultmix(~x, ~yr, ~o1 + o2, data = umf, K=23,
+ engine="R", control=list(maxit=1)))
+ expect_warning(fm_C <- gmultmix(~x, ~yr, ~o1 + o2, data = umf, K=23,
+ engine="C", control=list(maxit=1)))
+ expect_equal(coef(fm_R), coef(fm_C))
+
+
+})
+
+test_that("getP works when there is only 1 site", {
+ y <- matrix(0:3, 5, 4)
+ siteCovs <- data.frame(x = c(0,2,3,4,1))
+ siteCovs[3,1] <- NA
+ obsCovs <- data.frame(o1 = 1:20, o2 = exp(-5:4)/20)
+ yrSiteCovs <- data.frame(yr=factor(rep(1:2, 5)))
+
+ umf <- unmarkedFrameGMM(y = y, siteCovs = siteCovs, obsCovs = obsCovs,
+ yearlySiteCovs = yrSiteCovs, type="removal", numPrimary=2)[1,]
+
+ fm <- expect_warning(gmultmix(~x, ~yr, ~o1 + o2, data = umf, K=7, engine="C"))
+
+ gp <- getP(fm)
+ expect_equal(dim(gp), c(1,4))
+
+})
diff --git a/tests/testthat/test_gpcount.R b/tests/testthat/test_gpcount.R
new file mode 100644
index 0000000..022c2ce
--- /dev/null
+++ b/tests/testthat/test_gpcount.R
@@ -0,0 +1,119 @@
+context("gpcount fitting function")
+skip_on_cran()
+
+test_that("unmarkedFrameGPC subset works",{
+ y <- matrix(1:27, 3)
+ sc <- data.frame(x1 = 1:3)
+ ysc <- list(x2 = matrix(1:9, 3))
+ oc <- list(x3 = matrix(1:27, 3))
+
+ umf1 <- unmarkedFrameGPC(
+ y = y,
+ siteCovs = sc,
+ yearlySiteCovs = ysc,
+ obsCovs = oc,
+ numPrimary = 3)
+
+ dat <- as(umf1, "data.frame")
+
+ umf1.site1 <- umf1[1,]
+ expect_equal(umf1.site1@y, y[1,, drop=FALSE])
+ expect_equal(umf1.site1@siteCovs, sc[1,, drop=FALSE])
+ expect_equivalent(unlist(umf1.site1@obsCovs), oc$x3[1,])
+ expect_equivalent(unlist(umf1.site1@yearlySiteCovs),
+ ysc$x2[1,, drop=FALSE])
+ expect_equal(umf1.site1@numPrimary, 3)
+
+ umf1.sites1and3 <- umf1[c(1,3),]
+
+ expect_is(umf1.site1, "unmarkedFrameGPC")
+
+ umf1.sites1and1 <- umf1[c(1,1),]
+
+ umf1.obs1and2 <- umf1[,c(1,2)]
+
+ expect_equivalent(dim(getY(umf1.obs1and2)), c(3,6))
+ expect_equivalent(dim(siteCovs(umf1.obs1and2)), c(3,1))
+ expect_equivalent(dim(obsCovs(umf1.obs1and2)), c(18,1))
+
+ umf1.sites1and2.obs1and2 <- umf1[c(1,2),c(1,2)]
+ expect_equal(class(umf1.sites1and2.obs1and2)[1], "unmarkedFrameGPC")
+ expect_equivalent(dim(getY(umf1.sites1and2.obs1and2)), c(2,6))
+ expect_equivalent(dim(siteCovs(umf1.sites1and2.obs1and2)), c(2,1))
+ expect_equivalent(dim(obsCovs(umf1.sites1and2.obs1and2)), c(12,1))
+
+ # THis doesn't work
+ umf1.sites1and1.obs1and1 <- umf1[c(1,1),c(1,1)]
+})
+
+test_that("gpcount function works", {
+ y <- matrix(c(0,0,0, 1,0,1, 2,2,2,
+ 3,2,3, 2,2,2, 1,1,1,
+ NA,0,0, 0,0,0, 0,0,0,
+ 3,3,3, 3,1,3, 2,2,1,
+ 0,0,0, 0,0,0, 0,0,0), 5, 9, byrow=TRUE)
+ siteCovs <- data.frame(x = c(0,2,-1,4,-1))
+ obsCovs <- list(o1 = matrix(seq(-3, 3, length=length(y)), 5, 9))
+ obsCovs$o1[5,4:6] <- NA
+ yrSiteCovs <- list(yr=matrix(c('1','2','2'), 5, 3, byrow=TRUE))
+ yrSiteCovs$yr[4,2] <- NA
+
+ expect_warning(umf <- unmarkedFrameGPC(y = y, siteCovs = siteCovs, obsCovs = obsCovs,
+ yearlySiteCovs = yrSiteCovs, numPrimary=3))
+
+ expect_warning(fm <- gpcount(~x, ~yr, ~o1, data = umf, K=23))
+ expect_equal(fm@sitesRemoved, integer(0))
+ expect_equivalent(coef(fm),
+ c(1.14754541, 0.44499137, -1.52079283, -0.08881542,
+ 2.52037155, -0.10950615), tol = 1e-5)
+
+ # Check methods
+ expect_warning(gp <- getP(fm))
+ expect_equal(dim(gp), dim(y))
+
+ expect_warning(pr <- predict(fm, 'lambda'))
+ expect_equal(dim(pr), c(nrow(y), 4))
+
+ nd <- data.frame(x=c(0,1))
+ pr <- predict(fm, 'lambda', newdata=nd)
+ expect_equal(dim(pr), c(2,4))
+ expect_equal(pr[1,1], c(3.15045), tol=1e-4)
+
+ res <- residuals(fm)
+ expect_equal(dim(res), dim(y))
+
+ expect_warning(r <- ranef(fm))
+ expect_equal(dim(r@post), c(nrow(y), 24, 1))
+ expect_equal(bup(r), c(7.31, 12.63, 1.30, 16.12, 2.04), tol=1e-3)
+
+ expect_warning(s <- simulate(fm, 2))
+ expect_equal(length(s), 2)
+ expect_equal(dim(s[[1]]), dim(y))
+
+ expect_warning(pb <- parboot(fm, nsim=1))
+ expect_is(pb, "parboot")
+
+ # Check error when random effect in formula
+ expect_error(gpcount(~(1|dummy),~1,~1,umf))
+
+})
+
+test_that("gpcount R and C++ engines give same results",{
+
+ y <- matrix(c(0,0,0, 1,0,1, 2,2,2,
+ 3,2,3, 2,2,2, 1,1,1,
+ NA,0,0, 0,0,0, 0,0,0,
+ 3,3,3, 3,1,3, 2,2,1,
+ 0,0,0, 0,0,0, 0,0,0), 5, 9, byrow=TRUE)
+ siteCovs <- data.frame(x = c(0,2,-1,4,-1))
+ obsCovs <- list(o1 = matrix(seq(-3, 3, length=length(y)), 5, 9))
+ yrSiteCovs <- list(yr=matrix(c('1','2','2'), 5, 3, byrow=TRUE))
+
+
+ expect_warning(umf <- unmarkedFrameGPC(y = y, siteCovs = siteCovs, obsCovs = obsCovs,
+ yearlySiteCovs = yrSiteCovs, numPrimary=3))
+
+ fm <- gpcount(~x, ~yr, ~o1, data = umf, K=23, control=list(maxit=1))
+ fmR <- gpcount(~x, ~yr, ~o1, data = umf, K=23, engine="R", control=list(maxit=1))
+ expect_equal(coef(fm), coef(fmR))
+})
diff --git a/tests/testthat/test_linearComb.R b/tests/testthat/test_linearComb.R
new file mode 100644
index 0000000..d0a0f43
--- /dev/null
+++ b/tests/testthat/test_linearComb.R
@@ -0,0 +1,35 @@
+context("linearComb and backTransform")
+
+skip_on_cran()
+
+y <- matrix(rep(0:1,10)[1:10],5,2)
+siteCovs <- data.frame(x = c(0,2,3,4,1))
+obsCovs <- data.frame(o1 = 1:10, o2 = exp(-5:4)/10)
+umf <- unmarkedFrameOccu(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
+fm <- occu(~ o1 + o2 ~ x, data = umf)
+
+lc <- linearComb(fm, type='state', c(1,0.1))
+
+test_that("linearComb works",{
+
+ expect_is(lc, "unmarkedLinComb")
+ expect_equal(lc@estimate, as.numeric(c(1,0.1) %*% coef(fm, 'state')))
+ out <- capture.output(lc)
+ expect_equal(out[1], "Linear combination(s) of Occupancy estimate(s)")
+
+ df <- as(lc, "data.frame")
+ expect_is(df, "data.frame")
+ expect_equal(df[1,1], lc@estimate)
+})
+
+test_that("backTransform works",{
+
+ bt <- backTransform(lc)
+ expect_is(bt, "unmarkedBackTrans")
+ out <- capture.output(bt)
+ expect_equal(out[1], "Backtransformed linear combination(s) of Occupancy estimate(s)")
+
+ df <- as(bt, "data.frame")
+ expect_is(df, "data.frame")
+ expect_equal(df[1,1], 0.9998549)
+})
diff --git a/tests/testthat/test_makePiFun.R b/tests/testthat/test_makePiFun.R
new file mode 100644
index 0000000..91e29db
--- /dev/null
+++ b/tests/testthat/test_makePiFun.R
@@ -0,0 +1,69 @@
+context("Generated piFuns")
+
+test_that("getCombs returns all possible encounter histories",{
+ # all-zero eh is removed
+
+ out <- getCombs(1)
+ expect_equal(out, 1)
+
+ out <- getCombs(2)
+ expect_equal(out, matrix(c(0,1,1,0,1,1), nrow=3, byrow=T))
+
+ out <- getCombs(3)
+ expect_equal(out, matrix(c(0,0,1,0,1,0,0,1,1,1,0,0,
+ 1,0,1,1,1,0,1,1,1), nrow=7, byrow=T))
+
+})
+
+test_that("makeRemPiFun generates piFuns for varying-length removal periods",{
+
+ out <- makeRemPiFun(c(0.5,1,1.5))
+ expect_is(out, "function")
+ p <- matrix(c(0.2,0.15,0.1,0.2,0.15,0.1), nrow=2, byrow=T)
+ cp <- out(p)
+ expect_is(cp, "matrix")
+ expect_equal(dim(cp), c(2,3))
+ expect_equal(cp[1], 0.1055728)
+
+ p <- matrix(c(0.2,0.15,0.1,0.2), nrow=2, byrow=T)
+ expect_error(out(p))
+
+})
+
+test_that("makeCrPiFun generates MRR pifun",{
+
+ mrr <- makeCrPiFun(2)
+ expect_is(mrr, "function")
+
+ p <- matrix(c(0.2,0.15,0.1,0.2), nrow=2, byrow=T)
+
+ cp <- mrr(p)
+ expect_equal(cp, structure(c(0.12, 0.18, 0.17, 0.08, 0.03, 0.02),
+ .Dim = 2:3, .Dimnames = list(
+ NULL, c("01", "10", "11"))))
+})
+
+test_that("makeCrPiFunMb generates behavioral response pifun",{
+
+ mrr <- makeCrPiFunMb(2)
+ expect_is(mrr, "function")
+
+ p <- matrix(c(0.2,0.15,0.1,0.2), nrow=2, byrow=T)
+ cp <- mrr(p)
+ expect_equal(cp, structure(c(0.16, 0.09, 0.17, 0.08, 0.03, 0.02),
+ .Dim = 2:3, .Dimnames = list(
+ NULL, c("01", "10", "11"))))
+
+})
+
+test_that("makeCrPiFunMh generates individ hetero pifun",{
+ mrr <- makeCrPiFunMh(2)
+ expect_is(mrr, "function")
+
+ p <- matrix(c(0.2,0.15,0.1,0.2), nrow=2, byrow=T)
+ cp <- mrr(p)
+ expect_equal(cp, structure(c(0.16008585185222, 0.0906366734014539,
+ 0.16008585185222,0.0906366734014539, 0.0413982898797996,
+ 0.010483669158271), .Dim = 2:3, .Dimnames= list(
+ NULL, c("01", "10", "11"))))
+})
diff --git a/tests/testthat/test_modSel.R b/tests/testthat/test_modSel.R
new file mode 100644
index 0000000..14fffc2
--- /dev/null
+++ b/tests/testthat/test_modSel.R
@@ -0,0 +1,65 @@
+context("fitList and modSel methods")
+
+skip_on_cran()
+
+test_that("fitLists can be constructed",{
+ y <- matrix(rep(1, 10), 5, 2)
+ umf <- unmarkedFrameOccu(y = y, siteCovs=data.frame(x=-2:2),
+ obsCovs= data.frame(z=-5:4))
+ obsCovs(umf)[3, 1] <- NA
+ fm1 <- occu(~ 1 ~ 1, data = umf)
+ fm2 <- occu(~ 1 ~ x, data = umf)
+
+ fits1.1 <- fitList(m1=fm1, m2=fm2)
+ expect_equal(names(fits1.1@fits), c("m1","m2"))
+ expect_warning(fits1.2 <- fitList(fm1, fm2))
+ expect_equal(names(fits1.2@fits), c("fm1","fm2"))
+ fits2.1 <- fitList(fits = list(m1=fm1, m2=fm2))
+ expect_equal(names(fits2.1@fits), c("m1","m2"))
+ expect_warning(fits2.2 <- fitList(fits = list(fm1, fm2)))
+ expect_equal(names(fits2.2@fits), c("1","2"))
+
+ expect_equal(fits1.1, fits2.1)
+
+ expect_error(fitList(fm1, fm2, fits=list(fm1, fm2)))
+
+ siteCovs(umf) <- data.frame(x=-3:1)
+ fm2 <- occu(~ 1 ~ x, data = umf)
+ expect_error(expect_warning(fitList(fm1, fm2))) # Different umf used
+
+ expect_warning(fm3 <- occu(~ z ~ 1, data = umf))
+ expect_error(expect_warning(fitList(fm1, fm3))) # Missing value problem
+})
+
+test_that("modSel method works",{
+ y <- matrix(rep(1, 10), 5, 2)
+ umf <- unmarkedFrameOccu(y = y, siteCovs=data.frame(x=-2:2),
+ obsCovs= data.frame(z=-5:4))
+ fm1 <- occu(~ 1 ~ 1, data = umf)
+ fm2 <- occu(~ 1 ~ x, data = umf)
+
+ fits <- fitList(m1=fm1, m2=fm2)
+ ms1 <- modSel(fits)
+
+ expect_true(all(is.na(ms1@Full$Rsq)))
+ expect_equal(sum(ms1@Full$AICwt), 1)
+ expect_equal(ms1@Full$delta[1L], 0)
+
+ expect_error(modSel(fits, nullmod=fm2))
+
+ ms2 <- modSel(fits, nullmod='m1')
+
+ expect_equal(
+ ms1@Full[,-which(colnames(ms1@Full)=="Rsq")],
+ ms1@Full[,-which(colnames(ms2@Full)=="Rsq")]
+ )
+
+ # Fake hessian problem
+ fm1@opt$hessian[] <- NA
+ fm1@estimates@estimates$state@covMat[] <- NA
+ fits2 <- fitList(m1=fm1, m2=fm2)
+ ms3 <- modSel(fits2)
+ expect_equal(coef(ms1), coef(ms3))
+
+})
+
diff --git a/tests/testthat/test_multinomPois.R b/tests/testthat/test_multinomPois.R
new file mode 100644
index 0000000..6b4b693
--- /dev/null
+++ b/tests/testthat/test_multinomPois.R
@@ -0,0 +1,262 @@
+context("multinomPois fitting function")
+skip_on_cran()
+
+test_that("unmarkedFrameMPois can be constructed",{
+ y <- matrix(c(
+ 5, 3, 2,
+ 3, 3, 1,
+ 2, 0, 0,
+ 0, 0, 0,
+ 0, 0, 0), nrow=5, ncol=3, byrow=TRUE)
+
+ sc <- data.frame(x1 = c(NA, 2, 3, 4, 3))
+ oc <- list(x2 = matrix(c(
+ 1, 1, 1,
+ 3, NA, 1,
+ 0, 0, 1,
+ NA, NA, NA,
+ NA, 1, 0), nrow=5, ncol=3, byrow=TRUE))
+
+ umf1 <- unmarkedFrameMPois(y = y, siteCovs = sc, obsCovs = oc,
+ type="removal")
+ expect_is(umf1, "unmarkedFrameMPois")
+
+ o2y <- diag(ncol(y))
+ o2y[upper.tri(o2y)] <- 1
+ expect_equal(obsToY(umf1), o2y)
+
+ expect_error(umf2 <- unmarkedFrameMPois(y=y, siteCovs=sc, obsCovs=oc, type="double"))
+ umf2 <- unmarkedFrameMPois(y=y, siteCovs=sc,
+ obsCovs=lapply(oc, function(x) x[,1:2]),
+ type="double")
+ expect_is(umf2, "unmarkedFrameMPois")
+
+ umf3 <- unmarkedFrameMPois(y=y[,1:2], siteCovs=sc,
+ obsCovs=lapply(oc, function(x) x[,1:2]),
+ type="depDouble")
+ expect_is(umf3, "unmarkedFrameMPois")
+
+ expect_error(umf4 <- unmarkedFrameMPois(y=y, siteCovs=sc, obsCovs=oc, type="fake"))
+
+ # error when depDouble and >2 samples
+ expect_error(unmarkedFrameMPois(y=y, siteCovs=sc,
+ obsCovs=lapply(oc, function(x) x[,1:2]),
+ type="depDouble"))
+
+
+})
+
+test_that("multinomPois can fit a removal model",{
+
+ y <- matrix(c(
+ 5, 3, 2,
+ 3, 3, 1,
+ 2, 0, 0,
+ 0, 0, 0,
+ 0, 0, 0), nrow=5, ncol=3, byrow=TRUE)
+
+ sc <- data.frame(x1 = c(NA, 2, 3, 4, 3))
+ oc <- list(x2 = matrix(c(
+ 1, 1, 1,
+ 3, NA, 1,
+ 0, 0, 1,
+ NA, NA, NA,
+ NA, 1, 0), nrow=5, ncol=3, byrow=TRUE))
+
+ umf1 <- unmarkedFrameMPois(y = y, siteCovs = sc, obsCovs = oc,
+ type="removal")
+
+ #m1_R <- multinomPois(~1 ~1, umf1, engine="R")
+ m1_C <- multinomPois(~1 ~1, umf1, engine="C")
+ expect_equivalent(coef(m1_C), c(1.5257743, -0.2328092), tol=1e-5)
+ #checkEqualsNumeric(coef(m1_R), coef(m1_C), tol=1e-5)
+
+ #m2_R <- multinomPois(~x2 ~1, umf1, engine="R")
+ expect_warning(m2_C <- multinomPois(~x2 ~1, umf1, engine="C"))
+ expect_equivalent(coef(m2_C), c(1.9159845, 0.2248897, -0.1808144), tol=1e-5)
+ expect_equal(m2_C@sitesRemoved, 4:5)
+ #checkEqualsNumeric(coef(m2_R),coef(m2_C), tol=1e-5)
+
+ #m3_R <- multinomPois(~x2 ~x1, umf1, engine="R")
+ expect_warning(m3_C <- multinomPois(~x2 ~x1, umf1, engine="C"))
+ expect_equivalent(m3_C@sitesRemoved, c(1, 4:5))
+ expect_equivalent(coef(m3_C),
+ c(1.9118525, -0.4071202, 8.3569943, 0.3232485), tol=1e-5)
+ #checkEqualsNumeric(coef(m3_R),coef(m3_C), tol=1e-5)
+
+ # check methods
+ expect_warning(gp <- getP(m2_C))
+ expect_equal(dim(gp), c(3,3))
+ expect_equal(gp[1,1], 0.51101, tol=1e-4)
+
+ expect_warning(pr <- predict(m2_C, 'state'))
+ expect_equal(dim(pr), c(3,4))
+ expect_equal(pr[1,1], 6.7936, tol=1e-4)
+
+ nd <- data.frame(x2=c(0,1))
+ pr <- predict(m2_C, 'det', newdata=nd)
+ expect_equal(dim(pr), c(2,4))
+ expect_equal(pr[1,1], 0.55598, tol=1e-4)
+
+ res <- residuals(m2_C)
+ expect_equal(dim(res), dim(umf1@y))
+
+ expect_warning(r <- ranef(m2_C))
+ expect_equal(dim(r@post), c(3,56,1))
+ expect_equal(bup(r), c(10.794,0.000,2.655), tol=1e-4)
+
+ expect_warning(s <- simulate(m2_C, 2, na.rm=FALSE))
+ expect_equal(length(s), 2)
+
+ expect_equal(dim(s[[1]]), dim(umf1@y))
+
+ expect_warning(pb <- parboot(m2_C, nsim=1))
+ expect_is(pb, "parboot")
+})
+
+test_that("multinomPois can fit a double observer model",{
+ nSites <- 50
+ lambda <- 10
+ p1 <- 0.5
+ p2 <- 0.3
+ cp <- c(p1*(1-p2), p2*(1-p1), p1*p2)
+ set.seed(9023)
+ N <- rpois(nSites, lambda)
+ y <- matrix(NA, nSites, 3)
+ for(i in 1:nSites) {
+ y[i,] <- rmultinom(1, N[i], c(cp, 1-sum(cp)))[1:3]
+ }
+
+ observer <- matrix(c('A','B'), nSites, 2, byrow=TRUE)
+
+ umf <- expect_warning(unmarkedFrameMPois(y=y, obsCovs=list(observer=observer),
+ type="double"))
+
+ fm_C <- multinomPois(~observer-1 ~1, umf, engine="C")
+ expect_equivalent(coef(fm_C), c(2.2586622, 0.1739752, -0.5685933), tol = 1e-5)
+ expect_is(ranef(fm_C, K=30), "unmarkedRanef")
+
+})
+
+test_that("multinomPois can fit a dependent double observer model",{
+ nSites <- 50
+ lambda <- 10
+ p1 <- 0.5
+ p2 <- 0.3
+ cp <- c(p1, p2*(1-p1))
+ set.seed(9023)
+ N <- rpois(nSites, lambda)
+ y <- matrix(NA, nSites, 2)
+ for(i in 1:nSites) {
+ y[i,] <- rmultinom(1, N[i], c(cp, 1-sum(cp)))[1:2]
+ }
+ # Fit model
+ observer <- matrix(c('A','B'), nSites, 2, byrow=TRUE)
+ umf <- expect_warning(unmarkedFrameMPois(y=y, obsCovs=list(observer=observer),
+ type="depDouble"))
+
+ fm_C <- multinomPois(~observer-1 ~1, umf, engine="C")
+ expect_equivalent(coef(fm_C), c(2.0416086, 0.7430343, 0.4564236), tol = 1e-5)
+ expect_warning(r <- ranef(fm_C, K=30))
+ expect_is(r, "unmarkedRanef")
+})
+
+
+test_that("multinomPois handles NAs",{
+ y <- matrix(c(
+ 1, 0, 0,
+ 2, 1, 0,
+ 1, 0, 1,
+ 2, 1, 2,
+ 1, 0, 3,
+ 1, 1, 1), nrow=6, ncol=3, byrow=TRUE)
+ oc <- matrix(c(
+ 1, 0,
+ 2, 1,
+ 1, 1,
+ NA, 0,
+ 1, NA,
+ NA, NA), nrow=6, ncol=2, byrow=TRUE)
+
+ umf <- unmarkedFrameMPois(y = y, obsCovs = list(x=oc), type="double")
+
+ expect_warning(m2 <- multinomPois(~x ~1, umf, starts=c(1.3, 0, 0.2)))
+ expect_equal(m2@sitesRemoved, 4:6)
+
+})
+
+test_that("multinomPois can fit models with random effects",{
+ set.seed(9023)
+ nSites <- 50
+ lambda <- 10
+ p1 <- 0.5
+ p2 <- 0.3
+ cp <- c(p1*(1-p2), p2*(1-p1), p1*p2)
+ N <- rpois(nSites, lambda)
+ y <- matrix(NA, nSites, 3)
+ for(i in 1:nSites) {
+ y[i,] <- rmultinom(1, N[i], c(cp, 1-sum(cp)))[1:3]
+ }
+
+ # Fit model
+ observer <- matrix(c('A','B'), nSites, 2, byrow=TRUE)
+ expect_warning(umf <- unmarkedFrameMPois(y=y, obsCovs=list(observer=observer),
+ type="double"))
+ fm <- multinomPois(~observer-1 ~1, umf)
+ expect_true(inherits(fm, "unmarkedFitMPois"))
+ expect_true(is.null(fm@TMB))
+ pr <- predict(fm, "state")
+ expect_equivalent(dim(pr), c(50,4))
+
+ set.seed(1)
+ nSites <- 100
+ lambda <- 5
+ sc <- data.frame(ref=sample(letters[1:10], nSites, replace=T),
+ x1=rnorm(nSites))
+ observer <- matrix(c('A','B'), nSites, 2, byrow=TRUE)
+
+ ef <- rnorm(10, 0, 0.4)
+ names(ef) <- letters[1:10]
+ lambda <- exp(log(lambda) + ef[sc$ref])
+ N <- rpois(nSites, lambda)
+
+ y <- matrix(NA, nSites, 3)
+ for(i in 1:nSites) {
+ y[i,] <- rmultinom(1, N[i], c(cp, 1-sum(cp)))[1:3]
+ }
+ expect_warning(umf2 <- unmarkedFrameMPois(y=y, obsCovs=list(observer=observer),
+ type="double", siteCovs=sc))
+
+ fm <- multinomPois(~observer-1 ~x1 + (1|ref), umf2)
+
+ expect_true(inherits(fm@TMB, "list"))
+ expect_equivalent(sigma(fm)$sigma, 0.3655, tol=1e-3)
+ expect_true(inherits(randomTerms(fm), "data.frame"))
+ pr <- predict(fm, type='state')
+ pr2 <- predict(fm, "state", newdata=umf2@siteCovs[1:5,])
+ expect_equivalent(dim(pr), c(100, 4))
+ expect_equivalent(dim(pr2), c(5,4))
+
+ # Make sure simulate accounts for random effects
+ s <- simulate(fm, nsim=30)
+ avg <- apply(sapply(s, function(x) x[,1]),1, mean)
+ # average first count and predicted abundance should be highly correlated
+ expect_true(cor(avg, pr$Predicted) > 0.7)
+
+ umf2@y[1,1] <- NA
+ umf2@y[2,] <- NA
+ umf2@siteCovs$x1[3] <- NA
+ umf2@obsCovs$observer[80] <- NA
+
+ expect_warning(fm_na <- multinomPois(~observer-1 ~x1 + (1|ref), umf2))
+ expect_true(inherits(fm_na, "unmarkedFitMPois"))
+
+ expect_warning(umf3 <- unmarkedFrameMPois(y=y, obsCovs=list(observer=observer),
+ piFun="fake", obsToY=umf@obsToY, siteCovs=sc))
+
+ expect_error(multinomPois(~observer-1 ~x1 + (1|ref), umf3))
+
+ # Site covs in detection formula
+ expect_warning(fm <- multinomPois(~(1|ref)~1, umf2))
+ expect_true(sigma(fm)$Model[1]=="p")
+})
diff --git a/inst/unitTests/runit.multmixOpen.R b/tests/testthat/test_multmixOpen.R
index 40fe981..c66d3f9 100644
--- a/inst/unitTests/runit.multmixOpen.R
+++ b/tests/testthat/test_multmixOpen.R
@@ -1,3 +1,6 @@
+context("multmixOpen fitting function")
+skip_on_cran()
+
simData <- function(lambda=1, gamma=0.5, omega=0.8, p=0.5, M=100, T=5,
p2=NULL, type="removal")
{
@@ -45,7 +48,7 @@ simData <- function(lambda=1, gamma=0.5, omega=0.8, p=0.5, M=100, T=5,
return(list(y=matrix(y, M),N=N))
}
-test.multmixOpen.removal <- function(){
+test_that("multmixOpen can fit removal models",{
set.seed(123)
simy <- simData(lambda=4, gamma=0.5, omega=0.8, p=0.5,
@@ -56,42 +59,42 @@ test.multmixOpen.removal <- function(){
umf <- unmarkedFrameMMO(y=simy$y, numPrimary=5, siteCovs=sc,
type="removal")
- fit <- multmixOpen(~x1, ~1, ~1, ~x1, K=30, data=umf)
+ fit <- multmixOpen(~x1, ~1, ~1, ~x1, K=20, data=umf)
- checkEqualsNumeric(coef(fit), c(1.38860,0.043406,-0.68448,
+ expect_equivalent(coef(fit), c(1.38860,0.043406,-0.68448,
1.40703,0.03174,-0.00235), tol=1e-5)
#Check predict
pr <- predict(fit, type='lambda')
- checkEqualsNumeric(as.numeric(pr[1,]),
+ expect_equivalent(as.numeric(pr[1,]),
c(3.79942,0.298279,3.25808,4.43193), tol=1e-4)
#Check getP
pv <- getP(fit)
- checkEqualsNumeric(dim(pv), dim(umf@y))
- checkEqualsNumeric(pv[1,1:3], pv[1,4:6])
- checkEqualsNumeric(pv[1,1:3], c(0.5086598,0.2499250,0.1227982), tol=1e-5)
+ expect_equivalent(dim(pv), dim(umf@y))
+ expect_equivalent(pv[1,1:3], pv[1,4:6])
+ expect_equivalent(pv[1,1:3], c(0.5086598,0.2499250,0.1227982), tol=1e-5)
#Check residuals
r <- residuals(fit)
- checkEqualsNumeric(r[1,1:3], c(0.067122,-0.9497006,0.533337), tol=1e-4)
+ expect_equivalent(r[1,1:3], c(0.067122,-0.9497006,0.533337), tol=1e-4)
#Check simulate
set.seed(123)
sim <- simulate(fit, nsim=2)
- checkEqualsNumeric(sim[[1]][3,1:3], c(3,0,0))
- checkEqualsNumeric(dim(sim[[1]]), c(100,15))
+ expect_equivalent(sim[[1]][3,1:3], c(3,0,0))
+ expect_equivalent(dim(sim[[1]]), c(100,15))
#Check ranef
set.seed(123)
ran <- ranef(fit)
- checkEqualsNumeric(bup(ran)[1,1], 3.450738, tol=1e-5)
+ expect_equivalent(bup(ran)[1,1], 3.450738, tol=1e-5)
#Check error when random effect in formula
- checkException(multmixOpen(~(1|dummy), ~1, ~1, ~1, umf))
-}
+ expect_error(multmixOpen(~(1|dummy), ~1, ~1, ~1, umf))
+})
-test.multmixOpen.NA <- function(){
+test_that("multmixOpen handles NAs",{
set.seed(123)
simy <- simData(lambda=4, gamma=0.5, omega=0.8, p=0.5,
@@ -111,14 +114,11 @@ test.multmixOpen.NA <- function(){
umf <- unmarkedFrameMMO(y=simy$y, numPrimary=5, siteCovs=sc,
obsCov=oc, type="removal")
- fit <- multmixOpen(~x1, ~1, ~1, ~x2, K=30, data=umf)
+ fit <- expect_warning(multmixOpen(~x1, ~1, ~1, ~x2, K=20, data=umf))
- checkEqualsNumeric(coef(fit), c(1.3800182,0.0390053,
+ expect_equivalent(coef(fit), c(1.3800182,0.0390053,
-0.679937,1.398098,
0.02802259,0.010705), tol=1e-4)
- options(warn=2)
- checkException(multmixOpen(~x1, ~1, ~1, ~x2, K=30, data=umf))
- options(warn=0)
# Check ranef
set.seed(123)
@@ -133,39 +133,49 @@ test.multmixOpen.NA <- function(){
umf <- unmarkedFrameMMO(y=simy$y, numPrimary=5, siteCovs=sc,
obsCov=oc, type="removal")
- fit <- multmixOpen(~x1, ~1, ~1, ~x2, K=30, data=umf)
+ fit <- multmixOpen(~x1, ~1, ~1, ~x2, K=20, data=umf)
r <- ranef(fit)
- checkTrue(cor(simy$N[,1], bup(r)[,1]) > 0.9)
+ expect_true(cor(simy$N[,1], bup(r)[,1]) > 0.9)
-}
+})
-test.multmixOpen.double <- function(){
+test_that("multmixOpen can fit double observer models",{
set.seed(123)
simy <- simData(lambda=4, gamma=0.5, omega=0.8, p=0.5, p2=0.5,
M=300, T=5, type="double")
umf <- unmarkedFrameMMO(y=simy$y, numPrimary=5,
+ obsCovs=data.frame(x2=rnorm(300*2*5)),
siteCovs=data.frame(x1=rnorm(300)),
type="double")
- fit <- multmixOpen(~x1, ~1, ~1, ~x1, K=30, data=umf)
+ # Check that subset works
+ umf2 <- umf[1:10,]
+ expect_equal(numSites(umf2), 10)
+
+ fit <- multmixOpen(~x1, ~1, ~1, ~x1, K=20, data=umf)
- checkEqualsNumeric(coef(fit), c(1.405123,-0.037941,-0.52361,
- 1.321799,0.070564,-0.0150329), tol=1e-4)
+ expect_equivalent(coef(fit), c(1.4051,-0.04087,-0.52504,
+ 1.31978,0.072867,0.020069), tol=1e-4)
pv <- getP(fit)
- checkEqualsNumeric(dim(pv), dim(umf@y))
- checkEqualsNumeric(pv[1,1:3], pv[1,4:6])
+ expect_equivalent(dim(pv), dim(umf@y))
+ expect_equivalent(pv[1,1:3], pv[1,4:6])
- checkEqualsNumeric(pv[1,1:3], c(0.2497033,0.2497033,0.26752), tol=1e-5)
+ expect_equivalent(pv[1,1:3], c(0.24951,0.24951,0.272669), tol=1e-5)
-}
+ # Check that obs cov is handled correctly
+ fit2 <- multmixOpen(~x1, ~1, ~1, ~x2, K=20, data=umf)
+ expect_equivalent(coef(fit2), c(1.4046, -0.04114,-0.5238,1.3198,0.07129,-0.00405),
+ tol=1e-4)
+
+})
-test.multmixOpen.NB <- function(){
+test_that("multmixOpen can fit negative binomial models",{
set.seed(123)
simy <- simData(lambda=4, gamma=0.5, omega=0.8, p=0.5,
@@ -176,14 +186,14 @@ test.multmixOpen.NB <- function(){
umf <- unmarkedFrameMMO(y=simy$y, numPrimary=5, siteCovs=sc,
type="removal")
- fit <- multmixOpen(~x1, ~1, ~1, ~x1, K=30, mixture="NB", data=umf)
+ fit <- multmixOpen(~x1, ~1, ~1, ~x1, K=20, mixture="NB", data=umf)
- checkEqualsNumeric(coef(fit), c(1.38861,0.0433983,-0.68451,1.40705,
- 0.031728,-0.002354,9.81414),tol=1e-5)
+ expect_equivalent(coef(fit), c(1.38861,0.0433983,-0.68451,1.40705,
+ 0.031728,-0.002354,9.81437),tol=1e-5)
-}
+})
-test.multmixOpen.dynamics <- function(){
+test_that("pop dynamics work with multmixOpen",{
set.seed(123)
simy <- simData(lambda=4, gamma=2, omega=0.5, p=0.5,
@@ -196,17 +206,17 @@ test.multmixOpen.dynamics <- function(){
obsCov=oc, type="removal")
fm <- multmixOpen(~1, ~1, ~1, ~1, data = umf, K=25, dynamics="notrend")
- checkEqualsNumeric(coef(fm), c(1.35929,-0.18441,-0.041613), tol=1e-4)
+ expect_equivalent(coef(fm), c(1.35929,-0.18441,-0.041613), tol=1e-4)
fm <- multmixOpen(~1, ~1, ~1, ~1, data = umf, K=25, dynamics="trend")
- checkEqualsNumeric(coef(fm), c(1.43740,-0.01538,-0.22348), tol=1e-5)
+ expect_equivalent(coef(fm), c(1.43740,-0.01538,-0.22348), tol=1e-5)
fm <- multmixOpen(~1, ~1, ~1, ~1, data = umf, K=25, dynamics="autoreg")
- checkEqualsNumeric(coef(fm), c(1.45539,-0.76353,0.075356,-0.277835), tol=1e-5)
+ expect_equivalent(coef(fm), c(1.45539,-0.76353,0.075356,-0.277835), tol=1e-5)
#Sketchy estimates
#Maybe just because data were simulated using a different process?
#Leaving these in for now just to make sure they run without errors
fm <- multmixOpen(~1, ~1, ~1, ~1, data = umf, K=25, dynamics="gompertz")
- fm <- multmixOpen(~1, ~1, ~1, ~1, data = umf, K=25, dynamics="ricker")
-}
+ expect_warning(fm <- multmixOpen(~1, ~1, ~1, ~1, data = umf, K=25, dynamics="ricker"))
+})
diff --git a/inst/unitTests/runit.nmixTTD.R b/tests/testthat/test_nmixTTD.R
index 95a3cd5..28368b0 100644
--- a/inst/unitTests/runit.nmixTTD.R
+++ b/tests/testthat/test_nmixTTD.R
@@ -1,3 +1,6 @@
+context("nmixTTD fitting function")
+skip_on_cran()
+
#Setup common vars
M = 100 # Number of sites
nrep <- 3 # Number of visits per site
@@ -11,57 +14,61 @@ set.seed(123)
covDet <- matrix(rnorm(M*nrep),nrow = M,ncol = nrep) #Detection covariate
covDens <- rnorm(M) #Abundance/density covariate
-test.nmixTTD.P.exp <- function(){
+test_that("nmixTTD can fit a Poisson/exp model",{
set.seed(123)
dens <- exp(log(mu.dens) + beta1 * covDens)
N <- rpois(M, dens) # Realized density per site
lambda <- exp(log(mu.lambda) + alpha1 * covDet) # per-individual detection rate
ttd <- NULL
for(i in 1:nrep){
- ttd <- cbind(ttd,rexp(M, N*lambda[,i]))
+ expect_warning(ttd <- cbind(ttd,rexp(M, N*lambda[,i])))
}
ttd[N == 0,] <- 5 # Not observed where N = 0; ttd set to Tmax
ttd[ttd >= Tmax] <- 5 # Crop at Tmax
umf <- unmarkedFrameOccuTTD(y = ttd, surveyLength=5,
- siteCovs = data.frame(covDens=covDens),
- obsCovs = data.frame(covDet=as.vector(t(covDet))))
+ siteCovs = data.frame(covDens=covDens,
+ cdens2=rnorm(length(covDens)),
+ cdens3=rnorm(length(covDens))),
+ obsCovs = data.frame(covDet=as.vector(t(covDet)),
+ cdet2=rnorm(length(covDet)),
+ cdet3=rnorm(length(covDet))))
fit <- nmixTTD(~covDens, ~covDet, data=umf, K=max(N)+10)
- checkEqualsNumeric(coef(fit), c(-0.2846,1.1224,0.2221,-1.06713), tol=1e-4)
+ expect_equivalent(coef(fit), c(-0.2846,1.1224,0.2221,-1.06713), tol=1e-4)
#with NA
umf@y[1,1] <- NA
fit <- nmixTTD(~covDens, ~covDet, data=umf, K=max(N)+10)
- checkEqualsNumeric(coef(fit), c(-0.2846,1.1224,0.2221,-1.06713), tol=1e-4)
+ expect_equivalent(coef(fit), c(-0.2846,1.1224,0.2221,-1.06713), tol=1e-4)
#Predict
pr1 <- predict(fit, "state")
- checkEqualsNumeric(dim(pr1), c(M, 4))
- checkEqualsNumeric(pr1$Predicted[1:2], c(0.3371,0.3232), tol=1e-4)
+ expect_equivalent(dim(pr1), c(M, 4))
+ expect_equivalent(pr1$Predicted[1:2], c(0.3371,0.3232), tol=1e-4)
nd <- data.frame(covDens=0)
pr2 <- predict(fit, "state", newdata=nd)
- checkEqualsNumeric(pr2$Predicted, 0.7523, tol=1e-4)
+ expect_equivalent(pr2$Predicted, 0.7523, tol=1e-4)
pr3 <- predict(fit, "det")
- checkEqualsNumeric(dim(pr3), c(M*nrep, 4))
- checkEqualsNumeric(pr3$Predicted[1], 2.2710, tol=1e-4)
+ expect_equivalent(dim(pr3), c(M*nrep, 4))
+ expect_equivalent(pr3$Predicted[1], 2.2710, tol=1e-4)
nd <- data.frame(covDet=0)
pr4 <- predict(fit, "det", newdata=nd)
- checkEqualsNumeric(dim(pr4), c(1,4))
- checkEqualsNumeric(pr4$Predicted, 1.248748, tol=1e-4)
+ expect_equivalent(dim(pr4), c(1,4))
+ expect_equivalent(pr4$Predicted, 1.248748, tol=1e-4)
#Check with site covs in det formula
fit_pred <- nmixTTD(~1, ~covDens, data=umf, K=max(N)+10)
pr5 <- predict(fit_pred, "det")
- checkEqualsNumeric(dim(pr5), c(M*nrep, 4))
- checkEqualsNumeric(pr5$Predicted[1:3], rep(0.587956, 3), tol=1e-4)
- checkEqualsNumeric(pr5$Predicted[4:6], rep(0.5769142, 3), tol=1e-4)
+ expect_equivalent(dim(pr5), c(M*nrep, 4))
+ expect_equivalent(pr5$Predicted[1:3], rep(0.587956, 3), tol=1e-4)
+ expect_equivalent(pr5$Predicted[4:6], rep(0.5769142, 3), tol=1e-4)
nd5 <- data.frame(covDens=c(1,2))
pr6 <- predict(fit_pred, "det", newdata=nd5)
- checkEqualsNumeric(dim(pr6), c(2,4))
+ expect_equivalent(dim(pr6), c(2,4))
#Simulate
sim <- simulate(fit, 2)
- checkTrue(inherits(sim, "list"))
- checkEqualsNumeric(length(sim), 2)
- checkEqualsNumeric(dim(sim[[1]]), dim(umf@y))
+ expect_is(sim, "list")
+ expect_equivalent(length(sim), 2)
+ expect_equivalent(dim(sim[[1]]), dim(umf@y))
#Update
fit2 <- update(fit, data=umf[1:10,])
@@ -69,21 +76,28 @@ test.nmixTTD.P.exp <- function(){
#Ranef
r <- ranef(fit)
b <- bup(r)
- checkEqualsNumeric(length(b), M)
- checkEqualsNumeric(b[2], 1.204738, tol=1e-5)
+ expect_equivalent(length(b), M)
+ expect_equivalent(b[2], 1.204738, tol=1e-5)
- checkException(residuals(fit))
+ expect_error(residuals(fit))
#Try with threads=2
fit <- nmixTTD(~covDens, ~covDet, data=umf, K=max(N)+10)
fit_2 <- nmixTTD(~covDens, ~covDet, data=umf, K=max(N)+10, threads=2)
- checkEqualsNumeric(coef(fit), coef(fit_2))
+ expect_equivalent(coef(fit), coef(fit_2))
#Check error when random effect in formula
- checkException(nmixTTD(~(1|dummy), ~1, umf))
-}
+ expect_error(nmixTTD(~(1|dummy), ~1, umf))
+
+ #Check with more than 1 detection covariate
+ fit3 <- nmixTTD(~covDens, ~covDet+cdet2+cdet3, data=umf, K=max(N)+10)
+ expect_equivalent(length(coef(fit3, "det")), 4)
+ fit4 <- nmixTTD(~covDens+cdens2, ~covDet+cdet2+cdet3, data=umf, K=max(N)+10)
+ expect_equivalent(length(coef(fit4, "state")), 3)
+ expect_equivalent(length(coef(fit4, "det")), 4)
+})
-test.nmixTTD.P.weib <- function(){
+test_that("nmixTTD can fit a P/weib model",{
set.seed(123)
shape = 5
dens <- exp(log(mu.dens) + beta1 * covDens)
@@ -91,7 +105,7 @@ test.nmixTTD.P.weib <- function(){
lambda <- exp(log(mu.lambda) + alpha1 * covDet) # per-individual detection rate
ttd <- NULL
for(i in 1:nrep) {
- ttd <- cbind(ttd,rweibull(M, shape, 1/(N*lambda[,i])))
+ expect_warning(ttd <- cbind(ttd,rweibull(M, shape, 1/(N*lambda[,i]))))
}
ttd[N == 0,] <- 5 # Not observed where N = 0; ttd set to Tmax
ttd[ttd >= Tmax] <- 5 # Crop at Tmax
@@ -100,16 +114,16 @@ test.nmixTTD.P.weib <- function(){
obsCovs = data.frame(covDet=as.vector(t(covDet))))
fit <- nmixTTD(~covDens, ~covDet, data=umf, K=max(N)+10, ttdDist="weibull")
- checkEquals(names(fit@estimates@estimates), c("state","det","shape"))
- checkEqualsNumeric(coef(fit), c(-0.08528,1.0540,0.0326,-0.9981,1.7203), tol=1e-4)
+ expect_equal(names(fit@estimates@estimates), c("state","det","shape"))
+ expect_equivalent(coef(fit), c(-0.08528,1.0540,0.0326,-0.9981,1.7203), tol=1e-4)
sim <- simulate(fit, 2)
r <- ranef(fit)
-}
+})
-test.nmixTTD.NB.exp <- function(){
+test_that("nmixTTD can fit a NB/exp model",{
set.seed(123)
- M = 500 # Number of sites
+ M = 100 # Number of sites
covDet <- matrix(rnorm(M*nrep),nrow = M,ncol = nrep) #Detection covariate
covDens <- rnorm(M) #Abundance/density covariate
dens <- exp(log(mu.dens) + beta1 * covDens)
@@ -118,7 +132,7 @@ test.nmixTTD.NB.exp <- function(){
lambda <- exp(log(mu.lambda) + alpha1 * covDet) # per-individual detection rate
ttd <- NULL
for(i in 1:nrep) {
- ttd <- cbind(ttd,rexp(M, N*lambda[,i])) # Simulate time to first detection per visit
+ expect_warning(ttd <- cbind(ttd,rexp(M, N*lambda[,i])))
}
ttd[N == 0,] <- 5 # Not observed where N = 0; ttd set to Tmax
ttd[ttd >= Tmax] <- 5 # Crop at Tmax
@@ -127,16 +141,16 @@ test.nmixTTD.NB.exp <- function(){
obsCovs = data.frame(covDet=as.vector(t(covDet))))
fit <- nmixTTD(~covDens, ~covDet, data=umf, K=max(N)+10, mixture="NB")
- checkEquals(names(fit@estimates@estimates), c("state","det","alpha"))
- checkEqualsNumeric(coef(fit), c(-0.0991,1.017,-0.00264,-0.99387, 1.1499), tol=1e-4)
+ expect_equal(names(fit@estimates@estimates), c("state","det","alpha"))
+ expect_equivalent(coef(fit), c(-0.5082811,1.13194,0.38896,-1.05740,1.58577), tol=1e-4)
sim <- simulate(fit, 2)
r <- ranef(fit)
-}
+})
-test.nmixTTD.NB.weib <- function(){
+test_that("nmixTTD can fit a NB/weib model",{
set.seed(123)
- M = 500 # Number of sites
+ M = 100 # Number of sites
covDet <- matrix(rnorm(M*nrep),nrow = M,ncol = nrep) #Detection covariate
covDens <- rnorm(M) #Abundance/density covariate
dens <- exp(log(mu.dens) + beta1 * covDens)
@@ -146,7 +160,7 @@ test.nmixTTD.NB.weib <- function(){
lambda <- exp(log(mu.lambda) + alpha1 * covDet) # per-individual detection rate
ttd <- NULL
for(i in 1:nrep) {
- ttd <- cbind(ttd,rweibull(M, shape, 1/(N*lambda[,i])))
+ expect_warning(ttd <- cbind(ttd,rweibull(M, shape, 1/(N*lambda[,i]))))
}
ttd[N == 0,] <- 5 # Not observed where N = 0; ttd set to Tmax
ttd[ttd >= Tmax] <- 5 # Crop at Tmax
@@ -155,9 +169,35 @@ test.nmixTTD.NB.weib <- function(){
obsCovs = data.frame(covDet=as.vector(t(covDet))))
fit <- nmixTTD(~covDens, ~covDet, data=umf, K=max(N)+10,
mixture="NB", ttdDist="weibull")
- checkEquals(names(fit@estimates@estimates), c("state","det","alpha","shape"))
- checkEqualsNumeric(coef(fit), c(-0.0605,1.0328,-0.0006,-1.008,0.8141,1.6311), tol=1e-4)
+ expect_equal(names(fit@estimates@estimates), c("state","det","alpha","shape"))
+ expect_equivalent(coef(fit), c(-0.1690,1.1790,-0.01958,-0.97968,0.93577,1.7440), tol=1e-4)
sim <- simulate(fit, 2)
r <- ranef(fit)
-}
+})
+
+test_that("R and C++ engines give identical results",{
+
+ set.seed(123)
+ dens <- exp(log(mu.dens) + beta1 * covDens)
+ N <- rpois(M, dens) # Realized density per site
+ lambda <- exp(log(mu.lambda) + alpha1 * covDet) # per-individual detection rate
+ ttd <- NULL
+ for(i in 1:nrep){
+ expect_warning(ttd <- cbind(ttd,rexp(M, N*lambda[,i])))
+ }
+ ttd[N == 0,] <- 5 # Not observed where N = 0; ttd set to Tmax
+ ttd[ttd >= Tmax] <- 5 # Crop at Tmax
+ umf <- unmarkedFrameOccuTTD(y = ttd, surveyLength=5,
+ siteCovs = data.frame(covDens=covDens,
+ cdens2=rnorm(length(covDens)),
+ cdens3=rnorm(length(covDens))),
+ obsCovs = data.frame(covDet=as.vector(t(covDet)),
+ cdet2=rnorm(length(covDet)),
+ cdet3=rnorm(length(covDet))))
+
+ fit <- nmixTTD(~covDens, ~covDet, data=umf, K=max(N)+10, control=list(maxit=2))
+ fitR <- nmixTTD(~covDens, ~covDet, data=umf, K=max(N)+10,
+ engine="R", control=list(maxit=2))
+ expect_equal(coef(fit), coef(fitR))
+})
diff --git a/inst/unitTests/runit.nonparboot.R b/tests/testthat/test_nonparboot.R
index fa7682b..d8fe127 100644
--- a/inst/unitTests/runit.nonparboot.R
+++ b/tests/testthat/test_nonparboot.R
@@ -1,8 +1,7 @@
+context("nonparboot")
+skip_on_cran()
-
-
-
-test.nonparboot.occu <- function() {
+test_that("nonparboot works with occu",{
set.seed(3343)
R <- 20
@@ -18,23 +17,20 @@ test.nonparboot.occu <- function() {
umf <- unmarkedFrameOccu(y=y, siteCovs=data.frame(x1=x1),
obsCovs=list(x2=x2))
fm1 <- occu(~1 ~1, umf)
- fm2 <- occu(~x2 ~x1, umf)
+ fm2 <- expect_warning(occu(~x2 ~x1, umf))
fm1 <- nonparboot(fm1, B=2)
- fm2 <- nonparboot(fm2, B=2)
+ fm2 <- expect_warning(nonparboot(fm2, B=2))
- checkEqualsNumeric(vcov(fm2, method="nonparboot"), matrix(c(
+ expect_equivalent(vcov(fm2, method="nonparboot"), matrix(c(
0.07921827, -0.04160450, -0.10779357, -0.03159398,
-0.04160450, 0.02185019, 0.05661192, 0.01659278,
-0.10779357, 0.05661192, 0.14667645, 0.04299043,
-0.03159398, 0.01659278, 0.04299043, 0.01260037), 4, byrow=TRUE),
tolerance=1e-5)
-}
-
-
-
+})
-test.nonparboot.gmultmix <- function() {
+test_that("nonparboot works with gmultmix", {
set.seed(34)
n <- 10 # number of sites
@@ -66,6 +62,7 @@ test.nonparboot.gmultmix <- function() {
numPrimary=T, type="removal")
fm1 <- gmultmix(~1, ~1, ~1, umf1, K=10)
fm1 <- nonparboot(fm1, B=2)
+ expect_equal(length(fm1@bootstrapSamples), 2)
umf2 <- unmarkedFrameGMM(y=y.ijt, siteCovs=data.frame(sc=sc1),
obsCovs=list(oc=oc1),
@@ -84,12 +81,9 @@ test.nonparboot.gmultmix <- function() {
fm4 <- nonparboot(fm4, B=2)
-}
+})
-
-
-
-test.nonparboot.colext <- function() {
+test_that("nonparboot works with colext",{
set.seed(343)
nSites <- 10
@@ -128,7 +122,7 @@ test.nonparboot.colext <- function() {
m1 <- colext(~1, ~1, ~1, ~1, umf1)
m1 <- nonparboot(m1, B=2)
- checkEqualsNumeric(vcov(m1, method="nonparboot"),
+ expect_equivalent(vcov(m1, method="nonparboot"),
matrix(c(
0.06233947, 0.02616514, 0.06325770, 0.06703464,
0.02616514, 0.01098204, 0.02655053, 0.02813579,
@@ -147,14 +141,11 @@ test.nonparboot.colext <- function() {
yearlySiteCovs=list(ysc=ysc),
obsCovs=list(oc=oc), numPrimary=nYears)
- m2 <- colext(~sc, ~ysc, ~1, ~oc, umf2)
- m2 <- nonparboot(m2, B=2)
-
-
-
-}
+ m2 <- expect_warning(colext(~sc, ~ysc, ~1, ~oc, umf2))
+ m2 <- expect_warning(nonparboot(m2, B=2))
+})
-test.nonparboot.noObsCovs <- function() {
+test_that("nonparboot works without obs covs",{
data(frogs)
#No obs covs
@@ -162,6 +153,6 @@ test.nonparboot.noObsCovs <- function() {
set.seed(123)
fm <- occu(~ 1 ~ 1, pferUMF)
npb <- nonparboot(fm,B=4)
- checkEqualsNumeric(SE(npb), c(29.4412950, 0.1633507), tol=1e-5)
+ expect_equivalent(SE(npb), c(29.4412950, 0.1633507), tol=1e-5)
-}
+})
diff --git a/tests/testthat/test_occu.R b/tests/testthat/test_occu.R
new file mode 100644
index 0000000..7ea3afe
--- /dev/null
+++ b/tests/testthat/test_occu.R
@@ -0,0 +1,404 @@
+context("occu fitting function")
+
+skip_on_cran()
+
+test_that("occu can fit simple models",{
+
+ y <- matrix(rep(1,10)[1:10],5,2)
+ umf <- unmarkedFrameOccu(y = y)
+ fm <- occu(~ 1 ~ 1, data = umf)
+
+ occ <- fm['state']
+ det <- fm['det']
+
+ occ <- coef(backTransform(occ))
+ expect_equivalent(occ,1)
+
+ det <- coef(backTransform(det))
+ expect_equivalent(det,1)
+
+ bt <- backTransform(fm, type = 'state')
+ expect_equivalent(coef(bt), 1)
+
+ bt <- backTransform(fm, type = 'det')
+ expect_equivalent(coef(bt), 1)
+
+ est_obj <- fm@estimates@estimates$state
+ expect_equal(est_obj@invlink, "logistic")
+ expect_equal(est_obj@invlinkGrad, "logistic.grad")
+
+ y <- matrix(rep(0,10)[1:10],5,2)
+ umf <- unmarkedFrameOccu(y = y)
+ fm <- occu(~ 1 ~ 1, data = umf)
+
+ occ <- fm['state']
+ det <- fm['det']
+
+ occ <- coef(backTransform(occ))
+ expect_equivalent(occ, 0, tolerance = 1e-4)
+
+ det <- coef(backTransform(det))
+ expect_equivalent(det,0, tolerance = 1e-4)
+
+ bt <- backTransform(fm, type = 'state')
+ expect_equivalent(coef(bt), 0, tolerance = 1e-4)
+
+ bt <- backTransform(fm, type = 'det')
+ expect_equivalent(coef(bt), 0, tolerance = 1e-4)
+
+
+})
+
+test_that("occu can fit models with covariates",{
+ skip_on_cran()
+ y <- matrix(rep(0:1,10)[1:10],5,2)
+ siteCovs <- data.frame(x = c(0,2,3,4,1))
+ obsCovs <- data.frame(o1 = 1:10, o2 = exp(-5:4)/10)
+ umf <- unmarkedFrameOccu(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
+ fm <- occu(~ o1 + o2 ~ x, data = umf)
+ fmR <- occu(~ o1 + o2 ~x, data = umf, engine="R")
+ expect_equal(coef(fm), coef(fmR))
+
+ occ <- fm['state']
+ det <- fm['det']
+
+ expect_error(occ <- coef(backTransform(occ)))
+
+ expect_equivalent(coef(occ), c(8.590737, 2.472220), tolerance = 1e-4)
+ expect_equivalent(coef(det), c(0.44457, -0.14706, 0.44103), tolerance = 1e-4)
+
+ ci <- confint(occ)
+ expect_equal(dim(ci), c(2,2))
+
+ out <- capture.output(occ)
+ expect_equal(out[1], "Occupancy:")
+
+ occ.lc <- linearComb(fm, type = 'state', c(1, 0.5))
+ det.lc <- linearComb(fm, type = 'det', c(1, 0.3, -0.3))
+
+ expect_equivalent(coef(occ.lc), 9.826848, tol = 1e-4)
+ expect_equivalent(coef(det.lc), 0.2681477, tol = 1e-4)
+
+ expect_equivalent(coef(backTransform(occ.lc)), 1, tol = 1e-4)
+ expect_equivalent(coef(backTransform(det.lc)), 0.5666381, tol = 1e-4)
+
+ expect_error(backTransform(fm, type = "state"))
+ expect_error(backTransform(fm, type = "det"))
+
+ fitted <- fitted(fm)
+ expect_equivalent(fitted, structure(c(0.5738, 0.5014, 0.4318, 0.38581, 0.50171, 0.53764,
+0.46563, 0.40283, 0.39986, 0.79928), .Dim = c(5L, 2L)), tol = 1e-5)
+
+ # methods
+ gp <- getP(fm)
+ expect_equal(dim(gp), c(5,2))
+ res <- residuals(fm)
+ expect_equal(dim(res), c(5,2))
+ expect_equal(res[1,1], -0.57380, tol=1e-4)
+
+ r <- ranef(fm)
+ expect_equal(dim(r@post), c(5,2,1))
+ expect_equal(bup(r), c(1,1,1,1,1))
+
+ s <- simulate(fm, 2)
+ expect_equal(length(s), 2)
+ expect_equal(dim(s[[1]]), dim(umf@y))
+
+ fitstats <- function(fm) {
+ observed <- getY(fm@data)
+ expected <- fitted(fm)
+ resids <- residuals(fm)
+ sse <- sum(resids^2,na.rm=TRUE)
+ chisq <- sum((observed - expected)^2 / expected,na.rm=TRUE)
+ freeTuke <- sum((sqrt(observed) - sqrt(expected))^2,na.rm=TRUE)
+ out <- c(SSE=sse, Chisq=chisq, freemanTukey=freeTuke)
+ return(out)
+ }
+ pb <- parboot(fm, fitstats, nsim=3)
+ expect_equal(dim(pb@t.star), c(3,3))
+
+ y <- matrix(rep(0,10)[1:10],5,2)
+ siteCovs <- data.frame(x = c(0,2,3,4,1))
+ obsCovs <- data.frame(o1 = 1:10, o2 = exp(-5:4)/10)
+ umf <- unmarkedFrameOccu(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
+ expect_warning(fm <- occu(~ o1 + o2 ~ x, data = umf))
+ detMat <- fm@estimates@estimates$det@covMat
+ stMat <- fm@estimates@estimates$state@covMat
+ expect_equivalent(detMat, matrix(rep(NA,9),nrow=3))
+ expect_equivalent(stMat, matrix(rep(NA,4),nrow=2))
+
+})
+
+test_that("occu handles NAs",{
+
+ y <- matrix(rep(0:1,10)[1:10],5,2)
+ siteCovs <- data.frame(x = c(0,2,3,4,1))
+ siteCovs[3,1] <- NA
+ obsCovs <- data.frame(o1 = 1:10, o2 = exp(-5:4)/10)
+ umf <- unmarkedFrameOccu(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
+ expect_warning(fm <- occu(~ o1 + o2 ~ x, data = umf))
+ expect_equal(fm@sitesRemoved, 3)
+ expect_equivalent(coef(fm), c(8.70123, 4.58255, 0.66243, -0.22862, 0.58192), tol = 1e-5)
+
+ obsCovs[10,2] <- NA
+ umf <- unmarkedFrameOccu(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
+ expect_warning(fm <- occu(~ o1 + o2 ~ x, data = umf))
+ expect_equal(fm@sitesRemoved, 3)
+ expect_equivalent(coef(fm), c(8.91289, 1.89291, -1.42471, 0.67011, -8.44608), tol = 1e-5)
+
+})
+
+## Add some checks here.
+test_that("occu handles offsets",{
+
+ y <- matrix(rep(0:1,10)[1:10],5,2)
+ siteCovs <- data.frame(x = c(0,2,3,4,1))
+ obsCovs <- data.frame(o1 = 1:10, o2 = exp(-5:4)/10)
+ umf <- unmarkedFrameOccu(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
+ fm <- occu(~ o1 + o2 ~ offset(x), data = umf)
+ expect_equivalent(coef(fm),
+ structure(c(9.74361, 0.44327, -0.14683, 0.44085), .Names = c("psi(Int)",
+"p(Int)", "p(o1)", "p(o2)")), tol = 1e-5)
+ fm <- occu(~ o1 + offset(o2) ~ offset(x), data = umf)
+ expect_equivalent(coef(fm), structure(c(8.59459, 0.97574, -0.3096), .Names = c("psi(Int)",
+"p(Int)", "p(o1)")), tol=1e-5)
+
+})
+
+test_that("occu cloglog link function works",{
+ skip_on_cran()
+ #Adapted from example by J. Cohen
+ set.seed(123)
+ M = 500 #sample size
+ J = 3 #number of visits
+
+ #standardized covariates
+ elev <- runif(n = M, 0,100)
+ forest <- runif(n = M, 0,1)
+ wind <- array(runif(n = M * J, 0,20), dim = c(M, J))
+ elev=as.numeric(scale(elev))
+ forest=as.numeric(scale(forest))
+ wind[,1] <- as.numeric(scale(wind[,1]))
+ wind[,2] <- as.numeric(scale(wind[,2]))
+ wind[,3] <- as.numeric(scale(wind[,3]))
+
+ #regression parameters for abundance
+ beta0 = -0.69
+ beta1 = 0.71
+ beta2 = -0.5
+
+ #simulate abundance and derive true occupancy
+ lambda <- exp(beta0 + beta1 * elev + beta2 * forest)
+ N <- rpois(n = M, lambda = lambda)
+ z <- as.numeric(N>0)
+ #regression parameters for detection
+ alpha0 = -0.84
+ alpha1 = 2.
+ alpha2 = -1.2
+
+ #simulate detection
+ p <- plogis(alpha0 + alpha1 * elev + alpha2 * wind )
+
+ #create vectors of simulation values, for easy comparison to model estimates
+ true.beta.p <- c(alpha0,alpha1,alpha2)
+ true.beta.occ <- c(beta0,beta1,beta2)
+
+ #generate observed presence
+ Obs.pres <- matrix(NA,M,J)
+ for (i in 1:M){
+ for (j in 1:J){
+ Obs.pres[i,j] <- rbinom(1,1,z[i]*p[i,j])
+ }
+ }
+ Obs.ever <- apply(Obs.pres,1,max)
+
+ #create observation-level covariate data frame for unmarked
+ sitevec <- rep(1:M,3) #vector of site ID's
+ wind.df <- data.frame("wind"=wind)
+ colnames(wind.df) <- c("Wind.1","Wind.2","Wind.3")
+ wind.vec <- c(wind.df$Wind.1,wind.df$Wind.2,wind.df$Wind.3)
+ wind.frame <- data.frame("site"=sitevec,"wind"=wind.vec)
+ wind.frame.order <- wind.frame[order(wind.frame$site),]
+ wind.for.um <- data.frame(wind.frame.order$wind)
+ colnames(wind.for.um)="wind"
+
+ #create unmarked data object
+ occ.frame <- unmarkedFrameOccu(Obs.pres,
+ siteCovs=data.frame("ele"=elev,"forest"=forest),
+ obsCovs=wind.for.um)
+
+ #create model object
+ occ_test <-occu(~ele+wind ~ele+forest, occ.frame, linkPsi="cloglog",
+ se=F)
+ truth <- c(true.beta.occ, true.beta.p)
+ est <- coef(occ_test)
+ expect_equivalent(truth, est, tol=0.1)
+ expect_equivalent(est,
+ c(-0.7425,0.6600,-0.3333,-0.87547,2.0677,-1.3082), tol=1e-4)
+
+ est_obj <- occ_test@estimates@estimates$state
+ expect_equal(est_obj@invlink, "cloglog")
+ expect_equal(est_obj@invlinkGrad, "cloglog.grad")
+
+ #Check error if wrong link function
+ expect_error(occu(~ele+wind ~ele+forest, occ.frame, linkPsi="fake"))
+})
+
+test_that("occu predict works",{
+ skip_on_cran()
+ skip_if(!require(raster), "raster package unavailable")
+ set.seed(55)
+ R <- 20
+ J <- 4
+ x1 <- rnorm(R)
+ x2 <- factor(c(rep('A', R/2), rep('B', R/2)))
+ x3 <- matrix(rnorm(R*J), R, J)
+ z <- rbinom(R, 1, 0.5)
+ y <- matrix(rbinom(R*J, 1, z*0.6), R, J)
+ x1[1] <- NA
+ x3[2,1] <- NA
+ x3[3,] <- NA
+ umf1 <- unmarkedFrameOccu(y=y, siteCovs=data.frame(x1=x1, x2=x2),
+ obsCovs=list(x3=x3))
+ fm1 <- expect_warning(occu(~x3 ~x1+x2, umf1))
+ E1.1 <- expect_warning(predict(fm1, type="state"))
+ E1.2 <- expect_warning(predict(fm1, type="det"))
+
+ nd1.1 <- data.frame(x1=0, x2=factor('A', levels=c('A','B')))
+ nd1.2 <- data.frame(x3=0)
+ E1.3 <- predict(fm1, type="state", newdata=nd1.1, appendData=TRUE)
+ E1.4 <- predict(fm1, type="det", newdata=nd1.2)
+
+ r1 <- raster(matrix(rnorm(100), 10))
+ expect_error(predict(fm1, type="state", newdata=r1))
+ s1 <- stack(r1)
+ expect_error(predict(fm1, type="state", newdata=s1))
+ names(s1) <- c("x3")
+ E1.5 <- predict(fm1, type="det", newdata=s1)
+ E1.5 <- predict(fm1, type="det", newdata=s1, appendData=TRUE)
+
+ E1.6 <- expect_warning(predict(fm1, type="state", level=0.9))
+ expect_equal(as.numeric(E1.6[1,3:4]), c(0.01881844, 0.8538048))
+})
+
+test_that("occu predict can handle complex formulas",{
+
+ y <- matrix(rep(0:1,10)[1:10],5,2)
+ siteCovs <- data.frame(x = c(0,2,3,4,1))
+ obsCovs <- data.frame(o1 = 1:10, o2 = exp(-5:4)/10)
+ umf <- unmarkedFrameOccu(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
+ fm <- occu(~ scale(o1) + o2 ~ x, data = umf)
+
+ #Predict values should not depend on means/variance of newdata itself
+ nd1 <- obsCovs(umf[1:2,])
+ pr1 <- predict(fm, 'det', newdata=nd1)
+ nd2 <- obsCovs(umf[1:4,])
+ pr2 <- predict(fm, 'det', newdata=nd2)[1:4,]
+
+ expect_equivalent(pr1, pr2)
+
+ #Check factors
+ siteCovs$fac_cov <- factor(sample(c('a','b','c'), 5, replace=T),
+ levels=c('b','a','c'))
+
+ umf <- unmarkedFrameOccu(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
+ fm <- occu(~ o1 + o2 ~ fac_cov, data = umf)
+
+ pr3 <- predict(fm, 'state', newdata=data.frame(fac_cov=c('a','b')))
+ pr4 <- predict(fm, 'state', newdata=data.frame(fac_cov=c('b','a')))
+
+ expect_equivalent(as.matrix(pr3),as.matrix(pr4[2:1,]))
+ expect_error(predict(fm, 'state', newdata=data.frame(fac_cov=c('a','d'))))
+
+ #Check when original covs contain factor not used in formula
+ siteCovs$fac_cov2 <- factor(sample(c('a','b','c'), 5, replace=T),
+ levels=c('b','a','c'))
+
+ umf <- unmarkedFrameOccu(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
+ fm <- occu(~ o1 + o2 ~ fac_cov, data = umf)
+ #expect_warning(pr <- predict(fm, 'state', newdata=data.frame(fac_cov=c('a','b'))))
+
+})
+
+
+test_that("occu can handle random effects",{
+ skip_on_cran()
+ set.seed(123)
+ n_sites <- 100
+ n_years <- 8
+ site_id <- rep(1:n_sites, each=n_years)
+ M <- n_sites * n_years
+ J <- 5 # number of obs per year
+ site_covs <- data.frame(cov1=rnorm(M), site_id=factor(site_id))
+ beta <- c(intercept=0.5, cov1=0.3)
+ sig <- 1.2
+ site_effect <- rnorm(n_sites, 0, sig)
+ true_site_means <- plogis(beta[1] + site_effect)
+
+ psi <- rep(NA, M)
+ for (i in 1:M){
+ #Random group intercept on psi
+ psi[i] <- plogis(beta[1] + beta[2]*site_covs$cov1[i]
+ + site_effect[site_id[i]])
+ }
+
+ p <- 0.5
+ z <- rbinom(M, 1, psi)
+ y <- matrix(0, nrow=M, ncol=J)
+
+ for (i in 1:M){
+ if(z[i]==1){
+ y[i,] <- rbinom(J, 1, p)
+ }
+ }
+
+ umf <- unmarkedFrameOccu(y=y, siteCovs=site_covs)
+ fm <- occu(~1~cov1 + (1|site_id), umf)
+ expect_equivalent(coef(fm), c(0.65293, 0.39965, -0.02822), tol=1e-4)
+ expect_equivalent(sigma(fm)$sigma, 1.18816, tol=1e-4)
+
+ out <- capture.output(fm)
+ expect_equal(out[6], "Random effects:")
+
+ pr <- predict(fm, "state", newdata=data.frame(cov1=0, site_id=factor(1:100)))
+ expect_is(pr, "data.frame")
+
+ ft <- fitted(fm)
+ expect_equivalent(dim(ft), c(n_sites*n_years, J))
+
+ pb <- parboot(fm, nsim=1)
+ expect_is(pb, "parboot")
+
+ # Check custom initial values
+ expect_equal(fm@TMB$starts_order[1], "beta_det")
+ fmi <- occu(~1~cov1 + (1|site_id), umf, starts=c(10,0,0,0))
+ expect_equivalent(fmi@TMB$par["beta_det"], 10)
+ expect_error(occu(~1~cov1 + (1|site_id), umf, starts=rep(0,3)))
+ expect_error(occu(~1~cov1 + (1|site_id), umf, starts=c(100,0,0,0)))
+
+ # Check site covs as random effects in obs model
+ fm <- occu(~(1|site_id)~1, umf)
+ expect_true(sigma(fm)$Model[1]=="p")
+ pr <- predict(fm, 'det')
+ expect_true(inherits(pr, 'data.frame'))
+
+ umf2 <- unmarkedFrameOccu(y=getY(umf), siteCovs=NULL,
+ obsCovs=data.frame(obs_id=factor(sample(letters[1:5], length(getY(umf)), replace=T))))
+ fm <- occu(~(1|obs_id)~1, umf2)
+ expect_true(sigma(fm)$Model[1]=="p")
+
+ # Check vcov method
+ v1 <- vcov(fm)
+ expect_equivalent(dim(v1), c(2,2))
+ expect_equal(colnames(v1), c("psi(Int)","p(Int)"))
+
+ v2 <- vcov(fm, fixedOnly=FALSE)
+ expect_equivalent(dim(v2), c(7,7))
+ expect_equal(colnames(v2), c("psi(Int)","p(Int)",rep("p(b_det)", 5)))
+
+ fl <- fitList(m1=fm, m2=fm)
+ #options(warn=2)
+ #on.exit(options(warn=0))
+ test <- modSel(fl) # shouldn't warn
+ #options(warn=0)
+})
diff --git a/inst/unitTests/runit.occuFP.R b/tests/testthat/test_occuFP.R
index 3926e9b..f1381bb 100644
--- a/inst/unitTests/runit.occuFP.R
+++ b/tests/testthat/test_occuFP.R
@@ -1,4 +1,7 @@
-test.occuFP.fitList <- function() {
+context("occuFP fitting function")
+skip_on_cran()
+
+test_that("occuFP model can be fit",{
n = 100
o = 10
o1 = 5
@@ -18,10 +21,14 @@ test.occuFP.fitList <- function() {
m1 <- occuFP(detformula = ~ METH, FPformula = ~1,
stateformula = ~ habitat, data = umf1)
- fl <- fitList(m1,m1)
- checkEquals(class(fl)[1],"unmarkedFitList")
- checkEqualsNumeric(length(fl@fits), 2)
+ expect_equal(names(m1), c("state","det","fp"))
+ expect_warning(fl <- fitList(m1,m1))
+ expect_is(fl,"unmarkedFitList")
+ expect_equal(length(fl@fits), 2)
+
+ pr <- predict(m1, "fp")
+ expect_equal(dim(pr), c(1000, 4))
# Check error when random effect in formula
- checkException(occuFP(~(1|dummy), ~1, ~1, data=umf1))
-}
+ expect_error(occuFP(~(1|dummy), ~1, ~1, data=umf1))
+})
diff --git a/inst/unitTests/runit.occuMS.R b/tests/testthat/test_occuMS.R
index b7c2a48..aa0d024 100644
--- a/inst/unitTests/runit.occuMS.R
+++ b/tests/testthat/test_occuMS.R
@@ -1,4 +1,8 @@
-test.unmarkedFrameOccuMS <- function() {
+context("occuMS fitting function")
+skip_on_cran()
+
+test_that("unmarkedFrameOccuMS is constructed properly",{
+
set.seed(123)
N <- 100; J <- 3; S <- 3
psi <- c(0.5,0.3,0.2)
@@ -25,18 +29,71 @@ test.unmarkedFrameOccuMS <- function() {
umf <- unmarkedFrameOccuMS(y=y,siteCovs=site_covs,obsCovs=obs_covs)
- checkEquals(class(umf)[1], "unmarkedFrameOccuMS")
- checkEqualsNumeric(umf@numStates,3)
+ expect_equal(class(umf)[1], "unmarkedFrameOccuMS")
+ expect_equivalent(umf@numStates,3)
umf_sub1 <- umf[1:20,]
- checkEqualsNumeric(numSites(umf_sub1),20)
- checkEquals(class(umf_sub1)[1], "unmarkedFrameOccuMS")
+ expect_equivalent(numSites(umf_sub1),20)
+ expect_is(umf_sub1, "unmarkedFrameOccuMS")
y[y>1] <- 1
- checkException(unmarkedFrameOccuMS(y=y,siteCovs=site_covs,obsCovs=obs_covs))
-}
+ expect_error(unmarkedFrameOccuMS(y=y,siteCovs=site_covs,obsCovs=obs_covs))
+})
+
+test_that("occuMS R and C engines return same results",{
+ skip_on_cran()
+ set.seed(123)
+ N <- 20; J <- 2; S <- 3
+ site_covs <- matrix(rnorm(N*2),ncol=2)
+ obs_covs <- matrix(rnorm(N*J*2),ncol=2)
+ colnames(site_covs) <- paste0("sc",1:2)
+ colnames(obs_covs) <- paste0("oc", 1:2)
+
+ a1 <- -0.5; b1 <- 1; a2 <- -0.6; b2 <- -0.7
+ p11 <- -0.4; p12 <- -1.09; p22 <- -0.84
+ truth <- c(a1,b1,a2,b2,p11,0,p12,p22)
+
+ lp <- matrix(NA,ncol=S,nrow=N)
+ for (n in 1:N){
+ lp[n,2] <- exp(a1+b1*site_covs[n,1])
+ lp[n,3] <- exp(a2+b2*site_covs[n,2])
+ lp[n,1] <- 1
+ }
+ psi_mat <- lp/rowSums(lp)
+
+ z <- rep(NA,N)
+ for (n in 1:N){
+ z[n] <- sample(0:2, 1, replace=T, prob=psi_mat[n,])
+ }
+
+ probs_raw <- matrix(c(1,0,0,1,exp(p11),0,1,exp(p12),exp(p22)),nrow=3,byrow=T)
+ probs_raw <- probs_raw/rowSums(probs_raw)
+
+ y <- matrix(0,nrow=N,ncol=J)
+ for (n in 1:N){
+
+ probs <- switch(z[n]+1,
+ probs_raw[1,],
+ probs_raw[2,],
+ probs_raw[3,])
+ if(z[n]>0){
+ y[n,] <- sample(0:2, J, replace=T, probs)
+ }
+ }
+
+ umf <- unmarkedFrameOccuMS(y=y,siteCovs=as.data.frame(site_covs),
+ obsCovs=as.data.frame(obs_covs))
+
+ stateformulas <- c('~sc1','~sc2')
+ detformulas <- c('~oc1','~1','~1')
+ fit_R <- occuMS(detformulas, stateformulas, data=umf, engine="R")
+ fit_C <- occuMS(detformulas, stateformulas, data=umf, engine="C")
+
+ expect_equal(coef(fit_R), coef(fit_C), tol=1e-5)
+
+})
-test.occuMS.multinom.fit <- function(){
+test_that("occuMS can fit the multinomial model",{
#Simulate data
set.seed(123)
@@ -83,99 +140,104 @@ test.occuMS.multinom.fit <- function(){
stateformulas <- c('~sc1','~sc2')
detformulas <- c('~oc1','~1','~1')
- fit_R <- occuMS(detformulas, stateformulas, data=umf, engine="R")
+ #fit_R <- occuMS(detformulas, stateformulas, data=umf, engine="R")
fit_C <- occuMS(detformulas, stateformulas, data=umf, engine="C")
- checkEqualsNumeric(coef(fit_R),coef(fit_C))
- checkEqualsNumeric(coef(fit_C), c(-0.229630097798681, 0.67830519052921,
+ #expect_equivalent(coef(fit_R),coef(fit_C))
+ expect_equivalent(coef(fit_C), c(-0.229630097798681, 0.67830519052921,
-0.0220063419144645,-0.661255952886156,
-0.554553495521214, 0.510982412286882,
-1.61783147496373, -1.50645934199995))
#check state predict
- pr <- predict(fit_C, "psi")
- checkEqualsNumeric(length(pr),2)
- checkEqualsNumeric(sapply(pr,function(x) x[1,1]),c(0.22922,0.34897),tol=1e-4)
- checkEquals(names(pr),c('psi[1]','psi[2]'))
+ nul <- capture.output(pr <- predict(fit_C, "psi"))
+ expect_equal(length(pr),2)
+ expect_equivalent(sapply(pr,function(x) x[1,1]),c(0.22922,0.34897),tol=1e-4)
+ expect_equal(names(pr),c('psi[1]','psi[2]'))
#Check bootstrapped error for predict
- checkEqualsNumeric(as.numeric(pr[[1]][1,]),
+ expect_equivalent(as.numeric(pr[[1]][1,]),
c(0.2292279,0.1122459,0.07926078,0.5321636), tol=1e-4)
#det
- pr <- predict(fit_C, "det")
- checkEqualsNumeric(length(pr),3)
- checkEqualsNumeric(sapply(pr,function(x) x[1,1]),
+ nul <- capture.output(pr <- predict(fit_C, "det"))
+ expect_equal(length(pr),3)
+ expect_equivalent(sapply(pr,function(x) x[1,1]),
c(0.285455,0.13966,0.156119),tol=1e-4)
- checkEquals(names(pr),c('p[11]','p[12]','p[22]'))
+ expect_equal(names(pr),c('p[11]','p[12]','p[22]'))
- checkEqualsNumeric(as.numeric(pr[[1]][1,]),
+ expect_equivalent(as.numeric(pr[[1]][1,]),
c(0.285455,0.069013,0.168485,0.4447024), tol=1e-4)
#with new data (some missing)
newdata <- data.frame(oc1=rnorm(5),oc2=rnorm(5))
newdata[1,1] <- NA
- pr <- predict(fit_C,"det",newdata=newdata)
- checkTrue(is.na(pr[[1]][1,1]))
- checkEqualsNumeric(nrow(pr[[1]]), nrow(newdata))
- checkEqualsNumeric(as.numeric(pr[[1]][2,]),
+ nul <- capture.output(pr <- predict(fit_C,"det",newdata=newdata))
+ expect_true(is.na(pr[[1]][1,1]))
+ expect_equivalent(nrow(pr[[1]]), nrow(newdata))
+ expect_equivalent(as.numeric(pr[[1]][2,]),
c(0.343157,0.0703713,0.222039,0.488455),tol=1e-4)
newdata <- data.frame(sc1=rnorm(5),sc2=rnorm(5))
newdata[1,1] <- NA
- pr <- predict(fit_C,"psi",newdata=newdata)
- checkTrue(is.na(pr[[1]][1,1]))
- checkEqualsNumeric(nrow(pr[[1]]), nrow(newdata))
- checkEqualsNumeric(pr[[1]][2,1], 0.08791341,tol=1e-4)
+ nul <- capture.output(pr <- predict(fit_C,"psi",newdata=newdata))
+ expect_true(is.na(pr[[1]][1,1]))
+ expect_equivalent(nrow(pr[[1]]), nrow(newdata))
+ expect_equivalent(pr[[1]][2,1], 0.08791341,tol=1e-4)
#With site covs in obs covs
detformulas <- c('~sc1','~oc1','~1')
fit2 <- occuMS(detformulas, stateformulas, data=umf)
- pr <- predict(fit2, "psi")
- checkEqualsNumeric(nrow(pr[[1]]),N)
- pr <- predict(fit2, "det")
- checkEqualsNumeric(nrow(pr[[1]]), N*J)
+ nul <- capture.output(pr <- predict(fit2, "psi"))
+ expect_equivalent(nrow(pr[[1]]),N)
+ nul <- capture.output(pr <- predict(fit2, "det"))
+ expect_equivalent(nrow(pr[[1]]), N*J)
- pr_nd <- predict(fit2, "psi", newdata=data.frame(sc1=0, sc2=0))
- checkEqualsNumeric(nrow(pr_nd[[1]]), 1)
+ nul <- capture.output(pr_nd <- predict(fit2, "psi", newdata=data.frame(sc1=0, sc2=0)))
+ expect_equivalent(nrow(pr_nd[[1]]), 1)
- pr_nd <- predict(fit2, "det", newdata=data.frame(sc1=0, oc1=0))
- checkEqualsNumeric(nrow(pr_nd[[1]]), 1)
+ nul <- capture.output(pr_nd <- predict(fit2, "det", newdata=data.frame(sc1=0, oc1=0)))
+ expect_equivalent(nrow(pr_nd[[1]]), 1)
#check getP
ps <- getP(fit_C)
- checkEqualsNumeric(length(ps),3)
- checkEqualsNumeric(dim(ps[[1]]),c(numSites(fit_C@data),obsNum(fit_C@data)))
- checkTrue(min(unlist(ps))>=0)
- checkTrue(max(unlist(ps))<=1)
- checkEqualsNumeric(sapply(ps,function(x) x[1,1]),
+ expect_equivalent(length(ps),3)
+ expect_equivalent(dim(ps[[1]]),c(numSites(fit_C@data),obsNum(fit_C@data)))
+ expect_true(min(unlist(ps))>=0)
+ expect_true(max(unlist(ps))<=1)
+ expect_equivalent(sapply(ps,function(x) x[1,1]),
c(0.28545,0.13966,0.156119), tol=1e-4)
#check simulate
set.seed(123)
sim <- simulate(fit_C, 3)
- checkEqualsNumeric(length(sim),3)
- checkTrue(all(unlist(sim)%in%c(0:2)))
- checkEqualsNumeric(mean(fit_C@data@y),0.268)
- checkEqualsNumeric(sapply(sim,mean),c(0.244,0.280,0.288))
+ expect_equivalent(length(sim),3)
+ expect_true(all(unlist(sim)%in%c(0:2)))
+ expect_equivalent(mean(fit_C@data@y),0.268)
+ expect_equivalent(sapply(sim,mean),c(0.232,0.252,0.276))
#check fitted
set.seed(123)
fitvals <- fitted(fit_C)
- checkEqualsNumeric(dim(fitvals),c(N,J))
- checkEqualsNumeric(fitvals[1,1],0.2231388,tol=1e-4)
+ expect_equivalent(dim(fitvals),c(N,J))
+ expect_equivalent(fitvals[1,1],0.2231388,tol=1e-4)
+
+ #check ranef
+ set.seed(123)
+ r <- ranef(fit_C)
+ expect_equivalent(r@post[1,,1], c(0,0.5222,0.4778), tol=1e-4)
#Check fitList
- fl <- fitList(fit_C, fit_C)
- checkEquals(class(fl)[1],"unmarkedFitList")
- checkEqualsNumeric(length(fl@fits), 2)
+ expect_warning(fl <- fitList(fit_C, fit_C))
+ expect_is(fl,"unmarkedFitList")
+ expect_equivalent(length(fl@fits), 2)
# Check error when random effect in formula
stateformulas[1] <- "~(1|dummy)"
- checkException(occuMS(detformulas, stateformulas, data=umf))
-}
+ expect_error(occuMS(detformulas, stateformulas, data=umf))
+})
-test.occuMS.condbinom.fit <- function(){
+test_that("occuMS can fit the conditional binomial model",{
#Simulate data
set.seed(123)
@@ -225,49 +287,49 @@ test.occuMS.condbinom.fit <- function(){
stateformulas <- c('~V1','~V2')
detformulas <- c('~V1','~1','~1')
- fit_R <- occuMS(detformulas, stateformulas, data=umf,
- parameterization = "condbinom", engine="R")
+ #fit_R <- occuMS(detformulas, stateformulas, data=umf,
+ # parameterization = "condbinom", engine="R")
fit_C <- occuMS(detformulas, stateformulas, data=umf,
parameterization = "condbinom", engine="C")
- checkEqualsNumeric(coef(fit_R),coef(fit_C))
- checkEqualsNumeric(coef(fit_C), c(-0.5162987961667, 0.274284662180707,
+ #expect_equivalent(coef(fit_R),coef(fit_C))
+ expect_equivalent(coef(fit_C), c(-0.5162987961667, 0.274284662180707,
-0.272563632366871, -0.85606615784698,
-0.701816583657173, -0.104933853512668,
-0.21453135304912, 1.35756285443909))
#check state predict
- pr <- predict(fit_C, "psi")
- checkEqualsNumeric(length(pr),2)
- checkEqualsNumeric(as.numeric(pr[[1]][1,]),
+ nul <- capture.output(pr <- predict(fit_C, "psi"))
+ expect_equivalent(length(pr),2)
+ expect_equivalent(as.numeric(pr[[1]][1,]),
c(0.33849,0.08951,0.18945,0.52834), tol=1e-4)
- checkEquals(names(pr),c('psi','R'))
+ expect_equal(names(pr),c('psi','R'))
#det
- pr <- predict(fit_C, "det")
- checkEqualsNumeric(length(pr),3)
- checkEqualsNumeric(as.numeric(pr[[1]][1,]),
+ nul <- capture.output(pr <- predict(fit_C, "det"))
+ expect_equivalent(length(pr),3)
+ expect_equivalent(as.numeric(pr[[1]][1,]),
c(0.34812,0.090899,0.195866,0.53936662), tol=1e-4)
- checkEquals(names(pr),c('p[1]','p[2]','delta'))
+ expect_equal(names(pr),c('p[1]','p[2]','delta'))
#check getP
ps <- getP(fit_C)
- checkEqualsNumeric(length(ps),3)
- checkEqualsNumeric(dim(ps[[1]]),c(numSites(fit_C@data),obsNum(fit_C@data)))
- checkTrue(min(unlist(ps))>=0)
- checkTrue(max(unlist(ps))<=1)
- checkEqualsNumeric(sapply(ps,function(x) x[1,1]),
+ expect_equivalent(length(ps),3)
+ expect_equivalent(dim(ps[[1]]),c(numSites(fit_C@data),obsNum(fit_C@data)))
+ expect_true(min(unlist(ps))>=0)
+ expect_true(max(unlist(ps))<=1)
+ expect_equivalent(sapply(ps,function(x) x[1,1]),
c(0.34812,0.44657,0.79536), tol=1e-4)
#check simulate
set.seed(123)
sim <- simulate(fit_C, 3)
- checkEqualsNumeric(length(sim),3)
- checkTrue(all(unlist(sim)%in%c(0:2)))
- checkEqualsNumeric(mean(fit_C@data@y),0.2)
- checkEqualsNumeric(sapply(sim,mean),c(0.200,0.156,0.128))
-}
+ expect_equivalent(length(sim),3)
+ expect_true(all(unlist(sim)%in%c(0:2)))
+ expect_equivalent(mean(fit_C@data@y),0.2)
+ expect_equivalent(sapply(sim,mean),c(0.172,0.196,0.184))
+})
-test.occuMS.na <- function(){
+test_that("occuMS handles NAs properly",{
set.seed(123)
N <- 10; J <- 3; S <- 3
@@ -295,33 +357,43 @@ test.occuMS.na <- function(){
umf <- unmarkedFrameOccuMS(y=y,siteCovs=site_covs,obsCovs=obs_covs)
fit <- occuMS(rep('~1',3),rep('~1',2),data=umf,se=F)
- checkEqualsNumeric(fit@AIC,53.19191,tol=1e-4)
+ expect_equivalent(fit@AIC,53.19191,tol=1e-4)
yna <- y
yna[1,1] <- NA
+ obs_covs[1,1] <- NA
umf <- unmarkedFrameOccuMS(y=yna,siteCovs=site_covs,obsCovs=obs_covs)
fit <- occuMS(rep('~1',3),rep('~1',2),data=umf,se=F)
- checkEqualsNumeric(fit@AIC,53.06711,tol=1e-4)
+ expect_equivalent(fit@AIC,53.06711,tol=1e-4)
+
+ # Check simulate and ranef methods
+ fit <- occuMS(rep('~V1',3),rep('~1',2),data=umf,se=F)
+ s <- simulate(fit, nsim=3)
+ expect_equal(sum(is.na(unlist(s))), 3)
+ r <- ranef(fit)
+ expect_true(!any(is.na(r@post)))
+
+ fit_cb <- occuMS(rep('~V1',3),rep('~1',2),data=umf,se=F, parameterization='condbinom')
+ s <- simulate(fit_cb, nsim=3)
+ expect_equal(sum(is.na(unlist(s))), 3)
yna <- y
yna[1,] <- NA
sc_na <- site_covs
sc_na[5,1] <- NA
umf <- unmarkedFrameOccuMS(y=yna,siteCovs=sc_na,obsCovs=obs_covs)
+ expect_warning(occuMS(rep('~1',3),rep('~1',2),data=umf,se=F))
- options(warn=2)
- checkException(occuMS(rep('~1',3),rep('~1',2),data=umf,se=F))
- options(warn=1)
#Check that an NA in a variable not used in formulas doesn't drop
#entire record
- fit <- occuMS(rep('~1',3),rep('~1',2),data=umf,se=F)
- checkEqualsNumeric(fit@AIC,51.69428,tol=1e-4)
- checkEqualsNumeric(fit@sitesRemoved, 1)
+ expect_warning(fit <- occuMS(rep('~1',3),rep('~1',2),data=umf,se=F))
+ expect_equivalent(fit@AIC,51.69428,tol=1e-4)
+ expect_equivalent(fit@sitesRemoved, 1)
#Now actually use variable with missing value
- fit <- occuMS(rep('~1',3), c('~V1', '~1'), data=umf,se=F)
- checkEqualsNumeric(fit@sitesRemoved, c(1,5))
+ expect_warning(fit <- occuMS(rep('~1',3), c('~V1', '~1'), data=umf,se=F))
+ expect_equivalent(fit@sitesRemoved, c(1,5))
oc_na <- obs_covs
oc_na[1,1] <- NA
@@ -329,25 +401,21 @@ test.occuMS.na <- function(){
#Variable with missing value not used
fit <- occuMS(rep('~1',3),rep('~1',2), data=umf,se=F)
- checkEqualsNumeric(fit@AIC,53.19191,tol=1e-4)
+ expect_equivalent(fit@AIC,53.19191,tol=1e-4)
#Now actually used
- options(warn=2)
- checkException(occuMS(c('~V1',rep('~1',2)),rep('~1',2), data=umf,se=F))
- options(warn=1)
-
- fit <- occuMS(c('~V1',rep('~1',2)),rep('~1',2),data=umf,se=F)
- checkEqualsNumeric(fit@AIC,55.03718,tol=1e-4)
+ expect_warning(exfit <- occuMS(c('~V1',rep('~1',2)),rep('~1',2), data=umf,se=F))
+ expect_equivalent(exfit@AIC,55.03718,tol=1e-4)
#Check that fitting works when missing site cov and no obs covs
sc_na <- site_covs
sc_na[1,1] <- NA
umf <- unmarkedFrameOccuMS(y=y,siteCovs=sc_na)
- fit <- occuMS(rep('~1',3),rep('~V1',2),data=umf,se=F)
- checkEqualsNumeric(fit@sitesRemoved, 1)
-}
+ expect_warning(fit <- occuMS(rep('~1',3),rep('~V1',2),data=umf,se=F))
+ expect_equivalent(fit@sitesRemoved, 1)
+})
-test.occuMS.dynamic.multinomial <- function(){
+test_that("occuMS can fit a dynamic multinomial model",{
set.seed(123)
N <- 100 #Number of sites
@@ -444,56 +512,56 @@ detformulas <- c('~V1','~1','~1') #on p[1|1], p[1|2], p[2|2]
fitC <- occuMS(detformulas=detformulas, psiformulas=psiformulas,
phiformulas=phiformulas, data=umf)
-fitR <- occuMS(detformulas=detformulas, psiformulas=psiformulas,
- phiformulas=phiformulas, data=umf,engine="R")
+#fitR <- occuMS(detformulas=detformulas, psiformulas=psiformulas,
+# phiformulas=phiformulas, data=umf,engine="R")
-checkEqualsNumeric(fitC@AIC,799.1723,tol=1e-4)
-checkEqualsNumeric(fitC@AIC,fitR@AIC,tol=1e-4)
-checkEqualsNumeric(length(coef(fitC)),17)
+expect_equivalent(fitC@AIC,799.1723,tol=1e-4)
+#expect_equivalent(fitC@AIC,fitR@AIC,tol=1e-4)
+expect_equivalent(length(coef(fitC)),17)
phiformulas_new <- rep('~1',6)
fit_new <- update(fitC,phiformulas=phiformulas_new)
-checkEqualsNumeric(fit_new@AIC,800.8553,tol=1e-4)
-checkEqualsNumeric(length(coef(fit_new)),14)
+expect_equivalent(fit_new@AIC,800.8553,tol=1e-4)
+expect_equivalent(length(coef(fit_new)),14)
set.seed(123)
fit_sim <- simulate(fitC,nsim=2)
-checkEqualsNumeric(fit_sim[[1]][2,],c(0,2,1,0,0,2))
+expect_equivalent(fit_sim[[1]][2,],c(0,0,0,0,0,0))
-pr_phi <- predict(fitC,'phi')
+nul <- capture.output(pr_phi <- predict(fitC,'phi'))
pr_phi <- sapply(pr_phi, function(x) x$Predicted[1])
-checkEqualsNumeric(pr_phi,
+expect_equivalent(pr_phi,
c(0.055117,0.57195,0.931102,0.02733675,
0.2192255,0.1819882),tol=1e-4)
#Check predicting phi with newdata works
nd <- data.frame(V1=c(1,2), V2=1)
-pr_nd <- predict(fitC, "phi", newdata=nd)
-checkEqualsNumeric(length(pr_nd), 6)
-checkEqualsNumeric(sapply(pr_nd, nrow), rep(2,6))
+nul <- capture.output(pr_nd <- predict(fitC, "phi", newdata=nd))
+expect_equivalent(length(pr_nd), 6)
+expect_equivalent(sapply(pr_nd, nrow), rep(2,6))
#No differing covariates on either phi value so estimates should be the same
-checkEqualsNumeric(pr_nd[[3]][1,1], pr_nd[[3]][2,1])
+expect_equivalent(pr_nd[[3]][1,1], pr_nd[[3]][2,1])
umf_new <- umf
umf_new@y[1,1:3] <- NA
-options(warn=2)
-checkException(
+
+expect_warning(
occuMS(detformulas=detformulas, psiformulas=psiformulas,
phiformulas=phiformulas, data=umf_new)
)
-options(warn=1)
+
umf_miss <- umf
umf_miss@yearlySiteCovs[1,1] <- NA
-checkException(
+expect_error(
occuMS(detformulas=detformulas, psiformulas=psiformulas,
phiformulas=phiformulas, data=umf_miss)
)
-}
+})
-test.occuMS.dynamic.condbinom <- function(){
+test_that("occuMS can fit a dynamic cond binom model",{
set.seed(123)
N <- 100
@@ -575,28 +643,28 @@ fit_cbC <- occuMS(detformulas=detformulas, psiformulas=stateformulas,
parameterization='condbinom',
data=umf, se=T,engine="C")
-checkEqualsNumeric(length(coef(fit_cbC)),14)
-checkEqualsNumeric(fit_cbC@AIC,820.0645,tol=1e-4)
+expect_equivalent(length(coef(fit_cbC)),14)
+expect_equivalent(fit_cbC@AIC,820.0645,tol=1e-4)
-fit_cbR <- occuMS(detformulas=detformulas, psiformulas=stateformulas,
- phiformulas=phiformulas,
- parameterization='condbinom',
- data=umf, se=T,engine="R")
-checkEqualsNumeric(fit_cbC@AIC,fit_cbR@AIC,tol=1e-4)
+#fit_cbR <- occuMS(detformulas=detformulas, psiformulas=stateformulas,
+# phiformulas=phiformulas,
+# parameterization='condbinom',
+# data=umf, se=T,engine="R")
+#expect_equivalent(fit_cbC@AIC,fit_cbR@AIC,tol=1e-4)
set.seed(123)
-fit_sim <- simulate(fit_cbC,nsim=2)
-checkEqualsNumeric(fit_sim[[1]][1,],c(0,0,0,2,1,0))
+fit_sim <- simulate(fit_cbC,nsim=1)
+expect_equivalent(fit_sim[[1]][1,],c(0,0,0,0,2,1))
-pr_phi <- predict(fit_cbC,'phi')
+nul <- capture.output(pr_phi <- predict(fit_cbC,'phi'))
pr_phi <- sapply(pr_phi, function(x) x$Predicted[1])
-checkEqualsNumeric(pr_phi,
+expect_equivalent(pr_phi,
c(0.72966,0.54682,0.728597,0.3856194,
0.999950,0.5841778),tol=1e-4)
-}
+})
-test.occuMS.predit.complexFormulas <- function(){
+test_that("occuMS can handle complex formulas",{
#Simulate data
set.seed(123)
@@ -652,8 +720,8 @@ test.occuMS.predit.complexFormulas <- function(){
nd <- siteCovs(umf)[c(1,1),]
pr_nd3 <- predict(fit_C, type='psi', newdata=nd, se=F)$Predicted
- checkEqualsNumeric(pr_nd[1:2,], pr_nd2)
- checkEqualsNumeric(pr_nd[c(1,1),], pr_nd3)
+ expect_equivalent(pr_nd[1:2,], pr_nd2)
+ expect_equivalent(pr_nd[c(1,1),], pr_nd3)
#Check for factor level handling
site_covs2 <- as.data.frame(site_covs)
@@ -671,14 +739,14 @@ test.occuMS.predit.complexFormulas <- function(){
nd2 <- data.frame(occ_fac=factor(c('a','b'),levels=c('b','a','c')))
pr_nd2 <- predict(fm, type='psi', newdata=nd2, se=F)$Predicted
- checkEqualsNumeric(pr_nd, pr_nd2[c(2,1),])
+ expect_equivalent(pr_nd, pr_nd2[c(2,1),])
nd3 <- data.frame(occ_fac=c('a','b'))
pr_nd3 <- predict(fm, type='psi', newdata=nd3, se=F)$Predicted
- checkEqualsNumeric(pr_nd, pr_nd3[c(2,1),])
+ expect_equivalent(pr_nd, pr_nd3[c(2,1),])
nd4 <- data.frame(occ_fac=c('a','d'))
- checkException(predict(fm, type='psi', newdata=nd4, se=F))
+ expect_error(predict(fm, type='psi', newdata=nd4, se=F))
-}
+})
diff --git a/inst/unitTests/runit.occuMulti.R b/tests/testthat/test_occuMulti.R
index 7d41069..fbc264a 100644
--- a/inst/unitTests/runit.occuMulti.R
+++ b/tests/testthat/test_occuMulti.R
@@ -1,7 +1,33 @@
-test.occuMulti.fit.simple.1 <- function() {
+context("occuMulti fitting function")
+skip_on_cran()
- y <- list(matrix(rep(1,10),5,2),
- matrix(rep(1,10),5,2))
+test_that("unmarkedFrameOccuMulti construction and methods work",{
+
+ y <- list(matrix(1:15,5,3),
+ matrix(1:15,5,3))
+ umf <- unmarkedFrameOccuMulti(y = y)
+
+ expect_is(umf, "unmarkedFrameOccuMulti")
+ out <- capture.output(umf)
+ expect_equal(out[2], "Only showing observation matrix for species 1.")
+ s <- capture.output(summary(umf))
+ expect_equal(s[4], "2 species: sp1 sp2 ")
+
+ # Check plot
+ pdf(NULL)
+ pl <- plot(umf)
+ expect_is(pl, "trellis")
+ dev.off()
+
+ # check subset
+ umf_sub <- umf[,1:2]
+ expect_equal(umf_sub@ylist[[1]], umf@ylist[[1]][,1:2])
+})
+
+test_that("occuMulti can fit simple models",{
+
+ y <- list(matrix(rep(1,10)[1:10],5,2),
+ matrix(rep(1,10)[1:10],5,2))
umf <- unmarkedFrameOccuMulti(y = y)
fm <- occuMulti(detformulas=rep("~1",2),
stateformulas=rep("~1",3), data = umf, se=FALSE)
@@ -9,44 +35,41 @@ test.occuMulti.fit.simple.1 <- function() {
#Probably should not be calling predict here b/c unit test
#but complicated to get actual occupancy prob otherwise
occ <- predict(fm,'state')$Predicted[1,1]
- checkEqualsNumeric(occ,1, tolerance = 1e-4)
+ expect_equivalent(occ,1, tolerance = 1e-4)
detlist <- predict(fm,'det')
det <- sapply(detlist,function(x) x[1,1])
- checkEqualsNumeric(det, rep(1,length(detlist)), tolerance= 1e-4)
+ expect_equivalent(det, rep(1,length(detlist)), tolerance= 1e-4)
#Check fitList
- fl <- fitList(fm, fm)
- checkEquals(class(fl)[1],"unmarkedFitList")
- checkEqualsNumeric(length(fl@fits), 2)
+ expect_warning(fl <- fitList(fm, fm))
+ expect_is(fl,"unmarkedFitList")
+ expect_equivalent(length(fl@fits), 2)
#Check error when random effect in formula
- checkException(occuMulti(detformulas=rep("~1",2),
+ expect_error(occuMulti(detformulas=rep("~1",2),
stateformulas=c("~(1|group)",rep("~1",2)), umf))
-}
-
-test.occuMulti.fit.simple.0 <- function() {
- y <- list(matrix(rep(0,10),5,2),
- matrix(rep(0,10),5,2))
+ y <- list(matrix(rep(0,10)[1:10],5,2),
+ matrix(rep(0,10)[1:10],5,2))
umf <- unmarkedFrameOccuMulti(y = y)
fm <- occuMulti(detformulas=rep("~1",2),
stateformulas=rep("~1",3), data = umf, se=FALSE)
occ <- predict(fm,'state')$Predicted[1,1]
- checkEqualsNumeric(occ,0, tolerance = 1e-4)
+ expect_equivalent(occ,0, tolerance = 1e-4)
detlist <- predict(fm,'det')
det <- sapply(detlist,function(x) x[1,1])
- checkEqualsNumeric(det, rep(0,length(detlist)), tolerance= 1e-4)
+ expect_equivalent(det, rep(0,length(detlist)), tolerance= 1e-4)
-}
+})
-test.occuMulti.fit.covs <- function() {
+test_that("occuMulti can fit models with covariates",{
- y <- list(matrix(rep(0:1,10),5,2),
- matrix(rep(0:1,10),5,2))
+ y <- list(matrix(rep(0:1,10)[1:10],5,2),
+ matrix(rep(0:1,10)[1:10],5,2))
set.seed(123)
N <- dim(y[[1]])[1]
@@ -66,32 +89,37 @@ test.occuMulti.fit.covs <- function() {
occ <- fm['state']
det <- fm['det']
- checkEqualsNumeric(coef(occ), c(5.36630,0.79876,5.45492,-0.868451,9.21242,1.14561),
+ expect_equivalent(coef(occ), c(5.36630,0.79876,5.45492,-0.868451,9.21242,1.14561),
tolerance = 1e-4)
- checkEqualsNumeric(coef(det), c(-0.27586,-0.81837,-0.09537,0.42334), tolerance = 1e-4)
+ expect_equivalent(coef(det), c(-0.27586,-0.81837,-0.09537,0.42334), tolerance = 1e-4)
fit <- fitted(fm)
- checkEqualsNumeric(length(fit),2)
- checkEqualsNumeric(sapply(fit,function(x) x[1,1]),c(0.14954,0.30801), tol = 1e-4)
+ expect_equivalent(length(fit),2)
+ expect_equivalent(sapply(fit,function(x) x[1,1]),c(0.14954,0.30801), tol = 1e-4)
res <- residuals(fm)
- checkEqualsNumeric(length(res),2)
- checkEqualsNumeric(sapply(res,function(x) x[1,1]),c(-0.14954,-0.30801), tol= 1e-4)
+ expect_equivalent(length(res),2)
+ expect_equivalent(sapply(res,function(x) x[1,1]),c(-0.14954,-0.30801), tol= 1e-4)
gp <- getP(fm)
- checkEqualsNumeric(length(gp), 2)
- checkEqualsNumeric(dim(gp[[1]]), c(N,J))
+ expect_equivalent(length(gp), 2)
+ expect_equivalent(dim(gp[[1]]), c(N,J))
+
+ # ranef
+ expect_error(ran <- ranef(fm))
+ ran <- ranef(fm, species=1)
+ expect_equal(bup(ran), rep(1,5))
#Check site cov can be used in detection formula
detformulas <- c('~occ_cov1','~det_cov2')
fm <- occuMulti(detformulas, stateformulas, data = umf, se=FALSE)
- checkEqualsNumeric(coef(fm,'det')[2],3.355328e-05, tol=1e-4)
-}
+ expect_equivalent(coef(fm,'det')[2],3.355328e-05, tol=1e-4)
+})
-test.occuMulti.fit.NA <- function() {
+test_that("occuMulti can handle NAs",{
- y <- list(matrix(rep(0:1,10),5,2),
- matrix(rep(0:1,10),5,2))
+ y <- list(matrix(rep(0:1,10)[1:10],5,2),
+ matrix(rep(0:1,10)[1:10],5,2))
set.seed(456)
N <- dim(y[[1]])[1]
@@ -109,49 +137,42 @@ test.occuMulti.fit.NA <- function() {
occ_covsNA <- occ_covs
occ_covsNA[1,1] <- NA
umf <- unmarkedFrameOccuMulti(y = y, siteCovs = occ_covsNA, obsCovs = det_covs)
- checkException(occuMulti(detformulas, stateformulas, data=umf, se=FALSE))
+ expect_error(occuMulti(detformulas, stateformulas, data=umf, se=FALSE))
- #Check for warning when missing detection
yna <- y
yna[[1]][1,1] <- NA
- umf <- unmarkedFrameOccuMulti(y = yna, siteCovs = occ_covs, obsCovs = det_covs)
-
- options(warn=2)
- checkException(occuMulti(detformulas, stateformulas, data=umf, se=FALSE))
-
- options(warn=1)
+ expect_warning(umf <- unmarkedFrameOccuMulti(y = yna, siteCovs = occ_covs, obsCovs = det_covs))
#Check correct answer given when missing detection
- fm <- occuMulti(detformulas, stateformulas, data = umf, se=FALSE)
- checkEqualsNumeric(coef(fm)[c(1,7)], c(6.63207,0.35323), tol= 1e-4)
+ expect_warning(fm <- occuMulti(detformulas, stateformulas, data = umf, se=FALSE))
+ expect_equivalent(coef(fm)[c(1,7)], c(6.63207,0.35323), tol= 1e-4)
fit <- fitted(fm)
- checkTrue(is.na(fit[[1]][1,1]))
+ expect_true(is.na(fit[[1]][1,1]))
res <- residuals(fm)
- checkTrue(is.na(res[[1]][1,1]))
+ expect_true(is.na(res[[1]][1,1]))
gp <- getP(fm)
- checkTrue(is.na(gp[[1]][1,1]))
+ expect_true(is.na(gp[[1]][1,1]))
#Check error thrown when all detections are missing
yna[[1]][1,] <- NA
- umf <- unmarkedFrameOccuMulti(y = yna, siteCovs = occ_covs, obsCovs = det_covs)
- checkException(occuMulti(detformulas, stateformulas, data=umf, se=FALSE))
+ expect_warning(umf <- unmarkedFrameOccuMulti(y = yna, siteCovs = occ_covs, obsCovs = det_covs))
+ expect_error(occuMulti(detformulas, stateformulas, data=umf, se=FALSE))
#Check warning when missing covariate value on detection
det_covsNA <- det_covs
det_covsNA[1,1] <- NA
umf <- unmarkedFrameOccuMulti(y = y, siteCovs = occ_covs, obsCovs = det_covsNA)
- options(warn=2)
- checkException(occuMulti(detformulas,stateformulas,data=umf, se=FALSE))
- options(warn=1)
-}
+ expect_warning(occuMulti(detformulas,stateformulas,data=umf, se=FALSE))
-test.occuMulti.fit.fixed0 <- function(){
+})
- y <- list(matrix(rep(0:1,10),5,2),
- matrix(rep(0:1,10),5,2))
+test_that("occuMulti handles fixed 0 parameters",{
+
+ y <- list(matrix(rep(0:1,10)[1:10],5,2),
+ matrix(rep(0:1,10)[1:10],5,2))
set.seed(123)
N <- dim(y[[1]])[1]
@@ -170,20 +191,20 @@ test.occuMulti.fit.fixed0 <- function(){
fm <- occuMulti(detformulas, stateformulas, data = umf, se=FALSE)
occ <- fm['state']
- checkEqualsNumeric(length(coef(occ)),4)
- checkEqualsNumeric(coef(occ),c(12.26043,0.61183,12.41110,0.18764),tol=1e-4)
+ expect_equivalent(length(coef(occ)),4)
+ expect_equivalent(coef(occ),c(12.26043,0.61183,12.41110,0.18764),tol=1e-4)
stateformulas <- c('~occ_cov1','~occ_cov2')
fm2 <- occuMulti(detformulas, stateformulas, data = umf, maxOrder=1,se=FALSE)
occ <- fm2['state']
- checkEqualsNumeric(length(coef(occ)),4)
- checkEqualsNumeric(coef(occ),c(12.26043,0.61183,12.41110,0.18764),tol=1e-4)
+ expect_equivalent(length(coef(occ)),4)
+ expect_equivalent(coef(occ),c(12.26043,0.61183,12.41110,0.18764),tol=1e-4)
-}
+})
-test.occuMulti.predict <- function(){
+test_that("occuMulti predict method works",{
set.seed(123)
y <- list(matrix(rbinom(40,1,0.2),20,2),
@@ -204,26 +225,26 @@ test.occuMulti.predict <- function(){
fm <- occuMulti(detformulas, stateformulas, data = umf)
- prState <- predict(fm, type='state')
- checkEqualsNumeric(sapply(prState,function(x) x[1,1]),
+ nul <- capture.output(prState <- predict(fm, type='state'))
+ expect_equivalent(sapply(prState,function(x) x[1,1]),
c(0.30807707,0.20007250,0.04234835,0.73106618),tol=1e-4)
- prDet <- predict(fm, type='det')
- checkEqualsNumeric(as.numeric(prDet$sp2[1,]),
+ nul <- capture.output(prDet <- predict(fm, type='det'))
+ expect_equivalent(as.numeric(prDet$sp2[1,]),
c(0.190485,0.12201,0.0475270,0.525988), tol=1e-4)
#Check with newdata
nd <- siteCovs(umf)[1:2,]
- pr_nd <- predict(fm, type='state', newdata=nd)$Predicted
- checkEqualsNumeric(pr_nd[,1],c(0.3080771,0.3196486), tol=1e-4)
+ nul <- capture.output(pr_nd <- predict(fm, type='state', newdata=nd)$Predicted)
+ expect_equivalent(pr_nd[,1],c(0.3080771,0.3196486), tol=1e-4)
nd <- siteCovs(umf)[1:2,]
- pr_nd <- predict(fm, type='state', newdata=nd, species=1, cond=2)$Predicted
- checkEqualsNumeric(pr_nd,c(0.3858233,0.5402935), tol=1e-4)
+ nul <- capture.output(pr_nd <- predict(fm, type='state', newdata=nd, species=1, cond=2)$Predicted)
+ expect_equivalent(pr_nd,c(0.3858233,0.5402935), tol=1e-4)
#Make sure it works with newdata having only one row
nd <- siteCovs(umf)[1,]
- pr_nd <- predict(fm, type='state', newdata=nd)$Predicted
- checkEqualsNumeric(pr_nd[,1],c(0.3080771), tol=1e-4)
- pr_nd <- predict(fm, type='state', newdata=nd, species=1, cond=2)$Predicted
- checkEqualsNumeric(pr_nd,c(0.3858233), tol=1e-4)
+ nul <- capture.output(pr_nd <- predict(fm, type='state', newdata=nd)$Predicted)
+ expect_equivalent(pr_nd[,1],c(0.3080771), tol=1e-4)
+ nul <- capture.output(pr_nd <- predict(fm, type='state', newdata=nd, species=1, cond=2)$Predicted)
+ expect_equivalent(pr_nd,c(0.3858233), tol=1e-4)
stateformulas <- c('~1','~1','0')
detformulas <- c('~1','~det_cov2')
@@ -232,43 +253,46 @@ test.occuMulti.predict <- function(){
fm <- occuMulti(detformulas, stateformulas, data = umf)
- prState <- predict(fm, type='state')
- checkEqualsNumeric(sapply(prState,function(x) x[1,1]),
+ nul <- capture.output(prState <- predict(fm, type='state'))
+ expect_equivalent(sapply(prState,function(x) x[1,1]),
c(0.475928,0.2548407,0.01496681,0.86713789),tol=1e-4)
- prDet <- predict(fm, type='det')
- checkEqualsNumeric(as.numeric(prDet$sp2[1,]),
+ nul <- capture.output(prDet <- predict(fm, type='det'))
+ expect_equivalent(as.numeric(prDet$sp2[1,]),
c(0.20494,0.11865,0.0582563,0.517888), tol=1e-4)
#Check predicting co-occurrence
+
+ nul <- capture_output({
+
nd <- siteCovs(umf)[1:2,]
pr_all <- predict(fm, type='state', se=F)$Predicted[1:2,1]
pr_nd <- predict(fm, type='state', newdata=nd, species=c(1,2))$Predicted
- checkEqualsNumeric(pr_nd,pr_all, tol=1e-4)
+ expect_equivalent(pr_nd,pr_all, tol=1e-4)
#Check with site cov in detection formula
stateformulas <- c('~occ_cov2','~1','0')
detformulas <- c('~occ_cov1','~det_cov2')
fm <- occuMulti(detformulas, stateformulas, data = umf)
pr_state_actual <- predict(fm, "state")
- checkEqualsNumeric(length(pr_state_actual), 4)
- checkEqualsNumeric(pr_state_actual$Predicted[1,1], 0.729927907, tol=1e-5)
- checkEqualsNumeric(nrow(pr_state_actual$Predicted), 20)
+ expect_equivalent(length(pr_state_actual), 4)
+ expect_equivalent(pr_state_actual$Predicted[1,1], 0.729927907, tol=1e-5)
+ expect_equivalent(nrow(pr_state_actual$Predicted), 20)
pr_det_actual <- predict(fm, "det")
- checkEqualsNumeric(length(pr_det_actual), 2)
- checkEqualsNumeric(pr_det_actual$sp1$Predicted[1], 0.1448311, tol=1e-5)
- checkEqualsNumeric(nrow(pr_det_actual$sp1), 20*2)
+ expect_equivalent(length(pr_det_actual), 2)
+ expect_equivalent(pr_det_actual$sp1$Predicted[1], 0.1448311, tol=1e-5)
+ expect_equivalent(nrow(pr_det_actual$sp1), 20*2)
#with newdata
pr_state_nd <- predict(fm, "state", newdata=data.frame(occ_cov2=0))
- checkEqualsNumeric(length(pr_state_nd), 4)
- checkEqualsNumeric(pr_state_nd$Predicted[1,1], 0.7538309, tol=1e-5)
- checkEqualsNumeric(nrow(pr_state_nd$Predicted), 1)
+ expect_equivalent(length(pr_state_nd), 4)
+ expect_equivalent(pr_state_nd$Predicted[1,1], 0.7538309, tol=1e-5)
+ expect_equivalent(nrow(pr_state_nd$Predicted), 1)
pr_det_nd <- predict(fm, "det", newdata=data.frame(occ_cov1=0, det_cov2=0))
- checkEqualsNumeric(length(pr_det_nd), 2)
- checkEqualsNumeric(pr_state_nd$Predicted[1,1], 0.7538309, tol=1e-5)
- checkEqualsNumeric(nrow(pr_state_nd$Predicted), 1)
+ expect_equivalent(length(pr_det_nd), 2)
+ expect_equivalent(pr_state_nd$Predicted[1,1], 0.7538309, tol=1e-5)
+ expect_equivalent(nrow(pr_state_nd$Predicted), 1)
#With maxOrder set
stateformulas <- c('~occ_cov2','~1')
@@ -277,53 +301,57 @@ test.occuMulti.predict <- function(){
fm <- occuMulti(detformulas, stateformulas, data = umf, maxOrder=1)
pr_state <- predict(fm, "state")
- checkEqualsNumeric(length(pr_state), 4)
- checkEqualsNumeric(pr_state$Predicted[1,1], 0.729927907, tol=1e-5)
- checkEqualsNumeric(nrow(pr_state$Predicted), 20)
+ expect_equivalent(length(pr_state), 4)
+ expect_equivalent(pr_state$Predicted[1,1], 0.729927907, tol=1e-5)
+ expect_equivalent(nrow(pr_state$Predicted), 20)
pr_state_nd <- predict(fm, "state", newdata=data.frame(occ_cov2=0))
- checkEqualsNumeric(length(pr_state_nd), 4)
- checkEqualsNumeric(pr_state_nd$Predicted[1,1], 0.7538309, tol=1e-5)
- checkEqualsNumeric(nrow(pr_state_nd$Predicted), 1)
+ expect_equivalent(length(pr_state_nd), 4)
+ expect_equivalent(pr_state_nd$Predicted[1,1], 0.7538309, tol=1e-5)
+ expect_equivalent(nrow(pr_state_nd$Predicted), 1)
pr_det <- predict(fm, "det")
- checkEqualsNumeric(length(pr_det), 2)
- checkEqualsNumeric(pr_det$sp1$Predicted[1], 0.1448311, tol=1e-5)
- checkEqualsNumeric(nrow(pr_det$sp1), 20*2)
+ expect_equivalent(length(pr_det), 2)
+ expect_equivalent(pr_det$sp1$Predicted[1], 0.1448311, tol=1e-5)
+ expect_equivalent(nrow(pr_det$sp1), 20*2)
pr_det_nd <- predict(fm, "det", newdata=data.frame(occ_cov1=0, det_cov2=0))
- checkEqualsNumeric(length(pr_det_nd), 2)
- checkEqualsNumeric(pr_state_nd$Predicted[1,1], 0.7538309, tol=1e-5)
- checkEqualsNumeric(nrow(pr_state_nd$Predicted), 1)
+ expect_equivalent(length(pr_det_nd), 2)
+ expect_equivalent(pr_state_nd$Predicted[1,1], 0.7538309, tol=1e-5)
+ expect_equivalent(nrow(pr_state_nd$Predicted), 1)
+
+ })
#getP with maxOrder set
gp <- getP(fm)
- checkEquals(length(gp), 2)
- checkEquals(dim(gp[[1]]), c(20,2))
+ expect_equal(length(gp), 2)
+ expect_equal(dim(gp[[1]]), c(20,2))
#simulate with maxOrder set
s <- simulate(fm, 2)
- checkTrue(inherits(s, "list"))
- checkEquals(length(s), 2)
- checkEquals(dim(s[[1]][[1]]), c(N, J))
+ expect_is(s, "list")
+ expect_equal(length(s), 2)
+ expect_equal(dim(s[[1]][[1]]), c(N, J))
#fitList with maxOrder set
fm2 <- occuMulti(c("~1","~1"), c("~1","~1"), umf, maxOrder=1)
- fl2 <- fitList(fm, fm2)
- checkTrue(inherits(fl2, "unmarkedFitList"))
+ expect_warning(fl2 <- fitList(fm, fm2))
+ expect_is(fl2, "unmarkedFitList")
ms <- modSel(fl2)
- checkTrue(inherits(ms, "unmarkedModSel"))
+ expect_is(ms, "unmarkedModSel")
#fitted with maxOrder set
ft <- fitted(fm)
- checkEquals(length(ft), 2)
+ expect_equal(length(ft), 2)
#parboot with maxOrder set
pb <- parboot(fm, nsim=2)
- checkTrue(inherits(pb, "parboot"))
-}
+ expect_is(pb, "parboot")
-test.occuMulti.predict.NA <- function(){
+
+})
+
+test_that("occuMulti predict can handle NAs",{
set.seed(123)
y <- list(matrix(rbinom(40,1,0.2),20,2),
@@ -343,31 +371,36 @@ test.occuMulti.predict.NA <- function(){
umf <- unmarkedFrameOccuMulti(y = y, siteCovs = occ_covs, obsCovs = det_covs)
- fm <- occuMulti(detformulas, stateformulas, data = umf)
+ expect_warning(fm <- occuMulti(detformulas, stateformulas, data = umf))
prDet <- predict(fm, type='det')
- checkTrue(all(is.na(prDet$sp1[1,])))
- checkEqualsNumeric(as.numeric(prDet$sp1[2,]),
+ expect_true(all(is.na(prDet$sp1[1,])))
+ expect_equivalent(as.numeric(prDet$sp1[2,]),
c(0.49781,0.19621,0.175514,0.8219401), tol=1e-4)
#Check that you can predict with NAs in siteCovs
+
+ nul <- capture_output({
+
newdata <- siteCovs(umf)
newdata[1,1] <- NA
prOcc <- predict(fm, type='state', newdata=newdata)
- checkTrue(all(is.na(prOcc$Predicted[1,])))
- checkTrue(all(!is.na(sapply(prOcc,`[`,2,1))))
+ expect_true(all(is.na(prOcc$Predicted[1,])))
+ expect_true(all(!is.na(sapply(prOcc,`[`,2,1))))
prOcc_sp <- predict(fm, type='state', species=1, newdata=newdata)
- checkTrue(all(is.na(prOcc_sp[1,])))
- checkTrue(all(!is.na(prOcc_sp[2,])))
- checkEqualsNumeric(prOcc_sp$Predicted[2],0.4731427, tol=1e-4)
+ expect_true(all(is.na(prOcc_sp[1,])))
+ expect_true(all(!is.na(prOcc_sp[2,])))
+ expect_equivalent(prOcc_sp$Predicted[2],0.4731427, tol=1e-4)
prOcc_cond <- predict(fm, type='state', species=1, cond=2, newdata=newdata)
- checkTrue(all(is.na(prOcc_cond[1,])))
- checkTrue(all(!is.na(prOcc_cond[2,])))
- checkEqualsNumeric(prOcc_sp$Predicted[2],0.4731427, tol=1e-4)
-}
+ expect_true(all(is.na(prOcc_cond[1,])))
+ expect_true(all(!is.na(prOcc_cond[2,])))
+ expect_equivalent(prOcc_sp$Predicted[2],0.4731427, tol=1e-4)
+ })
+})
-test.occuMulti.predict.complexFormulas <- function(){
+
+test_that("occuMulti can handle complex formulas",{
#Check scale(), etc
set.seed(123)
@@ -389,6 +422,8 @@ test.occuMulti.predict.complexFormulas <- function(){
fm <- occuMulti(detformulas, stateformulas, data = umf)
+ nul <- capture_output({
+
#Check with newdata; contents of newdata should not
#effect resulting predictions (scale should be based on
#original data)
@@ -399,8 +434,8 @@ test.occuMulti.predict.complexFormulas <- function(){
nd <- siteCovs(umf)[c(1,1),]
pr_nd3 <- predict(fm, type='state', newdata=nd, se=F)$Predicted
- checkEqualsNumeric(pr_nd[1:2,], pr_nd2)
- checkEqualsNumeric(pr_nd[c(1,1),], pr_nd3)
+ expect_equivalent(pr_nd[1:2,], pr_nd2)
+ expect_equivalent(pr_nd[c(1,1),], pr_nd3)
#Check for factor level handling
occ_covs$occ_fac <- factor(sample(c('a','b','c'),N,replace=T))
@@ -415,24 +450,26 @@ test.occuMulti.predict.complexFormulas <- function(){
nd2 <- data.frame(occ_fac=factor(c('a','b'),levels=c('a','b','c')))
pr_nd2 <- predict(fm, type='state', newdata=nd2, se=F)$Predicted
- checkEqualsNumeric(pr_nd, pr_nd2[c(2,1),])
+ expect_equivalent(pr_nd, pr_nd2[c(2,1),])
nd3 <- data.frame(occ_fac=c('a','b'))
pr_nd3 <- predict(fm, type='state', newdata=nd3, se=F)$Predicted
- checkEqualsNumeric(pr_nd, pr_nd3[c(2,1),])
+ expect_equivalent(pr_nd, pr_nd3[c(2,1),])
nd4 <- data.frame(occ_fac=factor(c('a','d'),levels=c('a','d')))
- checkException(predict(fm, type='state', newdata=nd4, se=F))
+ expect_error(predict(fm, type='state', newdata=nd4, se=F))
#Check that predicting detection also works
nd5 <- data.frame(det_cov1 = rnorm(5))
pr_nd5 <- predict(fm, type='det', newdata=nd5)
- checkEqualsNumeric(sapply(pr_nd5, nrow), c(5,5))
- checkEqualsNumeric(pr_nd5$sp1$Predicted[1], 0.1680881)
-}
+ expect_equivalent(sapply(pr_nd5, nrow), c(5,5))
+ expect_equivalent(pr_nd5$sp1$Predicted[1], 0.1680881)
+
+ })
+})
-test.occuMulti.penalty <- function(){
+test_that("occuMulti penalized likelihood works",{
set.seed(123)
N <- 100; nspecies <- 3; J <- 5
@@ -483,28 +520,27 @@ test.occuMulti.penalty <- function(){
occFormulas <- c('~occ_cov1','~occ_cov2','~occ_cov3','~1','~1','~1','~1')
detFormulas <- c('~1','~1','~1')
+ nul <- capture_output({
+
fm <- occuMulti(detFormulas,occFormulas,umf)
- fm_pen <- occuMulti(detFormulas, occFormulas, data = umf, penalty=1, boot=10)
+ fm_pen <- occuMulti(detFormulas, occFormulas, data = umf, penalty=1, boot=5)
- checkEqualsNumeric(coef(fm_pen)[c(1,5)], c(0.5014605, -0.1078711), tol=1e-5)
- checkEqualsNumeric(length(fm_pen@bootstrapSamples), 10)
- checkEqualsNumeric(vcov(fm_pen), fm_pen@covMatBS)
- checkEqualsNumeric(fm_pen@estimates@estimates$state@covMat,
+ expect_equivalent(coef(fm_pen)[c(1,5)], c(0.5014605, -0.1078711), tol=1e-5)
+ expect_equivalent(length(fm_pen@bootstrapSamples), 5)
+ expect_equivalent(vcov(fm_pen), fm_pen@covMatBS)
+ expect_equivalent(fm_pen@estimates@estimates$state@covMat,
fm_pen@estimates@estimates$state@covMatBS)
set.seed(123)
- opt_fit <- optimizePenalty(fm, boot=3)
- checkEquals(opt_fit@call$penalty, 8)
+ opt_fit <- optimizePenalty(fm, penalties=c(0,1), boot=2)
+ expect_equal(opt_fit@call$penalty, 1)
+
+ })
- #Check manual setting penalty
- opt_fit <- optimizePenalty(fm, penalties=c(1), boot=3)
- checkEquals(opt_fit@call$penalty, 1)
- #Check manual setting k-fold
- opt_fit <- optimizePenalty(fm, k=3, boot=3)
-}
+})
-test.occuMulti.fix.NA.mismatch <- function(){
+test_that("Mismatched NAs are identified in unmarkedFrameOccuMulti",{
y1 <- matrix(rbinom(10,1,0.5), nrow=5)
y1[1,1] <- NA
@@ -517,15 +553,37 @@ test.occuMulti.fix.NA.mismatch <- function(){
ylist <- list(y1=y1,y2=y2,y3=y3)
- umf <- unmarkedFrameOccuMulti(y=ylist)
-
- options(warn=2)
- checkException(unmarkedFrameOccuMulti(y=ylist))
- options(warn=0)
+ expect_warning(umf <- unmarkedFrameOccuMulti(y=ylist))
pre_na <- sapply(ylist, function(x) sum(is.na(x)))
post_na <- sapply(umf@ylist, function(x) sum(is.na(x)))
- checkTrue(any(pre_na[1] != pre_na))
- checkTrue(!any(post_na[1] != post_na))
-}
+ expect_true(any(pre_na[1] != pre_na))
+ expect_true(!any(post_na[1] != post_na))
+})
+
+test_that("R and C++ engines give same results",{
+
+ y <- list(matrix(rep(0:1,10)[1:10],5,2),
+ matrix(rep(0:1,10)[1:10],5,2))
+
+ set.seed(123)
+ N <- dim(y[[1]])[1]
+ J <- dim(y[[1]])[2]
+ occ_covs <- as.data.frame(matrix(rnorm(N * 3),ncol=3))
+ names(occ_covs) <- paste('occ_cov',1:3,sep='')
+
+ det_covs <- as.data.frame(matrix(rnorm(N*J*2),ncol=2))
+ names(det_covs) <- paste('det_cov',1:2,sep='')
+
+ umf <- unmarkedFrameOccuMulti(y = y, siteCovs = occ_covs, obsCovs = det_covs)
+ stateformulas <- c('~occ_cov1','~occ_cov2','~occ_cov3')
+ detformulas <- c('~det_cov1','~det_cov2')
+
+ fm <- occuMulti(detformulas, stateformulas, data = umf, se=FALSE,
+ control=list(maxit=1))
+ fmR <- occuMulti(detformulas, stateformulas, data = umf, se=FALSE,
+ engine="R",control=list(maxit=1))
+ expect_equal(coef(fm), coef(fmR))
+
+})
diff --git a/tests/testthat/test_occuPEN.R b/tests/testthat/test_occuPEN.R
new file mode 100644
index 0000000..09e1d6c
--- /dev/null
+++ b/tests/testthat/test_occuPEN.R
@@ -0,0 +1,164 @@
+context("occuPEN fitting function")
+skip_on_cran()
+
+test_that("occuPEN can fit simple models",{
+
+ y <- matrix(rep(1,10)[1:10],5,2)
+ umf <- unmarkedFrameOccu(y = y)
+ fm <- occuPEN(~ 1 ~ 1, data = umf)
+
+ occ <- fm['state']
+ det <- fm['det']
+
+ occ <- coef(backTransform(occ))
+ expect_equivalent(occ,1)
+
+ det <- coef(backTransform(det))
+ expect_equivalent(det,1)
+
+ bt <- backTransform(fm, type = 'state')
+ expect_equivalent(coef(bt), 1)
+
+ bt <- backTransform(fm, type = 'det')
+ expect_equivalent(coef(bt), 1)
+
+ #Check error when random effect in formula
+ expect_error(occuPEN(~(1|dummy)~1, umf))
+
+ y <- matrix(rep(0,10)[1:10],5,2)
+ umf <- unmarkedFrameOccu(y = y)
+ fm <- occuPEN(~ 1 ~ 1, data = umf)
+
+ occ <- fm['state']
+ det <- fm['det']
+
+ occ <- coef(backTransform(occ))
+ expect_equivalent(occ, 0, tolerance = 1e-4)
+
+ det <- coef(backTransform(det))
+ expect_equivalent(det,0, tolerance = 1e-4)
+
+ bt <- backTransform(fm, type = 'state')
+ expect_equivalent(coef(bt), 0, tolerance = 1e-4)
+
+ bt <- backTransform(fm, type = 'det')
+ expect_equivalent(coef(bt), 0, tolerance = 1e-4)
+
+})
+
+test_that("occuPEN can fit models with covariates",{
+
+ y <- matrix(rep(0:1,10)[1:10],5,2)
+ siteCovs <- data.frame(x = c(0,2,3,4,1))
+ obsCovs <- data.frame(o1 = 1:10, o2 = exp(-5:4)/10)
+ umf <- unmarkedFrameOccu(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
+ fm <- occuPEN(~ o1 + o2 ~ x, data = umf)
+ fmR <- occuPEN(~o1 +o2~x, data=umf, engine="R")
+ expect_equal(coef(fm), coef(fmR))
+ fm1 <- occuPEN(~ o1 + o2 ~ x, data = umf,lambda=1,pen.type="Bayes")
+ fm2 <- occuPEN(~ o1 + o2 ~ x, data = umf,lambda=1,pen.type="Ridge")
+ MPLEla <- computeMPLElambda(~ o1 + o2 ~ x, data = umf)
+ fm3 <- occuPEN(~ o1 + o2 ~ x, data = umf,lambda=MPLEla,pen.type="MPLE")
+
+ occ <- fm['state']
+ det <- fm['det']
+
+ occ1 <- fm1['state']
+ det1 <- fm1['det']
+
+ occ2 <- fm2['state']
+ det2 <- fm2['det']
+
+ occ3 <- fm3['state']
+ det3 <- fm3['det']
+
+ expect_error(occ <- coef(backTransform(occ)))
+
+ expect_equivalent(coef(occ), c(8.590737, 2.472220), tolerance = 1e-4)
+ expect_equivalent(coef(det), c(0.44457, -0.14706, 0.44103), tolerance = 1e-4)
+
+ expect_equivalent(coef(occ1), c(0.7171743, 0.6977753), tolerance = 1e-4)
+ expect_equivalent(coef(det1), c(0.08143832, -0.06451574, 0.28695210), tolerance = 1e-4)
+
+ expect_equivalent(coef(occ2), c(1.009337e+01, 4.329662e-04), tolerance = 1e-4)
+ expect_equivalent(coef(det2), c(0.25892308, -0.09459618, 0.31092107), tolerance = 1e-4)
+
+ expect_equivalent(coef(occ3), c(8.590738, 2.472220), tolerance = 1e-4)
+ expect_equivalent(coef(det3), c(0.4445733, -0.1470601, 0.4410251), tolerance = 1e-4)
+
+ occ.lc <- linearComb(fm, type = 'state', c(1, 0.5))
+ det.lc <- linearComb(fm, type = 'det', c(1, 0.3, -0.3))
+
+ expect_equivalent(coef(occ.lc), 9.826848, tol = 1e-4)
+ expect_equivalent(coef(det.lc), 0.2681477, tol = 1e-4)
+
+ expect_equivalent(coef(backTransform(occ.lc)), 1, tol = 1e-4)
+ expect_equivalent(coef(backTransform(det.lc)), 0.5666381, tol = 1e-4)
+
+ expect_error(backTransform(fm, type = "state"))
+ expect_error(backTransform(fm, type = "det"))
+
+ fitted <- fitted(fm)
+ expect_equivalent(fitted, structure(c(0.5738, 0.5014, 0.4318, 0.38581, 0.50171, 0.53764,
+0.46563, 0.40283, 0.39986, 0.79928), .Dim = c(5L, 2L)), tol = 1e-5)
+
+ expect_error(occuPEN_CV(~ o1 + o2 ~ x, data = umf, k=15))
+ fmCV <- occuPEN_CV(~ o1 + o2 ~ x, data = umf)
+ expect_equivalent(fmCV@chosenLambda, 1, tol = 1e-4)
+ expect_equivalent(fmCV@lambdaScores, c(31.423777, 15.603297, 12.330360, 10.130768, 8.981720, 8.572523, 8.572841, 8.798436, 9.153270, 9.543802), tol = 1e-4)
+
+
+ y <- matrix(rep(0:1,10)[1:10],5,2)
+ siteCovs <- data.frame(x = c(0,2,3,4,1))
+ obsCovs <- data.frame(o1 = 1:10, o2 = exp(-5:4)/10)
+ umf <- unmarkedFrameOccu(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
+ expect_equivalent(computeMPLElambda(~ o1 + o2 ~ x, data = umf),4.017164e-11)
+ expect_error(fm <- occuPEN(~ o1 + o2 ~ x, data = umf,pen.type="none"))
+ expect_error(fm <- occuPEN(~ o1 + o2 ~ 1, data = umf,pen.type="MPLE"))
+ expect_error(fm <- occuPEN(~ 1 ~ 1, data = umf,pen.type="Ridge"))
+ expect_error(fm <- occuPEN_CV(~ o1 + o2 ~ x, data = umf,lambda=c(0)))
+ expect_error(fm <- occuPEN_CV(~ o1 + o2 ~ x, data = umf,foldAssignments=c(1,2,3,4,5),k=6))
+
+ # nonparboot
+ nbp <- nonparboot(fm, B=2)
+ expect_is(nbp@covMatBS, "matrix")
+ nbp_cv <- nonparboot(fmCV, B=2)
+ expect_is(nbp_cv@covMatBS, "matrix")
+
+})
+
+test_that("occuPEN can handle NAs",{
+
+ y <- matrix(rep(0:1,10)[1:10],5,2)
+ siteCovs <- data.frame(x = c(0,2,3,4,1))
+ siteCovs[3,1] <- NA
+ obsCovs <- data.frame(o1 = 1:10, o2 = exp(-5:4)/10)
+ umf <- unmarkedFrameOccu(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
+ expect_warning(fm <- occuPEN(~ o1 + o2 ~ x, data = umf))
+ expect_equal(fm@sitesRemoved, 3)
+ expect_equivalent(coef(fm), c(8.70123, 4.58255, 0.66243, -0.22862, 0.58192), tol = 1e-5)
+
+ obsCovs[10,2] <- NA
+ umf <- unmarkedFrameOccu(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
+ expect_warning(fm <- occuPEN(~ o1 + o2 ~ x, data = umf))
+ expect_equal(fm@sitesRemoved, 3)
+ expect_equivalent(coef(fm), c(8.91289, 1.89291, -1.42471, 0.67011, -8.44608), tol = 1e-5)
+
+})
+
+
+test_that("occuPEN can handle offsets",{
+
+ y <- matrix(rep(0:1,10)[1:10],5,2)
+ siteCovs <- data.frame(x = c(0,2,3,4,1))
+ obsCovs <- data.frame(o1 = 1:10, o2 = exp(-5:4)/10)
+ umf <- unmarkedFrameOccu(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
+ fm <- occuPEN(~ o1 + o2 ~ offset(x), data = umf)
+ expect_equivalent(coef(fm),
+ structure(c(9.74361, 0.44327, -0.14683, 0.44085), .Names = c("psi(Int)",
+"p(Int)", "p(o1)", "p(o2)")), tol = 1e-5)
+ fm <- occuPEN(~ o1 + offset(o2) ~ offset(x), data = umf)
+ expect_equivalent(coef(fm), structure(c(8.59459, 0.97574, -0.3096), .Names = c("psi(Int)",
+"p(Int)", "p(o1)")), tol=1e-5)
+
+})
diff --git a/tests/testthat/test_occuRN.R b/tests/testthat/test_occuRN.R
new file mode 100644
index 0000000..0fe384d
--- /dev/null
+++ b/tests/testthat/test_occuRN.R
@@ -0,0 +1,93 @@
+context("occuRN fitting function")
+skip_on_cran()
+
+test_that("occuRN can fit models",{
+
+ data(birds)
+ woodthrushUMF <- unmarkedFrameOccu(woodthrush.bin)
+
+ # R and C engines give same result
+ fm_R <- occuRN(~ obsNum ~ 1, woodthrushUMF, engine="R", K=5, control=list(maxit=1))
+ fm_C <- occuRN(~ obsNum ~ 1, woodthrushUMF, engine="C", K=5, control=list(maxit=1))
+ expect_equal(fm_R@AIC, fm_C@AIC)
+
+ # survey occasion-specific detection probabilities
+ fm_C <- occuRN(~ obsNum ~ 1, woodthrushUMF, engine="C", K=10)
+ #fm_R <- occuRN(~ obsNum ~ 1, woodthrushUMF, engine="R")
+
+ # check that output matches
+ #expect_equivalent(coef(fm_C),coef(fm_R),tol=1e-5)
+
+ # check output is correct
+ expect_equivalent(coef(fm_C),
+ c(0.7921122,-1.8328867,0.4268205,-0.1442194,0.4634105,0.7787513,
+ 0.8008794,1.0569827,0.8048578,0.8779660,0.9374874,0.7064848),tol=1e-3)
+
+ # check methods
+ gp <- getP(fm_C)
+ expect_equal(dim(gp), dim(woodthrushUMF@y))
+
+ pr <- predict(fm_C, 'state')
+ expect_equal(dim(pr), c(50,4))
+ expect_equal(pr[1,1], 2.204779, tol=1e-4)
+
+ pr <- predict(fm_C, 'det')
+ expect_equal(dim(pr), c(550,4))
+ expect_equal(pr[1,1], 0.13806, tol=1e-4)
+
+ res <- residuals(fm_C)
+ expect_equal(dim(res), dim(woodthrushUMF@y))
+ expect_equal(res[1,1], 0.73757, tol=1e-4)
+ r <- ranef(fm_C, K=10)
+ expect_equal(dim(r@post), c(50,11,1))
+
+ s <- simulate(fm_C, 2)
+ expect_equal(length(s), 2)
+ expect_equal(dim(s[[1]]), dim(woodthrushUMF@y))
+
+ pb <- parboot(fm_C, nsim=1)
+ expect_is(pb, "parboot")
+
+ # check error if random effect in formula
+ expect_error(occuRN(~(1|dummy)~1, umf))
+})
+
+test_that("occuRN can handle NAs",{
+
+ data(birds)
+ woodthrushUMF <- unmarkedFrameOccu(woodthrush.bin)
+
+ #Remove one observation
+ woodthrushUMF@y[1,1] <- NA
+
+ fm_C <- occuRN(~ obsNum ~ 1, woodthrushUMF, engine="C", K=10)
+ #fm_R <- occuRN(~ obsNum ~ 1, woodthrushUMF, engine="R")
+
+ # check that output matches
+ #expect_equivalent(coef(fm_C),coef(fm_R),tol=1e-5)
+
+ # check output is correct
+ expect_equivalent(coef(fm_C),
+ c(0.793042, -1.902789, 0.494098, -0.074573, 0.53074, 0.845903,
+ 0.867936, 1.123959, 0.871912, 0.944917, 1.004499, 0.773679), tol=1e-3)
+
+ #Remove entire site
+ woodthrush.bin_na <- woodthrush.bin
+ woodthrush.bin_na[1,] <- NA
+ woodthrushUMF <- unmarkedFrameOccu(woodthrush.bin_na)
+
+ expect_warning(fm_C <- occuRN(~ obsNum ~ 1, woodthrushUMF, engine="C", K=10))
+ #fm_R <- occuRN(~ obsNum ~ 1, woodthrushUMF, engine="R")
+
+ # check that site was removed
+ expect_equivalent(fm_C@sitesRemoved,1)
+
+ # check that output matches
+ #expect_equivalent(coef(fm_C),coef(fm_R),tol=1e-5)
+
+ # check output is correct
+ expect_equivalent(coef(fm_C),
+ c(0.783066, -1.920232, 0.448369, -0.009701, 0.490085, 0.814767,
+ 0.837669, 1.097903, 0.842467, 0.916831, 0.976707, 0.740672), tol=1e-3)
+})
+
diff --git a/inst/unitTests/runit.occuTTD.R b/tests/testthat/test_occuTTD.R
index 1e45803..f152cde 100644
--- a/inst/unitTests/runit.occuTTD.R
+++ b/tests/testthat/test_occuTTD.R
@@ -1,4 +1,7 @@
-test.unmarkedFrameOccuTTD <- function() {
+context("occuTTD fitting function")
+skip_on_cran()
+
+test_that("unmarkedFrameOccuTTD can be constructed",{
set.seed(123)
N <- 100
@@ -16,25 +19,35 @@ test.unmarkedFrameOccuTTD <- function() {
umf <- unmarkedFrameOccuTTD(y=y, surveyLength=Tmax, siteCovs=sc, obsCovs=oc)
- checkEqualsNumeric(getY(umf), y)
- checkEqualsNumeric(dim(getY(umf)), c(100,1))
- checkEqualsNumeric(siteCovs(umf), sc)
- checkEqualsNumeric(obsCovs(umf), oc)
+ expect_equivalent(getY(umf), y)
+ expect_equivalent(dim(getY(umf)), c(100,1))
+ expect_equivalent(siteCovs(umf), sc)
+ expect_equivalent(obsCovs(umf), oc)
- checkEqualsNumeric(umf@numPrimary, 1)
- checkEqualsNumeric(umf@surveyLength, matrix(Tmax, 100, 1))
- checkEquals(class(umf)[1], "unmarkedFrameOccuTTD")
+ expect_equivalent(umf@numPrimary, 1)
+ expect_equivalent(umf@surveyLength, matrix(Tmax, 100, 1))
+ expect_is(umf, "unmarkedFrameOccuTTD")
+ out <- capture.output(umf)
+ expect_equal(out[1], "Data frame representation of unmarkedFrame object.")
+ s <- capture.output(summary(umf))
+ expect_equal(s[3], "100 sites")
hd <- head(umf)
- checkEqualsNumeric(as(hd, 'data.frame'), as(umf, 'data.frame')[1:10,])
+ expect_equivalent(as(hd, 'data.frame'), as(umf, 'data.frame')[1:10,])
umf_sub <- umf[c(1,3),]
- checkEqualsNumeric(as(umf_sub, 'data.frame'), as(umf, 'data.frame')[c(1,3),])
+ expect_equivalent(as(umf_sub, 'data.frame'), as(umf, 'data.frame')[c(1,3),])
- checkException(umf[,2])
+ expect_error(umf[,2])
sl_bad <- c(10,10)
- checkException(unmarkedFrameOccuTTD(y, sl_bad))
+ expect_error(unmarkedFrameOccuTTD(y, sl_bad))
+
+ # plot
+ pdf(NULL)
+ pl <- plot(umf)
+ expect_is(pl, "histogram")
+ dev.off()
## Multiple observers
y <- cbind(y,y)
@@ -42,29 +55,64 @@ test.unmarkedFrameOccuTTD <- function() {
tm <- cbind(rep(10,N),rep(5,N))
umf <- unmarkedFrameOccuTTD(y=y, surveyLength=tm, siteCovs=sc, obsCovs=oc)
- checkEqualsNumeric(getY(umf), y)
- checkEqualsNumeric(dim(getY(umf)), c(100,2))
- checkEqualsNumeric(obsCovs(umf), oc)
+ expect_equivalent(getY(umf), y)
+ expect_equivalent(dim(getY(umf)), c(100,2))
+ expect_equivalent(obsCovs(umf), oc)
- checkEqualsNumeric(umf@numPrimary, 1)
- checkEqualsNumeric(umf@surveyLength, tm)
- checkException(umf[,2])
+ expect_equivalent(umf@numPrimary, 1)
+ expect_equivalent(umf@surveyLength, tm)
+ expect_error(umf[,2])
## Multiple primary periods
umf <- unmarkedFrameOccuTTD(y=y, surveyLength=tm, siteCovs=sc,
yearlySiteCovs=oc, numPrimary=2)
- checkEqualsNumeric(yearlySiteCovs(umf), oc)
- checkEqualsNumeric(umf@numPrimary, 2)
+ expect_equivalent(yearlySiteCovs(umf), oc)
+ expect_equivalent(umf@numPrimary, 2)
umf_sub <- umf[,2]
- checkEqualsNumeric(getY(umf_sub), y[,2,drop=F])
+ expect_equivalent(getY(umf_sub), y[,2,drop=F])
y <- rexp(N, 1/lam)
y <- cbind(y,y,y)
- checkException(unmarkedFrameOccuTTD(y,Tmax,numPrimary=2))
-}
+ expect_error(unmarkedFrameOccuTTD(y,Tmax,numPrimary=2))
+})
+
+test_that("occuTTD R and C engines return same results",{
+ skip_on_cran()
+ set.seed(123)
+ N <- 20; J <- 1
+
+ #Simulate occupancy
+ scovs <- data.frame(elev=c(scale(runif(N, 0,100))),
+ forest=runif(N,0,1),
+ wind=runif(N,0,1))
+ beta_N <- c(-0.69, 0.71, -0.5)
+ lambda_N <- exp(cbind(1, scovs$elev, scovs$forest) %*% beta_N)
+ abun <- rpois(N, lambda_N)
+ z <- as.numeric(abun>0)
+
+ #Simulate detection
+ Tmax <- 10
+ beta_lam <- c(-2, -0.2, 0.7)
+ rate <- exp(cbind(1, scovs$elev, scovs$wind) %*% beta_lam)
+ ttd <- rexp(N, rate)
+ ttd[z==0] <- Tmax
+ ttd[ttd>Tmax] <- Tmax
+
+ #Build UMF
+ umf <- unmarkedFrameOccuTTD(y=ttd, surveyLength=Tmax, siteCovs=scovs)
-test.occuTTD.singleseason <- function(){
+ fitR <- occuTTD(psiformula=~elev, detformula=~wind,
+ data=umf, linkPsi='cloglog', ttdDist='exp',engine="R")
+
+ fitC <- occuTTD(psiformula=~elev, detformula=~wind,
+ data=umf, linkPsi='cloglog', ttdDist='exp',engine="C")
+
+ expect_equal(coef(fitR), coef(fitC), tol=1e-5)
+
+})
+
+test_that("occuTTD can fit a single-season 1 obs model",{
#One observer------------------------------------
set.seed(123)
@@ -90,128 +138,142 @@ test.occuTTD.singleseason <- function(){
#Build UMF
umf <- unmarkedFrameOccuTTD(y=ttd, surveyLength=Tmax, siteCovs=scovs)
- fitR <- occuTTD(psiformula=~elev+forest, detformula=~elev+wind,
- data=umf, linkPsi='cloglog', ttdDist='exp',engine="R")
+ #fitR <- occuTTD(psiformula=~elev+forest, detformula=~elev+wind,
+ # data=umf, linkPsi='cloglog', ttdDist='exp',engine="R")
fitC <- occuTTD(psiformula=~elev+forest, detformula=~elev+wind,
data=umf, linkPsi='cloglog', ttdDist='exp',engine="C")
- checkEqualsNumeric(coef(fitR), coef(fitC), tol=1e-5)
- checkEqualsNumeric(coef(fitC), c(-0.6271,0.8157,-0.5982,-2.0588,
+ #expect_equivalent(coef(fitR), coef(fitC), tol=1e-5)
+ expect_equivalent(coef(fitC), c(-0.6271,0.8157,-0.5982,-2.0588,
-0.4042,1.2328), tol=1e-4)
- checkEqualsNumeric(coef(fitC), c(beta_N, beta_lam), tol=0.3)
+ expect_equivalent(coef(fitC), c(beta_N, beta_lam), tol=0.3)
#Check weibull
- fitR <- occuTTD(psiformula=~elev+forest, detformula=~elev+wind,
- data=umf, linkPsi='cloglog',
- ttdDist='weibull',engine="R")
+ #fitR <- occuTTD(psiformula=~elev+forest, detformula=~elev+wind,
+ # data=umf, linkPsi='cloglog',
+ # ttdDist='weibull',engine="R")
fitC <- occuTTD(psiformula=~elev+forest, detformula=~elev+wind,
data=umf, linkPsi='cloglog', ttdDist='weibull',
engine="C")
- checkEqualsNumeric(coef(fitR), coef(fitC))
- checkEqualsNumeric(coef(fitC), c(-0.6846,0.7807,-0.5662,-1.9600,
+ #expect_equivalent(coef(fitR), coef(fitC))
+ expect_equivalent(coef(fitC), c(-0.6846,0.7807,-0.5662,-1.9600,
-0.3779,1.1474,0.06856), tol=1e-4)
#Check missing value handling
ttd_na <- ttd; ttd_na[1] <- NA
umf_na <- unmarkedFrameOccuTTD(y=ttd_na, Tmax, siteCovs=scovs)
- fit_naR <- occuTTD(psiformula=~elev+forest, detformula=~elev+wind,
- data=umf_na, linkPsi='cloglog',
- ttdDist='weibull',engine="R")
+ #fit_naR <- occuTTD(psiformula=~elev+forest, detformula=~elev+wind,
+ # data=umf_na, linkPsi='cloglog',
+ # ttdDist='weibull',engine="R")
- fit_naC <- occuTTD(psiformula=~elev+forest, detformula=~elev+wind,
+ expect_warning(fit_naC <- occuTTD(psiformula=~elev+forest, detformula=~elev+wind,
data=umf_na, linkPsi='cloglog', ttdDist='weibull',
- engine="C")
+ engine="C"))
- checkEqualsNumeric(coef(fit_naR), coef(fit_naC), tol=1e-5)
- checkEqualsNumeric(fit_naC@AIC, 1185.15, tol=1e-4)
- checkEqualsNumeric(fit_naC@sitesRemoved, 1)
+ #expect_equivalent(coef(fit_naR), coef(fit_naC), tol=1e-5)
+ expect_equivalent(fit_naC@AIC, 1185.15, tol=1e-4)
+ expect_equivalent(fit_naC@sitesRemoved, 1)
set.seed(123)
- p <- parboot(fitC)
- checkEqualsNumeric(p@t.star[1,], 87.90704)
+ p <- parboot(fitC, nsim=3)
+ expect_equivalent(p@t.star[1,], 87.90704)
r <- ranef(fitC)
- checkEqualsNumeric(dim(r@post), c(N,2,1))
+ expect_equivalent(dim(r@post), c(N,2,1))
b <- bup(r)
- checkEqualsNumeric(length(b), N)
+ expect_equivalent(length(b), N)
- #Two observers-----------------------------------
+})
+
+test_that("occuTTD can fit a single-season multi-obs model",{
set.seed(123)
+ N <- 500
+ beta_N <- c(-0.69, 0.71, -0.5)
+ beta_lam <- c(-2, -0.2, 0.7)
+ scovs <- data.frame(elev=c(scale(runif(N, 0,100))),
+ forest=runif(N,0,1),
+ wind=runif(N,0,1))
+ lambda_N <- exp(cbind(1, scovs$elev, scovs$forest) %*% beta_N)
+ abun <- rpois(N, lambda_N)
+ z <- as.numeric(abun>0)
+
ocovs <- data.frame(obs=rep(c('A','B'),N))
Tmax <- 10
+ rate <- exp(cbind(1, scovs$elev, scovs$wind) %*% beta_lam)
rateB <- exp(cbind(1, scovs$elev, scovs$wind) %*% beta_lam + 0.2)
rate2 <- as.numeric(t(cbind(rate, rateB)))
+ set.seed(123)
ttd <- rexp(N*2, rate2)
ttd[ttd>Tmax] <- Tmax
ttd <- matrix(ttd, nrow=N, byrow=T)
ttd[z==0,] <- Tmax
- umf <- unmarkedFrameOccuTTD(y=ttd, surveyLength=Tmax,
- siteCovs=scovs, obsCovs=ocovs)
+ expect_warning(umf <- unmarkedFrameOccuTTD(y=ttd, surveyLength=Tmax,
+ siteCovs=scovs, obsCovs=ocovs))
- fitR <- occuTTD(psiformula=~elev+forest, detformula=~elev+wind+obs,
- data=umf, linkPsi='cloglog', ttdDist='exp',engine="R")
+ #fitR <- occuTTD(psiformula=~elev+forest, detformula=~elev+wind+obs,
+ # data=umf, linkPsi='cloglog', ttdDist='exp',engine="R")
fitC <- occuTTD(psiformula=~elev+forest, detformula=~elev+wind+obs,
data=umf, linkPsi='cloglog', ttdDist='exp',engine="C")
- checkEqualsNumeric(coef(fitR), coef(fitC))
+ #expect_equivalent(coef(fitR), coef(fitC))
#Check predict
- checkEqualsNumeric(as.numeric(predict(fitC, 'psi')[4,]),
+ expect_equivalent(as.numeric(predict(fitC, 'psi')[4,]),
c(0.7562,0.0407,0.6385,0.8588), tol=1e-4)
- checkEqualsNumeric(as.numeric(predict(fitC, 'det')[1,]),
+ expect_equivalent(as.numeric(predict(fitC, 'det')[1,]),
c(0.16059,0.02349,0.12056,0.2139), tol=1e-4)
- checkException(predict(fitC, 'col'))
+ expect_error(predict(fitC, 'col'))
#Check getP
gp <- getP(fitC)
- checkEqualsNumeric(dim(gp), c(500,2))
- checkEqualsNumeric(gp[1,], c(0.79929,0.8679),tol=1e-4)
+ expect_equivalent(dim(gp), c(500,2))
+ expect_equivalent(gp[1,], c(0.79929,0.8679),tol=1e-4)
#Check fitted
ft <- fitted(fitC)
- checkEqualsNumeric(dim(ft),c(500,2))
- checkEqualsNumeric(ft[1,], c(0.17963,0.19505), tol=1e-4)
+ expect_equivalent(dim(ft),c(500,2))
+ expect_equivalent(ft[1,], c(0.17963,0.19505), tol=1e-4)
#Check residuals
r <- residuals(fitC)
- checkEqualsNumeric(dim(r),c(500,2))
- checkEqualsNumeric(r[1,], c(0.82036,0.80494), tol=1e-4)
+ expect_equivalent(dim(r),c(500,2))
+ expect_equivalent(r[1,], c(0.82036,0.80494), tol=1e-4)
#Check ranef
r <- ranef(fitC)
- checkEqualsNumeric(dim(r@post), c(N,2,1))
+ expect_equivalent(dim(r@post), c(N,2,1))
b <- bup(r)
- checkEqualsNumeric(length(b), N)
+ expect_equivalent(length(b), N)
#Check site is retained when only one observation is missing
ttd_na <- ttd; ttd_na[1,1] <- NA
- umf_na <- unmarkedFrameOccuTTD(y=ttd_na, Tmax, siteCovs=scovs,
- obsCovs=ocovs)
+ expect_warning(umf_na <- unmarkedFrameOccuTTD(y=ttd_na, Tmax, siteCovs=scovs,
+ obsCovs=ocovs))
- fit_naR <- occuTTD(psiformula=~elev+forest, detformula=~elev+wind+obs,
- data=umf_na, linkPsi='cloglog',
- ttdDist='weibull',engine="R")
+ #fit_naR <- occuTTD(psiformula=~elev+forest, detformula=~elev+wind+obs,
+ # data=umf_na, linkPsi='cloglog',
+ # ttdDist='weibull',engine="R")
fit_naC <- occuTTD(psiformula=~elev+forest, detformula=~elev+wind+obs,
data=umf_na, linkPsi='cloglog', ttdDist='weibull',
engine="C")
- checkEqualsNumeric(coef(fit_naR), coef(fit_naC), tol=1e-5)
- checkEqualsNumeric(fit_naC@sitesRemoved, numeric(0))
+ #expect_equivalent(coef(fit_naR), coef(fit_naC), tol=1e-5)
+ expect_equivalent(fit_naC@sitesRemoved, numeric(0))
#Check site is removed when both obs are NA
ttd_na <- ttd; ttd_na[1,] <- NA
- umf_na <- unmarkedFrameOccuTTD(y=ttd_na, Tmax, siteCovs=scovs,
- obsCovs=ocovs)
+ expect_warning(umf_na <- unmarkedFrameOccuTTD(y=ttd_na, Tmax, siteCovs=scovs,
+ obsCovs=ocovs))
- fit_naC <- occuTTD(psiformula=~elev+forest, detformula=~elev+wind+obs,
+ expect_warning(fit_naC <- occuTTD(psiformula=~elev+forest, detformula=~elev+wind+obs,
data=umf_na, linkPsi='cloglog',
- ttdDist='weibull',engine="C")
- checkEqualsNumeric(fit_naC@sitesRemoved, 1)
+ ttdDist='weibull',engine="C"))
+ expect_equivalent(fit_naC@sitesRemoved, 1)
#Check logit link
set.seed(123)
@@ -233,25 +295,25 @@ test.occuTTD.singleseason <- function(){
umf <- unmarkedFrameOccuTTD(y=ttd, surveyLength=Tmax, siteCovs=scovs)
- fitR <- occuTTD(psiformula=~elev+forest, detformula=~elev+wind,
- data=umf, linkPsi='logit', ttdDist='exp',engine="R")
+ #fitR <- occuTTD(psiformula=~elev+forest, detformula=~elev+wind,
+ # data=umf, linkPsi='logit', ttdDist='exp',engine="R")
fitC <- occuTTD(psiformula=~elev+forest, detformula=~elev+wind,
data=umf, linkPsi='logit', ttdDist='exp',engine="C")
- checkEqualsNumeric(coef(fitR), coef(fitC))
- checkEqualsNumeric(coef(fitC), c(-0.5102,0.67941,-0.88612,-2.1219,
+ #expect_equivalent(coef(fitR), coef(fitC))
+ expect_equivalent(coef(fitC), c(-0.5102,0.67941,-0.88612,-2.1219,
-0.41504,1.3224), tol=1e-4)
# Check error when random effect in formula
- checkException(occuTTD(~(1|dummy), ~1, data=umf))
-}
+ expect_error(occuTTD(~(1|dummy), ~1, data=umf))
+})
-test.occuTTD.dynamic <- function(){
+test_that("occuTTD can fit a dynamic model",{
set.seed(123)
#Simulate initial occupancy
- N <- 5000; J <- 1; T <- 2
+ N <- 1000; J <- 1; T <- 2
scovs <- data.frame(elev=c(scale(runif(N, 0,100))),
forest=runif(N,0,1),
wind=runif(N,0,1))
@@ -295,9 +357,9 @@ test.occuTTD.dynamic <- function(){
ttd[z[,1]==0,1:2] <- Tmax
ttd[z[,2]==0,3:4] <- Tmax
- umf <- unmarkedFrameOccuTTD(y = ttd, surveyLength = Tmax,
+ expect_warning(umf <- unmarkedFrameOccuTTD(y = ttd, surveyLength = Tmax,
siteCovs = scovs, obsCovs=ocovs,
- yearlySiteCovs=ysc, numPrimary=2)
+ yearlySiteCovs=ysc, numPrimary=2))
fit <- occuTTD(psiformula=~elev+forest,detformula=~elev+wind+obs,
gammaformula=~forest, epsilonformula=~elev,
@@ -305,8 +367,8 @@ test.occuTTD.dynamic <- function(){
linkPsi='logit',ttdDist='exp',engine="C")
truth <- c(beta_psi, c_b0, c_b1, e_b0, e_b1, beta_lam, -0.5)
- checkEqualsNumeric(coef(fit), truth, tol=0.1)
- checkEqualsNumeric(fit@AIC, 45037.74,tol=1e-4)
+ #expect_equivalent(coef(fit), truth, tol=0.1)
+ expect_equivalent(fit@AIC, 9354.081,tol=1e-4)
umf_new <- umf[1:100,]
@@ -316,16 +378,16 @@ test.occuTTD.dynamic <- function(){
linkPsi='logit',ttdDist='exp',engine="C")
s <- simulate(fit, nsim=2)
- checkEqualsNumeric(length(s),2)
- checkEqualsNumeric(dim(s[[1]]), c(100,4))
+ expect_equivalent(length(s),2)
+ expect_equivalent(dim(s[[1]]), c(100,4))
r <- residuals(fit)
- checkEqualsNumeric(dim(r), c(100,4))
+ expect_equivalent(dim(r), c(100,4))
#Check ranef
r <- ranef(fit)
- checkEqualsNumeric(dim(r@post), c(100,2,T))
+ expect_equivalent(dim(r@post), c(100,2,T))
b <- bup(r)
- checkEqualsNumeric(dim(b), c(100,T))
+ expect_equivalent(dim(b), c(100,T))
# Check T > 2 works
N <- 100; J <- 1; T <- 3
@@ -372,19 +434,19 @@ test.occuTTD.dynamic <- function(){
ttd[z[,1]==0,1:2] <- Tmax
ttd[z[,2]==0,3:4] <- Tmax
- umf <- unmarkedFrameOccuTTD(y = ttd, surveyLength = Tmax,
+ expect_warning(umf <- unmarkedFrameOccuTTD(y = ttd, surveyLength = Tmax,
siteCovs = scovs, obsCovs=ocovs,
- yearlySiteCovs=ysc, numPrimary=T)
+ yearlySiteCovs=ysc, numPrimary=T))
fit2 <- occuTTD(psiformula=~elev+forest,detformula=~elev+wind+obs,
gammaformula=~forest, epsilonformula=~elev,
data=umf,se=T,
linkPsi='logit',ttdDist='exp',engine="C")
- checkTrue(inherits(fit2, "unmarkedFitOccuTTD"))
+ expect_is(fit2, "unmarkedFitOccuTTD")
-}
+})
-test.occuTTD.predict.complexFormulas <- function(){
+test_that("occuMulti predict works",{
#One observer------------------------------------
set.seed(123)
@@ -418,7 +480,7 @@ test.occuTTD.predict.complexFormulas <- function(){
pr1 <- predict(fitC, 'psi', newdata=nd1)$Predicted
pr2 <- predict(fitC, 'psi', newdata=nd2)$Predicted[1:2]
- checkEqualsNumeric(pr1,pr2)
+ expect_equivalent(pr1,pr2)
#Check factors
scovs$fac_cov <- factor(sample(c('a','b','c'), N, replace=T),
@@ -433,8 +495,8 @@ test.occuTTD.predict.complexFormulas <- function(){
pr2 <- predict(fitC, 'psi', newdata=data.frame(fac_cov=c('a','b')))
pr3 <- predict(fitC, 'psi', newdata=data.frame(fac_cov=factor(c('a','b'))))
- checkEqualsNumeric(as.matrix(pr1),as.matrix(pr2[2:1,]))
- checkEqualsNumeric(as.matrix(pr1),as.matrix(pr3[2:1,]))
- checkException(predict(fitC, 'psi', newdata=data.frame(fac_cov=c('a','d'))))
+ expect_equivalent(as.matrix(pr1),as.matrix(pr2[2:1,]))
+ expect_equivalent(as.matrix(pr1),as.matrix(pr3[2:1,]))
+ expect_error(predict(fitC, 'psi', newdata=data.frame(fac_cov=c('a','d'))))
-}
+})
diff --git a/tests/testthat/test_parboot.R b/tests/testthat/test_parboot.R
new file mode 100644
index 0000000..ca7e5e5
--- /dev/null
+++ b/tests/testthat/test_parboot.R
@@ -0,0 +1,102 @@
+context("parboot")
+skip_on_cran()
+
+y <- matrix(rep(0:1,10)[1:10],5,2)
+siteCovs <- data.frame(x = c(0,2,3,4,1))
+obsCovs <- data.frame(o1 = 1:10, o2 = exp(-5:4)/10)
+umf <- unmarkedFrameOccu(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
+fm <- occu(~ o1 + o2 ~ x, data = umf)
+
+fitstats <- function(fm) {
+ observed <- getY(fm@data)
+ expected <- fitted(fm)
+ resids <- residuals(fm)
+ sse <- sum(resids^2,na.rm=TRUE)
+ chisq <- sum((observed - expected)^2 / expected,na.rm=TRUE)
+ freeTuke <- sum((sqrt(observed) - sqrt(expected))^2,na.rm=TRUE)
+ out <- c(SSE=sse, Chisq=chisq, freemanTukey=freeTuke)
+ return(out)
+}
+
+fitstats2 <- function(fm, na.rm=TRUE) {
+ observed <- getY(fm@data)
+ expected <- fitted(fm)
+ resids <- residuals(fm)
+ sse <- sum(resids^2, na.rm=na.rm)
+ chisq <- sum((observed - expected)^2 / expected, na.rm=na.rm)
+ freeTuke <- sum((sqrt(observed) - sqrt(expected))^2, na.rm=na.rm)
+ out <- c(SSE=sse, Chisq=chisq, freemanTukey=freeTuke)
+ return(out)
+}
+
+test_that("parboot works", {
+ pb <- parboot(fm, fitstats, nsim=3)
+ expect_equal(dim(pb@t.star), c(3,3))
+
+ # check show
+ pb_out <- capture.output(pb)
+ expect_equal(pb_out[4], "Parametric Bootstrap Statistics:")
+
+ # check plot
+ pdf(NULL)
+ pl <- plot(pb)
+ dev.off()
+ expect_equal(pl, NULL)
+
+ # check that report argument gives warning
+ expect_warning(parboot(fm, fitstats, nsim=3, report=TRUE))
+})
+
+test_that("parboot works in parallel",{
+ skip_on_cran()
+ skip_on_ci()
+ # check parallel
+ pb <- parboot(fm, nsim=10, parallel=TRUE, ncores=2)
+ expect_equal(length(pb@t.star), 10)
+})
+
+test_that("parboot handles failing model fits", {
+
+ fail_func <- function(x){
+ rand <- rnorm(1)
+ if(rand > 0.5){
+ stop("fail")
+ }
+ return(rand)
+ }
+
+ set.seed(123)
+ expect_warning(pb <- parboot(fm, nsim=20, statistic=fail_func))
+ expect_equal(nrow(pb@t.star), 13)
+
+ expect_warning(pb <- parboot(fm, nsim=20, statistic=fail_func, parallel=TRUE))
+ expect_true(nrow(pb@t.star) < 20)
+
+})
+
+test_that("parboot handles statistic functions with additional arguments", {
+
+ opt_func <- function(x, y){
+ res <- mean(residuals(x), na.rm=TRUE)
+ c(res=res, y=y)
+ }
+
+ pb <- parboot(fm, nsim=10, statistic=opt_func, y=0.1)
+ expect_equal(colnames(pb@t.star), c("res", "y"))
+ expect_true(all(pb@t.star[,"y"]==0.1))
+
+ pb <- parboot(fm, nsim=10, statistic=opt_func, y=0.1, parallel=TRUE)
+ expect_equal(colnames(pb@t.star), c("res", "y"))
+ expect_true(all(pb@t.star[,"y"]==0.1))
+})
+
+# To show the fitstats function in parboot example works when there are NAs
+test_that("fitstats2 function handles NAs", {
+ umf2 <- umf
+ umf2@y[1,1] <- NA
+ fm2 <- occu(~ o1 + o2 ~ x, data = umf2)
+ expect_error(expect_warning(show(parboot(fm2, nsim=3, statistic=fitstats2, na.rm=FALSE))))
+ pb <- parboot(fm2, nsim=3, statistic=fitstats2, na.rm=TRUE)
+ expect_is(pb, "parboot")
+ expect_equal(nrow(pb@t.star), 3)
+})
diff --git a/tests/testthat/test_pcount.R b/tests/testthat/test_pcount.R
new file mode 100644
index 0000000..6db9966
--- /dev/null
+++ b/tests/testthat/test_pcount.R
@@ -0,0 +1,212 @@
+context("pcount fitting function")
+skip_on_cran()
+
+test_that("pcount can fit simple models",{
+
+ y <- matrix(c(
+ 8,7,
+ 6,7,
+ 8,8,
+ 8,6,
+ 7,7), nrow=5, ncol=2, byrow=TRUE)
+ siteCovs <- data.frame(x = c(0,2,3,4,1))
+ obsCovs <- data.frame(o1 = 1:10)
+ umf <- unmarkedFramePCount(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
+ fm <- pcount(~ o1 ~ offset(x), data = umf, K=30)
+ expect_equivalent(coef(fm), structure(c(-0.78814924, 2.62569034, -0.02578801),
+ .Names = c("lam(Int)", "p(Int)", "p(o1)")), tol = 1e-5)
+
+ y <- matrix(c(
+ 8,7,7,8,
+ 6,7,7,5,
+ 8,8,7,8,
+ 4,5,5,5,
+ 4,4,3,3), nrow=5, ncol=4, byrow=TRUE)
+ siteCovs <- data.frame(x = c(0,2,3,4,1))
+ obsCovs <- data.frame(o1 = seq(-1, 1, length=length(y)))
+ umf <- unmarkedFramePCount(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
+ fm <- pcount(~ o1 ~ x, data = umf, K=30)
+ expect_equivalent(coef(fm),
+ c(1.91984184, -0.02987393, 2.49421875, -0.23350448),
+ tol = 1e-5)
+
+ fm <- pcount(~o1~x, data=umf, K=30, mixture='ZIP')
+ pr <- predict(fm, 'state')
+ expect_is(pr, "data.frame")
+ expect_equivalent(as.numeric(pr[1,]), c(6.8184,2.0456,3.7871,12.2760), tol=1e-4)
+
+ nd <- data.frame(x=c(0,1))
+ pr <- predict(fm, 'state', newdata=nd)
+ expect_equal(dim(pr), c(2,4))
+
+ pr <- predict(fm, 'det')
+ expect_equal(dim(pr), c(20,4))
+
+ gp <- getP(fm)
+ expect_equal(dim(gp), dim(umf@y))
+
+ res <- residuals(fm)
+ expect_equal(dim(res), dim(umf@y))
+
+ r <- ranef(fm)
+ expect_equal(dim(r@post), c(5,31,1))
+ expect_equal(bup(r), c(8.01, 7.01, 8.07, 5.03, 4.01), tol=1e-3)
+ fm2 <- update(fm, mixture="NB")
+ r2 <- ranef(fm2)
+ expect_is(r2, "unmarkedRanef")
+ fm3 <- update(fm, mixture="ZIP")
+ r3 <- ranef(fm3)
+ expect_is(r3, "unmarkedRanef")
+
+ s <- simulate(fm, n=2)
+ expect_equal(length(s), 2)
+ expect_equal(dim(s[[1]]), dim(umf@y))
+
+ pb <- parboot(fm, nsim=1)
+ expect_is(pb, "parboot")
+
+})
+
+test_that("pcount predict works",{
+
+ set.seed(55)
+ R <- 20
+ J <- 4
+ N <- rpois(R, 2)
+ y <- matrix(rbinom(R*J, N, 0.7), R, J)
+ umf1 <- unmarkedFramePCount(y=y)
+
+ fm1 <- pcount(~1 ~1, umf1, K=40)
+ E1.1 <- predict(fm1, type="state")
+ E1.2 <- predict(fm1, type="det")
+
+ fm2 <- pcount(~1 ~1, umf1, K=40, mixture="NB")
+ E2.1 <- predict(fm2, type="state")
+ expect_error(predict(fm2, type="alpha"))
+
+ fm3 <- pcount(~1 ~1, umf1, K=40, mixture="ZIP")
+ E3.1 <- predict(fm3, type="state")
+ expect_error(predict(fm3, type="psi"))
+ expect_equal(E3.1[1,1], 1.818512, tol=1e-6)
+
+})
+
+test_that("pcount can fit models with random effects",{
+
+set.seed(35)
+nSites <- 300
+nVisits <- 3
+x <- rnorm(nSites) # a covariate
+beta0 <- 0
+beta1 <- 0.4
+
+ran <- rnorm(100, 0, 1)
+group <- factor(as.character(rep(1:100, each=3)))
+ran_ind <- as.numeric(group)
+
+lambda <- exp(beta0 + beta1*x +
+ ran[ran_ind]) # expected counts at each site
+N <- rpois(nSites, lambda) # latent abundance
+y <- matrix(NA, nSites, nVisits)
+p <- c(0.3, 0.6, 0.8) # detection prob for each visit
+for(j in 1:nVisits) {
+ y[,j] <- rbinom(nSites, N, p[j])
+}
+
+# Organize data
+visitMat <- matrix(as.character(1:nVisits), nSites, nVisits, byrow=TRUE)
+
+expect_warning(umf <- unmarkedFramePCount(y=y, siteCovs=data.frame(x=x,group=group),
+ obsCovs=list(visit=visitMat)))
+
+fm <- pcount(~1~x, umf, K=25)
+expect_is(fm, "unmarkedFitPCount")
+
+fmr <- pcount(~visit~x+(1|group), umf, K=25)
+
+expect_equivalent(coef(fmr), c(0.05397,0.3197,-0.8760,1.3668,2.078),
+ tol=1e-3)
+
+expect_true(inherits(sigma(fmr), 'data.frame'))
+expect_equal(sigma(fmr)$sigma, 1.05945, tol=1e-5)
+
+pr <- predict(fmr, "state")
+expect_equivalent(as.numeric(pr[1,]),
+ c(1.037050,0.58179,0.3453,3.1140), tol=1e-3)
+
+pr2 <- predict(fmr, "state", re.form=NA)
+expect_equivalent(as.numeric(pr2[1,]),
+ c(1.48366,0.2011,1.1374,1.93255), tol=1e-3)
+
+pr3 <- predict(fmr, "det")
+expect_true(inherits(pr3, "data.frame"))
+
+nd <- data.frame(x=siteCovs(umf)$x[c(1,4)], group=factor(c(1,2)))
+pr4 <- predict(fmr, "state", newdata=nd)
+expect_equivalent(pr4$Predicted, pr$Predicted[c(1,4)])
+
+# New group level
+nd <- data.frame(x=c(0,1), group=factor(101))
+expect_error(predict(fmr, "state", newdata=nd))
+
+nd <- data.frame(x=c(0,1))
+expect_error(expect_warning(predict(fmr, "state", newdata=nd)))
+
+pr5 <- predict(fmr, "state", newdata=nd, re.form=NA)
+expect_true(inherits(pr5, "data.frame"))
+
+ft <- fitted(fmr)
+expect_equivalent(dim(ft), c(300,3))
+
+r <- ranef(fmr)
+expect_true(inherits(r, "unmarkedRanef"))
+b <- bup(r)
+expect_true(cor(N, b) > 0.95)
+
+rt <- randomTerms(fmr)
+expect_true(inherits(rt, "data.frame"))
+expect_equivalent(dim(rt), c(100,8))
+expect_true(cor(ran, rt$Estimate) > 0.8)
+
+
+# Multiple random effects
+umf2 <- umf
+siteCovs(umf2)$id <- sample(letters[1:3], 300, replace=T)
+
+fmr2 <- pcount(~1~x+(1|group)+(1|id), umf2, K=25)
+
+expect_true(nrow(sigma(fmr2))==2)
+rt2 <- randomTerms(fmr2)
+expect_true(all(rt2$Groups==c(rep("group",100), rep("id",3))))
+
+# Check other distributions
+fmnb <- pcount(~1~1, umf, engine="TMB", mixture="NB", K=25)
+expect_true(inherits(fmnb@TMB, "list"))
+expect_true(all(names(fmnb@estimates@estimates)==c("state","det","alpha")))
+
+fmzip <- pcount(~1~1, umf, engine="TMB", mixture="ZIP", K=25)
+expect_true(inherits(fmnb@TMB, "list"))
+expect_true(all(names(fmnb@estimates@estimates)==c("state","det","alpha")))
+
+# Site random effects in det formula
+fm <- pcount(~(1|group)~1, umf2, K=19)
+expect_true(sigma(fm)$Model[1]=="p")
+})
+
+test_that("pcount R, C++ and TMB engines give same results",{
+
+ y <- matrix(c(
+ 8,7,7,8,
+ 6,7,7,5,
+ 8,8,7,8,
+ 4,5,5,5,
+ 4,4,3,3), nrow=5, ncol=4, byrow=TRUE)
+ siteCovs <- data.frame(x = c(0,2,3,4,1))
+ obsCovs <- data.frame(o1 = seq(-1, 1, length=length(y)))
+ umf <- unmarkedFramePCount(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
+ fmC <- pcount(~ o1 ~ x, data = umf, K=30, control=list(maxit=1))
+ fmT <- pcount(~ o1 ~ x, data = umf, K=30, control=list(maxit=1), engine="TMB")
+ fmR <- pcount(~ o1 ~ x, data = umf, K=30, control=list(maxit=1), engine="R")
+ expect_equal(coef(fmC), coef(fmR))
+ expect_equal(coef(fmC), coef(fmT), tol=1e-7)
+})
diff --git a/inst/unitTests/runit.pcount.spHDS.R b/tests/testthat/test_pcount.spHDS.R
index f1c2887..ee8380a 100644
--- a/inst/unitTests/runit.pcount.spHDS.R
+++ b/tests/testthat/test_pcount.spHDS.R
@@ -1,6 +1,7 @@
-test.pcount.spHDS<- function()
-{
+context("pcount.spHDS fitting function")
+skip_on_cran()
+test_that("pcount.spHDS can fit models",{
# Unit test here
set.seed(12)
x<- rnorm(50)
@@ -13,16 +14,16 @@ y<- rbinom(50, N, prob=p)
umf <- unmarkedFramePCount(y=matrix(y,ncol=1),
siteCovs=data.frame(dist=d,Habitat=x))
-summary(umf)
+#summary(umf)
fm1 <- pcount.spHDS(~ -1 + I(dist^2) ~ Habitat, umf, K=20)
-checkEqualsNumeric(
+expect_equivalent(
coef(fm1),
structure(c(-0.0521147712416163, 0.952296442491614, -1.66812493149504
), .Names = c("lam(Int)", "lam(Habitat)", "p(I(dist^2))"))
, tol=1e-5)
-checkException(pcount.spHDS(~(1|dummy)~1,umf))
-}
+expect_error(pcount.spHDS(~(1|dummy)~1,umf))
+})
diff --git a/inst/unitTests/runit.pcountOpen.R b/tests/testthat/test_pcountOpen.R
index f46c7da..c4bc456 100644
--- a/inst/unitTests/runit.pcountOpen.R
+++ b/tests/testthat/test_pcountOpen.R
@@ -1,7 +1,38 @@
-
-
-test.pcountOpen.null <- function()
-{
+context("pcountOpen fitting function")
+skip_on_cran()
+
+test_that("unmarkedFramePCO subset works",{
+ y <- matrix(1:27, 3)
+ sc <- data.frame(x1 = 1:3)
+ ysc <- list(x2 = matrix(1:9, 3))
+ oc <- list(x3 = matrix(1:27, 3))
+
+ umf1 <- unmarkedFramePCO(
+ y = y,
+ siteCovs = sc,
+ yearlySiteCovs = ysc,
+ obsCovs = oc,
+ numPrimary = 3)
+
+ dat <- as(umf1, "data.frame")
+
+ umf1.site1 <- umf1[1,]
+ expect_equal(umf1.site1@y, y[1,, drop=FALSE])
+ expect_equal(umf1.site1@siteCovs, sc[1,, drop=FALSE])
+ expect_equivalent(unlist(umf1.site1@obsCovs), oc$x3[1,])
+ expect_equivalent(unlist(umf1.site1@yearlySiteCovs),
+ ysc$x2[1,, drop=FALSE])
+ expect_equal(umf1.site1@numPrimary, 3)
+ expect_is(umf1.site1, "unmarkedFramePCO")
+
+ umf1.sites1and3 <- umf1[c(1,3),]
+
+ # subset by primary period
+ umf_sub <- umf1[,1:2]
+ expect_equal(umf_sub@numPrimary, 2)
+})
+
+test_that("pcountOpen can fit a null model",{
y <- matrix(c(
3, 2, 1, 4,
3, 4, 2, 1,
@@ -15,32 +46,47 @@ test.pcountOpen.null <- function()
fm1 <- pcountOpen(~1, ~1, ~1, ~1, data = umf, se=FALSE, K=10,
starts=c(1, 0, 0, 7))
- checkEqualsNumeric(coef(fm1),
+ expect_equivalent(coef(fm1),
c(0.9565311, 0.2741022, 0.1352888, 7.0041290),
tol = 1e-5)
fm2 <- pcountOpen(~1, ~1, ~1, ~1, data = umf, se=FALSE, fix="gamma",
K=10)
- checkEqualsNumeric(coef(fm2), c(1.8219354, 8.7416638, -0.2873611),
+ expect_equivalent(coef(fm2), c(1.8219354, 8.7416638, -0.2873611),
tol = 1e-3)
fm3 <- pcountOpen(~1, ~1, ~1, ~1, data = umf, se=FALSE, fix="omega",
K=30)
- checkEqualsNumeric(coef(fm3), c(1.8861091, -1.3102890, -0.4934883),
+ expect_equivalent(coef(fm3), c(1.8861091, -1.3102890, -0.4934883),
tol = 1e-5)
- # Check error when random effect in formula
- checkException(pcountOpen(~(1|dummy),~1,~1,~1, data=umf))
+ # methods
+ gp <- getP(fm1)
+ expect_equal(dim(gp), dim(umf@y))
-}
+ res <- residuals(fm1)
+ expect_equal(dim(res), dim(umf@y))
+ expect_equal(res[1,1], 0.39970, tol=1e-4)
+ s <- simulate(fm1, 2)
+ expect_equal(length(s), 2)
+ expect_equal(dim(s[[1]]), dim(umf@y))
+ r <- ranef(fm1)
+ expect_equal(dim(r@post), c(5,11,4))
+ expect_equal(dim(bup(r)), c(5,4))
+ expect_equal(bup(r)[1], 3.00236, tol=1e-5)
+ pb <- parboot(fm1, nsim=1)
+ expect_is(pb, "parboot")
+ # Check error when random effect in formula
+ expect_error(pcountOpen(~(1|dummy),~1,~1,~1, data=umf))
+
+})
-test.pcountOpen.na <- function()
-{
+test_that("pcountOpen handles NAs",{
y1 <- matrix(c(
NA, 2, 1, 4,
@@ -56,7 +102,7 @@ test.pcountOpen.na <- function()
fm1 <- pcountOpen(~1, ~1, ~1, ~1, data = umf1, se=FALSE, K=10,
starts=c(1.6, 0.24, 1.16, -0.268))
- checkEqualsNumeric(coef(fm1),
+ expect_equivalent(coef(fm1),
c(0.9536852, 0.4611643, -0.8655834, 3.2154420), tol = 1e-5)
y2 <- matrix(c(
@@ -74,21 +120,21 @@ test.pcountOpen.na <- function()
umf2 <- unmarkedFramePCO(y = y2, siteCovs = siteCovs, obsCovs = obsCovs,
yearlySiteCovs=ysc, numPrimary=4)
- fm2.1 <- pcountOpen(~1, ~1, ~1, ~o1, data = umf2, se=FALSE, K=10,
- starts=c(1.4, -1.3, 1.8, -1.1, 0.7))
- checkEqualsNumeric(coef(fm2.1),
+ expect_warning(fm2.1 <- pcountOpen(~1, ~1, ~1, ~o1, data = umf2, se=FALSE, K=10,
+ starts=c(1.4, -1.3, 1.8, -1.1, 0.7)))
+ expect_equivalent(coef(fm2.1),
c(1.239636, -2.085200, 1.770919, -0.602612, 1.255386),
tol = 1e-4)
- fm2.2 <- pcountOpen(~1, ~1, ~o2, ~1, data = umf2, se=FALSE, K=10,
- starts=c(1.2, -1, 2, 0, 0))
- checkEqualsNumeric(coef(fm2.2),
+ expect_warning(fm2.2 <- pcountOpen(~1, ~1, ~o2, ~1, data = umf2, se=FALSE, K=10,
+ starts=c(1.2, -1, 2, 0, 0)))
+ expect_equivalent(coef(fm2.2),
c(1.3242059, 0.8439311, -2.8217070, -10.1414153, 0.1176959),
tol = 1e-5)
- fm2.3 <- pcountOpen(~1, ~o2, ~1, ~1, data = umf2, se=FALSE, K=10,
- starts=c(1, 0, 0, -5, -1))
- checkEqualsNumeric(coef(fm2.3),
+ expect_warning(fm2.3 <- pcountOpen(~1, ~o2, ~1, ~1, data = umf2, se=FALSE, K=10,
+ starts=c(1, 0, 0, -5, -1)))
+ expect_equivalent(coef(fm2.3),
c(0.7013386, 0.5277811, -0.2350951, -1.8346326, 4.7771974),
tol = 1e-2)
@@ -104,12 +150,12 @@ test.pcountOpen.na <- function()
umf3 <- unmarkedFramePCO(y = y3, siteCovs = siteCovs, obsCovs = obsCovs,
numPrimary=4)
- fm3 <- pcountOpen(~1, ~1, ~1, ~1, data = umf3, se=FALSE, K=10,
- starts=c(1.5, 0, 1, 0))
- checkEqualsNumeric(coef(fm3),
+ expect_warning(fm3 <- pcountOpen(~1, ~1, ~1, ~1, data = umf3, se=FALSE, K=10,
+ starts=c(1.5, 0, 1, 0)))
+ expect_equivalent(coef(fm3),
c(0.9714456, 0.4481042, -0.8920462, 4.0379739 ),
tol = 1e-4)
- checkEquals(fm3@sitesRemoved, 6)
+ expect_equal(fm3@sitesRemoved, 6)
@@ -134,18 +180,18 @@ test.pcountOpen.na <- function()
y4.na <- is.na(go4) %*% o2y
y4.2 <- y4
y4.2[,-1][y4.na>0] <- NA
- y4.2
+ #y4.2
umf4 <- unmarkedFramePCO(y=y4, yearlySiteCovs=list(go4=cbind(go4, 1)),
numPrimary=4)
- fm4.1 <- pcountOpen(~1, ~go4, ~1, ~1, umf4, se=FALSE,
- starts=c(.8, .5, -.3, -1.5, 6))
- checkEquals(fm4.1@sitesRemoved, 1)
+ expect_warning(fm4.1 <- pcountOpen(~1, ~go4, ~1, ~1, umf4, se=FALSE,
+ starts=c(.8, .5, -.3, -1.5, 6)))
+ expect_equal(fm4.1@sitesRemoved, 1)
- fm4.2 <- pcountOpen(~1, ~1, ~go4, ~1, umf4, se=FALSE,
- starts=c(.8, 0, 5, -5, 7))
- checkEquals(fm4.2@sitesRemoved, 1)
+ expect_warning(fm4.2 <- pcountOpen(~1, ~1, ~go4, ~1, umf4, se=FALSE,
+ starts=c(.8, 0, 5, -5, 7)))
+ expect_equal(fm4.2@sitesRemoved, 1)
@@ -159,21 +205,21 @@ test.pcountOpen.na <- function()
umf5 <- unmarkedFramePCO(y=y5, numPrimary=3)
fm5 <- pcountOpen(~1, ~1, ~1, ~1, umf5, se=FALSE, K=10)
- checkEqualsNumeric(coef(fm5),
+ expect_equivalent(coef(fm5),
c(0.7269958, -0.3484145, 0.1494188, 1.9391898), tol=1e-5)
y6 <- y5
y6[1,1] <- y6[2,3:4] <- y6[3,5:6] <- y6[4,6] <- NA
umf6 <- unmarkedFramePCO(y=y6, numPrimary=3)
fm6 <- pcountOpen(~1, ~1, ~1, ~1, umf6, se=FALSE, K=10)
- checkEqualsNumeric(coef(fm6),
+ expect_equivalent(coef(fm6),
c(0.7945817, -0.4340502, 0.5614526, 1.4161393), tol=1e-5)
y7 <- y5
oc7 <- y6 + -2:1
umf7 <- unmarkedFramePCO(y=y7, obsCovs=list(oc=oc7), numPrimary=3)
- fm7 <- pcountOpen(~1, ~1, ~1, ~oc, umf7, se=FALSE, K=10)
- checkEqualsNumeric(coef(fm7),
+ expect_warning(fm7 <- pcountOpen(~1, ~1, ~1, ~oc, umf7, se=FALSE, K=10))
+ expect_equivalent(coef(fm7),
c(1.1986029, -9.9298367, 12.5760064, -0.8876606, 0.9525870),
tol=1e-4)
@@ -184,22 +230,15 @@ test.pcountOpen.na <- function()
umf8 <- unmarkedFramePCO(y=y8, yearlySiteCovs=list(ysc=ysc8),
numPrimary=3)
## !!!!!!!!!!!
- fm8 <- pcountOpen(~1, ~1, ~ysc, ~1, umf8, se=FALSE, K=10)
- checkEqualsNumeric(coef(fm8),
+ expect_warning(fm8 <- pcountOpen(~1, ~1, ~ysc, ~1, umf8, se=FALSE, K=10))
+ expect_equivalent(coef(fm8),
c(0.7278796, -0.8770411, 0.9170578, 0.0399341, 1.8956210),
tol=1e-4)
-}
-
-
-
-
-
-
+})
-test.pcountOpen.delta <- function()
-{
+test_that("pcountOpen handles different lengths of time between primary periods (delta)",{
M <- 5
T <- 4
y <- matrix(c(
@@ -219,7 +258,7 @@ test.pcountOpen.delta <- function()
1, 2, 2, 2,
1, 2, 2, 2), M, T, byrow=TRUE)
- checkEquals(delta, ans)
+ expect_equal(delta, ans)
dates2 <- matrix(c(
2, 4, 6, 8,
@@ -235,7 +274,7 @@ test.pcountOpen.delta <- function()
1, 3, 2, 2,
2, 3, 2, 2), M, T, byrow=TRUE)
- checkEquals(delta2, ans2)
+ expect_equal(delta2, ans2)
dates3 <- matrix(as.integer(c(
2, NA, 6, 8,
@@ -243,7 +282,7 @@ test.pcountOpen.delta <- function()
2, 4, 6, 8,
1, 4, 6, 8,
2, 4, 6, 8)), M, T, byrow=TRUE)
- checkException(unmarkedFramePCO(y=y, primaryPeriod=dates3,
+ expect_error(unmarkedFramePCO(y=y, primaryPeriod=dates3,
numPrimary=4))
dates4 <- dates2
@@ -252,7 +291,7 @@ test.pcountOpen.delta <- function()
delta4 <- formatDelta(dates4, is.na(y))
umf <- unmarkedFramePCO(y=y, primaryPeriod=dates4, numPrimary=4)
fm <- pcountOpen(~1, ~1, ~1, ~1, umf, K=10, starts=c(1.2, 0, 1.4, 1.2))
- checkEqualsNumeric(coef(fm),
+ expect_equivalent(coef(fm),
c(1.35779948, 0.11911809, -0.06946651, 5.78090618),
# c(1.2543989, -0.5429887, 0.6715887, 5.6593500),
tol = 1e-5)
@@ -276,76 +315,15 @@ test.pcountOpen.delta <- function()
NA, NA, 4, NA, # 4 not 5 b/c primary period 1 is day 2
1, 2, 2, 2), M, T, byrow=TRUE)
delta5 <- formatDelta(dates5, is.na(y5))
- checkEquals(delta5, ans5)
+ expect_equal(delta5, ans5)
dates6 <- y6 <- matrix(c(2L, 1L), 1, 2)
- checkException(unmarkedFramePCO(y=y6, primaryPeriod=dates6,
+ expect_error(unmarkedFramePCO(y=y6, primaryPeriod=dates6,
numPrimary=2))
+})
-
-}
-
-
-
-
-
-
-test.pcountOpen.secondSamps <- function()
-{
- y <- matrix(c(
- 0,0, 2,2, 3,2, 2,2,
- 2,2, 2,1, 3,2, 1,1,
- 1,0, 1,1, 0,0, 0,0,
- 0,0, 0,0, 0,0, 0,0), nrow=4, ncol=8, byrow=TRUE)
-
- sc <- data.frame(x1 = 1:4, x2 = c('A','A','B','B'))
-
- oc <- list(
- x3 = matrix(1:8, nrow=4, ncol=8, byrow=TRUE),
- x4 = matrix(letters[1:8], nrow=4, ncol=8, byrow=TRUE))
-
- ysc <- list(
- x5 = matrix(c(
- 1,2,3,4,
- 1,2,3,4,
- 1,2,3,4,
- 1,2,3,4), nrow=4, ncol=4, byrow=TRUE))
-
- umf1 <- unmarkedFramePCO(y=y, siteCovs=sc, obsCovs=oc,
- yearlySiteCovs=ysc, numPrimary=4)
-
- m1 <- pcountOpen(~1, ~1, ~1, ~1, umf1, K=10)
- checkEqualsNumeric(coef(m1),
- c(-0.2438797, -0.7838448, 0.5572557, 1.6925454), tol=1e-5)
-
-
- y2 <- y
- y2[1,1] <- NA
- umf2 <- unmarkedFramePCO(y=y2, siteCovs=sc, obsCovs=oc,
- yearlySiteCovs=ysc, numPrimary=4)
-
- m2 <- pcountOpen(~1, ~1, ~1, ~1, umf2, K=10)
-
-
-
-}
-
-
-
-
-
-
-
-
-
-
-
-
-
-test.pcountOpen.dynamics <- function()
-{
-
+test_that("pcountOpen can fit models with various dynamics",{
set.seed(3)
M <- 20
T <- 5
@@ -362,28 +340,28 @@ test.pcountOpen.dynamics <- function()
N[,t+1] <- S[,t] + G[,t]
}
y[] <- rbinom(M*T, N, p)
- colMeans(y)
+ #colMeans(y)
umf <- unmarkedFramePCO(y = y, numPrimary=T)
m1 <- pcountOpen(~1, ~1, ~1, ~1, umf, K=20, dynamics="autoreg")
- checkEqualsNumeric(coef(m1),
+ expect_equivalent(coef(m1),
c(1.5457081, -1.2129776, 0.5668830, 0.4987492),
tolerance=1e-5)
m2 <- pcountOpen(~1, ~1, ~1, ~1, umf, K=20, dynamics="notrend")
- checkEqualsNumeric(coef(m2),
+ expect_equivalent(coef(m2),
c(1.2131713, 0.7301736, 1.1949289),
tolerance=1e-5)
m3 <- pcountOpen(~1, ~1, ~1, ~1, umf, K=20, dynamics="trend")
- checkEqualsNumeric(coef(m3),
+ expect_equivalent(coef(m3),
c(1.67211946, -0.06534021, 0.18287762),
tolerance=1e-5)
-}
+})
-test.pcountOpen.fix <- function() {
+test_that("pcountOpen simulate and fitted methods work",{
set.seed(3)
M <- 50
@@ -406,25 +384,25 @@ test.pcountOpen.fix <- function() {
m1 <- pcountOpen(~1, ~1, ~1, ~1, umf, K=20)
m1_sim <- simulate(m1)
- checkEqualsNumeric(m1_sim[[1]][1,],c(3,4,4,2,2))
+ expect_equivalent(m1_sim[[1]][1,],c(3,4,4,2,2))
m2 <- pcountOpen(~1, ~1, ~1, ~1, umf, K=20, fix='gamma')
m2_sim <- simulate(m2)
- checkEqualsNumeric(m2_sim[[1]][1,],c(4,4,6,5,3))
+ expect_equivalent(m2_sim[[1]][1,],c(4,4,6,5,3))
m2_fit <- fitted(m2)
- checkEqualsNumeric(m2_fit[1,1],3.448029,tol=1e-4)
+ expect_equivalent(m2_fit[1,1],3.448029,tol=1e-4)
m3 <- pcountOpen(~1, ~1, ~1, ~1, umf, K=20, fix='omega')
m3_sim <- simulate(m3)
- checkEqualsNumeric(m3_sim[[1]][1,],c(2,1,3,5,4))
+ expect_equivalent(m3_sim[[1]][1,],c(2,1,3,5,4))
m3_fit <- fitted(m3)
- checkEqualsNumeric(m3_fit[1,1], 2.481839, tol=1e-4)
-}
+ expect_equivalent(m3_fit[1,1], 2.481839, tol=1e-4)
+})
-test.pcountOpen.predict <- function(){
+test_that("pcountOpen predict method works",{
set.seed(3)
- M <- 20
+ M <- 10
T <- 3
lambda <- 4
gamma <- 1.5
@@ -445,7 +423,7 @@ test.pcountOpen.predict <- function(){
umf <- unmarkedFramePCO(y = y, numPrimary=T, siteCovs=sc)
- m1 <- pcountOpen(~x1, ~x2, ~x3, ~x4, umf, K=20)
+ m1 <- pcountOpen(~x1, ~x2, ~x3, ~x4, umf, K=9)
#Make sure predicting with newdata works
p1 <- predict(m1, type = "lambda",
@@ -458,7 +436,11 @@ test.pcountOpen.predict <- function(){
newdata = data.frame(x3 = rnorm(5), x4 = rnorm(5)))
are_df <- sapply(list(p1,p2,p3,p4), function(x) inherits(x, "data.frame"))
- checkTrue(all(are_df))
+ expect_true(all(are_df))
-}
+ m2 <- pcountOpen(~x1, ~x2, ~x3, ~x4, umf, K=9, mixture="ZIP")
+ expect_warning(pr <- predict(m2,'lambda'))
+ expect_is(pr, "data.frame")
+ expect_equivalent(as.numeric(pr[1,]), c(2.572621,NA,NA,NA), tol=1e-4)
+})
diff --git a/inst/unitTests/runit.plotMarginal.R b/tests/testthat/test_plotMarginal.R
index 7389b54..fcbfe2a 100644
--- a/inst/unitTests/runit.plotMarginal.R
+++ b/tests/testthat/test_plotMarginal.R
@@ -1,4 +1,6 @@
-test.plotMarginal <- function(){
+context("plotMarginal")
+
+skip_on_cran()
set.seed(123)
dat_occ <- data.frame(x1=rnorm(500))
@@ -28,16 +30,17 @@ umf <- unmarkedFrameOccu(y=y, siteCovs=dat_occ, obsCovs=dat_p)
fm <- occu(~x2 ~x1 + group, umf)
+test_that("plotMarginal works", {
-plotMarginal(fm, "state", "x1")
-plotMarginal(fm, "state", "group")
-plotMarginal(fm, "det", "x2")
+ plotMarginal(fm, "state", "x1")
+ plotMarginal(fm, "state", "group")
+ plotMarginal(fm, "det", "x2")
-checkException(plotMarginal(fm, "state", "x2"))
+ expect_error(plotMarginal(fm, "state", "x2"))
-dat <- plotMarginalData(fm, "state", "group")
+ dat <- plotMarginalData(fm, "state", "group")
-checkTrue(inherits(dat, "data.frame"))
-checkEqualsNumeric(nrow(dat), 5)
+ expect_true(inherits(dat, "data.frame"))
+ expect_equal(nrow(dat), 5)
-}
+})
diff --git a/tests/testthat/test_powerAnalysis.R b/tests/testthat/test_powerAnalysis.R
new file mode 100644
index 0000000..d316a64
--- /dev/null
+++ b/tests/testthat/test_powerAnalysis.R
@@ -0,0 +1,127 @@
+context("powerAnalysis method")
+skip_on_cran()
+
+test_that("powerAnalysis method works",{
+ forms <- list(state=~elev, det=~1)
+ coefs <- list(state=c(intercept=0, elev=-0.4), det=c(intercept=0))
+ design <- list(M=300, J=8) # 300 sites, 8 occasions per site
+ occu_umf <- simulate("occu", formulas=forms, coefs=coefs, design=design)
+
+ template_model <- occu(~1~elev, occu_umf)
+ nul <- capture.output(expect_error(powerAnalysis(template_model)))
+
+ effect_sizes <- list(state=c(intercept=0, elev=-0.4), det=c(intercept=0))
+
+ nul <- capture_output({
+
+ set.seed(123)
+ pa <- powerAnalysis(template_model, coefs=effect_sizes, alpha=0.05, nsim=10)
+ expect_is(pa, "unmarkedPower")
+ s <- summary(pa)$Power
+ expect_true(s[2]>0.7)
+
+ # output printout
+ out <- capture.output(pa)
+ expect_equal(out[5], "Power Statistics:")
+
+ # update
+ pa_up <- update(pa, alpha=0.5)
+ expect_is(pa_up, "unmarkedPower")
+
+ # fewer sites
+ set.seed(123)
+ pa2 <- powerAnalysis(template_model, effect_sizes, design=list(M=50, J=3), nsim=10)
+ expect_true(all(summary(pa2)$Power < 0.4))
+
+ # more sites
+ set.seed(123)
+ pa3 <- powerAnalysis(template_model, effect_sizes, design=list(M=400, J=4), nsim=10)
+ expect_true(summary(pa3)$Power[2] >0.7)
+
+ # set null
+ set.seed(123)
+ nul <- list(state=c(intercept=5, elev=0), det=c(intercept=0))
+ pa4 <- powerAnalysis(template_model, effect_sizes, nulls=nul, nsim=10)
+ expect_true(summary(pa4)$Power[1]==1)
+ expect_equivalent(summary(pa4)$Null, c(5,0,0))
+
+ # list
+ pl <- unmarkedPowerList(list(pa, pa2, pa3, pa4))
+ expect_is(pl, "unmarkedPowerList")
+ s <- summary(pl)
+ expect_is(s, "data.frame")
+
+ pdf(NULL)
+ pl_plot <- plot(pl)
+ expect_is(pl_plot,"list")
+ dev.off()
+
+ # generate list
+ scenarios <- expand.grid(M=c(50,100), J=c(2,3))
+ pl <- unmarkedPowerList(template_model, effect_sizes, design=scenarios, nsim=10)
+ expect_is(pl, "unmarkedPowerList")
+
+ # With random effect
+ set.seed(123)
+ rguide <- list(group=factor(levels=letters[1:20]))
+ rform <- list(state=~x+(1|group), det=~1)
+ rcf <- list(state=c(intercept=0, x=0.5, group=0.7), det=c(intercept=0))
+ umfr <- simulate("occu", formulas=rform, design=design, coefs=rcf, guide=rguide)
+ fm <- occu(~1~x+(1|group), umfr)
+ pa5 <- powerAnalysis(fm, rcf, nsim=10)
+ s <- summary(pa5)
+ expect_equal(nrow(s), 3)
+ expect_equal(s$Power[2], 1)
+ })
+})
+
+test_that("custom datasets can be passed to powerAnalysis",{
+ set.seed(123)
+ coefs <- list(state=c(intercept=0, elev=-0.3), det=c(intercept=0))
+ design <- list(M=300, J=8)
+ forms <- list(state=~elev, det=~1)
+ pco_umf <- simulate("pcount", formulas=forms, coefs=coefs, design=design, nsim=10)
+
+ # convert pcount to occu umf
+ conv_umf <- lapply(pco_umf, function(x){
+ y <- x@y
+ y[y > 0] <- 1
+ unmarkedFrameOccu(y=y, siteCovs=siteCovs(x),
+ obsCovs=obsCovs(x))
+ })
+
+ fit <- occu(~1~elev, conv_umf[[1]])
+
+ nul <- capture.output({
+
+ pa <- powerAnalysis(fit, coefs=coefs, datalist=conv_umf, nsim=10)
+ expect_equivalent(summary(pa)$Power[2], 0.9, tol=1e-4)
+
+ pa2 <- powerAnalysis(fit, coefs=coefs, nsim=10)
+ expect_equivalent(summary(pa2)$Power[2], 0.8, tol=1e-4)
+
+ })
+
+ expect_error(powerAnalysis(fit, coefs=coefs, datalist=pco_umf))
+ expect_error(powerAnalysis(fit, coefs=coefs, datalist=conv_umf, nsim=20))
+})
+
+test_that("powerAnalysis can be run in parallel",{
+ skip_on_cran()
+ skip_on_ci()
+ forms <- list(state=~elev, det=~1)
+ coefs <- list(state=c(intercept=0, elev=-0.4), det=c(intercept=0))
+ design <- list(M=50, J=3) # 300 sites, 8 occasions per site
+ occu_umf <- simulate("occu", formulas=forms, coefs=coefs, design=design)
+
+ template_model <- occu(~1~elev, occu_umf)
+ nul <- capture.output(expect_error(powerAnalysis(template_model)))
+
+ effect_sizes <- list(state=c(intercept=0, elev=-0.4), det=c(intercept=0))
+ set.seed(123)
+ pa <- powerAnalysis(template_model, coefs=effect_sizes, alpha=0.05, nsim=3,
+ parallel=TRUE)
+ expect_is(pa, "unmarkedPower")
+
+
+})
diff --git a/tests/testthat/test_predict.R b/tests/testthat/test_predict.R
new file mode 100644
index 0000000..e92add1
--- /dev/null
+++ b/tests/testthat/test_predict.R
@@ -0,0 +1,140 @@
+context("predict-related functions")
+
+skip_on_cran()
+
+set.seed(123)
+cf <- list(state=c(intercept=0, elev=0.4, groupB=-0.5, groupC=0.6),
+ det=c(intercept=0))
+des <- list(M=100, J=5)
+guide <- list(group=factor(levels=c("A","B","C")))
+forms <- list(state=~elev+group, det=~1)
+
+umf <- simulate("occu", design=des, formulas=forms, coefs=cf, guide=guide)
+mod <- occu(~1~elev+group, umf)
+
+test_that("clean_up_covs works with dynamic model data",{
+
+ # Dynamic data
+ y <- matrix(c(
+ 3, 2, 1, 4,
+ 3, 4, 2, 1,
+ 0, 1, 2, 3
+ ), 3, 4, byrow=TRUE)
+ siteCovs <- data.frame(sc1 = 1:3)
+ obsCovs <- data.frame(oc1 = 1:12)
+ ysc <- data.frame(ysc1 = 1:6, ysc2=factor(rep(c("a","b"), 3)))
+ #ysc <- data.frame(ysc1 = 1:6, ysc2=factor(rep(c("a","b"), each=3)))
+ umf <- unmarkedFramePCO(y = y, siteCovs = siteCovs, obsCovs = obsCovs,
+ yearlySiteCovs=ysc, numPrimary=2)
+
+ dr <- unmarked:::clean_up_covs(umf, drop_final=TRUE)
+ expect_equal(dr$site_covs, data.frame(sc1=1:3))
+ expect_equal(dr$yearly_site_covs, data.frame(ysc1=c(1,NA,3,NA,5,NA),
+ ysc2=factor(c("a",NA,"a",NA,"a",NA)),
+ sc1=c(1,NA,2,NA,3,NA)))
+ expect_equivalent(dr$obs_covs, data.frame(oc1=1:12, ysc1=rep(1:6, each=2),
+ ysc2=factor(rep(c("a","b"), each=2)),
+ sc1=rep(1:3, each=4)))
+
+ no_drop <- unmarked:::clean_up_covs(umf)
+ expect_equivalent(no_drop$yearly_site_covs, data.frame(ysc1=1:6,
+ ysc2=factor(rep(c("a","b"),3)),
+ sc1=rep(1:3, each=2)))
+
+ umf <- unmarkedFramePCO(y=y, numPrimary=2)
+
+ cc <- unmarked:::clean_up_covs(umf, drop_final=TRUE)
+ expect_equivalent(cc$obs_covs,
+ data.frame(.dummy3=rep(1,12), .dummy2=rep(1,12), .dummy1=rep(1,12)))
+})
+
+test_that("clean_up_covs works with single-season models",{
+ y <- matrix(c(0,1,0,0,1,1), nrow=3)
+ umf <- unmarkedFrameOccu(y=y, siteCovs=data.frame(sc1=1:3),
+ obsCovs=data.frame(oc1=1:6))
+ cc <- unmarked:::clean_up_covs(umf)
+ expect_equal(names(cc), c("site_covs","obs_covs"))
+ expect_equivalent(cc$site_covs, data.frame(sc1=1:3))
+ expect_equivalent(cc$obs_covs, data.frame(oc1=1:6, sc1=rep(1:3, each=2)))
+ cc2 <- unmarked:::clean_up_covs(umf, drop_final=TRUE)
+ expect_equal(cc, cc2)
+})
+
+test_that("clean_up_covs works with models with no obs covs",{
+ # single season
+ ltUMF <- with(linetran, {
+ unmarkedFrameDS(y = cbind(dc1, dc2, dc3, dc4),
+ siteCovs = data.frame(Length, area, habitat),
+ dist.breaks = c(0, 5, 10, 15, 20),
+ tlength = linetran$Length * 1000, survey = "line", unitsIn = "m")
+ })
+ ltUMF
+
+ cc <- unmarked:::clean_up_covs(ltUMF)
+ expect_equal(names(cc), c("site_covs", "obs_covs"))
+ expect_equal(dim(cc$obs_covs), c(12,4))
+})
+
+test_that("clean_up_covs works with models where length(y) != length(p)",{
+ # double observer, etc
+ nSites <- 3
+ lambda <- 10
+ p1 <- 0.5
+ p2 <- 0.3
+ cp <- c(p1*(1-p2), p2*(1-p1), p1*p2)
+ N <- rpois(nSites, lambda)
+ y <- matrix(NA, nSites, 3)
+ for(i in 1:nSites) {
+ y[i,] <- rmultinom(1, N[i], c(cp, 1-sum(cp)))[1:3]
+ }
+
+ observer <- matrix(c('A','B'), nSites, 2, byrow=TRUE)
+ expect_warning(umf <- unmarkedFrameMPois(y=y,
+ siteCovs <- data.frame(sc1=1:3),
+ obsCovs=list(observer=observer),
+ type="double"))
+
+ cc <- unmarked:::clean_up_covs(umf)
+ expect_equivalent(cc$site_covs, data.frame(sc=1:3))
+ expect_equivalent(cc$obs_covs, data.frame(observer=factor(c(rep(c("A","B"), 3))),
+ sc1=rep(1:3, each=2)))
+
+})
+
+test_that("predicting from raster works",{
+
+ skip_if(!require(raster), "raster package unavailable")
+
+ set.seed(123)
+ # Create rasters
+ # Elevation
+ r_elev <- data.frame(x=rep(1:10, 10), y=rep(1:10, each=10), z=rnorm(100))
+ r_elev <- raster::rasterFromXYZ(r_elev)
+
+ #Group
+ r_group <- data.frame(x=rep(1:10, 10), y=rep(1:10, each=10),
+ z=sample(1:length(levels(umf@siteCovs$group)), 100, replace=T))
+ # Convert to 'factor' raster
+ r_group <- raster::as.factor(raster::rasterFromXYZ(r_group))
+ r_group@data@attributes <- data.frame(ID=raster::levels(r_group)[[1]], group=levels(umf@siteCovs$group))
+
+ # Stack
+ nd_raster <- raster::stack(r_elev, r_group)
+ names(nd_raster) <- c("elev", "group")
+ raster::crs(nd_raster) <- 32616
+
+ pr <- predict(mod, 'state', newdata=nd_raster)
+ expect_is(pr, 'RasterStack')
+ expect_equal(names(pr), c("Predicted","SE","lower","upper"))
+ expect_equal(pr[1,1][1], 0.3675313, tol=1e-5)
+ expect_equal(crs(pr), crs(nd_raster))
+
+ #append data
+ pr <- predict(mod, 'state', newdata=nd_raster, appendData=TRUE)
+ expect_is(pr, 'RasterStack')
+ expect_equal(names(pr)[5:6], c("elev","group"))
+
+ # Missing levels are handled
+ nd_2 <- nd_raster[[1]]
+ expect_error(predict(mod, 'state', newdata=nd_2))
+})
diff --git a/tests/testthat/test_ranef_predict.R b/tests/testthat/test_ranef_predict.R
new file mode 100644
index 0000000..251ed29
--- /dev/null
+++ b/tests/testthat/test_ranef_predict.R
@@ -0,0 +1,89 @@
+context("ranef predict method")
+skip_on_cran()
+
+test_that("ranef predict method works",{
+ #Single-season model
+ set.seed(4564)
+ R <- 10
+ J <- 5
+ N <- rpois(R, 3)
+ y <- matrix(NA, R, J)
+ y[] <- rbinom(R*J, N, 0.5)
+ y[1,] <- NA
+ y[2,1] <- NA
+ K <- 15
+
+ umf <- unmarkedFramePCount(y=y)
+ fm <- expect_warning(pcount(~1 ~1, umf, K=K))
+
+ re <- expect_warning(ranef(fm))
+
+ set.seed(123)
+ ps <- posteriorSamples(re, nsim=10)
+ expect_is(ps, "unmarkedPostSamples")
+
+ sh <- capture.output(show(ps))
+ expect_equal(sh[1], "Posterior samples from unmarked model")
+
+ #One is dropped bc of NA
+ expect_equivalent(dim(ps@samples), c(9,1,10))
+
+ # Brackets
+ expect_equal(ps[1,1,1], ps@samples[1,1,1])
+
+ # Method for unmarkedFit objects
+ set.seed(123)
+ ps2 <- expect_warning(posteriorSamples(fm, nsim=10))
+ expect_equal(ps, ps2)
+
+ # Custom function
+ set.seed(123)
+ myfunc <- function(x){
+ c(gr1=mean(x[1:4]), gr2=mean(x[5:9]))
+ }
+
+ pr <- predict(re, fun=myfunc, nsim=10)
+ expect_equivalent(dim(pr), c(2,10))
+ expect_equal(rownames(pr), c("gr1","gr2"))
+ expect_equivalent(as.numeric(pr[1,1:3]), c(7.0,5.0,4.75))
+
+ #Dynamic model
+ set.seed(7)
+ M <- 10
+ J <- 3
+ T <- 5
+ lambda <- 5
+ gamma <- 0.4
+ omega <- 0.6
+ p <- 0.5
+ N <- matrix(NA, M, T)
+ y <- array(NA, c(M, J, T))
+ S <- G <- matrix(NA, M, T-1)
+ N[,1] <- rpois(M, lambda)
+ y[,,1] <- rbinom(M*J, N[,1], p)
+ for(t in 1:(T-1)) {
+ S[,t] <- rbinom(M, N[,t], omega)
+ G[,t] <- rpois(M, gamma)
+ N[,t+1] <- S[,t] + G[,t]
+ y[,,t+1] <- rbinom(M*J, N[,t+1], p)
+ }
+
+ # Prepare data
+ umf <- unmarkedFramePCO(y = matrix(y, M), numPrimary=T)
+
+ # Fit model and backtransform
+ m1 <- pcountOpen(~1, ~1, ~1, ~1, umf, K=20)
+ re1 <- ranef(m1)
+
+ ps <- posteriorSamples(re1, nsim=10)
+ expect_equivalent(dim(ps@samples), c(10,5,10))
+ expect_equivalent(ps@samples[1,,1],c(7,4,3,1,1))
+
+ myfunc <- function(x){
+ apply(x, 2, function(x) c(mean(x[1:4]), mean(x[5:9])))
+ }
+
+ pr <- predict(re1, fun=myfunc, nsim=10)
+ expect_equivalent(dim(pr), c(2,5,10))
+ expect_equivalent(pr[1,1:3,1], c(3.5,2.5,1.5))
+})
diff --git a/tests/testthat/test_simulate.R b/tests/testthat/test_simulate.R
new file mode 100644
index 0000000..be8a356
--- /dev/null
+++ b/tests/testthat/test_simulate.R
@@ -0,0 +1,199 @@
+context("simulate method")
+skip_on_cran()
+
+test_that("simulate can generate new datasets from scratch",{
+
+ set.seed(123)
+ forms <- list(state=~elev, det=~1)
+ design <- list(M=300, J=5)
+
+ # Should write a better handler for this situation
+ bad_forms <- list(occu=~elev, det=~1)
+ expect_error(simulate("occu", formulas=bad_forms, design=design))
+
+ # When no coefficients list provided
+ nul <- capture_output(expect_error(simulate("occu", formulas=forms, design=design)))
+
+ cf <- list(state=c(intercept=0, elev=-0.4), det=c(intercept=0))
+ umf <- simulate("occu", formulas=forms, design=design, coefs=cf)
+ expect_is(umf, "unmarkedFrame")
+ expect_equivalent(dim(umf@y), c(300,5))
+ expect_equal(names(umf@siteCovs), "elev")
+
+ fm <- occu(~1~elev, umf)
+ expect_equivalent(coef(fm), c(-0.06492,-0.43037,0.0527354), tol=1e-4)
+
+ # With guide
+ set.seed(123)
+ guide <- list(elev=list(dist=rnorm, mean=2, sd=0.5),
+ landcover=factor(levels=c("forest","grass")))
+ forms$state <- ~elev+landcover
+ cf$state <- c(intercept=0, elev=-0.4, landcovergrass=0.5)
+ umf2 <- simulate("occu", formulas=forms, design=design, coefs=cf, guide=guide)
+ expect_equal(names(umf2@siteCovs), c("elev","landcover"))
+ expect_true(is.factor(umf2@siteCovs$landcover))
+ expect_equivalent(mean(umf2@siteCovs$elev), 2.01722, tol=1e-5)
+
+ # With random effect
+ set.seed(123)
+ rguide <- list(group=factor(levels=letters[1:20]))
+ rform <- list(state=~(1|group), det=~1)
+ rcf <- list(state=c(intercept=0, group=0.7), det=c(intercept=0))
+ umfr <- simulate("occu", formulas=rform, design=design, coefs=rcf, guide=rguide)
+ fm <- occu(~1~(1|group), umfr)
+ expect_equal(sigma(fm)$sigma, 0.6903913, tol=1e-5)
+
+ # pcount
+ set.seed(123)
+ cf$alpha <- c(alpha=0.5)
+ umf3 <- simulate("pcount", formulas=forms, design=design, coefs=cf, guide=guide,
+ mixture="NB", K=10)
+ fm2 <- pcount(~1~elev, umf3, mixture="NB", K=10)
+ expect_equivalent(coef(fm2), c(-0.1775, -0.2528, -0.083, 0.5293), tol=1e-3)
+
+ # distsamp
+ set.seed(123)
+ cf$alpha <- NULL
+ cf$det[1] <- log(30)
+ cf$state <- c(intercept=2, elev=0.5)
+ forms$state <- ~elev
+ umf4 <- simulate("distsamp", formulas=forms, design=design, coefs=cf,
+ dist.breaks=c(0,10,20,30,40,50), survey='point', unitsIn='m')
+ fm <- distsamp(~1~elev, umf4)
+ expect_equivalent(coef(fm), c(1.9389,0.5344,3.4521), tol=1e-4)
+
+ # Mpois
+ set.seed(123)
+ cf$dist[1] <- 0
+ cf$state <- c(intercept=1, elev=0.5)
+ umf5 <- simulate("multinomPois", formulas=forms, design=design, coefs=cf,
+ guide=guide)
+ fm <- multinomPois(~1~elev, umf5)
+ expect_equivalent(coef(fm), c(0.98163,0.50477,3.3633), tol=1e-3)
+
+ #colext
+ set.seed(123)
+ forms_colext <- list(psi=~elev, col=~1, ext=~1, det=~1)
+ cf_colext <- list(psi=c(intercept=0, elev=0.5), col=c(intercept=0),
+ ext=c(intercept=0), det=c(intercept=0))
+ design_colext <- list(M=300,T=3,J=5)
+ umf6 <- simulate("colext", formulas=forms_colext, design=design_colext,
+ coefs=cf_colext)
+ fm <- colext(~elev, ~1, ~1, ~1, umf6)
+ expect_equivalent(coef(fm), c(0.1598,0.6468,-0.0097,-0.01665,-0.0104),
+ tol=1e-3)
+
+ #occuTTD
+ set.seed(123)
+ cf_ttd <- cf_colext
+ cf_ttd$det <- c(intercept=log(0.5))
+ umf7 <- simulate("occuTTD", formulas=forms_colext, design=design_colext,
+ coefs=cf_ttd, surveyLength=3)
+ fm <- occuTTD(~elev, ~1, ~1, ~1, umf7)
+ expect_equivalent(coef(fm), c(-0.0434,0.5743,-0.0187,0.115,-0.672),
+ tol=1e-3)
+
+ #gdistsamp
+ set.seed(123)
+ cf_gds <- list(det=c(intercept=log(30)), lambda=c(intercept=2, elev=0.5),
+ phi=c(intercept=0))
+ forms_gds <- list(lambda=~elev, phi=~1, det=~1)
+ umf8 <- simulate("gdistsamp", formulas=forms_gds, design=design_colext, coefs=cf_gds,
+ dist.breaks=c(0,10,20,30,40,50), survey='line',
+ tlength=rep(100,300), unitsIn='m')
+ fm <- gdistsamp(~elev,~1,~1, umf8)
+ expect_equivalent(coef(fm), c(1.98053,0.5268,-0.05892,3.4113), tol=1e-3)
+
+ #gmultmix
+ set.seed(123)
+ cf_gmm <- list(det=c(intercept=0), lambda=c(intercept=2, elev=0.5),
+ phi=c(intercept=0))
+ forms_gmm <- list(lambda=~elev, phi=~1, det=~1)
+ umf9 <- simulate("gmultmix", formulas=forms_gmm, design=design_colext, coefs=cf_gmm,
+ type='removal')
+ fm <- gmultmix(~elev,~1,~1, umf9)
+ expect_equivalent(coef(fm), c(1.9529,0.5321,0.0529,-0.0373), tol=1e-4)
+
+ #gpcount
+ set.seed(123)
+ umf10 <- simulate("gpcount", formulas=forms_gmm, design=list(M=50,J=5,T=3), coefs=cf_gmm,
+ K=10)
+ fm <- gpcount(~elev,~1,~1, umf10, K=10)
+ expect_equivalent(coef(fm), c(1.4994,0.4024,1.1351,0.0978), tol=1e-4)
+
+ #pcountOpen
+ set.seed(123)
+ cf_pco <- list(lambda=c(intercept=2, elev=0.5), det=c(intercept=0),
+ gamma=c(intercept=0), omega=c(intercept=0))
+ design_pco <- list(M=100,J=5,T=3)
+ forms_pco <- list(lambda=~elev, det=~1, gamma=~1, omega=~1)
+ umf11 <- simulate("pcountOpen", formulas=forms_pco, design=design_pco,
+ coefs=cf_pco, K=15)
+ fm <- pcountOpen(~elev, ~1, ~1, ~1, data=umf11, K=15)
+ expect_equivalent(coef(fm), c(1.7703,0.0427,-0.2768,0.1288,0.0245), tol=1e-4)
+
+ #multmixOpen
+ set.seed(123)
+ umf12 <- simulate("multmixOpen", formulas=forms_pco, design=design_pco,
+ coefs=cf_pco, K=15, type='removal')
+ expect_is(umf12, "unmarkedFrameMMO")
+ #fm <- multmixOpen(~elev,~1,~1,~1, data=umf12, K=15)
+ #expect_equivalent(coef(fm), c(1.8128,0.0171,-0.4220,0.1921,-0.1122),tol=1e-4)
+
+ #distsampOpen
+ set.seed(123)
+ cf_dso <- cf_pco
+ cf_pco$det <- c(intercept=log(30))
+ design_dso <- list(M=200, J=5, T=5)
+ umf13 <- simulate("distsampOpen", formulas=forms_pco, design=design_dso,
+ coefs=cf_dso, K=20, unitsIn='m',
+ survey='point', dist.breaks=c(0,10,20,30,40,50))
+ expect_is(umf13, "unmarkedFrameDSO")
+ #fm <- distsampOpen(~elev,~1,~1,~1, data=umf13, K=20)
+ #expect_equivalent(coef(fm), c(1.70195,0.00067,-0.1141,0.09816,3.4179), tol=1e-4)
+
+ # occuMulti
+ set.seed(123)
+ occFormulas <- c('~occ_cov1','~occ_cov2','~occ_cov3','~1','~1','~1','~1')
+ detFormulas <- c('~1','~1','~1')
+ beta <- c(0.5,0.2,0.4,0.5,-0.1,-0.3,0.2,0.1,-1,0.1)
+ p_true <- c(0.6,0.7,0.5)
+
+ cf <- list(state=beta, det=log(p_true/(1-p_true)))
+ names(cf$state) <- c("[sp1] intercept", "[sp1] occ_cov1",
+ "[sp2] intercept", "[sp2] occ_cov2",
+ "[sp3] intercept", "[sp3] occ_cov3",
+ "[sp1:sp2] intercept","[sp1:sp3] intercept",
+ "[sp2:sp3] intercept","[sp1:sp2:sp3] intercept")
+ names(cf$det) <- c("[sp1] intercept", "[sp2] intercept", "[sp3] intercept")
+
+ umf14 <- simulate("occuMulti", formulas=list(state=occFormulas, det=detFormulas),
+ design=list(M=200, J=5), coefs=cf)
+ fm <- occuMulti(detFormulas, occFormulas, umf14)
+ expect_equivalent(coef(fm, 'det'), c(0.3650,0.8762,-0.04653), tol=1e-4)
+
+ # occuMS
+ set.seed(123)
+ bstate <- c(-0.5, 1, -0.6, -0.7)
+ bdet <- c(-0.4, 0, -1.09, -0.84)
+ detformulas <- c('~V1','~1','~1')
+ stateformulas <- c('~V1','~V2')
+ forms <- list(det=detformulas, state=stateformulas)
+ cf <- list(state=bstate, det=bdet)
+ expect_warning(umf15 <- simulate("occuMS", formulas=forms, coefs=cf, design=list(M=500, J=5, T=1)))
+ fm <- occuMS(forms$det, forms$state, data=umf15, parameterization="multinomial")
+ expect_equivalent(coef(fm, 'state'), c(-0.657,1.033,-0.633,-0.582), tol=1e-3)
+
+ # gdistremoval
+ set.seed(123)
+ formulas <- list(lambda=~sc1, rem=~oc1, dist=~1, phi=~1)
+ cf <- list(lambda=c(intercept=log(5), sc1=0.7), dist=c(intercept=log(50)),
+ rem=c(intercept=log(0.2/(1-0.2)), oc1=0.4))
+ design <- list(M=500, Jdist=4, Jrem=5, T=1)
+ umf16 <- simulate("gdistremoval", design=design, formulas=formulas, coefs=cf,
+ dist.breaks=c(0,25,50,75,100), unitsIn='m', output='abund',K=15)
+ fm <- gdistremoval(~sc1, removalformula=~oc1, distanceformula=~1,
+ data=umf16,K=15)
+ expect_is(fm, "unmarkedFitGDS")
+
+})
diff --git a/tests/testthat/test_unmarkedFrame.R b/tests/testthat/test_unmarkedFrame.R
new file mode 100644
index 0000000..b5c6044
--- /dev/null
+++ b/tests/testthat/test_unmarkedFrame.R
@@ -0,0 +1,217 @@
+context("unmarkedFrames")
+
+test_that("unmarkedFrame can be constructed",{
+ M <- 10
+ J <- 3
+ y <- matrix(rbinom(J * M, 1, 0.5), M, J)
+ siteCovs <- data.frame(a = rnorm(M), b = factor(gl(2,5)))
+ umf <- unmarkedFrame(y = y, siteCovs = siteCovs)
+ expect_is(umf, "unmarkedFrame")
+
+ out <- capture.output(umf)
+ expect_equal(out[1], "Data frame representation of unmarkedFrame object.")
+ s <- capture.output(summary(umf))
+ expect_equal(s[1], "unmarkedFrame Object")
+
+ # convert to data frame
+ df <- as(umf, "data.frame")
+ expect_is(df, "data.frame")
+})
+
+test_that("obsToY works", {
+ y <- matrix(c(
+ 1, 0, 0,
+ 2, 1, 0,
+ 1, 0, 1,
+ 2, 1, 2,
+ 1, 0, 3,
+ 1, 1, 1), nrow=6, ncol=3, byrow=TRUE)
+ oc <- matrix(c(
+ 1, 0,
+ 2, 1,
+ 1, 1,
+ NA, 0,
+ 1, NA,
+ NA, NA), nrow=6, ncol=2, byrow=TRUE)
+ umf <- unmarkedFrameMPois(y = y, obsCovs = list(x=oc), type="double")
+ o2y <- obsToY(umf)
+
+ expect_equal(o2y, matrix(1, 2, 3))
+ oc.na <- is.na(oc)
+ mult <- oc.na %*% o2y
+ expect_is(mult, "matrix")
+})
+
+test_that("Characters are converted to factors when umf is constructed",{
+ n <- 50 # number of sites
+ T <- 4 # number of primary periods
+ J <- 3 # number of secondary periods
+
+ y <- matrix(0:1, n, J*T)
+
+ #Site covs
+ sc <- data.frame(x=rnorm(n), y=sample(letters, 50, replace=TRUE))
+ expect_equal(sapply(sc, class), c(x="numeric", y="character"))
+ expect_warning(umf <- unmarkedFrame(y, siteCovs=sc))
+
+ umf <- expect_warning(unmarkedFrame(y, siteCovs=sc))
+ expect_equal(sapply(siteCovs(umf), class), c(x="numeric", y="factor"))
+
+ #Already factor
+ sc2 <- data.frame(x=rnorm(n), y=factor(sample(letters, 50, replace=TRUE)))
+ umf <- unmarkedFrame(y, siteCovs=sc2)
+ expect_equal(sapply(siteCovs(umf), class), c(x="numeric", y="factor"))
+
+ #Obs covs
+ oc <- data.frame(x=rnorm(n*J*T), y=sample(letters, n*J*T, replace=TRUE))
+ expect_equal(sapply(oc, class), c(x="numeric", y="character"))
+
+ expect_warning(umf <- unmarkedFrame(y, obsCovs=oc))
+
+ umf <- expect_warning(unmarkedFrame(y, obsCovs=oc))
+ expect_equal(sapply(obsCovs(umf), class), c(x="numeric", y="factor"))
+ expect_true(is.null(siteCovs(umf)))
+
+ #as list
+ oc <- list(x=matrix(oc$x, nrow=n), y=matrix(oc$y, nrow=n))
+ umf <- expect_warning(unmarkedFrameOccu(y, obsCovs=oc))
+ expect_equal(sapply(obsCovs(umf), class), c(x="numeric", y="factor"))
+ expect_true(is.null(siteCovs(umf)))
+
+ #Check conversion
+ df <- as(umf, "data.frame")
+ expect_equivalent(dim(df), c(50,36))
+
+ #Yearly site covs
+ ysc <- list(x=matrix(rnorm(n*T), nrow=n),
+ y=matrix(sample(letters, n*T, replace=TRUE), nrow=n))
+ umf <- expect_warning(unmarkedMultFrame(y, yearlySiteCovs=ysc, numPrimary=T))
+ expect_equal(sapply(yearlySiteCovs(umf), class), c(x="numeric", y="factor"))
+ expect_true(is.null(siteCovs(umf)))
+
+ #All
+
+ umf <- expect_warning(unmarkedMultFrame(y, yearlySiteCovs=ysc, obsCovs=oc,
+ siteCovs=sc, numPrimary=T))
+ expect_equal(sapply(yearlySiteCovs(umf), class), c(x="numeric", y="factor"))
+ expect_equal(sapply(obsCovs(umf), class), c(x="numeric", y="factor"))
+ expect_equal(sapply(obsCovs(umf), class), c(x="numeric", y="factor"))
+
+ df <- as(umf, "data.frame")
+ expect_equivalent(dim(df), c(50,46))
+})
+
+test_that("unmarkedMultFrame can be constructed",{
+ y <- matrix(1:27, 3)
+ sc <- data.frame(x1 = 1:3)
+ ysc <- list(x2 = matrix(1:9, 3))
+ oc <- list(x3 = matrix(1:27, 3))
+
+ umf1 <- unmarkedMultFrame(
+ y = y,
+ siteCovs = sc,
+ yearlySiteCovs = ysc,
+ obsCovs = oc,
+ numPrimary = 3)
+ expect_is(umf1, "unmarkedMultFrame")
+ out <- capture.output(umf1)
+ expect_equal(out[1], "Data frame representation of unmarkedFrame object.")
+
+ s <- capture.output(summary(umf1))
+ expect_equal(s[6], "Number of primary survey periods: 3 ")
+})
+
+test_that("unmarkedMultFrame subset works",{
+ y <- matrix(1:27, 3)
+ sc <- data.frame(x1 = 1:3)
+ ysc <- list(x2 = matrix(1:9, 3))
+ oc <- list(x3 = matrix(1:27, 3))
+
+ umf1 <- unmarkedMultFrame(
+ y = y,
+ siteCovs = sc,
+ yearlySiteCovs = ysc,
+ obsCovs = oc,
+ numPrimary = 3)
+
+ dat <- as(umf1, "data.frame")
+
+ umf1.obs1 <- umf1[,1]
+ expect_equal(umf1.obs1@y, y[,1:3])
+ expect_equal(umf1.obs1@siteCovs, sc)
+ expect_equivalent(unlist(umf1.obs1@obsCovs),
+ as.numeric(t(oc[[1]][,1:3])))
+ expect_equivalent(unlist(umf1.obs1@yearlySiteCovs), ysc[[1]][,1])
+ expect_equal(umf1.obs1@numPrimary, 1)
+
+ umf1.obs1and3 <- umf1[,c(1,3)]
+
+ umf1.site1 <- umf1[1,]
+ expect_equal(umf1.site1@y, y[1,, drop=FALSE])
+ expect_equal(umf1.site1@siteCovs, sc[1,, drop=FALSE])
+ expect_equivalent(unlist(umf1.site1@obsCovs), oc$x3[1,])
+ expect_equivalent(unlist(umf1.site1@yearlySiteCovs),
+ ysc$x2[1,, drop=FALSE])
+ expect_equal(umf1.site1@numPrimary, 3)
+
+ umf1.sites1and3 <- umf1[c(1,3),]
+})
+
+test_that("unmmarkedMultFrame handles unequal secondary periods",{
+ nsites <- 6
+ nyr <- 4
+ nrep <- 2
+ y <- matrix(c(
+ 1,0, 1,1, 0,0, 0,0,
+ 1,1, 0,0, 0,0, 0,0,
+ 0,0, 0,0, 0,0, 0,0,
+ 0,0, 1,1, 0,0, 0,0,
+ 1,1, 1,0, 0,1, 0,0,
+ 0,0, 0,0, 0,0, 1,1), nrow=nsites, ncol=nyr*nrep, byrow=TRUE)
+
+ umf1 <- unmarkedMultFrame(y=y, numPrimary=4)
+ expect_true(inherits(umf1, "unmarkedMultFrame"))
+
+ expect_error(unmarkedMultFrame(y=y[,-1], numPrimary=4))
+})
+
+test_that("yearlySiteCovs processing works",{
+
+ n <- 50 # number of sites
+ T <- 4 # number of primary periods
+ J <- 3 # number of secondary periods
+
+ site <- 1:50
+ years <- data.frame(matrix(rep(2010:2013, each=n), n, T))
+ years <- data.frame(lapply(years, as.factor))
+ dummy <- matrix(rep(c('a','b','c','d'),n),nrow=n,byrow=T)
+ occasions <- data.frame(matrix(rep(1:(J*T), each=n), n, J*T))
+ y <- matrix(0:1, n, J*T)
+
+ umf <- expect_warning(unmarkedMultFrame(y=y,
+ siteCovs = data.frame(site=site),
+ obsCovs=list(occasion=occasions),
+ yearlySiteCovs=list(year=years,dummy=dummy),
+ numPrimary=T))
+
+ as_df <- as(umf,'data.frame')
+
+ expect_equivalent(dim(as_df),c(50,33))
+ expect_true(all(names(as_df)[13:22] == c('site','year.1','year.2','year.3',
+ 'year.4','dummy.1','dummy.2','dummy.3',
+ 'dummy.4','occasion.1')))
+ expect_true(all(as_df$year.1==2010))
+ expect_true(all(as_df$dummy.1=='a'))
+
+
+ umf2 <- unmarkedMultFrame(y=y,
+ siteCovs = data.frame(site=site),
+ obsCovs=list(occasion=occasions),
+ numPrimary=T)
+
+ as_df2 <- as(umf2,'data.frame')
+
+ expect_equivalent(dim(as_df2),c(50,25))
+})
+
+
diff --git a/tests/testthat/test_utils.R b/tests/testthat/test_utils.R
new file mode 100644
index 0000000..bf868ed
--- /dev/null
+++ b/tests/testthat/test_utils.R
@@ -0,0 +1,32 @@
+context("utility functions")
+
+test_that("invertHessian function works",{
+
+ a <- 4; b <- 7; c <- 2; d <- 6
+ mat <- matrix(c(a,b,c,d), nrow=2, byrow=T)
+ mat_det <- a*d-b*c
+ inv_mat <- 1/mat_det * matrix(c(d, -b, -c, a), nrow=2, byrow=T)
+
+ fake_opt <- list(hessian=mat)
+
+ #Successful inversion
+ expect_equivalent(invertHessian(fake_opt, nrow(mat), TRUE),
+ inv_mat)
+
+ #When se=F
+ expect_equivalent(invertHessian(fake_opt, nrow(mat), FALSE),
+ matrix(rep(NA,4), nrow=2))
+
+ #When matrix is not invertible
+ bad_opt <- list(hessian=matrix(c(1, -2, -3, 6), nrow=2, byrow=T))
+ expect_error(solve(bad_opt$hessian))
+
+ #Should generate warning
+ expect_warning(invertHessian(bad_opt, nrow(bad_opt$hessian), TRUE))
+
+
+ #Should result in matrix of NAs
+ expect_equivalent(invertHessian(bad_opt, nrow(bad_opt$hessian), FALSE),
+ matrix(rep(NA,4), nrow=2))
+})
+
diff --git a/inst/unitTests/runit.vif.R b/tests/testthat/test_vif.R
index 968f30e..5476653 100644
--- a/inst/unitTests/runit.vif.R
+++ b/tests/testthat/test_vif.R
@@ -1,4 +1,7 @@
-test.vif.occu <- function() {
+context("vif method")
+skip_on_cran()
+
+test_that("vif works with occu models",{
set.seed(123)
data(frogs)
@@ -10,42 +13,42 @@ test.vif.occu <- function() {
obsCovs(pferUMF) <- data.frame(
obsvar1 = rnorm(numSites(pferUMF) * obsNum(pferUMF)),
obsvar2=obsvar2,obsvar3=obsvar3)
-
+
fm <- occu(~ obsvar1+obsvar2+obsvar3 ~ 1, pferUMF)
-
+
#No type provided
- checkException(vif_vals <- vif(fm))
+ expect_error(vif_vals <- vif(fm))
#Wrong type provided
- checkException(vif_vals <- vif(fm, type='fake'))
+ expect_error(vif_vals <- vif(fm, type='fake'))
#Not enough covs
- checkException(vif_vals <- vif(fm, type='state'))
+ expect_error(vif_vals <- vif(fm, type='state'))
#Get values for det
vif_vals <- vif(fm, type='det')
- checkEqualsNumeric(vif_vals, c(1.002240,4.49552,4.490039),tol=1e-4)
- checkEquals(names(vif_vals),c('obsvar1','obsvar2','obsvar3'))
+ expect_equivalent(vif_vals, c(1.002240,4.49552,4.490039),tol=1e-4)
+ expect_equal(names(vif_vals),c('obsvar1','obsvar2','obsvar3'))
#Compare to typical way of calculating
set.seed(123)
vt <- lm(obsvar2~obsvar1+obsvar3,data=obsCovs(pferUMF))
vt_2 <- 1/(1-summary(vt)$r.squared)
- checkEqualsNumeric(vif_vals[2],vt_2,tol=0.1)
+ expect_equivalent(vif_vals[2],vt_2,tol=0.1)
-}
+})
+
+test_that("vif works with multinomPois models",{
-test.vif.multinomPois <- function(){
-
set.seed(123)
data(ovendata)
ovenFrame <- unmarkedFrameMPois(ovendata.list$data,
siteCovs=as.data.frame(scale(ovendata.list$covariates[,-1])),
type = "removal")
fm1 <- multinomPois(~ 1 ~ ufc + trba, ovenFrame)
-
+
vif_vals <- vif(fm1, type='state')
- checkEqualsNumeric(vif_vals, c(1.285886,1.285886), tol=1e-4)
+ expect_equivalent(vif_vals, c(1.285886,1.285886), tol=1e-4)
-}
+})
diff --git a/vignettes/README.txt b/vignettes/README.txt
new file mode 100644
index 0000000..2949e94
--- /dev/null
+++ b/vignettes/README.txt
@@ -0,0 +1,13 @@
+# Several vignettes (colext, power) take too long for CRAN to run
+# Thus we have to pre-generate the results.
+# The raw files (without results yet) are .Rmd.orig files
+# These are ignored in package building
+# The final files (with results) are .Rmd - these are the files that actually build the vignettes
+# To generate an .Rmd from an .Rmd.orig (eg after updating relevant code)
+
+knitr::knit("colext.Rmd.orig", output="colext.Rmd")
+knitr::knit("powerAnalysis.Rmd.orig", output="powerAnalysis.Rmd")
+
+# This will run all the R code in the .Rmd.orig file and save the results
+# directly into the corresponding .Rmd file, which will then compile instantly on CRAN
+# Note that this will also create some figure png files which should not be deleted
diff --git a/vignettes/cap-recap.Rnw b/vignettes/cap-recap.Rmd
index 0e44dc3..0cc3149 100644
--- a/vignettes/cap-recap.Rnw
+++ b/vignettes/cap-recap.Rmd
@@ -1,59 +1,36 @@
-<<echo=false>>=
-options(width=70)
-options(continue=" ")
-library(tools)
-@
-
-\documentclass[a4paper]{article}
-\usepackage[OT1]{fontenc}
-\usepackage{Sweave}
-\usepackage[authoryear,round]{natbib}
-%\usepackage{fullpage}
-\usepackage[vmargin=1in,hmargin=1in]{geometry}
-\usepackage{amsmath}
-\bibliographystyle{ecology}
-
-\DefineVerbatimEnvironment{Sinput}{Verbatim} {xleftmargin=2em}
-\DefineVerbatimEnvironment{Soutput}{Verbatim}{xleftmargin=2em}
-\DefineVerbatimEnvironment{Scode}{Verbatim}{xleftmargin=2em}
-\fvset{listparameters={\setlength{\topsep}{0pt}}}
-\renewenvironment{Schunk}{\vspace{\topsep}}{\vspace{\topsep}}
-
-%%\VignetteIndexEntry{Capture-recapture}
-
-\title{Modeling variation in abundance using capture-recapture data}
-\author{Richard Chandler}
-\date{Feb 24, 2019}
-
-\begin{document}
-
-\maketitle
-
-\abstract{The ``{\tt un}'' in {\tt unmarked} is somewhat misleading
- because the package can be used to analyze data from marked
- animals. The three
- most common sampling methods that produce suitable data are removal
- sampling, double observer sampling, and capture-recapture
- methods. This document focuses on the analysis of capture-recapture
- data using a class of models known as multinomial $N$-mixture
- models \citep{royle_generalized_2004, dorazio_etal:2005}, which
- assume that capture-recapture data have been collected at a
- collection of sample locations (``sites''). Capture-recapture models
- can be fitted with
- constant parameters ($M_0$), time-specific parameters ($M_t$),
- and behavioral responses ($M_b$). In addition, spatial
- variation in abundance and capture probability can also be
- modeled using covariates. \texttt{unmarked} has two
- functions for fitting
- capture-recapture models: \texttt{multinomPois} and
- \texttt{gmultmix}. Both allow for user-defined functions to describe
- the capture process, and the latter allows for modeling of temporary
- emigration when data have been collected using the so-called robust
- design \citep{kendall_etal:1997,chandlerEA_2011}.
-}
-
-
-\section{Introduction}
+---
+title: Modeling variation in abundance using capture-recapture data
+author: Richard Chandler
+date: Feb 24, 2019
+bibliography: unmarked.bib
+csl: ecology.csl
+output:
+ rmarkdown::html_vignette:
+ fig_width: 5
+ fig_height: 3.5
+ number_sections: true
+ toc: true
+vignette: >
+ %\VignetteIndexEntry{Capture-recapture}
+ %\VignetteEngine{knitr::rmarkdown}
+ \usepackage[utf8]{inputenc}
+---
+
+```{r,echo=FALSE}
+options(rmarkdown.html_vignette.check_title = FALSE)
+```
+
+# Abstract
+
+The "un" in `unmarked` is somewhat misleading because the package can be used to analyze data from marked animals.
+The three most common sampling methods that produce suitable data are removal sampling, double observer sampling, and capture-recapture methods.
+This document focuses on the analysis of capture-recapture data using a class of models known as multinomial $N$-mixture models [@royle_generalized_2004; @dorazio_etal:2005], which assume that capture-recapture data have been collected at a collection of sample locations ("sites").
+Capture-recapture models can be fitted with constant parameters ($M_0$), time-specific parameters ($M_t$), and behavioral responses ($M_b$).
+In addition, spatial variation in abundance and capture probability can also be modeled using covariates.
+`unmarked` has two functions for fitting capture-recapture models: `multinomPois` and `gmultmix`.
+Both allow for user-defined functions to describe the capture process, and the latter allows for modeling of temporary emigration when data have been collected using the so-called robust design [@kendall_etal:1997; @chandlerEA_2011].
+
+# Introduction
In traditional capture-recapture models, $n$ individuals are captured
at a site during the course of $J$ sampling occasions. The encounter
@@ -66,44 +43,48 @@ Although traditional capture-recapture models are useful
for estimating population size when $p<1$, they do not allow one to model
variation in abundance, which is a central focus of much ecological
research.
-\citet{royle_generalized_2004} and \citet{dorazio_etal:2005} developed a framework for
+@royle_generalized_2004 and @dorazio_etal:2005 developed a framework for
modeling variation in both abundance and capture
probability when capture-recapture data are collected at a set of
$R$ sites. Site-specific abundance ($N_i; i=1,2,...,R$) is regarded
as latent variable following a discrete distribution such as the
Poisson or negative binomial. The encounter histories are then
tabulated at each site so that they can be regarded as an outcome of a
-multinomial distribution with cell probabilities {$\bf \pi$}
+multinomial distribution with cell probabilities $\bf \pi$
determined by a protocol-specific function of capture
probability. Assuming a Poisson
distribution, the model can be written as
+$$
\begin{gather}
N_i \sim \mbox{Poisson}(\lambda) \nonumber \\
{\bf y_i}|N_i \sim \mbox{Multinomial}(N_i, \pi(p))
\label{mod}
\end{gather}
+$$
In the above, $\lambda$ is the expected number of individuals at each
site. ${\bf y_i}$ is a vector containing the number of
individuals with encounter history $k; k=1,2,...K$ at site $i$. The
number of observable encounter histories $K$ depends on the sampling
protocol. For a capture-recapture study with 2 occasions, there are
-3 possible encounter histories $H \in (11, 10, 01)$. In Equation~\ref{mod},
+3 possible encounter histories $H \in (11, 10, 01)$. In Equation 1,
$\pi(p)$ is a function that that converts capture probability $p$ to
multinomial cell probabilities, \emph{i.e.}, the proportion
of individuals expected to have capture history $k$. For example, the
cell probabilities corresponding to the capture histories listed above
are
-\[
+
+$$
{\bf \pi}(p) = \{ p^2, p(1-p), (1-p)p \}.
-\]
+$$
+
The probability of not capturing an individual in this case ($H=00$)
is $(1-p)^2$.
Spatial variation in abundance can be modeled using covariates
with a log-link function
-\[
+$$
\log(\lambda_i) = \beta_0 + \beta_1 x_i
-\]
+$$
where $x_i$ is some site-specific covariate such as habitat type or
elevation. Multiple covariates can be considered and a more general
form of the above can be written as $\log(\lambda_i) =
@@ -111,95 +92,65 @@ form of the above can be written as $\log(\lambda_i) =
${\bf \beta}$ is a vector
of coefficients, possibly including an intercept.
Capture probability can be modeled using the logit-link in much the same way
-\[
+$$
\text{logit}(p_{ij}) = \alpha_0 + \alpha_1 v_{ij}
-\]
+$$
where $v_{ij}$ is some covariate specific to the site and
capture occasion. When $p$ is assumed to be constant, the model is
often referred to as model $M_0$. Alternatively, $p$ may be
occasion-specific
(model $M_t$) or may be influenced by animal behavior (model
-$M_b$). \citet{otis_etal:1978} and \citet{williams_etal:2002} are
+$M_b$). @otis_etal:1978 and @williams_etal:2002 are
comprehensive references.
-\section{Data}
-As previously mentioned, the data required by \texttt{unmarked} are an $R
-\times K$
-matrix in which each row is the vector of tabulated encounter
+# Data
+
+As previously mentioned, the data required by `unmarked` are an $R
+\times K$ matrix in which each row is the vector of tabulated encounter
histories for animals captured at some site. Capture-recapture data,
-however, is typically recorded in the format shown in
-Table~\ref{tab:raw}.
-
-\begin{table}[h]
- \footnotesize
- \begin{center}
- \caption{Capture-recapture data for 6 individuals sampled on 3
- occasions}
- \vspace{0.3cm}
- \begin{tabular}{lcc}
- \hline
- Animal ID & Site & Capture history \\
- \hline
- GB & A & 101 \\
- YR & A & 101 \\
- RO & A & 111 \\
- PP & A & 100 \\
- GY & B & 100 \\
- PR & B & 010 \\
- \hline
- \label{tab:raw}
- \end{tabular}
- \end{center}
-\end{table}
+however, is typically recorded in the format shown in Table 1.
+
+```{r, echo=FALSE}
+tab <- data.frame(
+ id = c("GB","YR","RO","PP","GY","PR"),
+ site = c(rep("A",4), "B", "B"),
+ cap = c("101","101","111","100","100","010")
+)
+names(tab) <- c("Animal ID", "Site", "Capture history")
+
+knitr::kable(tab, align="lcc",
+ caption="Table 1. Capture-recapture data for 6 individuals sampled on 3 occasions"
+)
+```
In the absence of individual covariates, the data in
-Table~\ref{tab:raw} can be converted to the requisite format as shown
-in Table~\ref{tab:format}. Notice that no captures were made in sites
+Table 1 can be converted to the requisite format as shown
+in Table 2. Notice that no captures were made in sites
C and D. It is important that such sites are retained in the analysis
in order to make inference about spatial variation in abundance.
-\begin{table}[h]
- \footnotesize
- \begin{center}
- \caption{Capture-recapture data from Table~\ref{tab:raw} in the
- format required by \texttt{unmarked}}
- \vspace{0.3cm}
- \begin{tabular}{lccccccc}
- \hline
- Site & \multicolumn{7}{c}{Encounter history} \\
- \cline{2-8}
- & 100 & 010 & 001 & 110 & 011 & 101 & 111 \\
- \hline
- A & 1 & 0 & 0 & 0 & 0 & 2 & 1 \\
- B & 1 & 1 & 0 & 0 & 0 & 0 & 0 \\
- C & 0 & 0 & 0 & 0 & 0 & 0 & 0 \\
- D & 0 & 0 & 0 & 0 & 0 & 0 & 0 \\
- \hline
- \label{tab:format}
- \end{tabular}
- \end{center}
-\end{table}
-
-
-
+```{r, echo=FALSE}
+tab2 <- data.frame(
+ Site=c("A","B","C","D"),
+ eh100=c(1,1,0,0), eh010=c(0,1,0,0), eh001=c(0,0,0,0),
+ eh110=c(0,0,0,0), eh011=c(0,0,0,0), eh101=c(2,0,0,0),
+ eh111=c(1,0,0,0))
+names(tab2) <- c("Site", "100","010","001","110","011","101","111")
+knitr::kable(tab2, align="lccccccc",
+ caption="Table 2. Capture-recapture data from Table 1 in the format required by unmarked")
+```
+# Closed Population Models
-
-\section{Closed Population Models}
-
-
-
-
-\subsection{Models $M_0$, $M_t$, and models with covariates of $p$.}
-
+## Models $M_0$, $M_t$, and models with covariates of $p$.
In this example we will analyze point count data collected on alder
-flycatchers (\emph{Empidonax alnorum}) by
-\citet{chandler_etal:2009}. Point count data such as these are
+flycatchers (*Empidonax alnorum*) by
+@chandler_etal:2009. Point count data such as these are
collected on unmarked animals, but one can apply
capture-recapture models because it is possible to keep track of
-individual birds during a short period of time \citep{alldredge_etal:2007}. That is, we can
+individual birds during a short period of time [@alldredge_etal:2007]. That is, we can
pretend like birds are marked by noting which time intervals they are
detected in during a short survey. The alder flycatcher data were
collected using fixed-area 15-minute point counts, which were divided
@@ -209,12 +160,11 @@ The following command imports the
capture histories for 50 individuals detected in 2005 at 49 point
count locations.
-\newpage
-
-<<>>=
+```{r}
alfl <- read.csv(system.file("csv", "alfl.csv", package="unmarked"))
head(alfl, 5)
-@
+```
+
We see 5 rows of data representing the encounter histories for 5 birds
detected at 2 points during 3 survey occasions. From these 5 birds, it appears as though
detection probability is high since each bird was detected during at
@@ -224,79 +174,82 @@ Associated with the bird data are site- and visit-specific covariates
for each of the 49 sites. We can import these data using the following
command:
-<<>>=
+```{r}
+
alfl.covs <- read.csv(system.file("csv", "alflCovs.csv",
package="unmarked"), row.names=1)
head(alfl.covs)
-@
-Each row of this \texttt{data.frame} corresponds to a point count
-location. The variable \texttt{struct} is a measure of vegetation
-structure, and \texttt{woody} is the percent cover of woody vegetation
+```
+
+Each row of this `data.frame` corresponds to a point count
+location. The variable `struct` is a measure of vegetation
+structure, and `woody` is the percent cover of woody vegetation
at each of the 50-m radius plots. Time of day and date were measured
for each of the three visits.
-To format the data for \texttt{unmarked}, we need to tabulate the
+To format the data for `unmarked`, we need to tabulate the
encounter histories for each site. Before doing so, let's first put
our capture histories in a single column. Let's also be explicit about
-the levels of our factors for both the newly created captureHistory
+the levels of our factors for both the newly created `captureHistory`
column and the point id column.
-<<>>=
+```{r}
alfl$captureHistory <- paste(alfl$interval1, alfl$interval2, alfl$interval3, sep="")
alfl$captureHistory <- factor(alfl$captureHistory,
levels=c("001", "010", "011", "100", "101", "110", "111"))
## Don't do this:
#levels(alfl$id) <- rownames(alfl.covs)
alfl$id <- factor(alfl$id, levels=rownames(alfl.covs))
-@
-Specifying the levels of \texttt{captureHistory} ensures that when we
+```
+
+Specifying the levels of `captureHistory` ensures that when we
tabulate the encounter histories, we will include zeros for histories
-that were not observed. Similarly, setting the levels of
-\texttt{alfl\$id} tells \textbf{R} that there
+that were not observed. Similarly, setting the levels of `alfl$id` tells `R` that there
were some sites where no ALFL were detected. This way, when we
tabulate the data, we get a frequency for each site, not just the ones
-with $>1$ detection. Here are the commands to extract data from the
+with >1 detection. Here are the commands to extract data from the
first primary period and to tabulate the encounter
histories.
-<<>>=
+```{r}
alfl.v1 <- alfl[alfl$survey==1,]
alfl.H1 <- table(alfl.v1$id, alfl.v1$captureHistory)
head(alfl.H1, 5)
-@
-The object \texttt{alfl.H1} contains the tabulated capture histories for
-each site. This is the format required by {\tt unmarked}. The data from
+```
+
+The object `alfl.H1` contains the tabulated capture histories for
+each site. This is the format required by `unmarked`. The data from
the first 5 sites
suggest that detection probability was high since the most
-common encounter history was $111$.
+common encounter history was `111`.
-Now we are almost ready to create our \texttt{unmarkedFrame} and begin
+Now we are almost ready to create our `unmarkedFrame` and begin
fitting models. We will fit our first series of models using the
-\texttt{multinomPois} function, which requires data formated using the
-\texttt{unmarkedFrameMPois} function. This constructor function
+`multinomPois` function, which requires data formated using the
+`unmarkedFrameMPois` function. This constructor function
has an argument \texttt{type}, which currently can be set to
-\texttt{"removal"} or \texttt{"double"}, corresponding to removal sampling
+`"removal"` or `"double"`, corresponding to removal sampling
data and double observer sampling respectively. In doing so, the
function automatically creates the function to convert $p$ to
-${\bf \pi}$. If \texttt{type} is missing, however, the user needs to
+${\bf \pi}$. If `type` is missing, however, the user needs to
specify
a function to convert detection probability to multinomial cell
probabilities. In the future, we may add an
\texttt{type} option to automatically handle standard
capture-recapture data too,
-but here we show how to supply it using a user-defined \texttt{piFun},
+but here we show how to supply it using a user-defined `piFun`,
which allows flexibility in converting detection probability
-to multinomial cell probabilities $\bf \pi$. The \texttt{piFun} must
+to multinomial cell probabilities $\bf \pi$. The `piFun` must
take a matrix of detection probabilities with $J$ columns
(3 in this case), and convert them to a
matrix of multinomial
cell probabilities with $K$ columns. Each column corresponds to the
probability of observing the encounter history $k$. Here is a
-\texttt{piFun} to compute the multinomial cell probabilities when there
+`piFun` to compute the multinomial cell probabilities when there
were 3 sampling occasions. This function allows us to fit models
$M_0$, $M_t$, or models with covariates of $p$.
-<<>>=
+```{r}
crPiFun <- function(p) {
p1 <- p[,1]
p2 <- p[,2]
@@ -309,47 +262,46 @@ crPiFun <- function(p) {
"110" = p1 * p2 * (1-p3),
"111" = p1 * p2 * p3)
}
-@
+```
To demonstrate how this works, imagine that we surveyed 2 sites and
detection probability was constant ($p=0.2$) among sites and survey
occasions. The function converts these capture probabilities to
multinomial cell probabilities. Note that these cell probabilities will
-sum to $< 1$ if capture probability is less than 1 over the 3 occasions.
+sum to <1 if capture probability is less than 1 over the 3 occasions.
-<<>>=
+```{r}
p <- matrix(0.4, 2, 3)
crPiFun(p)
rowSums(crPiFun(p))
-@
+```
When providing a user-defined \texttt{piFun}, we also need to provide
information about how to handle missing values. That is, if we have a
-missing value in a covariate, we need to know which values of {\bf y}
-are affected. In \texttt{unmarked}, this can be done by supplying a
-mapping-matrix to the \texttt{obsToY} argument in the
-\texttt{unmarkedFrameMPois} function. \texttt{obsToY} needs to be a matrix
+missing value in a covariate, we need to know which values of ${\bf y}$
+are affected. In `unmarked`, this can be done by supplying a
+mapping-matrix to the `obsToY` argument in the
+`unmarkedFrameMPois` function. `obsToY` needs to be a matrix
of zeros and ones with
the number of rows equal to the number of columns for some obsCov, and
-the number columns equal to the number of columns in {\bf y}.
-If \texttt{obsToY[j,k]}=1, then a missing value in {\tt obsCov[i,j]}
+the number columns equal to the number of columns in ${\bf y}$.
+If `obsToY[j,k]`=1, then a missing value in `obsCov[i,j]`
translates to
-a missing value in {\tt y[i,k]}. For the capture-recapture data
+a missing value in `y[i,k]`. For the capture-recapture data
considered here, we can set all
-elements of
-\texttt{obsToY} to 1.
+elements of `obsToY` to 1.
-<<>>=
+```{r}
o2y <- matrix(1, 3, 7)
-@
+```
-We are now ready to create the \texttt{unmarkedFrame}. In order to fit
+We are now ready to create the `unmarkedFrame`. In order to fit
model $M_t$, we need a covariate that references the time interval
-, which we call \texttt{intervalMat} below. We also provide a
+, which we call `intervalMat` below. We also provide a
couple of site-specific covariates: the percent cover of woody
vegetation and vegetation structure.
-<<>>=
+```{r}
library(unmarked)
intervalMat <- matrix(c('1','2','3'), 50, 3, byrow=TRUE)
class(alfl.H1) <- "matrix"
@@ -357,12 +309,11 @@ umf.cr1 <- unmarkedFrameMPois(y=alfl.H1,
siteCovs=alfl.covs[,c("woody", "struct", "time.1", "date.1")],
obsCovs=list(interval=intervalMat),
obsToY=o2y, piFun="crPiFun")
-@
-
+```
-Writing a \texttt{piFun} and creating the \texttt{obsToY} object are
+Writing a `piFun` and creating the `obsToY` object are
the hardest parts of a capture-recapture analysis in
-\texttt{unmarked}. Again, this is done automatically for removal models
+`unmarked`. Again, this is done automatically for removal models
and double observer models, and we may add an option to do this
automatically for capture-recapture data too, but hopefully
the flexibility allowed by specifying user-defined
@@ -372,87 +323,71 @@ Now that we have our data formatted we can fit some models. The
following correspond to model $M_0$, model $M_t$, and a model with a
continuous covariate effect on $p$.
-
-<<>>=
+```{r}
M0 <- multinomPois(~1 ~1, umf.cr1, engine="R")
Mt <- multinomPois(~interval-1 ~1, umf.cr1, engine="R")
Mx <- multinomPois(~time.1 ~1, umf.cr1, engine="R")
-@
+```
The first two models can be fit in other software programs. What is
-unique about \texttt{unmarked} is that we can also model variation in
+unique about `unmarked` is that we can also model variation in
abundance and detection probability among sites. The following model
treats abundance as
a function of the percent cover of woody vegetation.
-<<>>=
+```{r}
(M0.woody <- multinomPois(~1 ~woody, umf.cr1, engine="R"))
-@
+```
-
-This final model has a much lower AIC score than the other models, and
-it indicates
-that alder flycatcher abundance increases with the percent cover
-of woody vegetation. We can plot this relationship by predicting
-abundance at a sequence of woody vegetation values.
-<<woody,fig=TRUE,include=FALSE,width=5,height=5>>=
+```{r, fig.width=5, fig.height=5}
nd <- data.frame(woody=seq(0, 0.8, length=50))
E.abundance <- predict(M0.woody, type="state", newdata=nd, appendData=TRUE)
plot(Predicted ~ woody, E.abundance, type="l", ylim=c(0, 6),
ylab="Alder flycatchers / plot", xlab="Woody vegetation cover")
lines(lower ~ woody, E.abundance, col=gray(0.7))
lines(upper ~ woody, E.abundance, col=gray(0.7))
-@
-\begin{figure}[h!]
- \begin{center}
- \includegraphics[width=4in,height=4in]{cap-recap-woody}
- \end{center}
-\end{figure}
-
-\newpage
+```
What about detection probability? Since there was no evidence of
variation in $p$, we can simply back-transform the logit-scale estimate
to obtain $\hat{p}$.
-<<>>=
+```{r}
backTransform(M0.woody, type="det")
-@
+```
As suggested by the raw data, detection probability was very high. The
corresponding multinomial cell probabilities can be computed by
plugging this estimate of detection probability into our
-\texttt{piFun}. This \texttt{getP} function makes this easy.
+`piFun`. This `getP` function makes this easy.
-<<>>=
+```{r}
round(getP(M0.woody), 2)[1,]
-@
+```
Note that the encounter probability most likely to be observed was
111. In fact $p$ was so high that the probability of not detecting an
alder flycatcher was essentially zero, $(1-0.81)^3 = 0.007$.
-
-
-\subsection{Modeling behavioral responses, Model $M_b$}
+## Modeling behavioral responses, Model $M_b$
An animal's behavior might change after being captured. Both
trap avoidance and trap attraction are frequently
observed in a variety of taxa. A simple model of these two behaviors
-is known as model $M_b$ \citep{otis_etal:1978}. The model assumes that
+is known as model $M_b$ [@otis_etal:1978]. The model assumes that
newly-captured individuals are captured with probability $p_{naive}$
and then are subsequently recaptured with probability $p_{wise}$. If
$p_{wise} < p_{naive}$, then animals exhibit trap avoidance. In some
cases, such as when traps are baited, we might observed $p_{wise} >
-p_{naive}$ in which case the animals are said to be ``trap-happy''.
+p_{naive}$ in which case the animals are said to be "trap-happy".
-To fit model $M_b$ in \texttt{unmarked}, we need to create a new
-\texttt{piFun} and we need to provide an occasion-specific covariate
-(\texttt{obsCov}) that
+To fit model $M_b$ in `unmarked`, we need to create a new
+`piFun` and we need to provide an occasion-specific covariate
+(`obsCov`) that
distinguishes the two capture probabilities, $p_{naive}$ and
$p_{wise}$. The simplest possible approach is the following
-<<>>=
+```{r}
crPiFun.Mb <- function(p) { # p should have 3 columns
pNaive <- p[,1]
pWise <- p[,3]
@@ -464,64 +399,66 @@ crPiFun.Mb <- function(p) { # p should have 3 columns
"110" = pNaive * pWise * (1-pWise),
"111" = pNaive * pWise * pWise)
}
-@
-This function \texttt{crPiFun.Mb} allows capture probability to be
+```
+
+This function `crPiFun.Mb` allows capture probability to be
modeled as
-\[
+$$
\text{logit}(p_{ij}) = \alpha_{naive} + \alpha_{wise} behavior_j + \alpha_1 x_i
-\]
+$$
where $behavior_j$ is simply a dummy variable. Thus, when no
site-specific covariates ($x_i$) are included, $p_{ij}$ is either $p_{naive}$
or $p_{wise}$. The following code constructs a new
-\texttt{unmarkedFrame} and fits model $M_b$ to the alder
+`unmarkedFrame` and fits model $M_b$ to the alder
flycatcher data.
-<<>>=
+```{r}
behavior <- matrix(c('Naive','Naive','Wise'), 50, 3, byrow=TRUE)
umf.cr1Mb <- unmarkedFrameMPois(y=alfl.H1,
siteCovs=alfl.covs[,c("woody", "struct", "time.1")],
obsCovs=list(behavior=behavior),
obsToY=o2y, piFun="crPiFun.Mb")
M0 <- multinomPois(~1 ~1, umf.cr1Mb, engine="R")
-@
-
-\newpage
+```
-<<>>=
+```{r}
(Mb <- multinomPois(~behavior-1 ~1, umf.cr1Mb, engine="R"))
-@
+```
+
AIC gives us no reason to favor model $M_b$ over model $M_0$. This is
perhaps not too surprising given that the alder
flycatchers were not actually captured. Here is a command to compute
-95\% confidence intervals for the two detection probabilities.
-<<>>=
+95% confidence intervals for the two detection probabilities.
+
+```{r}
plogis(confint(Mb, type="det", method="profile"))
-@
+```
-\subsection{Caution, Warning, Danger}
-The function \texttt{crPiFun.Mb} is not generic and could easily be
+## Caution, Warning, Danger
+
+The function `crPiFun.Mb` is not generic and could easily be
abused. For example, you would get bogus results if you tried to use
this function to fit model $M_{bt}$, or if you incorrectly formatted
-the \texttt{behavior} covariate. Thus, extreme caution is advised when
-writing user-defined \texttt{piFun}s.
+the `behavior` covariate. Thus, extreme caution is advised when
+writing user-defined `piFun`s.
There are also a few limitations regarding user-defined
-\texttt{piFun}s. First, they can only take a single argument \verb+p+,
+`piFun`s. First, they can only take a single argument `p`,
which must be the $R \times J$ matrix of detection probabilities. This
makes it cumbersome to fit models such as model $M_h$ as described
below. It also makes it impossible to fit models such as model
$M_{bt}$. It
-would be better if \texttt{piFun}s could accept multiple
+would be better if `piFun`s could accept multiple
arguments, but this would require some modifications to
-\texttt{multinomPois} and \texttt{gmultmix}, which we may do in the
+`multinomPois` and `gmultmix`, which we may do in the
future.
-\subsection{Individual Heterogeneity in Capture Probability, Model $M_h$}
+## Individual Heterogeneity in Capture Probability, Model $M_h$
The capture-recapture models covered thus far assume
that variation in capture probability can be
explained by site-specific covariates, time, or behavior. Currently,
-\texttt{unmarked} can not fit so-called individual covariate models,
+`unmarked` can not fit so-called individual covariate models,
in which heterogeneity in $p$ is attributable to animal-specific
covariates. However, one could
partition the data into strata and analyze the strata separately. For
@@ -532,17 +469,15 @@ into 2 subsets.
Although individual covariate models cannot be considered, it is possible
to fit model $M_h$, which assumes
random variation in capture probability among individuals.
-Here is a \texttt{piFun}, based on code by Andy Royle. It assumes
+Here is a `piFun`, based on code by Andy Royle. It assumes
a logit-normal distribution for the random effects
-\[
+$$
\mbox{logit}(p_i) \sim Normal(\mu, \sigma^2).
-\]
+$$
These random effects are integrated out of the likelihood to obtain the
marginal probability of capture.
-\newpage
-
-<<>>=
+```{r}
MhPiFun <- function(p) {
mu <- qlogis(p[,1]) # logit(p)
sig <- exp(qlogis(p[1,2]))
@@ -575,65 +510,55 @@ for(i in 1:M) {
}
return(il)
}
-@
+```
This function does not allow for temporal variation in capture
-probability because we are using the second column of \verb+p+ as
+probability because we are using the second column of `p` as
$\sigma$, the parameter governing the variance of the random
effects. Once again, this is somewhat clumsy and it would be better to
-allow \texttt{piFun} to accept additional arguments, which could be
-controlled from \texttt{multinomPois} using an additional
-\texttt{formula}. Such features may be added evenually.
-
-Having defined our new \texttt{piFun}, we can fit the model as follows
-%<<>>=
-%library(unmarked)
-%parID <- matrix(c('p','sig','sig'), 50, 3, byrow=TRUE)
-%umf.cr2 <- unmarkedFrameMPois(y=alfl.H1,
-% siteCovs=alfl.covs[,c("woody", "struct", "time.1")],
-% obsCovs=list(parID=parID),
-% obsToY=o2y, piFun="MhPiFun")
-%multinomPois(~parID-1 ~woody, umf.cr2)
-%@
-\begin{Schunk}
-\begin{Sinput}
-> library(unmarked)
-> parID <- matrix(c('p','sig','sig'), 50, 3, byrow=TRUE)
-> umf.cr2 <- unmarkedFrameMPois(y=alfl.H1,
- siteCovs=alfl.covs[,c("woody", "struct", "time.1")],
- obsCovs=list(parID=parID),
- obsToY=o2y, piFun="MhPiFun")
-> multinomPois(~parID-1 ~woody, umf.cr2)
-\end{Sinput}
-\begin{Soutput}
-Call:
-multinomPois(formula = ~parID - 1 ~ woody, data = umf.cr2)
-
-Abundance:
- Estimate SE z P(>|z|)
-(Intercept) -0.84 0.363 -2.31 0.02078
-woody 2.59 0.680 3.81 0.00014
-
-Detection:
- Estimate SE z P(>|z|)
-parIDp 1.637 0.645 2.54 0.0112
-parIDsig 0.841 0.622 1.35 0.1762
-
-AIC: 242.3731
-\end{Soutput}
-\end{Schunk}
+allow `piFun` to accept additional arguments, which could be
+controlled from `multinomPois` using an additional
+`formula`. Such features may be added eventually.
+
+Having defined our new `piFun`, we can fit the model as follows
+
+```{r, eval=FALSE}
+parID <- matrix(c('p','sig','sig'), 50, 3, byrow=TRUE)
+umf.cr2 <- unmarkedFrameMPois(y=alfl.H1,
+ siteCovs=alfl.covs[,c("woody", "struct", "time.1")],
+ obsCovs=list(parID=parID),
+ obsToY=o2y, piFun="MhPiFun")
+multinomPois(~parID-1 ~woody, umf.cr2)
+```
+
+```
+## Call:
+## multinomPois(formula = ~parID - 1 ~ woody, data = umf.cr2)
+##
+## Abundance:
+## Estimate SE z P(>|z|)
+## (Intercept) -0.84 0.363 -2.31 0.02078
+## woody 2.59 0.680 3.81 0.00014
+##
+## Detection:
+## Estimate SE z P(>|z|)
+## parIDp 1.637 0.645 2.54 0.0112
+## parIDsig 0.841 0.622 1.35 0.1762
+##
+## AIC: 242.3731
+```
+
The estimate of $\sigma$ is high, indicating the existence of substantial
heterogeneity in detection probability. However, one should be aware of the
-concerns about $M_h$ raised by \citet{link:2003} who demonstrated that
+concerns about $M_h$ raised by @link:2003 who demonstrated that
population size $N$ is not an identifiable parameter among various
classes of models assumed for the random effects. For example, we
might use a beta distribution rather than a logit-normal distribution,
-and obtain very different estimates of abundance. \citet{link:2003}
+and obtain very different estimates of abundance. @link:2003
demonstrated that conventional methods such as AIC cannot be used to
discriminate among these models.
-
-\subsection{Distance-related heterogeneity}
+## Distance-related heterogeneity
Another source of individual heterogeneity in capture probability
arises from the distance between animal activity centers and
@@ -641,25 +566,24 @@ sample locations. Traditional capture-recapture models ignore this
important source of variation in capture probability, but
recently developed spatial capture-recapture (SCR) models overcome this
limitation
-\citep{efford:2004,royle_young:2008,royle_dorazio:2008}. Distance-related
+[@efford:2004; @royle_young:2008; @royle_dorazio:2008]. Distance-related
heterogeneity in detection
probability was probably not an important concern in the alder
flycatcher dataset because the plots were very small (0.785 ha) and
only singing birds were included in the analysis. If it were a
concern, we could of course collect distance data and use the
-\verb+gdistsamp+ function to fit a distance sampling model.
+`gdistsamp` function to fit a distance sampling model.
In other contexts, such as when using arrays of live traps,
distance sampling is not an option and
SCR models offer numerous advantages over traditional
capture-recapture models.
-
-\section{Modeling Temporary Emigration}
+# Modeling Temporary Emigration
In the previous analysis we used data from the first visit only.
-\citet{chandlerEA_2011} proposed a model that allows us to
+@chandlerEA_2011 proposed a model that allows us to
make use of the entire alder flycatcher dataset. The model is similar
-to the temporary emigration model of \citet{kendall_etal:1997} except
+to the temporary emigration model of @kendall_etal:1997 except
that we are
interested in modeling variation in abundance among sites.
@@ -674,25 +598,27 @@ to sampling during primary period $t$. We now collect
capture-recapture data
at each site during each primary period, and obtain the data $\bf
y_{it}$. The model can be written as
+$$
\begin{gather}
M_i \sim \mbox{Poisson}(\lambda) \nonumber \\
N_{it}|M_i \sim \mbox{Binomial}(M_i, \phi) \nonumber \\
{\bf y_{it}}|N_{it} \sim \mbox{Multinomial}(N_{it}, \pi(p))
\label{mod:te}
\end{gather}
+$$
where $\phi$ is the probability of being available for capture. This
can be modeled as a function of covariates using the logit-link.
The data structure for the robust design is more complex than before,
-but it is easy to create in \textbf{R}. We can once again use the
-\texttt{table} function---but this time, we create a three-dimensional table
+but it is easy to create in `R`. We can once again use the
+`table` function - but this time, we create a three-dimensional table
rather than a two-dimensional one. We also need to expand the
-\texttt{obsToY} mapping matrix so that it has a block diagonal
+`obsToY` mapping matrix so that it has a block diagonal
structure. This isn't so intuitive, but the
commands below are generic and can be applied to other
capture-recapture designs.
-<<>>=
+```{r}
alfl.H <- table(alfl$id, alfl$captureHistory, alfl$survey)
alfl.Hmat <- cbind(alfl.H[,,1], alfl.H[,,2], alfl.H[,,3])
nVisits <- 3
@@ -702,41 +628,34 @@ umf.cr <- unmarkedFrameGMM(y=alfl.Hmat,
yearlySiteCovs=list(date=alfl.covs[,3:5], time=alfl.covs[,6:8]),
obsCovs=list(interval=cbind(intervalMat,intervalMat,intervalMat)),
obsToY=o2yGMM, piFun="crPiFun", numPrimary=nVisits)
-@
-
+```
Notice that we have 3 types of covariates now. The site-specific
covariates are the same as before. Now, however, the observation
-covariates must match the dimensions of the {\bf y} matrix. We can
+covariates must match the dimensions of the ${\bf y}$ matrix. We can
also have a class of covariates that vary among primary periods but
-not within primary periods. These are called yearlySiteCovs, which is
-a misleading name. It is a carry-over from other ``open population"
-models in \texttt{unmarked}, but it should be remembered that these
+not within primary periods. These are called `yearlySiteCovs`, which is
+a misleading name. It is a carry-over from other "open population"
+models in `unmarked`, but it should be remembered that these
models are most suitable for data from a single year, since we assume
no births or mortalities.
-We can fit the model using the \texttt{gmultmix} function, which has a
+We can fit the model using the `gmultmix` function, which has a
slightly different set of arguments. Rather than a single formula, the
function takes 3 formulas for abundance covariates, availability
covariates, and detection covariates in that order.
-<<>>=
+```{r}
(fm1 <- gmultmix(~woody, ~1, ~time+date, umf.cr, engine="R"))
-@
+```
Results from this model are similar to those obtained using the subset
of data, but the standard error for the woody estimate has
-decreased. If we back-transform the estimate of $\phi$, we see that
+decreased. If we back-transform the estimate of $\phi$, we see that
the probability of being available for detection is 0.31.
-Another feature of \texttt{gmultmix} is that $N$ can be modeled using
+Another feature of `gmultmix` is that $N$ can be modeled using
either the Poisson or negative binomial distribution. We might
eventually add other options such as the zero-inflated Poisson.
-
-
-\bibliography{unmarked}
-
-
-
-\end{document}
+# References
diff --git a/vignettes/colext-cov.pdf b/vignettes/colext-cov.pdf
deleted file mode 100644
index d831e7c..0000000
--- a/vignettes/colext-cov.pdf
+++ /dev/null
Binary files differ
diff --git a/vignettes/colext-data-1.png b/vignettes/colext-data-1.png
new file mode 100644
index 0000000..6d8aa71
--- /dev/null
+++ b/vignettes/colext-data-1.png
Binary files differ
diff --git a/vignettes/colext-est-1.png b/vignettes/colext-est-1.png
new file mode 100644
index 0000000..7df8149
--- /dev/null
+++ b/vignettes/colext-est-1.png
Binary files differ
diff --git a/vignettes/colext-gof-1.png b/vignettes/colext-gof-1.png
new file mode 100644
index 0000000..dfe673a
--- /dev/null
+++ b/vignettes/colext-gof-1.png
Binary files differ
diff --git a/vignettes/colext-gof.pdf b/vignettes/colext-gof.pdf
deleted file mode 100644
index da28c00..0000000
--- a/vignettes/colext-gof.pdf
+++ /dev/null
Binary files differ
diff --git a/vignettes/colext-pred-1.png b/vignettes/colext-pred-1.png
new file mode 100644
index 0000000..c248a7a
--- /dev/null
+++ b/vignettes/colext-pred-1.png
Binary files differ
diff --git a/vignettes/colext-sim.pdf b/vignettes/colext-sim.pdf
deleted file mode 100644
index 04e0c5d..0000000
--- a/vignettes/colext-sim.pdf
+++ /dev/null
Binary files differ
diff --git a/vignettes/colext-yearlysim.pdf b/vignettes/colext-yearlysim.pdf
deleted file mode 100644
index 02d67e0..0000000
--- a/vignettes/colext-yearlysim.pdf
+++ /dev/null
Binary files differ
diff --git a/vignettes/colext.Rnw b/vignettes/colext.Rmd
index dbb5a9b..0bfc1a1 100644
--- a/vignettes/colext.Rnw
+++ b/vignettes/colext.Rmd
@@ -1,103 +1,38 @@
-<<echo=false>>=
-options(width=70)
-options(continue=" ")
-@
-
-
-\documentclass[12pt]{article}
-
-
-\usepackage[OT1]{fontenc}
-\usepackage{Sweave}
-%\usepackage{natbib}
-\usepackage{fullpage}
-\usepackage[vmargin=1in,hmargin=1in]{geometry}
-%\bibliographystyle{plain}
-
-\SweaveOpts{keep.source=TRUE}
-
-\DefineVerbatimEnvironment{Sinput}{Verbatim} {xleftmargin=2em}
-\DefineVerbatimEnvironment{Soutput}{Verbatim}{xleftmargin=2em}
-\DefineVerbatimEnvironment{Scode}{Verbatim}{xleftmargin=2em}
-\fvset{listparameters={\setlength{\topsep}{0pt}}}
-\renewenvironment{Schunk}{\vspace{\topsep}}{\vspace{\topsep}}
-
-%%\VignetteIndexEntry{Dynamic occupancy models}
-
-
-\usepackage{amsmath}
-\usepackage{amssymb} % used for symbols in figure legends
-\usepackage{url}
-\usepackage{framed}
-\usepackage{float}
-
-\usepackage{lineno}
-\floatstyle{plain}
-\floatname{panel}{Panel}
-\newfloat{panel}{h}{txt}
-
-\renewcommand{\baselinestretch}{1}
-\setlength{\textwidth}{6.5in}
-%\setlength{\evensidemargin}{0.1875in}
-%\setlength{\oddsidemargin}{0.1875in}
-\setlength{\evensidemargin}{0in}
-\setlength{\oddsidemargin}{0in}
-
-\setlength{\textheight}{8.425in}
-%\setlength{\headheight}{.5in}
-%\setlength{\headsep}{.5in}
-%\setlength{\parindent}{.25in}
-\setlength{\topmargin}{0.025in}
-
-
-%paragraph formatting
-\usepackage{indentfirst} % indent first line of paragraph in new sections
-\usepackage{setspace} % for double or single space
-%\singlespacing
-%
-\usepackage{graphicx}
-
-\begin{document}
-
-% \textbf{Running title: Dynamic occupancy modeling in unmarked}
-
-\vspace{1 cm}
-
-\begin{center}
- \Large \textbf{Dynamic occupancy models in unmarked}
-\end{center}
-
-\vspace{1 cm}
-
-\noindent Marc K\'{e}ry and Richard Chandler\\
-
-\noindent Swiss Ornithological Institute and University of Georgia \\
-
-\vspace{1 cm}
-\begin{center}
- \textbf{16 August 2016}
-\end{center}
-
-% \today
-
-% Key words:
-
-\vspace{1 cm}
-
-\begin{center}
- \textbf{Abstract}
-\end{center}
-Dynamic occupancy models (MacKenzie et al. 2003) allow inference about
-the occurrence of ``things'' at collections of ``sites''
+---
+title: Dynamic occupancy models in unmarked
+author:
+- name: Marc Kéry, Swiss Ornithological Institute
+- name: Richard Chandler, University of Georgia
+date: August 16, 2016
+bibliography: unmarked.bib
+csl: ecology.csl
+output:
+ rmarkdown::html_vignette:
+ fig_width: 5
+ fig_height: 3.5
+ number_sections: true
+ toc: true
+vignette: >
+ %\VignetteIndexEntry{Dynamic occupancy models}
+ %\VignetteEngine{knitr::rmarkdown}
+ \usepackage[utf8]{inputenc}
+---
+
+
+
+# Abstract
+
+Dynamic occupancy models [@mackenzie_estimating_2003] allow inference about
+the occurrence of "things" at collections of "sites"
and about how changes in occurrence are driven by colonization and
local extinction. These models also account for imperfect detection
-probability. Depending on how ``thing'' and ``site'' are defined,
+probability. Depending on how "thing" and "site" are defined,
occupancy may have vastly different biological meanings,
including the presence of a disease in an individual (disease
incidence) of a species at a site (occurrence, distribution), or of an
individual in a territory.
-Dynamic occupancy models in \textbf{unmarked} are fit using the
-function \emph{colext}.
+Dynamic occupancy models in `unmarked` are fit using the
+function `colext`.
All parameters can be modeled as functions of covariates, i.e.,
first-year occupancy with covariates varying by site
(site-covariates),
@@ -109,22 +44,8 @@ bird survey MHB.
We also give examples to show how predictions, along with standard
errors and confidence intervals, can be obtained.
+# Introduction
-\newpage
-
-\singlespacing % single
-% \doublespacing
-
-
-\newpage
-\raggedright
-% \indentfirst
-\setlength{\parindent}{.25in}
-% \linenumbers % Switch on/off line numbers
-
-
-
-\section{Introduction}
Occurrence is a quantity of central importance in many branches of
ecology and related sciences.
The presence of a disease in an individual or of a species
@@ -135,14 +56,14 @@ Thus, depending on how we define the thing we are looking for and the
sample unit, very different biological quantities can be analyzed
using statistical models for occupancy.
-If we denote presence of the ``thing'' as $y=1$ and its absence as
+If we denote presence of the "thing" as $y=1$ and its absence as
$y=0$, then it is natural to characterize all these metrics by the
-probability that a randomly chosen sample unit (``site'') is occupied,
-i.e., has a ``thing'' present: $Pr(y=1) = \psi$.
+probability that a randomly chosen sample unit ("site") is occupied,
+i.e., has a "thing" present: $Pr(y=1) = \psi$.
We call this the occupancy probability, or occupancy for short, and
from now on will call the sample unit,
-where the presence or absence of a ``thing'' is assessed, generically
-a ``site''.
+where the presence or absence of a "thing" is assessed, generically
+a "site".
Naturally, we would like to explore factors that affect the likelihood
that a site is occupied.
@@ -151,12 +72,12 @@ customary statistical model for occurrence.
In this model, we treat occurrence $y$ as a binomial random variable
with trial size 1 and success probability $p$, or, equivalently, a
Bernoulli trial with $p$.
-``Success'' means occurrence, so $p$ is the occurrence probability.
+"Success" means occurrence, so $p$ is the occurrence probability.
It can be modeled as a linear or other function of covariates via a
suitable link function, e.g., the logit link.
-This simple model is described in many places, including McCullagh and
-Nelder (1989), Royle and Dorazio (2008, chapter 3), K\'{e}ry (2010,
-chapter 17) and K\'{e}ry and Schaub (2011, chapter 3).
+This simple model is described in many places, including @McCullagh_1989,
+Royle and Dorazio [-@royle_dorazio:2008, chapter 3], Kéry [-@Kery_2010,
+chapter 17] and Kéry and Schaub [-@Kery_2011, chapter 3].
A generalization of this model accounts for changes in the occupancy
state of sites by introducing parameters for survival
@@ -170,58 +91,54 @@ a site occupied at $t$ is again occupied at $t+1$ as $Pr(y_{i,t+1} = 1
This represents the survival probability of a site that is occupied.
Of course, we could also choose to express this component of occupancy
dynamics by the converse, extinction probability $\epsilon$ ---
-the parameterization used in \textbf{unmarked}.
+the parameterization used in `unmarked`.
To model the fate of an unoccupied site, we denote as $Pr(y_{i,t+1} =
1 | y_{i,t} = 0 ) = \gamma$ the probability that an unoccupied site at
$t$ becomes occupied at $t+1$.
This is the colonization probability of an empty site.
-Such a dynamic model of occurrence has become famous in the ecological literature under the name ``metapopulation model'' (Hanski 1998).
+Such a dynamic model of occurrence has become famous in the ecological literature under the name "metapopulation model" [@Hanski_1998].
However, when using ecological data collected in the field to fit such
models of occurrence, we face the usual challenge of imperfect
-detection (e.g. K\'{e}ry and Schmidt 2008).
+detection [e.g. @Kery_2008].
For instance, a species can go unobserved at a surveyed site or an
occupied territory can appear unoccupied during a particular survey,
perhaps because both birds are away hunting.
Not accounting for detection error may seriously bias all parameter
-estimators of a metapopulation model (Moilanen 2002; Royle and Dorazio
-2008).
+estimators of a metapopulation model [@Moilanen_2002; @royle_dorazio:2008].
To account for this additional stochastic component in the generation
of most ecological field data, the classical metapopulation model may
be generalized to include a submodel for the observation process,
which allows an occupied site to be recorded as unoccupied.
-This model has been developed by MacKenzie et al. (2003). It is
-described as a hierarchical model by Royle and K\'{e}ry (2007), Royle
-and Dorazio (2008, chapter 9) and K\'{e}ry and Schaub (2011, chapter
-13). The model is usually called a multi-season, multi-year or a
+This model has been developed by @mackenzie_estimating_2003. It is
+described as a hierarchical model by @Royle_2007, Royle
+and Dorazio [-@royle_dorazio:2008, chapter 9] and Kéry and Schaub [-@Kery_2011, chapter 13].
+The model is usually called a multi-season, multi-year or a
dynamic site-occupancy model.
The former terms denote the fact that it is applied to multiple
-``seasons'' or years and the latter emphasizes that the model allows
+"seasons" or years and the latter emphasizes that the model allows
for between-season occurrence dynamics.
-This vignette describes the use of the \textbf{unmarked} function
-\emph{colext} to fit dynamic occupancy models. Note that we will use
+This vignette describes the use of the `unmarked` function
+`colext` to fit dynamic occupancy models. Note that we will use
italics for the names of functions.
Static occupancy models, i.e., for a single season without changes in
-the occupancy state (MacKenzie et al. 2002), can be fit with \emph{occu},
-for the model described by MacKenzie et al. (2002) and Tyre et
-al. (2003), and with \emph{occuRN}, for the heterogeneity occupancy model
-described by Royle and Nichols (2003).
+the occupancy state [@mackenzie_estimating_2002], can be fit with `occu`,
+for the model described by @mackenzie_estimating_2002 and @Tyre_2002, and with `occuRN`, for the heterogeneity occupancy model
+described by @royle_estimating_2003.
In the next section (section 2), we give a more technical description
of the dynamic occupancy model.
In section 3, we provide R code for generating data under a basic
-dynamic occupancy model and illustrate use of \emph{colext} for fitting the
+dynamic occupancy model and illustrate use of `colext` for fitting the
model.
In section 4, we use real data from the Swiss breeding bird survey MHB
-(Schmid et al. 2004) to fit a few more elaborate models with
+[@schmid_etal:2004] to fit a few more elaborate models with
covariates for all parameters.
We also give examples illustrating how to compute predictions, with
-standard errors and 95\% confidence intervals, for the parameters.
-
+standard errors and 95% confidence intervals, for the parameters.
+# Dynamic occupancy models
-
-\section{Dynamic occupancy models}
To be able to estimate the parameters of the dynamic occupancy model
(probabilities of occurrence, survival and colonization) separately
from the parameters for the observation process (detection
@@ -236,15 +153,14 @@ That is, $y_{ijt}=1$ if at least one individual is detected and
$y_{ijt}=0$ if none is detected.
The model makes the following assumptions:
-\begin{itemize}
-\item replicate surveys at a site during a single season are
+* replicate surveys at a site during a single season are
independent (or else dependency must be modeled)
-\item occurrence state $z_{it}$ (see below) does not change over
+* occurrence state $z_{it}$ (see below) does not change over
replicate surveys at site $i$ during season $t$
-\item there are no false-positive errors, i.e., a species can only be
+* there are no false-positive errors, i.e., a species can only be
overlooked where it occurs, but it cannot be detected where it does
not in fact occur (i.e., there are no false-positives)
-\end{itemize}
+
The complete model consists of one submodel to describe the ecological
process, or state, and another submodel for the observation process,
which is dependent on the result of the ecological process.
@@ -255,26 +171,24 @@ The observation process describes the probability of detecting a
presence (i.e., $y = 1$) at a site that is occupied and takes account
of false-negative observation errors.
+## Ecological or state process
-
-
-\subsection{Ecological or state process}
This initial state is denoted $z_{i1}$ and represents occurrence at
site $i$ during season 1.
For this, the model assumes a Bernoulli trial governed by the
occupancy probability in the first season $\psi_{i1}$:
-\[
- z_{i1} = Bernoulli(\psi_{i1})
-\]
+$$
+z_{i1} = Bernoulli(\psi_{i1})
+$$
-We must distinguish the sample quantity ``occurrence'' at a site, $z$,
-from the population quantity ``occupancy probability'', $\psi$.
+We must distinguish the sample quantity "occurrence" at a site, $z$,
+from the population quantity "occupancy probability", $\psi$.
The former is the realization of a Bernoulli random variable with
parameter $\psi$.
This distinction becomes important when we want to compute the number
of occupied sites among the sample of surveyed sites;
-see Royle and K\'{e}ry (2007) and Weir et al. (2009) for this
+see @Royle_2007 and @Weir_2009 for this
distinction.
For all later seasons ($t = 2, 3, \ldots T$), occurrence is a function
@@ -285,9 +199,9 @@ $\phi_{it}$, also called probability of persistence (= 1 minus the
probability of local extinction),
and the probability of colonization $\gamma_{it}$.
-\[
- z_{it} \sim Bernoulli(z_{i,t-1} \phi_{it} + (1-z_{i,t-1}) \gamma_{it})
-\]
+$$
+z_{it} \sim Bernoulli(z_{i,t-1} \phi_{it} + (1-z_{i,t-1}) \gamma_{it})
+$$
Hence, if site $i$ is unoccupied at $t-1$ , $z_{i,t-1}=0$, and the
success probability of the Bernoulli is
@@ -304,23 +218,23 @@ $z_{i1}$ , $\phi_{it}$ and $\gamma_{it}$.
Variances of these derived estimates can be obtained via the delta
method or the bootstrap.
+## Observation process
-\subsection{Observation process}
To account for the observation error (specifically, false-negative
observations), the conventional Bernoulli detection process is
assumed, such that
-\[
- y_{ijt} \sim Bernoulli(z_{it} p_{ijt})
-\]
+$$
+y_{ijt} \sim Bernoulli(z_{it} p_{ijt})
+$$
Here, $y_{ijt}$ is the detection probability at site $i$ during
survey $j$ and season $t$. Detection is conditional on occurrence, and
multiplying $p_{ijt}$ with $z_{it}$ ensures that occurrence can only
be detected where in fact a species occurs, i.e. where $z_{it}=1$.
+## Modeling of parameters
-\subsection{Modeling of parameters}
The preceding, fully general model description allows for site-($i$)
dependence of all parameters. In addition to that, survival and
colonization probabilities may be season-($t$)dependent and detection
@@ -344,18 +258,16 @@ form
Julian date of the survey $j$ at site $i$ in season $t$.
We note that for first-year occupancy, only covariates that vary among
-sites (``site covariates'') can be fitted, while for survival and
-colonization, covariates that vary by site and by season (``yearly
-site covariates'') may be fitted as well.
+sites ("site covariates") can be fitted, while for survival and
+colonization, covariates that vary by site and by season ("yearly
+site covariates") may be fitted as well.
For detection, covariates of three formats may be fitted:
-``site-covariates'', ``yearly-site-covariates'' and
-``observation-covariates'', as
-they are called in \textbf{unmarked}.
+"site-covariates", "yearly-site-covariates" and
+"observation-covariates", as
+they are called in `unmarked`.
+# Dynamic occupancy models for simulated data
-
-
-\section{Dynamic occupancy models for simulated data}
We first generate a simple, simulated data set
with specified, year-specific values for
the parameters as well as design specifications, i.e., number of
@@ -364,18 +276,15 @@ Then, we show how to fit a dynamic occupancy model with
year-dependence in the parameters for colonization, extinction and
detection probability.
-\subsection{Simulating, formatting, and summarizing data}
+## Simulating, formatting, and summarizing data
+
To simulate the data, we execute the following R code.
The actual values for these parameters for each year are drawn
randomly from a uniform distribution with
the specified bounds.
-%%<<eval=true,echo=false>>=
-%%load(system.file("ws", "dynocc.RData", package="unmarked"))
-%%@
-\begin{small}
-<<>>=
+```r
M <- 250 # Number of sites
J <- 3 # num secondary sample periods
T <- 10 # num primary sample periods
@@ -415,12 +324,10 @@ for(i in 1:M){
for (k in 2:T){
psi[k] <- psi[k-1]*phi[k-1] + (1-psi[k-1])*gamma[k-1]
}
-@
-\end{small}
-
+```
We have now generated a single realization from the stochastic system
-thus defined. Figure~\ref{fig:sim}
+thus defined. Figure 1
illustrates the fundamental issue
of imperfect detection --- the actual proportion of sites occupied
differs greatly from the observed proportion of sites occupied, and
@@ -428,8 +335,9 @@ because $p$ varies among years, the observed data cannot be used as a
valid index of the parameter of interest $\psi_i$.
-\begin{small}
-<<sim,fig=true,include=false,width=6,height=6>>=
+
+
+```r
plot(1:T, colMeans(z), type = "b", xlab = "Year",
ylab = "Proportion of sites occupied",
col = "black", xlim=c(0.5, 10.5), xaxp=c(1,10,9),
@@ -440,192 +348,173 @@ psi.app <- colMeans(apply(y, c(1,3), max))
lines(1:T, psi.app, type = "b", col = "blue", lty=3, lwd = 2)
legend(1, 0.6, c("truth", "observed"),
col=c("black", "blue"), lty=c(1,3), pch=c(16,1))
-@
-\end{small}
-
-
-\begin{figure}[!h]
-\centering
-\includegraphics[width=5in,height=5in]{colext-sim.pdf}
-\caption{Summary of the multi-year occupancy data set generated.}
-\label{fig:sim}
-\end{figure}
+```
+![Figure 1. Summary of the multi-year occupancy data set generated.](colext-data-1.png)
To analyze this data set with a dynamic occupancy model in
-\textbf{unmarked}, we first load the package.
+`unmarked`, we first load the package.
+
-<<>>=
+```r
library(unmarked)
-@
+```
Next, we reformat the detection/non-detection data from a 3-dimensional
array (as generated) into a 2-dimensional matrix with M rows.
That is, we put the annual tables of data (the slices of the former
-3-D array) sideways to produce a ``wide'' layout of the data.
+3-D array) sideways to produce a "wide" layout of the data.
-\begin{small}
-<<>>=
-yy <- matrix(y, M, J*T)
-@
-\end{small}
+```r
+yy <- matrix(y, M, J*T)
+```
Next, we create a matrix indicating the year each site was surveyed.
-\begin{small}
-<<>>=
+
+```r
year <- matrix(c('01','02','03','04','05','06','07','08','09','10'),
nrow(yy), T, byrow=TRUE)
-@
-\end{small}
+```
-To organize the data in the format required by \emph{colext}, we make
-use of the function \emph{unmarkedMultFrame}. The only required
-arguments are \emph{y}, the detection/non-detection data, and
-\emph{numPrimary}, the number of seasons. The three types of
+To organize the data in the format required by `colext`, we make
+use of the function `unmarkedMultFrame`. The only required
+arguments are `y`, the detection/non-detection data, and
+`numPrimary`, the number of seasons. The three types of
covariates described earlier can also be supplied using the arguments
-\emph{siteCovs}, \emph{yearlySiteCovs}, and \emph{obsCovs}. In this case,
+`siteCovs`, `yearlySiteCovs`, and `obsCovs`. In this case,
we only make use of the second type, which must have M rows and T
columns.
-\begin{small}
-<<>>=
+```r
simUMF <- unmarkedMultFrame(
y = yy,
yearlySiteCovs = list(year = year),
numPrimary=T)
summary(simUMF)
-@
-\end{small}
-
-
+```
+
+```
+## unmarkedFrame Object
+##
+## 250 sites
+## Maximum number of observations per site: 30
+## Mean number of observations per site: 30
+## Number of primary survey periods: 10
+## Number of secondary survey periods: 3
+## Sites with at least one detection: 195
+##
+## Tabulation of y observations:
+## 0 1
+## 6430 1070
+##
+## Yearly-site-level covariates:
+## year
+## 01 : 250
+## 02 : 250
+## 03 : 250
+## 04 : 250
+## 05 : 250
+## 06 : 250
+## (Other):1000
+```
+
+## Model fitting
-\subsection{Model fitting}
We are ready to fit a few dynamic occupancy models.
We will fit a model with constant values for all parameters and
another with full time-dependence for colonization, extinction and
detection probability. We also time the calculations.
-\begin{small}
-
-%<<eval=true>>=
-%# Model with all constant parameters
-%m0 <- colext(psiformula= ~1, gammaformula = ~ 1, epsilonformula = ~ 1,
-% pformula = ~ 1, data = simUMF, method="BFGS")
-%@
-
-%<<>>=
-%summary(m0)
-%@
-
-
-
-\begin{Schunk}
-\begin{Sinput}
-> # Model with all constant parameters
-> m0 <- colext(psiformula= ~1, gammaformula = ~ 1, epsilonformula = ~ 1,
- pformula = ~ 1, data = simUMF, method="BFGS")
-\end{Sinput}
-\end{Schunk}
-
-\begin{Schunk}
-\begin{Sinput}
-> summary(m0)
-\end{Sinput}
-\begin{Soutput}
-Call:
-colext(psiformula = ~1, gammaformula = ~1, epsilonformula = ~1,
- pformula = ~1, data = simUMF, method = "BFGS")
-
-Initial (logit-scale):
- Estimate SE z P(>|z|)
- -0.813 0.158 -5.16 2.46e-07
-
-Colonization (logit-scale):
- Estimate SE z P(>|z|)
- -1.77 0.0807 -22 2.75e-107
-
-Extinction (logit-scale):
- Estimate SE z P(>|z|)
- -0.59 0.102 -5.79 7.04e-09
-
-Detection (logit-scale):
- Estimate SE z P(>|z|)
- -0.0837 0.0562 -1.49 0.137
-
-AIC: 4972.597
-Number of sites: 250
-optim convergence code: 0
-optim iterations: 27
-Bootstrap iterations: 0
-\end{Soutput}
-\end{Schunk}
-
-
-
-\end{small}
+```r
+# Model with all constant parameters
+m0 <- colext(psiformula= ~1, gammaformula = ~ 1, epsilonformula = ~ 1,
+ pformula = ~ 1, data = simUMF, method="BFGS")
+summary(m0)
+```
+
+```
+##
+## Call:
+## colext(psiformula = ~1, gammaformula = ~1, epsilonformula = ~1,
+## pformula = ~1, data = simUMF, method = "BFGS")
+##
+## Initial (logit-scale):
+## Estimate SE z P(>|z|)
+## -0.813 0.158 -5.16 2.46e-07
+##
+## Colonization (logit-scale):
+## Estimate SE z P(>|z|)
+## -1.77 0.0807 -22 2.75e-107
+##
+## Extinction (logit-scale):
+## Estimate SE z P(>|z|)
+## -0.59 0.102 -5.79 7.04e-09
+##
+## Detection (logit-scale):
+## Estimate SE z P(>|z|)
+## -0.0837 0.0562 -1.49 0.137
+##
+## AIC: 4972.597
+## Number of sites: 250
+## optim convergence code: 0
+## optim iterations: 27
+## Bootstrap iterations: 0
+```
The computation time was only a few seconds.
Note that all parameters were estimated on the logit scale. To
back-transform to the original scale, we can simply use the
-inverse-logit function, named \emph{plogis} in R.
+inverse-logit function, named `plogis` in R.
-\begin{small}
-<<>>=
+```r
plogis(-0.813)
-@
-\end{small}
+```
+```
+## [1] 0.3072516
+```
-Alternatively, we can use \emph{backTransform}, which
+Alternatively, we can use `backTransform`, which
computes standard errors using the delta method. Confidence intervals
-are also easily obtained using the function \emph{confint}.
+are also easily obtained using the function `confint`.
We first remind ourselves of the names of parameters, which can all be
used as arguments for these functions.
-\begin{small}
-
-%<<>>=
-%names(m0)
-%backTransform(m0, type="psi")
-%confint(backTransform(m0, type="psi"))
-%@
-
+```r
+names(m0)
+```
-\begin{Schunk}
-\begin{Sinput}
-> names(m0)
-\end{Sinput}
-\begin{Soutput}
-[1] "psi" "col" "ext" "det"
-\end{Soutput}
-\begin{Sinput}
-> backTransform(m0, type="psi")
-\end{Sinput}
-\begin{Soutput}
-Backtransformed linear combination(s) of Initial estimate(s)
+```
+## [1] "psi" "col" "ext" "det"
+```
- Estimate SE LinComb (Intercept)
- 0.307 0.0335 -0.813 1
+```r
+backTransform(m0, type="psi")
+```
-Transformation: logistic
-\end{Soutput}
-\begin{Sinput}
-> confint(backTransform(m0, type="psi"))
-\end{Sinput}
-\begin{Soutput}
- 0.025 0.975
- 0.2457313 0.3765804
-\end{Soutput}
-\end{Schunk}
+```
+## Backtransformed linear combination(s) of Initial estimate(s)
+##
+## Estimate SE LinComb (Intercept)
+## 0.307 0.0335 -0.813 1
+##
+## Transformation: logistic
+```
-\end{small}
+```r
+confint(backTransform(m0, type="psi"))
+```
+```
+## 0.025 0.975
+## 0.2457313 0.3765804
+```
Next, we fit the dynamic occupancy model with full year-dependence in
the parameters describing occupancy dynamics and also in detection.
@@ -643,116 +532,101 @@ differences. For simple presentation, a means parameterization is more
practical. It can be specified by adding a -1 to the formula for the
time-dependent parameters.
-\begin{small}
-<<eval=false>>=
+```r
m1 <- colext(psiformula = ~1, # First-year occupancy
gammaformula = ~ year-1, # Colonization
epsilonformula = ~ year-1, # Extinction
pformula = ~ year-1, # Detection
data = simUMF)
-@
-<<eval=false,echo=false>>=
m1
-@
-\begin{Schunk}
-\begin{Sinput}
-> m1
-\end{Sinput}
-\begin{Soutput}
-Call:
-colext(psiformula = ~1, gammaformula = ~year - 1, epsilonformula = ~year -
- 1, pformula = ~year - 1, data = simUMF)
-
-Initial:
- Estimate SE z P(>|z|)
- -0.273 0.302 -0.906 0.365
-
-Colonization:
- Estimate SE z P(>|z|)
-year01 -2.08 0.951 -2.19 2.86e-02
-year02 -2.18 0.365 -5.96 2.52e-09
-year03 -1.98 0.274 -7.23 4.88e-13
-year04 -2.32 0.678 -3.42 6.37e-04
-year05 -1.89 0.478 -3.95 7.78e-05
-year06 -1.76 0.294 -5.97 2.44e-09
-year07 -1.55 0.230 -6.73 1.75e-11
-year08 -1.43 0.228 -6.29 3.19e-10
-year09 -2.35 0.470 -5.00 5.64e-07
-
-Extinction:
- Estimate SE z P(>|z|)
-year01 -1.4209 0.418 -3.401 6.72e-04
-year02 -0.4808 0.239 -2.009 4.45e-02
-year03 -1.2606 0.366 -3.440 5.83e-04
-year04 -0.0907 0.650 -0.139 8.89e-01
-year05 -0.6456 0.599 -1.078 2.81e-01
-year06 -0.9586 0.378 -2.539 1.11e-02
-year07 -1.2279 0.365 -3.362 7.74e-04
-year08 -1.1894 0.292 -4.076 4.58e-05
-year09 -0.6292 0.635 -0.991 3.22e-01
-
-Detection:
- Estimate SE z P(>|z|)
-year01 -1.0824 0.244 -4.434 9.26e-06
-year02 -0.2232 0.148 -1.508 1.32e-01
-year03 0.2951 0.154 1.918 5.52e-02
-year04 0.0662 0.161 0.412 6.81e-01
-year05 -2.0396 0.433 -4.706 2.52e-06
-year06 -0.6982 0.232 -3.005 2.66e-03
-year07 0.2413 0.165 1.466 1.43e-01
-year08 0.0847 0.155 0.548 5.84e-01
-year09 0.6052 0.140 4.338 1.44e-05
-year10 -1.1699 0.306 -3.828 1.29e-04
-
-AIC: 4779.172
-\end{Soutput}
-\end{Schunk}
-\end{small}
-
-
-
-
-\subsection{Manipulating results: prediction and plotting}
+```
+
+```
+##
+## Call:
+## colext(psiformula = ~1, gammaformula = ~year - 1, epsilonformula = ~year -
+## 1, pformula = ~year - 1, data = simUMF)
+##
+## Initial:
+## Estimate SE z P(>|z|)
+## -0.273 0.302 -0.906 0.365
+##
+## Colonization:
+## Estimate SE z P(>|z|)
+## year01 -2.08 0.951 -2.19 2.86e-02
+## year02 -2.18 0.365 -5.96 2.52e-09
+## year03 -1.98 0.274 -7.23 4.88e-13
+## year04 -2.32 0.678 -3.42 6.37e-04
+## year05 -1.89 0.478 -3.95 7.78e-05
+## year06 -1.76 0.294 -5.97 2.44e-09
+## year07 -1.55 0.230 -6.73 1.75e-11
+## year08 -1.43 0.228 -6.29 3.19e-10
+## year09 -2.35 0.470 -5.00 5.64e-07
+##
+## Extinction:
+## Estimate SE z P(>|z|)
+## year01 -1.4209 0.418 -3.401 6.72e-04
+## year02 -0.4808 0.239 -2.009 4.45e-02
+## year03 -1.2606 0.366 -3.440 5.83e-04
+## year04 -0.0907 0.650 -0.139 8.89e-01
+## year05 -0.6456 0.599 -1.078 2.81e-01
+## year06 -0.9586 0.378 -2.539 1.11e-02
+## year07 -1.2279 0.365 -3.362 7.74e-04
+## year08 -1.1894 0.292 -4.076 4.58e-05
+## year09 -0.6292 0.635 -0.991 3.22e-01
+##
+## Detection:
+## Estimate SE z P(>|z|)
+## year01 -1.0824 0.244 -4.434 9.26e-06
+## year02 -0.2232 0.148 -1.508 1.32e-01
+## year03 0.2951 0.154 1.918 5.52e-02
+## year04 0.0662 0.161 0.412 6.81e-01
+## year05 -2.0396 0.433 -4.706 2.52e-06
+## year06 -0.6982 0.232 -3.005 2.66e-03
+## year07 0.2413 0.165 1.466 1.43e-01
+## year08 0.0847 0.155 0.548 5.84e-01
+## year09 0.6052 0.140 4.338 1.44e-05
+## year10 -1.1699 0.306 -3.828 1.29e-04
+##
+## AIC: 4779.172
+```
+
+## Manipulating results: prediction and plotting
Again, all estimates are shown on the logit-scale. Back-transforming
estimates when covariates, such as year, are present involves an
-extra step. Specifically, we need to tell \textbf{unmarked} the values
+extra step. Specifically, we need to tell `unmarked` the values
of our covariate
at which we want an estimate. This can be done using
-\emph{backTransform} in combination with \emph{linearComb}, although
-it can be easier to use \emph{predict}. \emph{predict} allows the user
+`backTransform` in combination with `linearComb`, although
+it can be easier to use `predict`. `predict` allows the user
to supply a data.frame in which each row represents a combination of
covariate values of interest. Below, we create data.frames called
-\emph{nd} with each row representing a year.
+`nd` with each row representing a year.
Then we request yearly estimates of the probability of extinction,
colonization and detection,
-and compare them to ``truth'', i.e., the values with which we
+and compare them to "truth", i.e., the values with which we
simulated the data set. Note that there are T-1 extinction and
colonization parameters in this case, so we do not need to include
-year `10' in \emph{nd}.
+year 10 in `nd`.
-\begin{small}
-<<eval=false>>=
+```r
nd <- data.frame(year=c('01','02','03','04','05','06','07','08','09'))
E.ext <- predict(m1, type='ext', newdata=nd)
E.col <- predict(m1, type='col', newdata=nd)
nd <- data.frame(year=c('01','02','03','04','05','06','07','08','09','10'))
E.det <- predict(m1, type='det', newdata=nd)
-@
-\end{small}
+```
-
-Predict returns the predictions along with standard errors and
+`predict` returns the predictions along with standard errors and
confidence intervals. These can be used to create plots. The
-\emph{with} function is used to simplify the process of requesting the
-columns of data.frame returned by \emph{predict}.
-
+`with` function is used to simplify the process of requesting the
+columns of `data.frame` returned by `predict`.
-\begin{small}
-<<yearlysim,eval=false,fig=true,include=false,width=3,height=7>>=
+```r
op <- par(mfrow=c(3,1), mai=c(0.6, 0.6, 0.1, 0.1))
with(E.ext, { # Plot for extinction probability
@@ -787,99 +661,75 @@ with(E.det, { # Plot for detection probability: note 10 years
legend(7.5, 1, c('Parameter','Estimate'), col=c(1,4), pch=c(16, 1),
cex=0.8)
})
+```
-par(op)
-@
-
-\end{small}
-
-
+![Figure 2. Yearly estimates of parameters](colext-est-1.png)
+```r
+par(op)
+```
-\begin{figure}
- \centering
- \includegraphics[width=3in,height=7in]{colext-yearlysim.pdf}
- \caption{Yearly estimates of $\epsilon$, $\gamma$ and $p$.}
- \label{fig:yearlysim}
-\end{figure}
-
-Figure~\ref{fig:yearlysim} shows that the 95\% confidence intervals
+Figure 2 shows that the 95% confidence intervals
include the true parameter values, and the point estimates are not too
far off.
-
-\subsection{Derived parameters}
+## Derived parameters
Estimates of occupancy probability in years $T>1$ must be derived from the
estimates of first-year occupancy and the two parameters governing the
dynamics, extinction/survival and colonization.
-\textbf{unmarked} does this automatically in two ways. First, the
+`unmarked` does this automatically in two ways. First, the
population-level estimates of occupancy probability
$\psi_t = \psi_{t-1}\phi_{t-1} + (1-\phi_{t-1})\gamma$ are calculated
and stored in the slot named \emph{projected}. Slots can be accessed
-using the @ operator, e.g. fm@projected.
+using the `@` operator, e.g. `fm@projected`.
In some cases, interest may lie in making
inference about the proportion of the sampled sites that are occupied,
rather than the entire population of sites. These estimates are
-contained in the \emph{smoothed} slot of the fitted model. Thus, the
-\emph{projected} values are estimates of population parameters, and
-the \emph{smoothed} estimates are of the finite-sample
-quantities. Discussions of the differences can be found in Weir et
-al. (2009).
+contained in the `smoothed` slot of the fitted model. Thus, the
+`projected` values are estimates of population parameters, and
+the `smoothed` estimates are of the finite-sample
+quantities. Discussions of the differences can be found in @Weir_2009.
Bootstrap methods can be used to compute standard errors of derived
parameter estimates. Here we employ a non-parametric bootstrap to obtain
standard errors of the smoothed estimates of occupancy probability
during each year.
-\begin{small}
-%<<eval=true>>=
-%m1 <- nonparboot(m1, B = 10)
-%@
-%<<eval=true>>=
-%cbind(psi=psi, smoothed=smoothed(m1)[2,], SE=m1@smoothed.mean.bsse[2,])
-%@
-
-
-\begin{Schunk}
-\begin{Sinput}
-> m1 <- nonparboot(m1, B = 10)
-> cbind(psi=psi, smoothed=smoothed(m1)[2,], SE=m1@smoothed.mean.bsse[2,])
-\end{Sinput}
-\begin{Soutput}
- psi smoothed SE
-1 0.4000000 0.4320671 0.05781066
-2 0.3493746 0.4110124 0.03605041
-3 0.2977125 0.3139967 0.02811819
-4 0.3148447 0.3278179 0.02861192
-5 0.3192990 0.2316695 0.06840470
-6 0.2915934 0.2528485 0.03243467
-7 0.3114415 0.2928429 0.02950853
-8 0.3636580 0.3504885 0.03023857
-9 0.3654064 0.3936991 0.02617258
-10 0.3460641 0.3095786 0.07354332
-\end{Soutput}
-\end{Schunk}
-
-
-\end{small}
-
-
-In practice, B should be much higher, possibly $>$ 1000 for complex
+
+```r
+m1 <- nonparboot(m1, B = 10)
+cbind(psi=psi, smoothed=smoothed(m1)[2,], SE=m1@smoothed.mean.bsse[2,])
+```
+
+```
+## psi smoothed SE
+## 1 0.4000000 0.4320671 0.06783911
+## 2 0.3493746 0.4110124 0.03786402
+## 3 0.2977125 0.3139967 0.02780818
+## 4 0.3148447 0.3278179 0.04303542
+## 5 0.3192990 0.2316695 0.10858419
+## 6 0.2915934 0.2528485 0.04179036
+## 7 0.3114415 0.2928429 0.03113920
+## 8 0.3636580 0.3504885 0.04224678
+## 9 0.3654064 0.3936991 0.02103870
+## 10 0.3460641 0.3095786 0.06830698
+```
+
+In practice, `B` should be much higher, possibly >1000 for complex
models .
Another derived parameters of interest is turnover probability
-\[
+$$
\tau_t = \frac{\gamma_{t-1}(1-\psi_{t-1})}{\gamma_{t-1}(1-\psi_{t-1})
+ \phi_{t-1}\psi_{t-1}}
-\]
+$$
The following function returns these estimates.
-\begin{small}
-<<>>=
+```r
turnover <- function(fm) {
psi.hat <- plogis(coef(fm, type="psi"))
if(length(psi.hat) > 1)
@@ -897,53 +747,38 @@ turnover <- function(fm) {
}
return(tau.hat)
}
-@
-\end{small}
-
-
+```
The bootstrap again offers a means of estimating variance. Here we
show how to generate 95\% confidence intervals for the turnover
estimates using the parametric bootstrap.
-\begin{small}
-
-
-\begin{Schunk}
-\begin{Sinput}
-> pb <- parboot(m1, statistic=turnover, nsim=2)
-> turnCI <- cbind(pb@t0,
- t(apply(pb@t.star, 2, quantile, probs=c(0.025, 0.975))))
-> colnames(turnCI) <- c("tau", "lower", "upper")
-\end{Sinput}
-\end{Schunk}
-\begin{Schunk}
-\begin{Sinput}
-> turnCI
-\end{Sinput}
-\begin{Soutput}
- tau lower upper
-t*1 0.1532645 0.09613841 0.1060208
-t*2 0.1911530 0.14770601 0.1694802
-t*3 0.2537292 0.18514773 0.2469985
-t*4 0.2604356 0.18947604 0.2029920
-t*5 0.3989303 0.49754613 0.5671067
-t*6 0.3758690 0.28901007 0.3022026
-t*7 0.3537473 0.39050385 0.4278534
-t*8 0.3174983 0.25300357 0.3222170
-t*9 0.1704449 0.14896392 0.1815896
-\end{Soutput}
-\end{Schunk}
-
-
-\end{small}
-
+```r
+pb <- parboot(m1, statistic=turnover, nsim=2)
+turnCI <- cbind(pb@t0,
+ t(apply(pb@t.star, 2, quantile, probs=c(0.025, 0.975))))
+colnames(turnCI) <- c("tau", "lower", "upper")
+turnCI
+```
+
+```
+## tau lower upper
+## t*1 0.1532645 0.00536045 0.1974714
+## t*2 0.1911530 0.07881180 0.2119585
+## t*3 0.2537292 0.19777204 0.2785973
+## t*4 0.2604356 0.04063769 0.4197328
+## t*5 0.3989303 0.34078483 0.4720357
+## t*6 0.3758690 0.32703698 0.5370796
+## t*7 0.3537473 0.32696166 0.3564059
+## t*8 0.3174983 0.32925238 0.4139696
+## t*9 0.1704449 0.18946470 0.3186236
+```
Which bootstrap method is most appropriate for variance estimation?
For detailed distinctions between the
-non-parametric and the parametric bootstrap, see Davison and Hinkley
-(1997). We note simply that the parametric bootstrap resamples from
+non-parametric and the parametric bootstrap, see @Davison_1997.
+We note simply that the parametric bootstrap resamples from
the fitted model, and thus the
measures of uncertainty are purely
functions of the distributions assumed by the model. Non-parametric
@@ -951,10 +786,7 @@ bootstrap samples, in contrast, are obtained by resampling the
data, not the model, and thus are not necessarily affected by the
variance formulas of the model's distributions.
-
-
-\subsection{Goodness-of-fit}
-
+## Goodness-of-fit
In addition to estimating the variance of an estimate, the parametric
bootstrap can be used to assess goodness-of-fit. For this purpose, a
@@ -966,21 +798,17 @@ the distribution of the fit-statistic, and a \emph{P}-value
can be computed as the proportion of simulated values greater than the
observed value.
-Hosmer et al. (1997) found that a $\chi^2$ statistic performed
+@Hosmer_1997 found that a $\chi^2$ statistic performed
reasonably well in assessing lack of fit for logistic regression
models. We know of no studies formally
evaluating the performance of various fit-statistics for dynamic
occupancy models, so this approach should be
considered experimental. Fit-statistics applied to aggregated
-encounter histories offer an alternative approach (MacKenzie and
-Bailey 2004), but are difficult to implement when J*T is high and
+encounter histories offer an alternative approach [@MacKenzie_2004], but are difficult to implement when J*T is high and
missing values or continuous covariates are present.
-\begin{small}
-
-<<eval=false,echo=true>>=
-
+```r
chisq <- function(fm) {
umf <- getData(fm)
y <- getY(umf)
@@ -994,81 +822,79 @@ chisq <- function(fm) {
set.seed(344)
pb.gof <- parboot(m0, statistic=chisq, nsim=100)
-@
-<<gof,fig=true,include=false,width=5,height=5,echo=false,eval=false>>=
plot(pb.gof, xlab=expression(chi^2), main="", col=gray(0.95),
xlim=c(7300, 7700))
-@
-\end{small}
-
+```
-\begin{figure}[!h]
-\centering
-\includegraphics[width=5in,height=5in]{colext-gof.pdf}
-\caption{Goodness-of-fit}
-\label{fig:gof}
-\end{figure}
+![Figure 3. Goodness-of-fit](colext-gof-1.png)
-Figure~\ref{fig:gof} indicates that, as expected, the constant
+Figure 3 indicates that, as expected, the constant
parameter model does not fit the data well.
+# Dynamic occupancy models for crossbill data from the Swiss MHB
+## The crossbill data set
-\section{Dynamic occupancy models for crossbill data from the Swiss MHB}
-
-\subsection{The crossbill data set}
-The crossbill data are included with the \texttt{unmarked} package.
+The crossbill data are included with the `unmarked` package.
The dataset contains the results of nine years of surveys (1999--2007)
-for the European crossbill (\emph{Loxia curvirostra}),
+for the European crossbill (*Loxia curvirostra*),
a pine-seed eating finch, in 267 1-km$^2$ sample quadrats in Switzerland.
Quadrats are surveyed annually as part of the Swiss breeding bird
-survey MHB (Schmid et al. 2004).
+survey MHB [@schmid_etal:2004].
They are laid out as a grid over Switzerland and surveyed 2 or 3 times
every breeding season (mid-April to late June)
by experienced field ornithologists along a haphazard survey route of
-length 1--9 km (average 5 km).
+length 1-9 km (average 5 km).
High-elevation sites are only surveyed twice per breeding season.
+## Importing, formatting, and summarizing data
+The data can be loaded into an open R workspace using the `data` command.
-\subsection{Importing, formatting, and summarizing data}
-The data can be loaded into an open R workspace using the \verb+data+
-command.
-\begin{small}
-<<>>=
+```r
data(crossbill)
colnames(crossbill)
-@
-\end{small}
-
+```
+
+```
+## [1] "id" "ele" "forest" "surveys" "det991" "det992" "det993"
+## [8] "det001" "det002" "det003" "det011" "det012" "det013" "det021"
+## [15] "det022" "det023" "det031" "det032" "det033" "det041" "det042"
+## [22] "det043" "det051" "det052" "det053" "det061" "det062" "det063"
+## [29] "det071" "det072" "det073" "date991" "date992" "date993" "date001"
+## [36] "date002" "date003" "date011" "date012" "date013" "date021" "date022"
+## [43] "date023" "date031" "date032" "date033" "date041" "date042" "date043"
+## [50] "date051" "date052" "date053" "date061" "date062" "date063" "date071"
+## [57] "date072" "date073"
+```
We have three covariates that vary by site: median elevation of the
-quadrat (ele, in metres), forest cover of the quadrat (forest, in
+quadrat (`ele`, in metres), forest cover of the quadrat (`forest`, in
percent) and the number of surveys per season (i.e., 2 or 3,
surveys).
These are called site covariates, because they vary by sites only.
-The 27 columns entitled ``det991''--``det073'' contain the crossbill
+The 27 columns entitled `det991` - `det073` contain the crossbill
detection/nondetection data during all surveys over the 9 years.
They contain a 1 when at least one crossbill was recorded during a
survey and a 0 otherwise.
-NAs indicate surveys that did not take place, either because a site is
+`NA`s indicate surveys that did not take place, either because a site is
high-elevation and has no third survey or because it failed to be
surveyed altogether in a year.
-The final 27 columns entitled ``date991'' -- ``date073'' give the Julian
+The final 27 columns entitled `date991` - `date073` give the Julian
date of each survey.
-They represent a `survey-covariate' or `observation covariate'.
-We note that the paper by Royle and K\'{e}ry (2007) used a subset of this
+They represent a "survey-covariate" or "observation covariate".
+We note that the paper by @Royle_2007 used a subset of this
data set.
-AIC-based model selection (see section 4.4.) requires
+AIC-based model selection (see section 5.4) requires
that all models are fit to the same data.
-\textbf{unmarked} removes missing data in a context specific way. For
-missing siteCovs, the entire row of data must be removed. However, for
-missing \emph{yearlySiteCovs} or \emph{obsCovs}, only the
+`unmarked` removes missing data in a context specific way. For
+missing `siteCovs`, the entire row of data must be removed. However, for
+missing `yearlySiteCovs` or `obsCovs`, only the
corresponding observation
-are removed. Thus, if \textbf{unmarked} removes different observations
+are removed. Thus, if `unmarked` removes different observations
from different models, the models cannot be compared using AIC. A way
around this is to remove the detection data corresponding to
missing covariates before fitting the models.
@@ -1076,47 +902,42 @@ The crossbill data have missing dates and so we remove the associated
detection/non-detection data.
-<<>>=
+
+```r
DATE <- as.matrix(crossbill[,32:58])
y.cross <- as.matrix(crossbill[,5:31])
y.cross[is.na(DATE) != is.na(y.cross)] <- NA
-@
+```
In addition, continuous covariates should be transformed in a way
that brings their values close to zero in order to improve
or even enable numerical convergence of the maximum-likelihood routine.
-We do this ``by hand'' and note that we could also have used the R
-function \emph{scale}. We subtract the mean and divide by the standard
+We do this "by hand" and note that we could also have used the R
+function `scale`. We subtract the mean and divide by the standard
deviation.
-\begin{small}
-<<eval=true>>=
+```r
sd.DATE <- sd(c(DATE), na.rm=TRUE)
mean.DATE <- mean(DATE, na.rm=TRUE)
DATE <- (DATE - mean.DATE) / sd.DATE
-@
-\end{small}
+```
Before we can fit occupancy models, we need to format this data set
appropriately.
-\begin{small}
-
-<<>>=
+```r
years <- as.character(1999:2007)
years <- matrix(years, nrow(crossbill), 9, byrow=TRUE)
umf <- unmarkedMultFrame(y=y.cross,
siteCovs=crossbill[,2:3], yearlySiteCovs=list(year=years),
obsCovs=list(date=DATE),
numPrimary=9)
-@
-\end{small}
-
+```
+## Model fitting
-\subsection{Model fitting}
We fit a series of models that represent different hypotheses about
the colonization-extinction dynamics of Swiss crossbills
at a spatial scale of 1 km$^2$.
@@ -1125,136 +946,94 @@ parameterization,
but for detection probability, we choose an effects parameterization.
The latter is more useful for getting predictions in the presence of
other explanatory variables for that parameter.
-For model fm5 with more complex covariate relationships, we use as
+For model `fm5` with more complex covariate relationships, we use as
starting values for the optimization routine
-the solution from a ``neighboring'' model with slightly less
-complexity, model fm4.
+the solution from a "neighboring" model with slightly less
+complexity, model `fm4`.
Wise choice of starting values can be decisive for success or failure
of maximum likelihood estimation.
-\begin{small}
-
-<<eval=false>>=
+```r
# A model with constant parameters
fm0 <- colext(~1, ~1, ~1, ~1, umf)
-@
-<<eval=false>>=
+
# Like fm0, but with year-dependent detection
fm1 <- colext(~1, ~1, ~1, ~year, umf)
-@
-<<eval=false>>=
+
# Like fm0, but with year-dependent colonization and extinction
fm2 <- colext(~1, ~year-1, ~year-1, ~1, umf)
-@
-<<eval=false>>=
+
# A fully time-dependent model
fm3 <- colext(~1, ~year-1, ~year-1, ~year, umf)
-@
-<<eval=false>>=
+
# Like fm3 with forest-dependence of 1st-year occupancy
fm4 <- colext(~forest, ~year-1, ~year-1, ~year, umf)
-@
-<<eval=false>>=
+
# Like fm4 with date- and year-dependence of detection
fm5 <- colext(~forest, ~year-1, ~year-1, ~year + date + I(date^2),
umf, starts=c(coef(fm4), 0, 0))
-@
-<<eval=false>>=
+
# Same as fm5, but with detection in addition depending on forest cover
fm6 <- colext(~forest, ~year-1, ~year-1, ~year + date + I(date^2) +
forest, umf)
-@
-\end{small}
-
-
+```
+## Model selection
-\subsection{Model selection}
We can compare models using the Akaike information criterion
($AIC$).
-Note that \textbf{unmarked} yields $AIC$, not $AIC_c$
+Note that `unmarked` yields $AIC$, not $AIC_c$
because the latter would require the sample size,
which is not really known for
hierarchical models such as the dynamic occupancy model.
-Model selection and model-averaged prediction in \textbf{unmarked}
-require that we create a list of models using \emph{fitList}.
+Model selection and model-averaged prediction in `unmarked`
+require that we create a list of models using `fitList`.
This function organizes models and conducts a series of tests to
ensure that the models were fit to the same data.
-\begin{small}
-
-%<<eval=true>>=
-%models <- fitList('psi(.)gam(.)eps(.)p(.)' = fm0,
-% 'psi(.)gam(.)eps(.)p(Y)' = fm1,
-% 'psi(.)gam(Y)eps(Y)p(.)' = fm2,
-% 'psi(.)gam(Y)eps(Y)p(Y)' = fm3,
-% 'psi(F)gam(Y)eps(Y)p(Y)' = fm4,
-% 'psi(F)gam(Y)eps(Y)p(YD2)' = fm5,
-% 'psi(F)gam(Y)eps(Y)p(YD2F)' = fm6)
-%ms <- modSel(models)
-%ms
-%@
-
-\begin{Schunk}
-\begin{Sinput}
-> models <- fitList('psi(.)gam(.)eps(.)p(.)' = fm0,
- 'psi(.)gam(.)eps(.)p(Y)' = fm1,
- 'psi(.)gam(Y)eps(Y)p(.)' = fm2,
- 'psi(.)gam(Y)eps(Y)p(Y)' = fm3,
- 'psi(F)gam(Y)eps(Y)p(Y)' = fm4,
- 'psi(F)gam(Y)eps(Y)p(YD2)' = fm5,
- 'psi(F)gam(Y)eps(Y)p(YD2F)' = fm6)
-> ms <- modSel(models)
-> ms
-\end{Sinput}
-\begin{Soutput}
- nPars AIC delta AICwt cumltvWt
-psi(F)gam(Y)eps(Y)p(YD2F) 30 4986.39 0.00 1.0e+00 1.00
-psi(F)gam(Y)eps(Y)p(YD2) 29 5059.30 72.91 1.5e-16 1.00
-psi(F)gam(Y)eps(Y)p(Y) 27 5095.38 108.99 2.2e-24 1.00
-psi(.)gam(.)eps(.)p(Y) 12 5111.32 124.93 7.5e-28 1.00
-psi(.)gam(Y)eps(Y)p(Y) 26 5127.63 141.24 2.1e-31 1.00
-psi(.)gam(Y)eps(Y)p(.) 18 5170.54 184.15 1.0e-40 1.00
-psi(.)gam(.)eps(.)p(.) 4 5193.50 207.11 1.1e-45 1.00
-\end{Soutput}
-\end{Schunk}
-
-\end{small}
-
+```r
+models <- fitList('psi(.)gam(.)eps(.)p(.)' = fm0,
+ 'psi(.)gam(.)eps(.)p(Y)' = fm1,
+ 'psi(.)gam(Y)eps(Y)p(.)' = fm2,
+ 'psi(.)gam(Y)eps(Y)p(Y)' = fm3,
+ 'psi(F)gam(Y)eps(Y)p(Y)' = fm4,
+ 'psi(F)gam(Y)eps(Y)p(YD2)' = fm5,
+ 'psi(F)gam(Y)eps(Y)p(YD2F)' = fm6)
+ms <- modSel(models)
+ms
+```
+
+```
+## nPars AIC delta AICwt cumltvWt
+## psi(F)gam(Y)eps(Y)p(YD2F) 30 4986.39 0.00 1.0e+00 1.00
+## psi(F)gam(Y)eps(Y)p(YD2) 29 5059.30 72.91 1.5e-16 1.00
+## psi(F)gam(Y)eps(Y)p(Y) 27 5095.38 108.99 2.2e-24 1.00
+## psi(.)gam(.)eps(.)p(Y) 12 5111.32 124.93 7.5e-28 1.00
+## psi(.)gam(Y)eps(Y)p(Y) 26 5127.63 141.24 2.1e-31 1.00
+## psi(.)gam(Y)eps(Y)p(.) 18 5170.54 184.15 1.0e-40 1.00
+## psi(.)gam(.)eps(.)p(.) 4 5193.50 207.11 1.1e-45 1.00
+```
One model has overwhelming support, so we can base inference on that
one alone. Before doing so, we point out how to extract coefficients
-from a \emph{fitList} object, and convert the results to a
-\emph{data.frame}, which could be exported from R.
-
-\begin{small}
+from a `fitList` object, and convert the results to a
+`data.frame`, which could be exported from R.
-%<<eval=false>>=
-%coef(ms) # Estimates only
-%SE(ms) # Standard errors only
-%toExport <- as(ms, "data.frame") # Everything
-%@
-\begin{Schunk}
-\begin{Sinput}
-> coef(ms) # Estimates only
-> SE(ms) # Standard errors only
-> toExport <- as(ms, "data.frame") # Everything
-\end{Sinput}
-\end{Schunk}
+```r
+coef(ms) # Estimates only
+SE(ms) # Standard errors only
+toExport <- as(ms, "data.frame") # Everything
+```
+## Manipulating results: Prediction and plotting
-\end{small}
-
-
-
-\subsection{Manipulating results: Prediction and plotting}
Fitted models can be used to predict expected outcomes when given new
-data. For example, one could ask ``how many crossbills would you
-expect to find in a quadrat with 50\% forest cover?'' Prediction also
+data. For example, one could ask "how many crossbills would you
+expect to find in a quadrat with 50% forest cover?" Prediction also
offers a way of
presenting the results of an analysis. We illustrate by plotting the
predictions of $\psi$ and $p$ over the range of covariate values studied.
@@ -1263,9 +1042,7 @@ to its original scale after obtaining predictions on the
standardized scale.
-\begin{small}
-
-<<cov,eval=false,fig=true,include=false,width=6,height=3>>=
+```r
op <- par(mfrow=c(1,2), mai=c(0.8,0.8,0.1,0.1))
nd <- data.frame(forest=seq(0, 100, length=50))
@@ -1292,138 +1069,23 @@ with(E.p, {
lines(dateOrig, Predicted+1.96*SE, col=gray(0.7))
lines(dateOrig, Predicted-1.96*SE, col=gray(0.7))
})
-par(op)
-@
-
-\end{small}
-
-
-\begin{figure}[!h]
-\centering
-\includegraphics[width=6in,height=3in]{colext-cov.pdf}
-\caption{Covariates}
-\label{fig:cov}
-\end{figure}
-
-
+```
+![Figure 4. Covariates](colext-pred-1.png)
+```r
+par(op)
+```
+**Acknowledgments**
-\section*{Acknowledgments}
-Special thanks goes to Ian Fiske, the author of \emph{colext} and the
-original developer of \textbf{unmarked}. Andy Royle provided the
+Special thanks goes to Ian Fiske, the author of `colext` and the
+original developer of `unmarked`. Andy Royle provided the
initial funding and support for the package. The questions of many
people on the users' list motivated the writing of this document.
+# References
-
-\newpage
-
-\section*{References}
-\newcommand{\rf}{\vskip .1in\par\sloppy\hangindent=1pc\hangafter=1
- \noindent}
-
-\rf Davison, A.C and D.V. Hinkley. 1997. \emph{Bootstrap Methods and Their
-Application}, first ed. Cambridge University Press.
-
-\rf Dorazio, R.M., and Royle, J.A. 2005. Estimating size and
-composition of biological communities by modeling the occurrence of
-species. Journal of the American Statistical Association 100:
-389--398.
-
-\rf Dorazio, R.M., K\'{e}ry, M., Royle, J.A., and Plattner,
-M. 2010. Models for inference in dynamic metacommunity
-systems. Ecology 91: 2466--2475.
-
-\rf Hanski, I. 1998. Metapopulation dynamics. Nature 396: 41--49.
-
-\rf Hosmer, D.W., T. Hosmer, S. le Cressie, and S. Lemeshow. 1997. A
-comparision of goodness-of-fit tests for the logistic
-regression model. Statistics in Medicine 16:965--980.
-
-\rf K\'{e}ry, M. 2010. \emph{Introduction to WinBUGS for
- Ecologists. A Bayesian approach to regression, ANOVA, mixed
- models and related analyses}. Academic Press, Burlington, MA.
-
-\rf K\'{e}ry, M., Royle, J.A., Plattner, M, and Dorazio,
-R.M. 2009. Species richness and occupancy estimation in communities
-subject to temporary emigration. Ecology 90: 1279--1290.
-
-\rf K\'{e}ry, M., and Schaub, M. 2011. \emph{Bayesian population
- analysis using WinBUGS}. Academic Press, Burlington. (due December
-2011)
-
-\rf K\'{e}ry, M., and Schmidt, B.R. 2008. Imperfect detection and its
-consequences for monitoring for conservation. Community Ecology 9:
-207--216.
-
-\rf MacKenzie, D.I and L. Bailey. 2004. Assessing the fit of
-site-occupancy models. Journal of Agricultural, Biological, and
-Environmental Statistics 9:300--318.
-
-\rf MacKenzie, D.I., Nichols, J.D., Hines, J.E., Knutson, M.G., and
-Franklin, A.B. 2003. Estimating site occupancy, colonization, and
-local extinction when a species is detected imperfectly. Ecology 84:
-2200--2207.
-
-\rf MacKenzie, D.I., Nichols, J.D., Lachman, G.B., Droege, S., Royle,
-J.A., and Langtimm, C.A. 2002. Estimating site occupancy rates when
-detection probability rates are less than one. Ecology 83:
-2248--2255.
-
-\rf MacKenzie, D.I., Nichols, J.D., Seamans, M.E., and Gutierrez,
-R.J. 2009. Modeling species occurrence dynamics with multiple states
-and imperfect detection. Ecology 90: 823--835.
-
-\rf McCullagh, P., and Nelder, J.A. 1989. \emph{Generalized linear
- models}. Chapman and Hall.
-
-\rf Miller, D.A., Nichols, J.D., McClintock, B.T., Grant, E.H.C.,
-Bailey, L.L., and Weir, L. 2011. Improving occupancy estimation when
-two types of observational errors occur: non-detection and species
-misidentification. Ecology, in press.
-
-\rf Moilanen, A. 2002. Implications of empirical data quality to
-metapopulation model parameter estimation and application. Oikos 96:
-516--530.
-
-\rf Nichols, J.D., Hines, J.E., MacKenzie, D.I., Seamans, M.E., and
-Gutierrez, R.J. 2007. Occupancy estimation and modeling with multiple
-states and state uncertainty. Ecology 88: 1395--1400.
-
-\rf Royle, J.A., Dorazio, R.M. 2008. \emph{Hierarchical modeling and
- inference in ecology: The analysis of data from populations,
- metapopulations, and communities}. Academic Press, San Diego.
-
-\rf Royle, J.A., and K\'{e}ry, M. 2007. A Bayesian state-space
-formulation of dynamic occupancy models. Ecology 88: 1813--1823.
-
-\rf Royle, J.A., and Link, W.A., 2005. A general class of multinomial
-mixture models for anuran calling survey data. Ecology 86:
-2505--2512.
-
-\rf Royle, J.A., and Link, W.A., 2006. Generalized site occupancy
-models allowing for false positive and false negative errors. Ecology
-87: 835--841.
-
-\rf Royle, J.A., and Nichols, J.D. 2003. Estimating abundance from
-repeated presence-absence data or point counts. Ecology 84, 777--790.
-
-\rf Schmid, H., Zbinden, N., and Keller,
-V. 2004. \emph{\"{U}berwachung der Bestandsentwicklung h\"{a}ufiger
- Brutv\"{o}gel in der Schweiz}. Swiss Ornithological Institute,
-Sempach, Switzerland.
-
-\rf Tyre, A.J., Tenhumberg, B., Field, S.A., Niejalke, D., Parris, K.,
-and Possingham, H.P. 2003. Improving precision and reducing bias in
-biological surveys: estimating false-negative error rates. Ecological
-Applications 13, 1790--1801.
-
-\rf Weir, L., I.J. Fiske, and J.A. Royle. 2009. Trends in anuran
-occupancy from northeastern states of the North American Amphibian
-Monitoring Program. Herpetological Conservation and Biology
-4:389--402.
-
-
-\end{document}
+```{r, echo=FALSE}
+options(rmarkdown.html_vignette.check_title = FALSE)
+```
diff --git a/vignettes/colext.Rmd.orig b/vignettes/colext.Rmd.orig
new file mode 100644
index 0000000..9e5a2cb
--- /dev/null
+++ b/vignettes/colext.Rmd.orig
@@ -0,0 +1,873 @@
+---
+title: Dynamic occupancy models in unmarked
+author:
+- name: Marc Kéry, Swiss Ornithological Institute
+- name: Richard Chandler, University of Georgia
+date: August 16, 2016
+bibliography: unmarked.bib
+csl: ecology.csl
+output:
+ rmarkdown::html_vignette:
+ fig_width: 5
+ fig_height: 3.5
+ number_sections: true
+ toc: true
+vignette: >
+ %\VignetteIndexEntry{Dynamic occupancy models}
+ %\VignetteEngine{knitr::rmarkdown}
+ \usepackage[utf8]{inputenc}
+---
+
+```{r,echo=FALSE}
+options(rmarkdown.html_vignette.check_title = FALSE)
+knitr::opts_chunk$set(message=FALSE, warning=FALSE)
+knitr::opts_chunk$set(fig.path="")
+set.seed(456)
+```
+
+# Abstract
+
+Dynamic occupancy models [@mackenzie_estimating_2003] allow inference about
+the occurrence of "things" at collections of "sites"
+and about how changes in occurrence are driven by colonization and
+local extinction. These models also account for imperfect detection
+probability. Depending on how "thing" and "site" are defined,
+occupancy may have vastly different biological meanings,
+including the presence of a disease in an individual (disease
+incidence) of a species at a site (occurrence, distribution), or of an
+individual in a territory.
+Dynamic occupancy models in `unmarked` are fit using the
+function `colext`.
+All parameters can be modeled as functions of covariates, i.e.,
+first-year occupancy with covariates varying by site
+(site-covariates),
+colonization and survival with site- and yearly-site-covariates and
+detection with site-, yearly-site- and sample-occasion-covariates.
+We give two commented example analyses: one for a simulated data set
+and another for a real data set on crossbills in the Swiss breeding
+bird survey MHB.
+We also give examples to show how predictions, along with standard
+errors and confidence intervals, can be obtained.
+
+# Introduction
+
+Occurrence is a quantity of central importance in many branches of
+ecology and related sciences.
+The presence of a disease in an individual or of a species
+at a site are two common types of occurrence studies.
+The associated biological metrics are the incidence of the disease and
+species occurrence or species distribution.
+Thus, depending on how we define the thing we are looking for and the
+sample unit, very different biological quantities can be analyzed
+using statistical models for occupancy.
+
+If we denote presence of the "thing" as $y=1$ and its absence as
+$y=0$, then it is natural to characterize all these metrics by the
+probability that a randomly chosen sample unit ("site") is occupied,
+i.e., has a "thing" present: $Pr(y=1) = \psi$.
+We call this the occupancy probability, or occupancy for short, and
+from now on will call the sample unit,
+where the presence or absence of a "thing" is assessed, generically
+a "site".
+
+Naturally, we would like to explore factors that affect the likelihood
+that a site is occupied.
+A binomial generalized linear model, or logistic regression, is the
+customary statistical model for occurrence.
+In this model, we treat occurrence $y$ as a binomial random variable
+with trial size 1 and success probability $p$, or, equivalently, a
+Bernoulli trial with $p$.
+"Success" means occurrence, so $p$ is the occurrence probability.
+It can be modeled as a linear or other function of covariates via a
+suitable link function, e.g., the logit link.
+This simple model is described in many places, including @McCullagh_1989,
+Royle and Dorazio [-@royle_dorazio:2008, chapter 3], Kéry [-@Kery_2010,
+chapter 17] and Kéry and Schaub [-@Kery_2011, chapter 3].
+
+A generalization of this model accounts for changes in the occupancy
+state of sites by introducing parameters for survival
+(or alternatively, extinction) and colonization probability.
+Thus, when we have observations of occurrence for more than a single
+point in time, we can model the transition of the occupancy
+state at site $i$ between successive times as another Bernoulli trial.
+To model the fate of an occupied site, we denote the probability that
+a site occupied at $t$ is again occupied at $t+1$ as $Pr(y_{i,t+1} = 1
+| y_{i,t} = 1 ) = \phi$.
+This represents the survival probability of a site that is occupied.
+Of course, we could also choose to express this component of occupancy
+dynamics by the converse, extinction probability $\epsilon$ ---
+the parameterization used in `unmarked`.
+To model the fate of an unoccupied site, we denote as $Pr(y_{i,t+1} =
+1 | y_{i,t} = 0 ) = \gamma$ the probability that an unoccupied site at
+$t$ becomes occupied at $t+1$.
+This is the colonization probability of an empty site.
+Such a dynamic model of occurrence has become famous in the ecological literature under the name "metapopulation model" [@Hanski_1998].
+
+However, when using ecological data collected in the field to fit such
+models of occurrence, we face the usual challenge of imperfect
+detection [e.g. @Kery_2008].
+For instance, a species can go unobserved at a surveyed site or an
+occupied territory can appear unoccupied during a particular survey,
+perhaps because both birds are away hunting.
+Not accounting for detection error may seriously bias all parameter
+estimators of a metapopulation model [@Moilanen_2002; @royle_dorazio:2008].
+To account for this additional stochastic component in the generation
+of most ecological field data, the classical metapopulation model may
+be generalized to include a submodel for the observation process,
+which allows an occupied site to be recorded as unoccupied.
+This model has been developed by @mackenzie_estimating_2003. It is
+described as a hierarchical model by @Royle_2007, Royle
+and Dorazio [-@royle_dorazio:2008, chapter 9] and Kéry and Schaub [-@Kery_2011, chapter 13].
+The model is usually called a multi-season, multi-year or a
+dynamic site-occupancy model.
+The former terms denote the fact that it is applied to multiple
+"seasons" or years and the latter emphasizes that the model allows
+for between-season occurrence dynamics.
+
+This vignette describes the use of the `unmarked` function
+`colext` to fit dynamic occupancy models. Note that we will use
+italics for the names of functions.
+Static occupancy models, i.e., for a single season without changes in
+the occupancy state [@mackenzie_estimating_2002], can be fit with `occu`,
+for the model described by @mackenzie_estimating_2002 and @Tyre_2002, and with `occuRN`, for the heterogeneity occupancy model
+described by @royle_estimating_2003.
+In the next section (section 2), we give a more technical description
+of the dynamic occupancy model.
+In section 3, we provide R code for generating data under a basic
+dynamic occupancy model and illustrate use of `colext` for fitting the
+model.
+In section 4, we use real data from the Swiss breeding bird survey MHB
+[@schmid_etal:2004] to fit a few more elaborate models with
+covariates for all parameters.
+We also give examples illustrating how to compute predictions, with
+standard errors and 95% confidence intervals, for the parameters.
+
+# Dynamic occupancy models
+
+To be able to estimate the parameters of the dynamic occupancy model
+(probabilities of occurrence, survival and colonization) separately
+from the parameters for the observation process (detection
+probability), replicate observations are required from a period of
+closure,
+during which the occupancy state of a site must remain constant, i.e.,
+it is either occupied or unoccupied.
+The modeled data $y_{ijt}$ are indicators for whether a species is
+detected at site $i$ ($i = 1, 2, \ldots M$), during replicate survey
+$j$ ($j = 1, 2, \ldots J$) in season $t$ ($t = 1, 2, \ldots T$).
+That is, $y_{ijt}=1$ if at least one individual is detected and
+$y_{ijt}=0$ if none is detected.
+
+The model makes the following assumptions:
+* replicate surveys at a site during a single season are
+ independent (or else dependency must be modeled)
+* occurrence state $z_{it}$ (see below) does not change over
+ replicate surveys at site $i$ during season $t$
+* there are no false-positive errors, i.e., a species can only be
+ overlooked where it occurs, but it cannot be detected where it does
+ not in fact occur (i.e., there are no false-positives)
+
+The complete model consists of one submodel to describe the ecological
+process, or state, and another submodel for the observation process,
+which is dependent on the result of the ecological process.
+The ecological process describes the latent occurrence dynamics for
+all sites in terms of parameters for the probability of initial
+occurrence and site survival and colonization.
+The observation process describes the probability of detecting a
+presence (i.e., $y = 1$) at a site that is occupied and takes account
+of false-negative observation errors.
+
+## Ecological or state process
+
+This initial state is denoted $z_{i1}$ and represents occurrence at
+site $i$ during season 1.
+For this, the model assumes a Bernoulli trial governed by the
+occupancy probability in the first season $\psi_{i1}$:
+
+$$
+z_{i1} = Bernoulli(\psi_{i1})
+$$
+
+We must distinguish the sample quantity "occurrence" at a site, $z$,
+from the population quantity "occupancy probability", $\psi$.
+The former is the realization of a Bernoulli random variable with
+parameter $\psi$.
+This distinction becomes important when we want to compute the number
+of occupied sites among the sample of surveyed sites;
+see @Royle_2007 and @Weir_2009 for this
+distinction.
+
+For all later seasons ($t = 2, 3, \ldots T$), occurrence is a function
+of occurrence at site $i$ at time $t-1$ and one of two parameters that
+describe the colonization-extinction dynamics of the system.
+These dynamic parameters are the probability of local survival
+$\phi_{it}$, also called probability of persistence (= 1 minus the
+probability of local extinction),
+and the probability of colonization $\gamma_{it}$.
+
+$$
+z_{it} \sim Bernoulli(z_{i,t-1} \phi_{it} + (1-z_{i,t-1}) \gamma_{it})
+$$
+
+Hence, if site $i$ is unoccupied at $t-1$ , $z_{i,t-1}=0$, and the
+success probability of the Bernoulli is
+$0*\phi_{it} + (1-0) * \gamma_{it}$, so the site is occupied
+(=colonized) in season $t$ with probability $\gamma_{it}$
+. Conversely, if site $i$ is occupied at $t-1$ , $z_{i,t-1}=1$, and
+the success probability of the Bernoulli is given by $1*\phi_{it} +
+(1-1) * \gamma_{it}$, so the site is occupied in (=survives to) season
+$t$ with probability $\phi_{it}$.
+
+Occupancy probability ($\psi_{it}$) and occurrence ($z_{it}$) at all
+later times $t$ can be computed recursively from $\psi_{i1}$,
+$z_{i1}$ , $\phi_{it}$ and $\gamma_{it}$.
+Variances of these derived estimates can be obtained via the delta
+method or the bootstrap.
+
+## Observation process
+
+To account for the observation error (specifically, false-negative
+observations), the conventional Bernoulli detection process is
+assumed, such that
+
+$$
+y_{ijt} \sim Bernoulli(z_{it} p_{ijt})
+$$
+
+Here, $y_{ijt}$ is the detection probability at site $i$ during
+survey $j$ and season $t$. Detection is conditional on occurrence, and
+multiplying $p_{ijt}$ with $z_{it}$ ensures that occurrence can only
+be detected where in fact a species occurs, i.e. where $z_{it}=1$.
+
+## Modeling of parameters
+
+The preceding, fully general model description allows for site-($i$)
+dependence of all parameters. In addition to that, survival and
+colonization probabilities may be season-($t$)dependent and detection
+probability season-($t$) and survey-($j$) dependent.
+All this complexity may be dropped, especially the dependence on
+sites. On the other hand, all parameters that are indexed in some way
+can be modeled, e.g., as functions of covariates that vary along the
+dimension denoted by an index. We will fit linear functions (on the
+logit link scale) of covariates into first-year occupancy, survival
+and colonization and into detection probability.
+That is, for probabilities of first-year occupancy, survival,
+colonization and detection, respectively, we will fit models of the
+form
+ $logit(\psi_{i1}) = \alpha + \beta x_i$, where $x_i$ may be forest
+ cover or elevation of site $i$ ,
+ $logit(\phi_{it}) = \alpha + \beta x_{it}$, where $x_{it}$ may be
+ tree mast at site $i$ during season $t$,
+ $logit(\gamma_{it}) = \alpha + \beta x_{it}$, for a similarly
+ defined covariate $x_{it}$, or
+ $logit(p_{ijt}) = \alpha + \beta x_{ijt}$ , where $x_{ijt}$ is the
+ Julian date of the survey $j$ at site $i$ in season $t$.
+
+We note that for first-year occupancy, only covariates that vary among
+sites ("site covariates") can be fitted, while for survival and
+colonization, covariates that vary by site and by season ("yearly
+site covariates") may be fitted as well.
+For detection, covariates of three formats may be fitted:
+"site-covariates", "yearly-site-covariates" and
+"observation-covariates", as
+they are called in `unmarked`.
+
+# Dynamic occupancy models for simulated data
+
+We first generate a simple, simulated data set
+with specified, year-specific values for
+the parameters as well as design specifications, i.e., number of
+sites, years and surveys per year.
+Then, we show how to fit a dynamic occupancy model with
+year-dependence in the parameters for colonization, extinction and
+detection probability.
+
+## Simulating, formatting, and summarizing data
+
+To simulate the data, we execute the following R code.
+The actual values for these parameters for each year are drawn
+randomly from a uniform distribution with
+the specified bounds.
+
+```{r}
+M <- 250 # Number of sites
+J <- 3 # num secondary sample periods
+T <- 10 # num primary sample periods
+
+psi <- rep(NA, T) # Occupancy probability
+muZ <- z <- array(dim = c(M, T)) # Expected and realized occurrence
+y <- array(NA, dim = c(M, J, T)) # Detection histories
+
+set.seed(13973)
+psi[1] <- 0.4 # Initial occupancy probability
+p <- c(0.3,0.4,0.5,0.5,0.1,0.3,0.5,0.5,0.6,0.2)
+phi <- runif(n=T-1, min=0.6, max=0.8) # Survival probability (1-epsilon)
+gamma <- runif(n=T-1, min=0.1, max=0.2) # Colonization probability
+
+# Generate latent states of occurrence
+# First year
+z[,1] <- rbinom(M, 1, psi[1]) # Initial occupancy state
+# Later years
+for(i in 1:M){ # Loop over sites
+ for(k in 2:T){ # Loop over years
+ muZ[k] <- z[i, k-1]*phi[k-1] + (1-z[i, k-1])*gamma[k-1]
+ z[i,k] <- rbinom(1, 1, muZ[k])
+ }
+}
+
+# Generate detection/non-detection data
+for(i in 1:M){
+ for(k in 1:T){
+ prob <- z[i,k] * p[k]
+ for(j in 1:J){
+ y[i,j,k] <- rbinom(1, 1, prob)
+ }
+ }
+}
+
+# Compute annual population occupancy
+for (k in 2:T){
+ psi[k] <- psi[k-1]*phi[k-1] + (1-psi[k-1])*gamma[k-1]
+ }
+```
+
+We have now generated a single realization from the stochastic system
+thus defined. Figure 1
+illustrates the fundamental issue
+of imperfect detection --- the actual proportion of sites occupied
+differs greatly from the observed proportion of sites occupied, and
+because $p$ varies among years, the observed data cannot be used as a
+valid index of the parameter of interest $\psi_i$.
+
+
+
+```{r colext-data, fig.width=5, fig.height=5, fig.cap="Figure 1. Summary of the multi-year occupancy data set generated."}
+plot(1:T, colMeans(z), type = "b", xlab = "Year",
+ ylab = "Proportion of sites occupied",
+ col = "black", xlim=c(0.5, 10.5), xaxp=c(1,10,9),
+ ylim = c(0,0.6), lwd = 2, lty = 1,
+ frame.plot = FALSE, las = 1, pch=16)
+
+psi.app <- colMeans(apply(y, c(1,3), max))
+lines(1:T, psi.app, type = "b", col = "blue", lty=3, lwd = 2)
+legend(1, 0.6, c("truth", "observed"),
+ col=c("black", "blue"), lty=c(1,3), pch=c(16,1))
+```
+
+To analyze this data set with a dynamic occupancy model in
+`unmarked`, we first load the package.
+
+```{r}
+library(unmarked)
+```
+
+Next, we reformat the detection/non-detection data from a 3-dimensional
+array (as generated) into a 2-dimensional matrix with M rows.
+That is, we put the annual tables of data (the slices of the former
+3-D array) sideways to produce a "wide" layout of the data.
+
+```{r}
+yy <- matrix(y, M, J*T)
+```
+
+Next, we create a matrix indicating the year each site was surveyed.
+
+```{r}
+year <- matrix(c('01','02','03','04','05','06','07','08','09','10'),
+ nrow(yy), T, byrow=TRUE)
+```
+
+To organize the data in the format required by `colext`, we make
+use of the function `unmarkedMultFrame`. The only required
+arguments are `y`, the detection/non-detection data, and
+`numPrimary`, the number of seasons. The three types of
+covariates described earlier can also be supplied using the arguments
+`siteCovs`, `yearlySiteCovs`, and `obsCovs`. In this case,
+we only make use of the second type, which must have M rows and T
+columns.
+
+```{r}
+simUMF <- unmarkedMultFrame(
+ y = yy,
+ yearlySiteCovs = list(year = year),
+ numPrimary=T)
+summary(simUMF)
+```
+
+## Model fitting
+
+We are ready to fit a few dynamic occupancy models.
+We will fit a model with constant values for all parameters and
+another with full time-dependence for colonization, extinction and
+detection probability. We also time the calculations.
+
+```{r}
+# Model with all constant parameters
+m0 <- colext(psiformula= ~1, gammaformula = ~ 1, epsilonformula = ~ 1,
+ pformula = ~ 1, data = simUMF, method="BFGS")
+summary(m0)
+```
+
+The computation time was only a few seconds.
+Note that all parameters were estimated on the logit scale. To
+back-transform to the original scale, we can simply use the
+inverse-logit function, named `plogis` in R.
+
+```{r}
+plogis(-0.813)
+```
+
+Alternatively, we can use `backTransform`, which
+computes standard errors using the delta method. Confidence intervals
+are also easily obtained using the function `confint`.
+We first remind ourselves of the names of parameters, which can all be
+used as arguments for these functions.
+
+```{r}
+names(m0)
+backTransform(m0, type="psi")
+confint(backTransform(m0, type="psi"))
+```
+
+Next, we fit the dynamic occupancy model with full year-dependence in
+the parameters describing occupancy dynamics and also in detection.
+This is the same model under which we generated the data set, so we
+would expect accurate estimates.
+
+By default in R, a factor such as year in this analysis, is a
+parameterized in terms of an intercept and effects representing
+differences. This would mean that the parameter for the first year is
+the intercept and the effects would denote the differences between
+the parameter values in all other years, relative to the parameter
+value in the first year, which serves as a reference level.
+This treatment or effects parameterization is useful for testing for
+differences. For simple presentation, a means parameterization is more
+practical. It can be specified by adding a -1 to the formula for the
+time-dependent parameters.
+
+```{r}
+m1 <- colext(psiformula = ~1, # First-year occupancy
+ gammaformula = ~ year-1, # Colonization
+ epsilonformula = ~ year-1, # Extinction
+ pformula = ~ year-1, # Detection
+ data = simUMF)
+m1
+```
+
+## Manipulating results: prediction and plotting
+
+Again, all estimates are shown on the logit-scale. Back-transforming
+estimates when covariates, such as year, are present involves an
+extra step. Specifically, we need to tell `unmarked` the values
+of our covariate
+at which we want an estimate. This can be done using
+`backTransform` in combination with `linearComb`, although
+it can be easier to use `predict`. `predict` allows the user
+to supply a data.frame in which each row represents a combination of
+covariate values of interest. Below, we create data.frames called
+`nd` with each row representing a year.
+Then we request yearly estimates of the probability of extinction,
+colonization and detection,
+and compare them to "truth", i.e., the values with which we
+simulated the data set. Note that there are T-1 extinction and
+colonization parameters in this case, so we do not need to include
+year 10 in `nd`.
+
+```{r}
+nd <- data.frame(year=c('01','02','03','04','05','06','07','08','09'))
+E.ext <- predict(m1, type='ext', newdata=nd)
+E.col <- predict(m1, type='col', newdata=nd)
+nd <- data.frame(year=c('01','02','03','04','05','06','07','08','09','10'))
+E.det <- predict(m1, type='det', newdata=nd)
+```
+
+`predict` returns the predictions along with standard errors and
+confidence intervals. These can be used to create plots. The
+`with` function is used to simplify the process of requesting the
+columns of `data.frame` returned by `predict`.
+
+```{r colext-est, fig.height=7, fig.width=3, fig.cap="Figure 2. Yearly estimates of parameters"}
+op <- par(mfrow=c(3,1), mai=c(0.6, 0.6, 0.1, 0.1))
+
+with(E.ext, { # Plot for extinction probability
+ plot(1:9, Predicted, pch=1, xaxt='n', xlab='Year',
+ ylab=expression(paste('Extinction probability ( ', epsilon, ' )')),
+ ylim=c(0,1), col=4)
+ axis(1, at=1:9, labels=nd$year[1:9])
+ arrows(1:9, lower, 1:9, upper, code=3, angle=90, length=0.03, col=4)
+ points((1:9)-0.1, 1-phi, col=1, lwd = 1, pch=16)
+ legend(7, 1, c('Parameter', 'Estimate'), col=c(1,4), pch=c(16, 1),
+ cex=0.8)
+ })
+
+with(E.col, { # Plot for colonization probability
+ plot(1:9, Predicted, pch=1, xaxt='n', xlab='Year',
+ ylab=expression(paste('Colonization probability ( ', gamma, ' )')),
+ ylim=c(0,1), col=4)
+ axis(1, at=1:9, labels=nd$year[1:9])
+ arrows(1:9, lower, 1:9, upper, code=3, angle=90, length=0.03, col=4)
+ points((1:9)-0.1, gamma, col=1, lwd = 1, pch=16)
+ legend(7, 1, c('Parameter', 'Estimate'), col=c(1,4), pch=c(16, 1),
+ cex=0.8)
+ })
+
+with(E.det, { # Plot for detection probability: note 10 years
+ plot(1:10, Predicted, pch=1, xaxt='n', xlab='Year',
+ ylab=expression(paste('Detection probability ( ', p, ' )')),
+ ylim=c(0,1), col=4)
+ axis(1, at=1:10, labels=nd$year)
+ arrows(1:10, lower, 1:10, upper, code=3, angle=90, length=0.03, col=4)
+ points((1:10)-0.1, p, col=1, lwd = 1, pch=16)
+ legend(7.5, 1, c('Parameter','Estimate'), col=c(1,4), pch=c(16, 1),
+ cex=0.8)
+ })
+
+par(op)
+```
+
+Figure 2 shows that the 95% confidence intervals
+include the true parameter values, and the point estimates are not too
+far off.
+
+## Derived parameters
+
+Estimates of occupancy probability in years $T>1$ must be derived from the
+estimates of first-year occupancy and the two parameters governing the
+dynamics, extinction/survival and colonization.
+`unmarked` does this automatically in two ways. First, the
+population-level estimates of occupancy probability
+$\psi_t = \psi_{t-1}\phi_{t-1} + (1-\phi_{t-1})\gamma$ are calculated
+and stored in the slot named \emph{projected}. Slots can be accessed
+using the `@` operator, e.g. `fm@projected`.
+In some cases, interest may lie in making
+inference about the proportion of the sampled sites that are occupied,
+rather than the entire population of sites. These estimates are
+contained in the `smoothed` slot of the fitted model. Thus, the
+`projected` values are estimates of population parameters, and
+the `smoothed` estimates are of the finite-sample
+quantities. Discussions of the differences can be found in @Weir_2009.
+
+Bootstrap methods can be used to compute standard errors of derived
+parameter estimates. Here we employ a non-parametric bootstrap to obtain
+standard errors of the smoothed estimates of occupancy probability
+during each year.
+
+```{r}
+m1 <- nonparboot(m1, B = 10)
+cbind(psi=psi, smoothed=smoothed(m1)[2,], SE=m1@smoothed.mean.bsse[2,])
+```
+
+In practice, `B` should be much higher, possibly >1000 for complex
+models .
+
+Another derived parameters of interest is turnover probability
+
+$$
+\tau_t = \frac{\gamma_{t-1}(1-\psi_{t-1})}{\gamma_{t-1}(1-\psi_{t-1})
+ + \phi_{t-1}\psi_{t-1}}
+$$
+
+The following function returns these estimates.
+
+```{r}
+turnover <- function(fm) {
+ psi.hat <- plogis(coef(fm, type="psi"))
+ if(length(psi.hat) > 1)
+ stop("this function only works if psi is scalar")
+ T <- getData(fm)@numPrimary
+ tau.hat <- numeric(T-1)
+ gamma.hat <- plogis(coef(fm, type="col"))
+ phi.hat <- 1 - plogis(coef(fm, type="ext"))
+ if(length(gamma.hat) != T-1 | length(phi.hat) != T-1)
+ stop("this function only works if gamma and phi T-1 vectors")
+ for(t in 2:T) {
+ psi.hat[t] <- psi.hat[t-1]*phi.hat[t-1] +
+ (1-psi.hat[t-1])*gamma.hat[t-1]
+ tau.hat[t-1] <- gamma.hat[t-1]*(1-psi.hat[t-1]) / psi.hat[t]
+ }
+ return(tau.hat)
+ }
+```
+
+The bootstrap again offers a means of estimating variance. Here we
+show how to generate 95\% confidence intervals for the turnover
+estimates using the parametric bootstrap.
+
+```{r}
+pb <- parboot(m1, statistic=turnover, nsim=2)
+turnCI <- cbind(pb@t0,
+ t(apply(pb@t.star, 2, quantile, probs=c(0.025, 0.975))))
+colnames(turnCI) <- c("tau", "lower", "upper")
+turnCI
+```
+
+Which bootstrap method is most appropriate for variance estimation?
+For detailed distinctions between the
+non-parametric and the parametric bootstrap, see @Davison_1997.
+We note simply that the parametric bootstrap resamples from
+the fitted model, and thus the
+measures of uncertainty are purely
+functions of the distributions assumed by the model. Non-parametric
+bootstrap samples, in contrast, are obtained by resampling the
+data, not the model, and thus are not necessarily affected by the
+variance formulas of the model's distributions.
+
+## Goodness-of-fit
+
+In addition to estimating the variance of an estimate, the parametric
+bootstrap can be used to assess goodness-of-fit. For this purpose, a
+fit-statistic, i.e. one that compares
+observed and expected values, is evaluated using the original fitted
+model, and numerous other models fitted to simulated datasets. The
+simulation yields an approximation of
+the distribution of the fit-statistic, and a \emph{P}-value
+can be computed as the proportion of simulated values greater than the
+observed value.
+
+@Hosmer_1997 found that a $\chi^2$ statistic performed
+reasonably well in assessing lack of fit for logistic regression
+models. We know of no studies formally
+evaluating the performance of various fit-statistics for dynamic
+occupancy models, so this approach should be
+considered experimental. Fit-statistics applied to aggregated
+encounter histories offer an alternative approach [@MacKenzie_2004], but are difficult to implement when J*T is high and
+missing values or continuous covariates are present.
+
+```{r colext-gof, fig.height=5, fig.width=5, fig.cap="Figure 3. Goodness-of-fit"}
+chisq <- function(fm) {
+ umf <- getData(fm)
+ y <- getY(umf)
+ sr <- fm@sitesRemoved
+ if(length(sr)>0)
+ y <- y[-sr,,drop=FALSE]
+ fv <- fitted(fm, na.rm=TRUE)
+ y[is.na(fv)] <- NA
+ sum((y-fv)^2/(fv*(1-fv)))
+ }
+
+set.seed(344)
+pb.gof <- parboot(m0, statistic=chisq, nsim=100)
+
+plot(pb.gof, xlab=expression(chi^2), main="", col=gray(0.95),
+ xlim=c(7300, 7700))
+```
+
+Figure 3 indicates that, as expected, the constant
+parameter model does not fit the data well.
+
+# Dynamic occupancy models for crossbill data from the Swiss MHB
+
+## The crossbill data set
+
+The crossbill data are included with the `unmarked` package.
+The dataset contains the results of nine years of surveys (1999--2007)
+for the European crossbill (*Loxia curvirostra*),
+a pine-seed eating finch, in 267 1-km$^2$ sample quadrats in Switzerland.
+Quadrats are surveyed annually as part of the Swiss breeding bird
+survey MHB [@schmid_etal:2004].
+They are laid out as a grid over Switzerland and surveyed 2 or 3 times
+every breeding season (mid-April to late June)
+by experienced field ornithologists along a haphazard survey route of
+length 1-9 km (average 5 km).
+High-elevation sites are only surveyed twice per breeding season.
+
+## Importing, formatting, and summarizing data
+
+The data can be loaded into an open R workspace using the `data` command.
+
+```{r}
+data(crossbill)
+colnames(crossbill)
+```
+
+We have three covariates that vary by site: median elevation of the
+quadrat (`ele`, in metres), forest cover of the quadrat (`forest`, in
+percent) and the number of surveys per season (i.e., 2 or 3,
+surveys).
+These are called site covariates, because they vary by sites only.
+The 27 columns entitled `det991` - `det073` contain the crossbill
+detection/nondetection data during all surveys over the 9 years.
+They contain a 1 when at least one crossbill was recorded during a
+survey and a 0 otherwise.
+`NA`s indicate surveys that did not take place, either because a site is
+high-elevation and has no third survey or because it failed to be
+surveyed altogether in a year.
+The final 27 columns entitled `date991` - `date073` give the Julian
+date of each survey.
+They represent a "survey-covariate" or "observation covariate".
+We note that the paper by @Royle_2007 used a subset of this
+data set.
+
+AIC-based model selection (see section 5.4) requires
+that all models are fit to the same data.
+`unmarked` removes missing data in a context specific way. For
+missing `siteCovs`, the entire row of data must be removed. However, for
+missing `yearlySiteCovs` or `obsCovs`, only the
+corresponding observation
+are removed. Thus, if `unmarked` removes different observations
+from different models, the models cannot be compared using AIC. A way
+around this is to remove the detection data corresponding to
+missing covariates before fitting the models.
+The crossbill data have missing dates and so we remove the associated
+detection/non-detection data.
+
+
+```{r}
+DATE <- as.matrix(crossbill[,32:58])
+y.cross <- as.matrix(crossbill[,5:31])
+y.cross[is.na(DATE) != is.na(y.cross)] <- NA
+```
+
+In addition, continuous covariates should be transformed in a way
+that brings their values close to zero in order to improve
+or even enable numerical convergence of the maximum-likelihood routine.
+We do this "by hand" and note that we could also have used the R
+function `scale`. We subtract the mean and divide by the standard
+deviation.
+
+```{r}
+sd.DATE <- sd(c(DATE), na.rm=TRUE)
+mean.DATE <- mean(DATE, na.rm=TRUE)
+DATE <- (DATE - mean.DATE) / sd.DATE
+```
+
+Before we can fit occupancy models, we need to format this data set
+appropriately.
+
+```{r}
+years <- as.character(1999:2007)
+years <- matrix(years, nrow(crossbill), 9, byrow=TRUE)
+umf <- unmarkedMultFrame(y=y.cross,
+ siteCovs=crossbill[,2:3], yearlySiteCovs=list(year=years),
+ obsCovs=list(date=DATE),
+ numPrimary=9)
+```
+
+## Model fitting
+
+We fit a series of models that represent different hypotheses about
+the colonization-extinction dynamics of Swiss crossbills
+at a spatial scale of 1 km$^2$.
+We fit year effects on colonization and extinction in the means
+parameterization,
+but for detection probability, we choose an effects parameterization.
+The latter is more useful for getting predictions in the presence of
+other explanatory variables for that parameter.
+For model `fm5` with more complex covariate relationships, we use as
+starting values for the optimization routine
+the solution from a "neighboring" model with slightly less
+complexity, model `fm4`.
+Wise choice of starting values can be decisive for success or failure
+of maximum likelihood estimation.
+
+```{r}
+# A model with constant parameters
+fm0 <- colext(~1, ~1, ~1, ~1, umf)
+
+# Like fm0, but with year-dependent detection
+fm1 <- colext(~1, ~1, ~1, ~year, umf)
+
+# Like fm0, but with year-dependent colonization and extinction
+fm2 <- colext(~1, ~year-1, ~year-1, ~1, umf)
+
+# A fully time-dependent model
+fm3 <- colext(~1, ~year-1, ~year-1, ~year, umf)
+
+# Like fm3 with forest-dependence of 1st-year occupancy
+fm4 <- colext(~forest, ~year-1, ~year-1, ~year, umf)
+
+# Like fm4 with date- and year-dependence of detection
+fm5 <- colext(~forest, ~year-1, ~year-1, ~year + date + I(date^2),
+ umf, starts=c(coef(fm4), 0, 0))
+
+# Same as fm5, but with detection in addition depending on forest cover
+fm6 <- colext(~forest, ~year-1, ~year-1, ~year + date + I(date^2) +
+ forest, umf)
+```
+
+## Model selection
+
+We can compare models using the Akaike information criterion
+($AIC$).
+Note that `unmarked` yields $AIC$, not $AIC_c$
+because the latter would require the sample size,
+which is not really known for
+hierarchical models such as the dynamic occupancy model.
+
+Model selection and model-averaged prediction in `unmarked`
+require that we create a list of models using `fitList`.
+This function organizes models and conducts a series of tests to
+ensure that the models were fit to the same data.
+
+```{r}
+models <- fitList('psi(.)gam(.)eps(.)p(.)' = fm0,
+ 'psi(.)gam(.)eps(.)p(Y)' = fm1,
+ 'psi(.)gam(Y)eps(Y)p(.)' = fm2,
+ 'psi(.)gam(Y)eps(Y)p(Y)' = fm3,
+ 'psi(F)gam(Y)eps(Y)p(Y)' = fm4,
+ 'psi(F)gam(Y)eps(Y)p(YD2)' = fm5,
+ 'psi(F)gam(Y)eps(Y)p(YD2F)' = fm6)
+ms <- modSel(models)
+ms
+```
+
+One model has overwhelming support, so we can base inference on that
+one alone. Before doing so, we point out how to extract coefficients
+from a `fitList` object, and convert the results to a
+`data.frame`, which could be exported from R.
+
+```{r, eval=FALSE}
+coef(ms) # Estimates only
+SE(ms) # Standard errors only
+toExport <- as(ms, "data.frame") # Everything
+```
+
+## Manipulating results: Prediction and plotting
+
+Fitted models can be used to predict expected outcomes when given new
+data. For example, one could ask "how many crossbills would you
+expect to find in a quadrat with 50% forest cover?" Prediction also
+offers a way of
+presenting the results of an analysis. We illustrate by plotting the
+predictions of $\psi$ and $p$ over the range of covariate values studied.
+Note that because we standardized date, we need to transform it back
+to its original scale after obtaining predictions on the
+standardized scale.
+
+```{r colext-pred, fig.height=3, fig.width=6, fig.cap="Figure 4. Covariates"}
+op <- par(mfrow=c(1,2), mai=c(0.8,0.8,0.1,0.1))
+
+nd <- data.frame(forest=seq(0, 100, length=50))
+E.psi <- predict(fm6, type="psi", newdata=nd, appendData=TRUE)
+
+with(E.psi, {
+ plot(forest, Predicted, ylim=c(0,1), type="l",
+ xlab="Percent cover of forest",
+ ylab=expression(hat(psi)), cex.lab=0.8, cex.axis=0.8)
+ lines(forest, Predicted+1.96*SE, col=gray(0.7))
+ lines(forest, Predicted-1.96*SE, col=gray(0.7))
+ })
+
+nd <- data.frame(date=seq(-2, 2, length=50),
+ year=factor("2005", levels=c(unique(years))),
+ forest=50)
+E.p <- predict(fm6, type="det", newdata=nd, appendData=TRUE)
+E.p$dateOrig <- E.p$date*sd.DATE + mean.DATE
+
+with(E.p, {
+ plot(dateOrig, Predicted, ylim=c(0,1), type="l",
+ xlab="Julian date", ylab=expression( italic(p) ),
+ cex.lab=0.8, cex.axis=0.8)
+ lines(dateOrig, Predicted+1.96*SE, col=gray(0.7))
+ lines(dateOrig, Predicted-1.96*SE, col=gray(0.7))
+ })
+par(op)
+```
+
+**Acknowledgments**
+
+Special thanks goes to Ian Fiske, the author of `colext` and the
+original developer of `unmarked`. Andy Royle provided the
+initial funding and support for the package. The questions of many
+people on the users' list motivated the writing of this document.
+
+# References
diff --git a/vignettes/distsamp.Rnw b/vignettes/distsamp.Rmd
index 1e969c8..8fa04ec 100644
--- a/vignettes/distsamp.Rnw
+++ b/vignettes/distsamp.Rmd
@@ -1,58 +1,49 @@
-<<echo=false>>=
-options(width=70)
-options(continue=" ")
-@
-
-\documentclass[a4paper]{article}
-\usepackage[OT1]{fontenc}
-\usepackage{Sweave}
-\usepackage{natbib}
-%\usepackage{fullpage}
-\usepackage[vmargin=1in,hmargin=1in]{geometry}
-\bibliographystyle{ecology}
-
-\DefineVerbatimEnvironment{Sinput}{Verbatim} {xleftmargin=2em}
-\DefineVerbatimEnvironment{Soutput}{Verbatim}{xleftmargin=2em}
-\DefineVerbatimEnvironment{Scode}{Verbatim}{xleftmargin=2em}
-\fvset{listparameters={\setlength{\topsep}{0pt}}}
-\renewenvironment{Schunk}{\vspace{\topsep}}{\vspace{\topsep}}
-
-%%\VignetteIndexEntry{Distance sampling analysis}
-
-\title{Distance sampling analysis in unmarked}
-\author{Richard Chandler\\USGS Patuxent Wildlife Research Center}
-\date{March 4, 2020}
-
-
-\begin{document}
-
-\newcommand{\code}[1]{\texttt{\small{#1}}}
-\newcommand{\package}[1]{\textsf{\small{#1}}}
-
-\maketitle
-
-\abstract{Distance sampling is a wildlife sampling technique used to
- estimate population size or density. Describing how density varies
- spatially is often of equal interest; however, conventional methods
- of analysis do not allow for explicit modeling of both density and
- detection probability. The function \code{distsamp} implements the
- multinomial-Poisson mixture model of %Royle et. al
- \citet{royle_modeling_2004}, which was developed to overcome this
- limitation. This model requires that line- or point-transects are
- spatially replicated and that distance data are recorded in discrete
- intervals. The function \code{gdistsamp} extends this basic model,
- by introducing the parameter $\phi$, the probability of
- being available for detection \citep{chandlerEA_2011}. Furthermore,
- this function allows
- abundance to be modeled using the negative binomial distribution,
- which may be useful for dealing with over-dispersion. This document
- describes how to format data, fit models,
- and manipulate results in package \package{unmarked}. It does not
- cover the statistical theory and assumptions underlying distance
- sampling \citep{buckland_distsamp_2001}, which the user is expected
- to be familiar with. }
-
-\section{Introduction}
+---
+title: Distance sampling analysis in unmarked
+author: Richard Chandler, USGS Patuxent Wildlife Research Center
+date: March 4, 2020
+bibliography: unmarked.bib
+csl: ecology.csl
+output:
+ rmarkdown::html_vignette:
+ fig_width: 5
+ fig_height: 3.5
+ number_sections: true
+ toc: true
+vignette: >
+ %\VignetteIndexEntry{Distance sampling analysis}
+ %\VignetteEngine{knitr::rmarkdown}
+ \usepackage[utf8]{inputenc}
+
+---
+
+```{r,echo=FALSE}
+options(rmarkdown.html_vignette.check_title = FALSE)
+```
+
+# Abstract
+
+Distance sampling is a wildlife sampling technique used to
+estimate population size or density. Describing how density varies
+spatially is often of equal interest; however, conventional methods
+of analysis do not allow for explicit modeling of both density and
+detection probability. The function `distsamp` implements the
+multinomial-Poisson mixture model of @royle_modeling_2004, which was developed to overcome this
+limitation. This model requires that line- or point-transects are
+spatially replicated and that distance data are recorded in discrete
+intervals. The function \code{gdistsamp} extends this basic model,
+by introducing the parameter $\phi$, the probability of
+being available for detection [@chandlerEA_2011]. Furthermore,
+this function allows
+abundance to be modeled using the negative binomial distribution,
+which may be useful for dealing with over-dispersion. This document
+describes how to format data, fit models,
+and manipulate results in package \package{unmarked}. It does not
+cover the statistical theory and assumptions underlying distance
+sampling [@buckland_distsamp_2001], which the user is expected
+to be familiar with.
+
+# Introduction
Spatial variation in density is common to virtually all wildlife
populations, and describing this variation is a central objective of
@@ -61,28 +52,23 @@ necessary to account for individuals present but not
detected. Distance from observer is a ubiquitous source of variation
in detection probability, and thus distance sampling has become a
commonly used survey methodology. Numerous options exist for analyzing
-distance sampling data, but here the focus is on the model of Royle et
-al. \citep{royle_modeling_2004}, which assumes that multiple transects
+distance sampling data, but here the focus is on the model of @royle_modeling_2004, which assumes that multiple transects
have been surveyed and distance data are recorded in discrete
intervals. The details of the model formulation are as follows:
The latent transect-level abundance distribution is currently assumed
to be
-
-\begin{equation}
+$$
\label{eq:1}
N_{i} \sim \mathrm{Poisson}(\lambda)
\quad i=1,\dots,M\
-\end{equation}
-
+$$
The detection process is modeled as
-
-\begin{equation}
+$$
\label{eq:2}
y_{ij} \sim \mathrm{Multinomial}(N_{i}, \pi_{ij})
\quad i=1,\dots,M\;j=1,\dots,J
-\end{equation}
-
+$$
where $\pi_{ij}$ is the multinomial cell probability for transect $i$
in distance class $j$. These are computed by integrating a detection
function such as the half-normal (with scale parameter $\sigma$) over
@@ -91,20 +77,20 @@ each distance interval.
Parameters $\lambda$ and $\sigma$ can be vectors affected by
transect-specific covariates using the log link.
-\section{Importing, formatting, and summarizing data}
+# Importing, formatting, and summarizing data
The first step is to import the data into R. The simplest option is to
-use the \code{read.csv} function to import a .csv file that has been
+use the `read.csv` function to import a .csv file that has been
formatted so that each row represents a transect, and columns describe
either the number of individuals detected in each distance interval or
transect-specific covariates. Alternatively, if data were not recorded
in discrete distance intervals, a .csv file could be imported that
contains a row for each individual detected and columns for the
distances and transect names. This could then be converted to
-transect-level data using the function \code{formatDistData}. For
+transect-level data using the function `formatDistData`. For
example,
-<<>>=
+```{r}
library(unmarked)
dists <- read.csv(system.file("csv", "distdata.csv", package="unmarked"),
stringsAsFactors=TRUE)
@@ -114,86 +100,79 @@ levels(dists$transect)
yDat <- formatDistData(dists, distCol="distance",
transectNameCol="transect", dist.breaks=c(0, 5, 10, 15, 20))
yDat
-@
+```
-Here we have created an object called yDat that contains counts for
+Here we have created an object called `yDat` that contains counts for
each transect (row) in each distance interval (columns). Note the
-method used to include transect "g", which was surveyd but where no
-individuals were detected. It is important that all survyed transects
+method used to include transect `"g"`, which was surveyed but where no
+individuals were detected. It is important that all surveyed transects
are included in the analysis.
Suppose there also exists transect-specific covariate data.
-<<>>=
+```{r}
(covs <- data.frame(canopyHt = c(5, 8, 3, 2, 4, 7, 5),
habitat = c('A','A','A','A','B','B','B'), row.names=letters[1:7]))
-@
+```
-The function \code{unmarkedFrameDS} can now be used to organize these
+The function `unmarkedFrameDS` can now be used to organize these
data along with their metadata (study design (line- or
point-transect), distance class break points, transect lengths, and
-units of measurement) into an object to be used as the \code{data}
-argument in \code{distsamp}. By organizing the data this way, the user
+units of measurement) into an object to be used as the `data`
+argument in `distsamp`. By organizing the data this way, the user
does not need to repetitively specify these arguments during each call
-to \code{distsamp}, thereby reducing the potential for errors and
+to `distsamp`, thereby reducing the potential for errors and
facilitating data summary and manipulation.
-<<>>=
+```{r}
umf <- unmarkedFrameDS(y=as.matrix(yDat), siteCovs=covs, survey="line",
dist.breaks=c(0, 5, 10, 15, 20), tlength=rep(100, 7),
unitsIn="m")
-@
+```
-Note that there is no \code{obsCovs} argument, meaning that
+Note that there is no `obsCovs` argument, meaning that
distance-interval-level covariates cannot be included in the
-analysis. The call to \code{unmarkedFrameDS} indicates that the data
+analysis. The call to `unmarkedFrameDS` indicates that the data
were collected on seven line transects, each 100 meters long, and
detections were tabulated into distance intervals defined by the
-\code{dist.breaks} cutpoints. It is important that both transect
+`dist.breaks` cutpoints. It is important that both transect
lengths and distance break points are provided in the same units
-specified by \code{unitsIn}.
+specified by `unitsIn`.
We can look at these data using a variety of methods.
-<<umfhist,fig=TRUE,include=FALSE,width=4,height=4>>=
+```{r, fig.height=4, fig.width=4, fig.cap="Figure 1. Histogram of detection distances"}
summary(umf)
hist(umf, xlab="distance (m)", main="", cex.lab=0.8, cex.axis=0.8)
-@
-\begin{figure}[!ht]
- \centering
- \includegraphics[width=4in,height=4in]{distsamp-umfhist}
- \caption{Histogram of detection distances.}
- \label{fig:umfhist}
-\end{figure}
+```
-\newpage
-\section{Model fitting}
+# Model fitting
Now that we have put our data into an object of class
-\code{unmarkedFrameDS}, we are ready to fit some models with
-\code{distsamp}. The first argument is a \code{formula} which
+`unmarkedFrameDS`, we are ready to fit some models with
+`distsamp`. The first argument is a `formula` which
specifies the detection covariates followed by the density (or
abundance) covariates. The only other required argument is the
-\code{data}, but several other optional arguments exist. By default,
+`data`, but several other optional arguments exist. By default,
the half-normal detection function is used to model density in animals
-/ ha. The detection function can be selected using the \code{keyfun}
-argument. The response can be changed from ``density", to ``abund"
-with the \code{output} argument. When modeling density, the output
-units can be changed from ``ha" to ``kmsq" using the \code{unitsOut}
-argument. \code{distsamp} also includes the arguments \code{starts},
-\code{method}, and \code{control}, which are common to all unmarked
+/ ha. The detection function can be selected using the `keyfun`
+argument. The response can be changed from `"density"`, to `"abund"`
+with the `output` argument. When modeling density, the output
+units can be changed from `"ha"` to `"kmsq"` using the `unitsOut`
+argument. `distsamp` also includes the arguments `starts`,
+`method`, and `control`, which are common to all unmarked
fitting functions.
-Below is a series of models that demonstrates \code{distsamp}'s
+Below is a series of models that demonstrates `distsamp`'s
arguments and defaults.
-<<>>=
+```{r}
hn_Null <- distsamp(~1~1, umf)
hn_Null <- distsamp(~1~1, umf, keyfun="halfnorm", output="density",
unitsOut="ha")
haz_Null <- distsamp(~1~1, umf, keyfun="hazard")
hn_Hab.Ht <- distsamp(~canopyHt ~habitat, umf)
-@
+```
The first two models are the same, a null half-normal detection
function with density returned in animals / ha (on the log-scale). The
@@ -201,58 +180,57 @@ third model uses the hazard-rate detection function, and the fourth
model includes covariates affecting the Poisson mean ($\lambda$) and
the half-normal scale parameter ($\sigma$).
-
Once a model has been fit, typing its name will display parameter
estimate information and AIC. A summary method shows extra details
including the scale on which parameters were estimated and convergence
results.
-<<>>=
+```{r}
haz_Null
-@
+```
-\section{Manipulating results}
+# Manipulating results
Back-transforming estimates to the original scale and obtaining
standard errors via the delta method is easily accomplished:
-<<>>=
+```{r}
names(haz_Null)
backTransform(haz_Null, type="state")
backTransform(haz_Null, type="det")
backTransform(haz_Null, type="scale")
backTransform(linearComb(hn_Hab.Ht['det'], c(1, 5)))
-@
+```
The first back-transformation returns population density, since this
-is the default state parameter modeled when \code{distsamp}'s
-\code{output} argument is set to ``density". The second
+is the default state parameter modeled when `distsamp`'s
+`output` argument is set to `"density"`. The second
back-transformation returns the hazard-rate shape parameter, and third
is the hazard-rate scale parameter. When covariates are present,
-\code{backTransform} in conjunction with \code{linearComb} should be
+`backTransform` in conjunction with `linearComb` should be
used. Here, we requested the value of sigma when canopy height was 5
meters tall. Note that the intercept was included in the calculation
by setting the first value in the linear equation to 1.
Parameters that do not occur in the likelihood may also be of
-interest. For example, the number of individuals occuring in the
+interest. For example, the number of individuals occurring in the
sampled plots (local population size) is a fundamental parameter in
monitoring and conservation efforts. The following commands can be
used to derive this parameter from our model of density:
-<<>>=
+```{r}
site.level.density <- predict(hn_Hab.Ht, type="state")$Predicted
plotArea.inHectares <- 100 * 40 / 10000
site.level.abundance <- site.level.density * plotArea.inHectares
(N.hat <- sum(site.level.abundance))
-@
+```
-To describe the uncertainty of N.hat, or any other derived parameter,
+To describe the uncertainty of `N.hat`, or any other derived parameter,
we can use a parametric bootstrap approach. First we define a function
-to estimate N.hat, and then we apply this function to numerous models
+to estimate `N.hat`, and then we apply this function to numerous models
fit to data simulated from our original model.
-<<>>=
+```{r}
getN.hat <- function(fit) {
d <- predict(fit, type="state")$Predicted
a <- d * (100 * 40 / 10000)
@@ -261,51 +239,51 @@ getN.hat <- function(fit) {
}
pb <- parboot(hn_Hab.Ht, statistic=getN.hat, nsim=25)
pb
-@
+```
-Here, \code{t\_B} is an approximation of the sampling distribution for
-\code{N.hat}, conditioned on our fitted model. Confidence intervals
-can be calculated from the quantiles of \code{t\_B}. Note that in
-practice nsim should be set to a much larger value and a
+Here, `t_B` is an approximation of the sampling distribution for
+`N.hat`, conditioned on our fitted model. Confidence intervals
+can be calculated from the quantiles of `t_B`. Note that in
+practice `nsim` should be set to a much larger value and a
goodness-of-fit test should be performed before making inference from
-a fitted model. Parameteric bootstrapping can be used for the latter
-by supplying a fit statistic such as \code{SSE} instead of
-\code{getN.hat}. See ?parboot and vignette('unmarked') for examples.
+a fitted model. Parametric bootstrapping can be used for the latter
+by supplying a fit statistic such as `SSE` instead of
+`getN.hat`. See `?parboot` and `vignette('unmarked')` for examples.
-\section{Prediction and plotting}
+# Prediction and plotting
-A \code{predict} method exits for all \code{unmarkedFit} objects,
+A `predict` method exits for all `unmarkedFit` objects,
which is useful when multiple covariate combinations exist. This
method also facilitates plotting. Suppose we wanted model predictions
from the covariate model along the range of covariate values
-studied. First we need to make new \code{data.frame}s holding the
+studied. First we need to make new `data.frame`s holding the
desired covariate combinations. Note that column names must match
those of the original data, and factor variables must contain the same
levels.
-<<>>=
+```{r}
head(habConstant <- data.frame(canopyHt = seq(2, 8, length=20),
habitat=factor("A", levels=c("A", "B"))))
(htConstant <- data.frame(canopyHt = 5,
habitat=factor(c("A", "B"))))
-@
+```
-Now \code{predict} can be used to estimate density and $\sigma$ for
-each row of our new \code{data.frame}s.
+Now `predict` can be used to estimate density and $\sigma$ for
+each row of our new `data.frame`s.
-<<>>=
+```{r}
(Elambda <- predict(hn_Hab.Ht, type="state", newdata=htConstant,
appendData=TRUE))
head(Esigma <- predict(hn_Hab.Ht, type="det", newdata=habConstant,
appendData=TRUE))
-@
+```
Once predictions have been made, plotting is
-straight-forward. Figure~\ref{fig:predplot}a, shows density as a
-function of habitat type, and Figure~\ref{fig:predplot}b shows that
+straight-forward. Figure 2a shows density as a
+function of habitat type, and Figure 2b shows that
$\sigma$ is not related to canopy height.
-<<predplot,fig=TRUE,include=FALSE,width=6,height=3>>=
+```{r, fig.height=3, fig.width=6, fig.cap="Figure 2. Predicted covariate relationships"}
par(mfrow=c(1, 2))
with(Elambda, {
x <- barplot(Predicted, names=habitat, xlab="Habitat",
@@ -322,32 +300,24 @@ with(Esigma, {
lines(canopyHt, Predicted+SE, lty=2)
lines(canopyHt, Predicted-SE, lty=2)
})
-@
-\begin{figure}[!ht]
- \centering
- \includegraphics{distsamp-predplot}
- \caption{Predicted covariate relatonships.}
- \label{fig:predplot}
-\end{figure}
-
+```
Plots of the detection function parameters can be less informative
than plots of the detection functions themselves. To do the latter, we
can plug predicted values of $\sigma$ at given covariate values into
-the \code{gxhn} function. For instance, Figure~\ref{fig:detplot}a
+the `gxhn` function. For instance, Figure 3a
shows to the half-normal function at a canopy height of 2m. This was
plotted by setting $\sigma$ to 10.8, the predicted value shown
above. The available detection functions are described on the
-\code{detFuns} help page. Probability density functions such as
-\code{dxhn} can be plotted with the distance histogram using the
-\code{hist} method for \code{unmarkedFitDS} objects
-(Figure\ref{fig:detplot}b). This only works for models without
+`detFuns` help page. Probability density functions such as
+`dxhn` can be plotted with the distance histogram using the
+`hist` method for `unmarkedFitDS` objects
+(Figure 3b). This only works for models without
detection covariates; however, probability density functions at
specific covariate values can be added in a fashion similar to that
-above (Figure\ref{fig:detplot}b).
-
+above (Figure 3b).
-<<detplot,fig=TRUE,include=FALSE,width=6,height=3>>=
+```{r, fig.width=6, fig.height=3, fig.cap="Figure 3. Detection and probability density functions"}
par(mfrow=c(1, 2))
plot(function(x) gxhn(x, sigma=10.8), 0, 20, xlab="Distance (m)",
ylab="Detection prob. at 2m canopy ht.", cex.lab=0.7,
@@ -358,17 +328,9 @@ plot(function(x) dxhn(x, sigma=10.8), 0, 20, add=TRUE, col="blue")
plot(function(x) dxhn(x, sigma=9.9), 0, 20, add=TRUE, col="green")
legend('topright', c("Canopy ht. = 2m", "Null", "Canopy ht. = 8m"),
col=c("blue", "black", "green"), lty=1, cex=0.4)
-@
-\begin{figure}[!ht]
- \centering
- \includegraphics{distsamp-detplot}
- \caption{Detection and probability density functions.}
- \label{fig:detplot}
-\end{figure}
-
-\newpage
+```
-\section{Model extensions}
+# Model extensions
A common criticism of distance sampling is that all individuals must
be available for detection. Similarly, the probability of detecting an
@@ -376,29 +338,26 @@ individual a distance of 0 must be 1. These assumptions often cannot
be met. For instance, when counting cues such as bird songs or whale
blows, the probability that an individual will produce a cue (and thus
be available for detection) is rarely 1 during the sampling
-interval. Recently developed methods \citep{chandlerEA_2011}
+interval. Recently developed methods [@chandlerEA_2011]
allow for the estimation of the
probability of being available for detection $\phi$. To do so,
replicate distance sampling observations must be collected at each
transect. These replicates could be collected using repeated visits or
multiple observers working independently. Implementation of this model
-in \package{unmarked} is accomplished using the \code{gdistsamp}
+in `unmarked` is accomplished using the `gdistsamp`
function. The function also provides the option to model abundance
using the negative binomial distribution. Formatting data and
specifying models is similar to methods described above and is more
fully outlined in the help pages.
-\section{Conclusion}
+# Conclusion
This document has emphasized methods tailored to distance sampling
analysis; however, the more general methods available in package
-\package{unmarked} can also be applied to models fitted using
-\code{distsamp} and \code{gdistsamp}.
+`unmarked` can also be applied to models fitted using
+`distsamp` and `gdistsamp`.
For example, model-selection and model-averaging can be
-accomplished using the \code{fitList} function and the \code{modSel}
-and \code{predict} methods.
-
-
-\bibliography{unmarked}
+accomplished using the `fitList` function and the `modSel`
+and `predict` methods.
-\end{document}
+# References
diff --git a/vignettes/ecology.bst b/vignettes/ecology.bst
deleted file mode 100644
index 1896827..0000000
--- a/vignettes/ecology.bst
+++ /dev/null
@@ -1,1460 +0,0 @@
-%%
-%% This is file `ecology.bst',
-%% generated with the docstrip utility.
-%%
-%% The original source files were:
-%%
-%% merlin.mbs (with options: `head,exlang,ay,nat,nm-rev1,dt-beg,note-yr,vol-bf,vnum-x,jnm-x,btit-rm,english,nfss,{}')
-%% english.mbs (with options: `exlang,ay,nat,nm-rev1,dt-beg,note-yr,vol-bf,vnum-x,jnm-x,btit-rm,english,nfss,{}')
-%% merlin.mbs (with options: `tail,exlang,ay,nat,nm-rev1,dt-beg,note-yr,vol-bf,vnum-x,jnm-x,btit-rm,english,nfss,{}')
-%% ----------------------------------------
-%% *** Bibliographystyle for Ecology ***
-%%
- %-------------------------------------------------------------------
- % The original source file contains the following version information:
- % \ProvidesFile{merlin.mbs}[1996/02/05 3.7 (PWD)]
- %
- % NOTICE:
- % This file may be used for non-profit purposes.
- % It may not be distributed in exchange for money,
- % other than distribution costs.
- %
- % The author provides it `as is' and does not guarantee it in any way.
- %
- % Copyright (C) 1994, 1995, 1996 Patrick W. Daly
- %-------------------------------------------------------------------
- % For use with BibTeX version 0.99a or later
- %-------------------------------------------------------------------
- % This bibliography style file is intended for texts in
- % ENGLISH
- % This is an author-year citation style bibliography. As such, it is
- % non-standard LaTeX, and requires a special package file to function properly.
- % Such a package is natbib.sty by Patrick W. Daly
- % The form of the \bibitem entries is
- % \bibitem[Jones et al.(1990)]{key}...
- % \bibitem[Jones et al.(1990)Jones, Baker, and Smith]{key}...
- % The essential feature is that the label (the part in brackets) consists
- % of the author names, as they should appear in the citation, with the year
- % in parentheses following. There must be no space before the opening
- % parenthesis!
- % With natbib v5.3, a full list of authors may also follow the year.
- % In natbib.sty, it is possible to define the type of enclosures that is
- % really wanted (brackets or parentheses), but in either case, there must
- % be parentheses in the label.
- % The \cite command functions as follows:
- % \cite{key} ==>> Jones et al. (1990)
- % \cite[]{key} ==>> (Jones et al., 1990)
- % \cite[chap. 2]{key} ==>> (Jones et al., 1990, chap. 2)
- % \cite[e.g.][]{key} ==>> (e.g. Jones et al., 1990)
- % \cite[e.g.][p. 32]{key} ==>> (e.g. Jones et al., p. 32)
- % \citeauthor{key} Jones et al.
- % \citefullauthor{key} Jones, Baker, and Smith
- % \citeyear{key} 1990
- %---------------------------------------------------------------------
-
-ENTRY
- { address
- author
- booktitle
- chapter
- edition
- editor
- howpublished
- institution
- journal
- key
- month
- note
- number
- organization
- pages
- publisher
- school
- series
- title
- type
- volume
- year
- }
- {}
- { label extra.label sort.label short.list }
-
-INTEGERS { output.state before.all mid.sentence after.sentence after.block }
-
-FUNCTION {init.state.consts}
-{ #0 'before.all :=
- #1 'mid.sentence :=
- #2 'after.sentence :=
- #3 'after.block :=
-}
-
-STRINGS { s t }
-
-FUNCTION {output.nonnull}
-{ 's :=
- output.state mid.sentence =
- { ", " * write$ }
- { output.state after.block =
- { add.period$ write$
- newline$
- "\newblock " write$
- }
- { output.state before.all =
- 'write$
- { add.period$ " " * write$ }
- if$
- }
- if$
- mid.sentence 'output.state :=
- }
- if$
- s
-}
-
-FUNCTION {output}
-{ duplicate$ empty$
- 'pop$
- 'output.nonnull
- if$
-}
-
-FUNCTION {output.check}
-{ 't :=
- duplicate$ empty$
- { pop$ "empty " t * " in " * cite$ * warning$ }
- 'output.nonnull
- if$
-}
-
-FUNCTION {fin.entry}
-{ add.period$
- write$
- newline$
-}
-
-FUNCTION {new.block}
-{ output.state before.all =
- 'skip$
- { after.block 'output.state := }
- if$
-}
-
-FUNCTION {new.sentence}
-{ output.state after.block =
- 'skip$
- { output.state before.all =
- 'skip$
- { after.sentence 'output.state := }
- if$
- }
- if$
-}
-
-FUNCTION {add.blank}
-{ " " * before.all 'output.state :=
-}
-
-FUNCTION {date.block}
-{
- new.block
-}
-
-FUNCTION {not}
-{ { #0 }
- { #1 }
- if$
-}
-
-FUNCTION {and}
-{ 'skip$
- { pop$ #0 }
- if$
-}
-
-FUNCTION {or}
-{ { pop$ #1 }
- 'skip$
- if$
-}
-
-FUNCTION {non.stop}
-{ duplicate$
- "}" * add.period$
- #-1 #1 substring$ "." =
-}
-
-FUNCTION {new.block.checkb}
-{ empty$
- swap$ empty$
- and
- 'skip$
- 'new.block
- if$
-}
-
-FUNCTION {field.or.null}
-{ duplicate$ empty$
- { pop$ "" }
- 'skip$
- if$
-}
-
-FUNCTION {emphasize}
-{ duplicate$ empty$
- { pop$ "" }
- { "\emph{" swap$ * "}" * }
- if$
-}
-
-FUNCTION {bolden}
-{ duplicate$ empty$
- { pop$ "" }
- { "\textbf{" swap$ * "}" * }
- if$
-}
-
-FUNCTION {capitalize}
-{ "u" change.case$ "t" change.case$ }
-
-FUNCTION {space.word}
-{ " " swap$ * " " * }
-
- % Here are the language-specific definitions for explicit words.
- % Each function has a name bbl.xxx where xxx is the English word.
- %-------------------------------------------------------------------
- % The original source file contains the following version information:
- % \ProvidesFile{english.mbs}[1995/05/04 1.1 (PWD)]
- % Copyright (C) 1994, 1995 Patrick W. Daly
- %-------------------------------------------------------------------
-
- % The language selected here is ENGLISH
-FUNCTION {bbl.and}
-{ "and"}
-
-FUNCTION {bbl.editors}
-{ "editors" }
-
-FUNCTION {bbl.editor}
-{ "editor" }
-
-FUNCTION {bbl.edby}
-{ "edited by" }
-
-FUNCTION {bbl.edition}
-{ "edition" }
-
-FUNCTION {bbl.volume}
-{ "volume" }
-
-FUNCTION {bbl.of}
-{ "of" }
-
-FUNCTION {bbl.number}
-{ "number" }
-
-FUNCTION {bbl.nr}
-{ "no." }
-
-FUNCTION {bbl.in}
-{ "in" }
-
-FUNCTION {bbl.pages}
-{ "pages" }
-
-FUNCTION {bbl.page}
-{ "page" }
-
-FUNCTION {bbl.chapter}
-{ "chapter" }
-
-FUNCTION {bbl.techrep}
-{ "Technical Report" }
-
-FUNCTION {bbl.mthesis}
-{ "Master's thesis" }
-
-FUNCTION {bbl.phdthesis}
-{ "Ph.D. thesis" }
-
-FUNCTION {bbl.first}
-{ "First" }
-
-FUNCTION {bbl.second}
-{ "Second" }
-
-FUNCTION {bbl.third}
-{ "Third" }
-
-FUNCTION {bbl.fourth}
-{ "Fourth" }
-
-FUNCTION {bbl.fifth}
-{ "Fifth" }
-
-FUNCTION {bbl.st}
-{ "st" }
-
-FUNCTION {bbl.nd}
-{ "nd" }
-
-FUNCTION {bbl.rd}
-{ "rd" }
-
-FUNCTION {bbl.th}
-{ "th" }
-
-FUNCTION {eng.ord}
-{ duplicate$ "1" swap$ *
- #-2 #1 substring$ "1" =
- { bbl.th * }
- { duplicate$ #-1 #1 substring$
- duplicate$ "1" =
- { pop$ bbl.st * }
- { duplicate$ "2" =
- { pop$ bbl.nd * }
- { "3" =
- { bbl.rd * }
- { bbl.th * }
- if$
- }
- if$
- }
- if$
- }
- if$
-}
-
-MACRO {jan} {"January"}
-
-MACRO {feb} {"February"}
-
-MACRO {mar} {"March"}
-
-MACRO {apr} {"April"}
-
-MACRO {may} {"May"}
-
-MACRO {jun} {"June"}
-
-MACRO {jul} {"July"}
-
-MACRO {aug} {"August"}
-
-MACRO {sep} {"September"}
-
-MACRO {oct} {"October"}
-
-MACRO {nov} {"November"}
-
-MACRO {dec} {"December"}
-
- % End of language definition file
-
-MACRO {acmcs} {"ACM Computing Surveys"}
-
-MACRO {acta} {"Acta Informatica"}
-
-MACRO {cacm} {"Communications of the ACM"}
-
-MACRO {ibmjrd} {"IBM Journal of Research and Development"}
-
-MACRO {ibmsj} {"IBM Systems Journal"}
-
-MACRO {ieeese} {"IEEE Transactions on Software Engineering"}
-
-MACRO {ieeetc} {"IEEE Transactions on Computers"}
-
-MACRO {ieeetcad}
- {"IEEE Transactions on Computer-Aided Design of Integrated Circuits"}
-
-MACRO {ipl} {"Information Processing Letters"}
-
-MACRO {jacm} {"Journal of the ACM"}
-
-MACRO {jcss} {"Journal of Computer and System Sciences"}
-
-MACRO {scp} {"Science of Computer Programming"}
-
-MACRO {sicomp} {"SIAM Journal on Computing"}
-
-MACRO {tocs} {"ACM Transactions on Computer Systems"}
-
-MACRO {tods} {"ACM Transactions on Database Systems"}
-
-MACRO {tog} {"ACM Transactions on Graphics"}
-
-MACRO {toms} {"ACM Transactions on Mathematical Software"}
-
-MACRO {toois} {"ACM Transactions on Office Information Systems"}
-
-MACRO {toplas} {"ACM Transactions on Programming Languages and Systems"}
-
-MACRO {tcs} {"Theoretical Computer Science"}
-
-INTEGERS { nameptr namesleft numnames }
-
-FUNCTION {format.names}
-{ 's :=
- #1 'nameptr :=
- s num.names$ 'numnames :=
- numnames 'namesleft :=
- { namesleft #0 > }
- { nameptr #1 >
- { s nameptr "{f.~}{vv~}{ll}{, jj}" format.name$ 't := }
- { s nameptr "{vv~}{ll}{, f.}{, jj}" format.name$ 't := }
- if$
- nameptr #1 >
- {
- namesleft #1 >
- { ", " * t * }
- {
- numnames #2 >
- { "," * }
- 'skip$
- if$
- t "others" =
- { " et~al." * }
- { bbl.and space.word * t * }
- if$
- }
- if$
- }
- 't
- if$
- nameptr #1 + 'nameptr :=
- namesleft #1 - 'namesleft :=
- }
- while$
-}
-
-FUNCTION {format.names.ed}
-{ 's :=
- #1 'nameptr :=
- s num.names$ 'numnames :=
- numnames 'namesleft :=
- { namesleft #0 > }
- { s nameptr
- "{f.~}{vv~}{ll}{, jj}"
- format.name$ 't :=
- nameptr #1 >
- {
- namesleft #1 >
- { ", " * t * }
- {
- numnames #2 >
- { "," * }
- 'skip$
- if$
- t "others" =
- { " et~al." * }
- { bbl.and space.word * t * }
- if$
- }
- if$
- }
- 't
- if$
- nameptr #1 + 'nameptr :=
- namesleft #1 - 'namesleft :=
- }
- while$
-}
-
-FUNCTION {format.key}
-{ empty$
- { key field.or.null }
- { "" }
- if$
-}
-
-FUNCTION {format.authors}
-{ author empty$
- { "" }
- {
- author format.names
- }
- if$
-}
-
-FUNCTION {format.editors}
-{ editor empty$
- { "" }
- {
- editor format.names
- editor num.names$ #1 >
- { ", " * bbl.editors * }
- { ", " * bbl.editor * }
- if$
- }
- if$
-}
-
-FUNCTION {format.in.editors}
-{ editor empty$
- { "" }
- { editor format.names.ed
- editor num.names$ #1 >
- { ", " * bbl.editors * }
- { ", " * bbl.editor * }
- if$
- }
- if$
-}
-
-FUNCTION {format.title}
-{ title empty$
- { "" }
- { title "t" change.case$
- }
- if$
-}
-
-FUNCTION {format.full.names}
-{'s :=
- #1 'nameptr :=
- s num.names$ 'numnames :=
- numnames 'namesleft :=
- { namesleft #0 > }
- { s nameptr
- "{vv~}{ll}" format.name$ 't :=
- nameptr #1 >
- {
- namesleft #1 >
- { ", " * t * }
- {
- numnames #2 >
- { "," * }
- 'skip$
- if$
- t "others" =
- { " et~al." * }
- { bbl.and space.word * t * }
- if$
- }
- if$
- }
- 't
- if$
- nameptr #1 + 'nameptr :=
- namesleft #1 - 'namesleft :=
- }
- while$
-}
-
-FUNCTION {author.editor.key.full}
-{ author empty$
- { editor empty$
- { key empty$
- { cite$ #1 #3 substring$ }
- 'key
- if$
- }
- { editor format.full.names }
- if$
- }
- { author format.full.names }
- if$
-}
-
-FUNCTION {author.key.full}
-{ author empty$
- { key empty$
- { cite$ #1 #3 substring$ }
- 'key
- if$
- }
- { author format.full.names }
- if$
-}
-
-FUNCTION {editor.key.full}
-{ editor empty$
- { key empty$
- { cite$ #1 #3 substring$ }
- 'key
- if$
- }
- { editor format.full.names }
- if$
-}
-
-FUNCTION {make.full.names}
-{ type$ "book" =
- type$ "inbook" =
- or
- 'author.editor.key.full
- { type$ "proceedings" =
- 'editor.key.full
- 'author.key.full
- if$
- }
- if$
-}
-
-FUNCTION {output.bibitem}
-{ newline$
- "\bibitem[" write$
- label write$
- ")" make.full.names duplicate$ short.list =
- { pop$ }
- { * }
- if$
- "]{" * write$
- cite$ write$
- "}" write$
- newline$
- ""
- before.all 'output.state :=
-}
-
-FUNCTION {n.dashify}
-{ 't :=
- ""
- { t empty$ not }
- { t #1 #1 substring$ "-" =
- { t #1 #2 substring$ "--" = not
- { "--" *
- t #2 global.max$ substring$ 't :=
- }
- { { t #1 #1 substring$ "-" = }
- { "-" *
- t #2 global.max$ substring$ 't :=
- }
- while$
- }
- if$
- }
- { t #1 #1 substring$ *
- t #2 global.max$ substring$ 't :=
- }
- if$
- }
- while$
-}
-
-FUNCTION {word.in}
-{ bbl.in capitalize
- " " * }
-
-FUNCTION {format.date}
-{ year duplicate$ empty$
- { "empty year in " cite$ * "; set to ????" * warning$
- pop$ "????" }
- 'skip$
- if$
- extra.label *
-}
-
-FUNCTION {format.btitle}
-{ title
-}
-
-FUNCTION {tie.or.space.connect}
-{ duplicate$ text.length$ #3 <
- { "~" }
- { " " }
- if$
- swap$ * *
-}
-
-FUNCTION {either.or.check}
-{ empty$
- 'pop$
- { "can't use both " swap$ * " fields in " * cite$ * warning$ }
- if$
-}
-
-FUNCTION {format.bvolume}
-{ volume empty$
- { "" }
- { bbl.volume volume tie.or.space.connect
- series empty$
- 'skip$
- { bbl.of space.word * series emphasize * }
- if$
- "volume and number" number either.or.check
- }
- if$
-}
-
-FUNCTION {format.number.series}
-{ volume empty$
- { number empty$
- { series field.or.null }
- { output.state mid.sentence =
- { bbl.number }
- { bbl.number capitalize }
- if$
- number tie.or.space.connect
- series empty$
- { "there's a number but no series in " cite$ * warning$ }
- { bbl.in space.word * series * }
- if$
- }
- if$
- }
- { "" }
- if$
-}
-
-FUNCTION {is.num}
-{ chr.to.int$
- duplicate$ "0" chr.to.int$ < not
- swap$ "9" chr.to.int$ > not and
-}
-
-FUNCTION {extract.num}
-{ duplicate$ 't :=
- "" 's :=
- { t empty$ not }
- { t #1 #1 substring$
- t #2 global.max$ substring$ 't :=
- duplicate$ is.num
- { s swap$ * 's := }
- { pop$ "" 't := }
- if$
- }
- while$
- s empty$
- 'skip$
- { pop$ s }
- if$
-}
-
-FUNCTION {convert.edition}
-{ edition extract.num "l" change.case$ 's :=
- s "first" = s "1" = or
- { bbl.first 't := }
- { s "second" = s "2" = or
- { bbl.second 't := }
- { s "third" = s "3" = or
- { bbl.third 't := }
- { s "fourth" = s "4" = or
- { bbl.fourth 't := }
- { s "fifth" = s "5" = or
- { bbl.fifth 't := }
- { s #1 #1 substring$ is.num
- { s eng.ord 't := }
- { edition 't := }
- if$
- }
- if$
- }
- if$
- }
- if$
- }
- if$
- }
- if$
- t
-}
-
-FUNCTION {format.edition}
-{ edition empty$
- { "" }
- { output.state mid.sentence =
- { convert.edition "l" change.case$ " " * bbl.edition * }
- { convert.edition "t" change.case$ " " * bbl.edition * }
- if$
- }
- if$
-}
-
-INTEGERS { multiresult }
-
-FUNCTION {multi.page.check}
-{ 't :=
- #0 'multiresult :=
- { multiresult not
- t empty$ not
- and
- }
- { t #1 #1 substring$
- duplicate$ "-" =
- swap$ duplicate$ "," =
- swap$ "+" =
- or or
- { #1 'multiresult := }
- { t #2 global.max$ substring$ 't := }
- if$
- }
- while$
- multiresult
-}
-
-FUNCTION {format.pages}
-{ pages empty$
- { "" }
- { pages multi.page.check
- { bbl.pages pages n.dashify tie.or.space.connect }
- { bbl.page pages tie.or.space.connect }
- if$
- }
- if$
-}
-
-FUNCTION {format.vol.num.pages}
-{ volume field.or.null
- bolden
- pages empty$
- 'skip$
- { duplicate$ empty$
- { pop$ format.pages }
- { ":" * pages n.dashify * }
- if$
- }
- if$
-}
-
-FUNCTION {format.chapter.pages}
-{ chapter empty$
- 'format.pages
- { type empty$
- { bbl.chapter }
- { type "l" change.case$ }
- if$
- chapter tie.or.space.connect
- pages empty$
- 'skip$
- { ", " * format.pages * }
- if$
- }
- if$
-}
-
-FUNCTION {format.in.ed.booktitle}
-{ booktitle empty$
- { "" }
- { editor empty$
- { word.in booktitle emphasize * }
- { word.in format.in.editors * ", " *
- booktitle emphasize * }
- if$
- }
- if$
-}
-
-FUNCTION {format.thesis.type}
-{ type empty$
- 'skip$
- { pop$
- type "t" change.case$
- }
- if$
-}
-
-FUNCTION {format.tr.number}
-{ type empty$
- { bbl.techrep }
- 'type
- if$
- number empty$
- { "t" change.case$ }
- { number tie.or.space.connect }
- if$
-}
-
-FUNCTION {format.article.crossref}
-{
- word.in
- " \cite{" * crossref * "}" *
-}
-
-FUNCTION {format.book.crossref}
-{ volume empty$
- { "empty volume in " cite$ * "'s crossref of " * crossref * warning$
- word.in
- }
- { bbl.volume capitalize
- volume tie.or.space.connect
- bbl.of space.word *
- }
- if$
- " \cite{" * crossref * "}" *
-}
-
-FUNCTION {format.incoll.inproc.crossref}
-{
- word.in
- " \cite{" * crossref * "}" *
-}
-
-FUNCTION {article}
-{ output.bibitem
- format.authors "author" output.check
- author format.key output
- format.date "year" output.check
- date.block
- format.title "title" output.check
- new.block
- crossref missing$
- { journal
- emphasize
- "journal" output.check
- add.blank
- format.vol.num.pages output
- }
- { format.article.crossref output.nonnull
- format.pages output
- }
- if$
- new.block
- note output
- fin.entry
-}
-
-FUNCTION {book}
-{ output.bibitem
- author empty$
- { format.editors "author and editor" output.check
- editor format.key output
- }
- { format.authors output.nonnull
- crossref missing$
- { "author and editor" editor either.or.check }
- 'skip$
- if$
- }
- if$
- format.date "year" output.check
- date.block
- format.btitle "title" output.check
- crossref missing$
- { format.bvolume output
- new.block
- format.number.series output
- new.sentence
- publisher "publisher" output.check
- address output
- }
- {
- new.block
- format.book.crossref output.nonnull
- }
- if$
- format.edition output
- new.block
- note output
- fin.entry
-}
-
-FUNCTION {booklet}
-{ output.bibitem
- format.authors output
- author format.key output
- format.date "year" output.check
- date.block
- format.title "title" output.check
- new.block
- howpublished output
- address output
- new.block
- note output
- fin.entry
-}
-
-FUNCTION {inbook}
-{ output.bibitem
- author empty$
- { format.editors "author and editor" output.check
- editor format.key output
- }
- { format.authors output.nonnull
- crossref missing$
- { "author and editor" editor either.or.check }
- 'skip$
- if$
- }
- if$
- format.date "year" output.check
- date.block
- format.btitle "title" output.check
- crossref missing$
- { format.bvolume output
- format.chapter.pages "chapter and pages" output.check
- new.block
- format.number.series output
- new.sentence
- publisher "publisher" output.check
- address output
- }
- {
- format.chapter.pages "chapter and pages" output.check
- new.block
- format.book.crossref output.nonnull
- }
- if$
- format.edition output
- new.block
- note output
- fin.entry
-}
-
-FUNCTION {incollection}
-{ output.bibitem
- format.authors "author" output.check
- author format.key output
- format.date "year" output.check
- date.block
- format.title "title" output.check
- new.block
- crossref missing$
- { format.in.ed.booktitle "booktitle" output.check
- format.bvolume output
- format.number.series output
- format.chapter.pages output
- new.sentence
- publisher "publisher" output.check
- address output
- format.edition output
- }
- { format.incoll.inproc.crossref output.nonnull
- format.chapter.pages output
- }
- if$
- new.block
- note output
- fin.entry
-}
-
-FUNCTION {inproceedings}
-{ output.bibitem
- format.authors "author" output.check
- author format.key output
- format.date "year" output.check
- date.block
- format.title "title" output.check
- new.block
- crossref missing$
- { format.in.ed.booktitle "booktitle" output.check
- format.bvolume output
- format.number.series output
- format.pages output
- address output
- new.sentence
- organization output
- publisher output
- }
- { format.incoll.inproc.crossref output.nonnull
- format.pages output
- }
- if$
- new.block
- note output
- fin.entry
-}
-
-FUNCTION {conference} { inproceedings }
-
-FUNCTION {manual}
-{ output.bibitem
- format.authors output
- author format.key output
- format.date "year" output.check
- date.block
- format.btitle "title" output.check
- organization address new.block.checkb
- organization output
- address output
- format.edition output
- new.block
- note output
- fin.entry
-}
-
-FUNCTION {mastersthesis}
-{ output.bibitem
- format.authors "author" output.check
- author format.key output
- format.date "year" output.check
- date.block
- format.btitle "title" output.check
- new.block
- bbl.mthesis format.thesis.type output.nonnull
- school "school" output.check
- address output
- new.block
- note output
- fin.entry
-}
-
-FUNCTION {misc}
-{ output.bibitem
- format.authors output
- author format.key output
- format.date "year" output.check
- date.block
- format.title output
- new.block
- howpublished output
- new.block
- note output
- fin.entry
-}
-
-FUNCTION {phdthesis}
-{ output.bibitem
- format.authors "author" output.check
- author format.key output
- format.date "year" output.check
- date.block
- format.btitle "title" output.check
- new.block
- bbl.phdthesis format.thesis.type output.nonnull
- school "school" output.check
- address output
- new.block
- note output
- fin.entry
-}
-
-FUNCTION {proceedings}
-{ output.bibitem
- format.editors output
- editor format.key output
- format.date "year" output.check
- date.block
- format.btitle "title" output.check
- format.bvolume output
- format.number.series output
- address output
- new.sentence
- organization output
- publisher output
- new.block
- note output
- fin.entry
-}
-
-FUNCTION {techreport}
-{ output.bibitem
- format.authors "author" output.check
- author format.key output
- format.date "year" output.check
- date.block
- format.title "title" output.check
- new.block
- format.tr.number output.nonnull
- institution "institution" output.check
- address output
- new.block
- note output
- fin.entry
-}
-
-FUNCTION {unpublished}
-{ output.bibitem
- format.authors "author" output.check
- author format.key output
- format.date "year" output.check
- date.block
- format.title "title" output.check
- new.block
- note "note" output.check
- fin.entry
-}
-
-FUNCTION {default.type} { misc }
-
-READ
-
-FUNCTION {sortify}
-{ purify$
- "l" change.case$
-}
-
-INTEGERS { len }
-
-FUNCTION {chop.word}
-{ 's :=
- 'len :=
- s #1 len substring$ =
- { s len #1 + global.max$ substring$ }
- 's
- if$
-}
-
-FUNCTION {format.lab.names}
-{ 's :=
- s #1 "{vv~}{ll}" format.name$
- s num.names$ duplicate$
- #2 >
- { pop$ " et~al." * }
- { #2 <
- 'skip$
- { s #2 "{ff }{vv }{ll}{ jj}" format.name$ "others" =
- { " et~al." * }
- { bbl.and
- space.word * s #2 "{vv~}{ll}" format.name$ * }
- if$
- }
- if$
- }
- if$
-}
-
-FUNCTION {author.key.label}
-{ author empty$
- { key empty$
- { cite$ #1 #3 substring$ }
- 'key
- if$
- }
- { author format.lab.names }
- if$
-}
-
-FUNCTION {author.editor.key.label}
-{ author empty$
- { editor empty$
- { key empty$
- { cite$ #1 #3 substring$ }
- 'key
- if$
- }
- { editor format.lab.names }
- if$
- }
- { author format.lab.names }
- if$
-}
-
-FUNCTION {editor.key.label}
-{ editor empty$
- { key empty$
- { cite$ #1 #3 substring$ }
- 'key
- if$
- }
- { editor format.lab.names }
- if$
-}
-
-FUNCTION {calc.short.authors}
-{ type$ "book" =
- type$ "inbook" =
- or
- 'author.editor.key.label
- { type$ "proceedings" =
- 'editor.key.label
- 'author.key.label
- if$
- }
- if$
- 'short.list :=
-}
-
-FUNCTION {calc.label}
-{ calc.short.authors
- short.list
- "("
- *
- year duplicate$ empty$
- { pop$ "????" }
- 'skip$
- if$
- *
- 'label :=
-}
-
-FUNCTION {sort.format.names}
-{ 's :=
- #1 'nameptr :=
- ""
- s num.names$ 'numnames :=
- numnames 'namesleft :=
- { namesleft #0 > }
- { s nameptr
- "{vv{ } }{ll{ }}{ f{ }}{ jj{ }}"
- format.name$ 't :=
- nameptr #1 >
- {
- " " *
- namesleft #1 = t "others" = and
- { "aaaaa" * }
- { t sortify * }
- if$
- }
- { t sortify * }
- if$
- nameptr #1 + 'nameptr :=
- namesleft #1 - 'namesleft :=
- }
- while$
-}
-
-FUNCTION {sort.format.title}
-{ 't :=
- "A " #2
- "An " #3
- "The " #4 t chop.word
- chop.word
- chop.word
- sortify
- #1 global.max$ substring$
-}
-
-FUNCTION {author.sort}
-{ author empty$
- { key empty$
- { "to sort, need author or key in " cite$ * warning$
- ""
- }
- { key sortify }
- if$
- }
- { author sort.format.names }
- if$
-}
-
-FUNCTION {author.editor.sort}
-{ author empty$
- { editor empty$
- { key empty$
- { "to sort, need author, editor, or key in " cite$ * warning$
- ""
- }
- { key sortify }
- if$
- }
- { editor sort.format.names }
- if$
- }
- { author sort.format.names }
- if$
-}
-
-FUNCTION {editor.sort}
-{ editor empty$
- { key empty$
- { "to sort, need editor or key in " cite$ * warning$
- ""
- }
- { key sortify }
- if$
- }
- { editor sort.format.names }
- if$
-}
-
-FUNCTION {presort}
-{ calc.label
- label sortify
- " "
- *
- type$ "book" =
- type$ "inbook" =
- or
- 'author.editor.sort
- { type$ "proceedings" =
- 'editor.sort
- 'author.sort
- if$
- }
- if$
- #1 entry.max$ substring$
- 'sort.label :=
- sort.label
- *
- " "
- *
- title field.or.null
- sort.format.title
- *
- #1 entry.max$ substring$
- 'sort.key$ :=
-}
-
-ITERATE {presort}
-
-SORT
-
-STRINGS { last.label next.extra }
-
-INTEGERS { last.extra.num number.label }
-
-FUNCTION {initialize.extra.label.stuff}
-{ #0 int.to.chr$ 'last.label :=
- "" 'next.extra :=
- #0 'last.extra.num :=
- #0 'number.label :=
-}
-
-FUNCTION {forward.pass}
-{ last.label label =
- { last.extra.num #1 + 'last.extra.num :=
- last.extra.num int.to.chr$ 'extra.label :=
- }
- { "a" chr.to.int$ 'last.extra.num :=
- "" 'extra.label :=
- label 'last.label :=
- }
- if$
- number.label #1 + 'number.label :=
-}
-
-FUNCTION {reverse.pass}
-{ next.extra "b" =
- { "a" 'extra.label := }
- 'skip$
- if$
- extra.label 'next.extra :=
- extra.label
- duplicate$ empty$
- 'skip$
- { "{" swap$ * "}" * }
- if$
- 'extra.label :=
- label extra.label * 'label :=
-}
-
-EXECUTE {initialize.extra.label.stuff}
-
-ITERATE {forward.pass}
-
-REVERSE {reverse.pass}
-
-FUNCTION {bib.sort.order}
-{ sort.label
- " "
- *
- year field.or.null sortify
- *
- " "
- *
- title field.or.null
- sort.format.title
- *
- #1 entry.max$ substring$
- 'sort.key$ :=
-}
-
-ITERATE {bib.sort.order}
-
-SORT
-
-FUNCTION {begin.bib}
-{ preamble$ empty$
- 'skip$
- { preamble$ write$ newline$ }
- if$
- "\begin{thebibliography}{" number.label int.to.str$ * "}" *
- write$ newline$
-}
-
-EXECUTE {begin.bib}
-
-EXECUTE {init.state.consts}
-
-ITERATE {call.type$}
-
-FUNCTION {end.bib}
-{ newline$
- "\end{thebibliography}" write$ newline$
-}
-
-EXECUTE {end.bib}
-%% End of customized bst file
-%%
-%% End of file `ecology.bst'. \ No newline at end of file
diff --git a/vignettes/ecology.csl b/vignettes/ecology.csl
new file mode 100644
index 0000000..1d3c0c7
--- /dev/null
+++ b/vignettes/ecology.csl
@@ -0,0 +1,188 @@
+<?xml version="1.0" encoding="utf-8"?>
+<style xmlns="http://purl.org/net/xbiblio/csl" class="in-text" default-locale="en-US" version="1.0" demote-non-dropping-particle="sort-only">
+ <info>
+ <title>Ecology</title>
+ <id>http://www.zotero.org/styles/ecology</id>
+ <link href="http://www.zotero.org/styles/ecology" rel="self"/>
+ <link href="http://esapubs.org/esapubs/AuthorInstructions.htm" rel="documentation"/>
+ <author>
+ <name>Rintze Zelle</name>
+ <uri>http://twitter.com/rintzezelle</uri>
+ </author>
+ <category citation-format="author-date"/>
+ <category field="biology"/>
+ <issn>0012-9658</issn>
+ <updated>2012-09-27T22:06:38+00:00</updated>
+ <rights license="http://creativecommons.org/licenses/by-sa/3.0/">This work is licensed under a Creative Commons Attribution-ShareAlike 3.0 License</rights>
+ </info>
+ <macro name="container-contributors">
+ <choose>
+ <if type="chapter paper-conference" match="any">
+ <text term="in" suffix=" " font-style="italic"/>
+ <names variable="editor translator" delimiter=", ">
+ <name and="text" initialize-with=". " delimiter=", "/>
+ <label form="long" prefix=", " suffix="."/>
+ </names>
+ </if>
+ </choose>
+ </macro>
+ <macro name="secondary-contributors">
+ <choose>
+ <if type="chapter paper-conference" match="none">
+ <names variable="editor translator" delimiter=", " prefix=" (" suffix=")">
+ <name and="text" initialize-with=". " delimiter=", "/>
+ <label form="short" prefix=", " text-case="capitalize-first"/>
+ </names>
+ </if>
+ </choose>
+ </macro>
+ <macro name="author">
+ <names variable="author">
+ <name name-as-sort-order="first" and="text" sort-separator=", " initialize-with=". " delimiter=", " delimiter-precedes-last="always"/>
+ <label prefix=", "/>
+ <substitute>
+ <names variable="editor"/>
+ <names variable="translator"/>
+ <text variable="title"/>
+ </substitute>
+ </names>
+ </macro>
+ <macro name="author-short">
+ <names variable="author">
+ <name form="short" and="text" delimiter=", " initialize-with=". "/>
+ <substitute>
+ <names variable="editor"/>
+ <names variable="translator"/>
+ <choose>
+ <if type="bill book graphic legal_case legislation motion_picture report song" match="any">
+ <text variable="title" form="short" font-style="italic"/>
+ </if>
+ <else>
+ <text variable="title" form="short" quotes="true"/>
+ </else>
+ </choose>
+ </substitute>
+ </names>
+ </macro>
+ <macro name="access">
+ <choose>
+ <if type="webpage">
+ <text variable="URL"/>
+ </if>
+ </choose>
+ </macro>
+ <macro name="publisher">
+ <group delimiter=", ">
+ <choose>
+ <if type="article-journal article-magazine" match="none">
+ <text variable="genre"/>
+ <text variable="publisher"/>
+ <text variable="publisher-place"/>
+ </if>
+ </choose>
+ </group>
+ </macro>
+ <macro name="issued">
+ <choose>
+ <if variable="issued">
+ <group prefix=" " suffix=".">
+ <date variable="issued">
+ <date-part name="year"/>
+ </date>
+ <choose>
+ <if type="article-journal bill book chapter graphic legal_case legislation motion_picture paper-conference report song" match="none">
+ <date variable="issued">
+ <date-part prefix=", " name="month"/>
+ <date-part prefix=" " name="day"/>
+ </date>
+ </if>
+ </choose>
+ </group>
+ </if>
+ <else>
+ <text prefix=" (" term="no date" suffix=")." form="short"/>
+ </else>
+ </choose>
+ </macro>
+ <macro name="issued-year">
+ <choose>
+ <if variable="issued">
+ <date variable="issued">
+ <date-part name="year"/>
+ </date>
+ </if>
+ <else>
+ <text term="no date" form="short"/>
+ </else>
+ </choose>
+ </macro>
+ <macro name="edition">
+ <choose>
+ <if type="bill book chapter graphic legal_case legislation motion_picture paper-conference report song" match="any">
+ <choose>
+ <if is-numeric="edition">
+ <number variable="edition" form="long-ordinal" text-case="capitalize-first"/>
+ <text term="edition" form="long" prefix=" " suffix="."/>
+ </if>
+ <else>
+ <text variable="edition" suffix="."/>
+ </else>
+ </choose>
+ </if>
+ </choose>
+ </macro>
+ <macro name="locators">
+ <choose>
+ <if type="article-journal article-magazine article-newspaper" match="any">
+ <text variable="container-title" prefix=". "/>
+ <text variable="volume" prefix=" "/>
+ <text variable="page" prefix=":"/>
+ </if>
+ <else-if type="bill book chapter graphic legal_case legislation motion_picture paper-conference report song" match="any">
+ <group prefix=". " delimiter=" ">
+ <label variable="page" form="long" text-case="capitalize-first"/>
+ <text variable="page"/>
+ <text macro="container-contributors"/>
+ <text macro="secondary-contributors"/>
+ <text variable="container-title"/>
+ </group>
+ </else-if>
+ </choose>
+ </macro>
+ <macro name="citation-locator">
+ <group>
+ <label variable="locator" form="short"/>
+ <text variable="locator" prefix=" "/>
+ </group>
+ </macro>
+ <citation et-al-min="3" et-al-use-first="1" disambiguate-add-year-suffix="true" collapse="year">
+ <sort>
+ <key variable="issued"/>
+ <key macro="author"/>
+ </sort>
+ <layout prefix="(" suffix=")" delimiter=", ">
+ <group delimiter=" ">
+ <text macro="author-short"/>
+ <text macro="issued-year"/>
+ <text macro="citation-locator"/>
+ </group>
+ </layout>
+ </citation>
+ <bibliography hanging-indent="true" entry-spacing="0" line-spacing="2">
+ <sort>
+ <key macro="author"/>
+ <key variable="issued"/>
+ </sort>
+ <layout suffix=".">
+ <text macro="author" suffix="."/>
+ <text macro="issued" suffix=" "/>
+ <text variable="title"/>
+ <text macro="locators"/>
+ <group delimiter=". " prefix=". ">
+ <text macro="edition"/>
+ <text macro="publisher"/>
+ <text macro="access"/>
+ </group>
+ </layout>
+ </bibliography>
+</style>
diff --git a/vignettes/figures/poweranalysis-acfl-1.png b/vignettes/figures/poweranalysis-acfl-1.png
new file mode 100644
index 0000000..5744674
--- /dev/null
+++ b/vignettes/figures/poweranalysis-acfl-1.png
Binary files differ
diff --git a/vignettes/figures/poweranalysis-acfl-2.png b/vignettes/figures/poweranalysis-acfl-2.png
new file mode 100644
index 0000000..6c212c2
--- /dev/null
+++ b/vignettes/figures/poweranalysis-acfl-2.png
Binary files differ
diff --git a/vignettes/figures/poweranalysis-alpha.png b/vignettes/figures/poweranalysis-alpha.png
new file mode 100755
index 0000000..aa10668
--- /dev/null
+++ b/vignettes/figures/poweranalysis-alpha.png
Binary files differ
diff --git a/vignettes/figures/poweranalysis-effectsizes.png b/vignettes/figures/poweranalysis-effectsizes.png
new file mode 100644
index 0000000..6435dae
--- /dev/null
+++ b/vignettes/figures/poweranalysis-effectsizes.png
Binary files differ
diff --git a/vignettes/figures/poweranalysis-list-1.png b/vignettes/figures/poweranalysis-list-1.png
new file mode 100644
index 0000000..8d30a98
--- /dev/null
+++ b/vignettes/figures/poweranalysis-list-1.png
Binary files differ
diff --git a/vignettes/figures/poweranalysis-modinfo.png b/vignettes/figures/poweranalysis-modinfo.png
new file mode 100755
index 0000000..06f2698
--- /dev/null
+++ b/vignettes/figures/poweranalysis-modinfo.png
Binary files differ
diff --git a/vignettes/figures/poweranalysis-nulls.png b/vignettes/figures/poweranalysis-nulls.png
new file mode 100755
index 0000000..0994edb
--- /dev/null
+++ b/vignettes/figures/poweranalysis-nulls.png
Binary files differ
diff --git a/vignettes/figures/poweranalysis-run.png b/vignettes/figures/poweranalysis-run.png
new file mode 100755
index 0000000..d7b1fc2
--- /dev/null
+++ b/vignettes/figures/poweranalysis-run.png
Binary files differ
diff --git a/vignettes/figures/poweranalysis-scenarios.png b/vignettes/figures/poweranalysis-scenarios.png
new file mode 100755
index 0000000..ce4da1b
--- /dev/null
+++ b/vignettes/figures/poweranalysis-scenarios.png
Binary files differ
diff --git a/vignettes/figures/poweranalysis-summaryplot.png b/vignettes/figures/poweranalysis-summaryplot.png
new file mode 100755
index 0000000..0f7b79f
--- /dev/null
+++ b/vignettes/figures/poweranalysis-summaryplot.png
Binary files differ
diff --git a/vignettes/figures/poweranalysis-summarytable.png b/vignettes/figures/poweranalysis-summarytable.png
new file mode 100755
index 0000000..02b6477
--- /dev/null
+++ b/vignettes/figures/poweranalysis-summarytable.png
Binary files differ
diff --git a/vignettes/occuMulti.Rmd b/vignettes/occuMulti.Rmd
new file mode 100644
index 0000000..25eae85
--- /dev/null
+++ b/vignettes/occuMulti.Rmd
@@ -0,0 +1,521 @@
+---
+title: Multispecies occupancy models with occuMulti
+author: Ken Kellner
+date: November 15, 2021
+bibliography: unmarked.bib
+csl: ecology.csl
+output:
+ rmarkdown::html_vignette:
+ fig_width: 5
+ fig_height: 3.5
+ number_sections: true
+ toc: true
+vignette: >
+ %\VignetteIndexEntry{Multispecies occupancy models with occuMulti}
+ %\VignetteEngine{knitr::rmarkdown}
+ \usepackage[utf8]{inputenc}
+
+---
+
+```{r,echo=FALSE}
+options(rmarkdown.html_vignette.check_title = FALSE)
+```
+
+# Introduction
+
+The @Rota2016 occupancy model is designed for presence/absence datasets with two or more (potentially) interacting species.
+The model allows for estimation of occupancy probabilities and the strength of interactions between species, as well as covariate effects on these parameters.
+The model generalizes the standard single-species occupancy model from @mackenzie_estimating_2002.
+
+The model assumes the latent occupancy state at site $i$ for a set of $s$ potentially interacting species is a vector $Z_i$ of length $s$ containing a sequence of the values 0 or 1.
+For example, when $s = 2$, the possible states are [11], [10], [01], or [00], corresponding to both species present, only species 1 or species 2 present, or both species absent, respectively.
+The latent state modeled as a multivariate Bernoulli random variable:
+$$
+ Z_i \sim \mathrm{MVB}(\psi_i)
+$$
+where $\psi_i$ is a vector of length $2^s$ containing the probability of each possible combination of 0s and 1s, such that $\sum \psi_i = 1$.
+
+For $s = 2$, the corresponding natural parameters, $f$, are
+
+$$
+\begin{split}
+ f_1 &= \mathrm{log}(\psi_{10}/\psi_{00}) \\
+ f_2 &= \mathrm{log}(\psi_{01}/\psi_{00}) \\
+ f_{12} &= \mathrm{log}((\psi_{11} * \psi_{00})/(\psi_{10} * \psi_{01}))
+\end{split}
+$$
+
+The natural parameters can then be modeled as linear functions of covariates.
+
+The observation process is similar to the standard single-species occupancy model, except that the observations $y_{ij}$ at site $i$ on occasion $j$ are vectors of length $s$ and there are independent values of detection probability $p$ for each species $s$:
+$$
+ y_{ij} | Z_i \sim \mathrm{Bernoulli}(Z_i * p_{sij})
+$$
+See @Rota2016 for more details on model structure.
+In `unmarked`, the model can be fit with the `occuMulti` function.
+
+# Simple multispecies analysis
+
+We will start with a simple analysis using presence/absence data from camera traps for three species: coyote, red fox, and bobcat.
+The data are a simplified version of the data used in @Rota2016, with the data collapsed three into three-week long time periods.
+
+## Formatting the data
+
+The dataset is included with `unmarked` and is called `MesoCarnivores`.
+First, we need to load in the dataset, which is a list with several components.
+
+```{r, eval=FALSE}
+library(unmarked)
+data(MesoCarnivores)
+names(MesoCarnivores)
+```
+
+Presence/absence matrices for the three species are in list elements `bobcat`, `coyote`, and `redfox`, and `sitecovs` contains the site-level covariate data.
+
+Using this information, we will create an `unmarkedFrameOccuMulti` object.
+You can get more information by looking at the help file for `unmarkedFrameOccuMulti`:
+
+```{r, eval=FALSE}
+?unmarkedFrameOccuMulti
+```
+
+First we combine the detection data for the 3 species into one named list.
+These names will be used throughout the multispecies analysis, so pick useful ones.
+
+```{r}
+ylist <- list(bobcat=MesoCarnivores$bobcat, coyote=MesoCarnivores$coyote,
+ redfox=MesoCarnivores$redfox)
+lapply(ylist, head)
+```
+
+The site covariates are contained in a data frame:
+
+```{r}
+head(MesoCarnivores$sitecovs)
+```
+
+The site covariates include a metric of disturbance in a 5 km radius (`Dist_5km`), housing density in a 5 km radius (`HDens_5km`), latitude, longitude, a metric of how many people use the site (`People_site`) and whether the camera site is on (or off) a trail.
+Using our `ylist`, site covariates, and observation covariates, we can construct an `unmarkedFrameOccuMulti` object.
+
+```{r}
+umf <- unmarkedFrameOccuMulti(y=ylist, siteCovs=MesoCarnivores$sitecovs)
+```
+
+## Occupancy formulas
+
+While most `unmarked` models have only one or two formulas (and a single formula for occupancy or abundance), `occuMulti` requires one formula per natural parameter $f$.
+Thus, there will be multiple formulas associated with occupancy.
+These formulas are organized into an ordered character vector.
+It can be hard to keep track of how many natural parameters there are and what each one represents.
+It can be helpful to look at the $f$-design matrix, which is generated by `unmarkedFrameOccuMulti`.
+
+```{r}
+umf@fDesign
+```
+
+The number and order of the formulas in the vector should match the column names of this matrix.
+There are 7 columns in the matrix: thus, we'll need 7 formulas total, and they should be provided in the following order:
+
+```{r}
+colnames(umf@fDesign)
+```
+
+For this model we'll set the 1st and 2nd-order $f$ parameters to be intercept-only, and fix the 3rd order parameter at 0.
+We will combine our formulas into a vector called `stateformulas`, like this:
+
+```{r}
+stateformulas <- c("~1","~1","~1","~1","~1","~1","0")
+```
+
+Notice that the formulas are character strings (each wrapped in `""`). This is required.
+
+## Detection formulas
+
+Each species has its own detection probability formula.
+Thus, there should be 3 total formulas combined in a `detformulas` vector.
+The order of the formulas should match the order of species in `ylist`.
+For this model, all three species will have intercept-only detection formulas.
+
+```{r}
+detformulas <- c("~1","~1","~1")
+```
+
+## Fit the model
+
+First, look at the help file for `occuMulti` to check what the required arguments are:
+
+```{r, eval=FALSE}
+?occuMulti
+```
+
+We now have all the pieces we need (`unmarkedFrameOccuMulti`, `stateformulas`, `detformulas`) needed to run a basic model which we will call `mod_null`.
+
+```{r}
+mod_null <- occuMulti(detformulas=detformulas, stateformulas=stateformulas, data=umf)
+summary(mod_null)
+```
+
+The regression parameters associated with each $f$ are identified by the species name (or combination of species names) in brackets.
+
+A few things to notice:
+
+* Coyote occupancy is the highest of the three species.
+* Negative relationship between bobcat and red fox
+* Positive relationships between coyote and the other two species
+* There is no three-species interaction term in the summary, because we fixed it at 0.
+
+## Occupancy probabilities
+
+To get the expected probability for each occupancy state ([11], [10] and so on) at each site, use the `predict` function.
+This gives you the probabilities along with standard errors and a 95% CI.
+
+```{r}
+occ_prob <- predict(mod_null, type="state")
+head(occ_prob$Predicted)
+```
+
+The rows of this matrix should sum to 1.
+All rows are the same because estimated occupancies at all sites are the same - we didn't include any covariates.
+
+## Marginal occupancy
+
+It's often more interesting to look at occupancy for species individually.
+For example, you might want to know the marginal occupancy of one species at each site (across all possible occupancy states).
+
+You can do this by specifying the `species` argument in `predict`, which will automatically sum up the appropriate occupancy states.
+
+```{r}
+redfox_marginal <- predict(mod_null, type="state", species="redfox")
+head(redfox_marginal)
+```
+
+## Plotting marginal occupancy
+
+Outputs from `predict` can be used to compare marginal occupancy across species with a plot.
+First, we'll need to get marginal occupancy for the other two species, and combine the three estimates into a single data frame.
+
+```{r}
+coy_marginal <- predict(mod_null, type="state", species="coyote")
+bob_marginal <- predict(mod_null, type="state", species="bobcat")
+all_marginal <- rbind(redfox_marginal[1,], coy_marginal[1,], bob_marginal[1,])
+all_marginal$Species <- c("Red fox", "Coyote", "Bobcat")
+```
+
+Now we can plot the estimated marginal occupancy for each species, along with 95\% CIs.
+
+```{r, fig.height=5}
+plot(1:3, all_marginal$Predicted, ylim=c(0.1,0.4),
+ xlim=c(0.5,3.5), pch=19, cex=1.5, xaxt='n',
+ xlab="", ylab="Marginal occupancy and 95% CI")
+axis(1, at=1:3, labels=all_marginal$Species)
+
+# CIs
+top <- 0.1
+for (i in 1:3){
+ segments(i, all_marginal$lower[i], i, all_marginal$upper[i])
+ segments(i-top, all_marginal$lower[i], i+top)
+ segments(i-top, all_marginal$upper[i], i+top)
+}
+```
+
+## Conditional occupancy
+
+Alternatively, you might want to know the probability of occupancy of one species, conditional on the presence of another. Use the `species` and `cond` arguments together for this.
+For example, the probability of red fox occupancy, conditional on coyote presence:
+
+```{r}
+redfox_coy <- predict(mod_null, type="state", species="redfox", cond="coyote")
+head(redfox_coy)
+```
+
+What about conditional on coyote *absence*?
+Simply add a `"-"` before the species name.
+
+```{r}
+redfox_nocoy <- predict(mod_null, type="state", species="redfox", cond="-coyote")
+head(redfox_nocoy)
+```
+
+## Plotting conditional occupancy
+
+You can use this output from `predict` to generate comparison plots.
+
+```{r, fig.height=5}
+cond_data <- rbind(redfox_coy[1,], redfox_nocoy[1,])
+cond_data$Coyote_status <- c("Present","Absent")
+
+plot(1:2, cond_data$Predicted, ylim=c(0,0.3),
+ xlim=c(0.5,2.5), pch=19, cex=1.5, xaxt='n',
+ xlab="Coyote status", ylab="Red fox occupancy and 95% CI")
+axis(1, at=1:2, labels=cond_data$Coyote_status)
+
+# CIs
+top <- 0.1
+for (i in 1:2){
+ segments(i, cond_data$lower[i], i, cond_data$upper[i])
+ segments(i-top, cond_data$lower[i], i+top)
+ segments(i-top, cond_data$upper[i], i+top)
+}
+```
+
+Note that red fox occupancy is higher at sites where coyotes were present, which corresponds with the positive interaction term between the two species we saw in the model output summary.
+
+# Multispecies model with covariates
+
+Now we'll fit a model with covariates on some natural parameters.
+It might be helpful to look at the order for our $f$ parameters again:
+
+```{r}
+colnames(umf@fDesign)
+```
+
+And our available site covariates:
+
+```{r}
+head(siteCovs(umf))
+```
+
+## Add housing density as a covariate
+
+We'll fit a model with an effect of housing density (`HDens_5km`) on the first-order parameters for all three species.
+The two-way interactions will remain intercept-only, and the three-way interaction will remain fixed at 0.
+Here's the vector of $f$ formulas:
+
+```{r}
+sf <- c("~HDens_5km","~HDens_5km","~HDens_5km","~1","~1","~1","0")
+```
+
+Inside your formula, you can wrap the variable name in \code{scale()} to standardize it, which we should do, because the housing density variable is not scaled.
+
+```{r}
+sf <- c("~scale(HDens_5km)","~scale(HDens_5km)","~scale(HDens_5km)","~1","~1","~1","0")
+```
+
+Detection formulas will remain the same, so we're now ready to fit a new model, `mod_hdens`.
+
+```{r}
+mod_hdens <- occuMulti(stateformulas=sf, detformulas=detformulas, umf)
+summary(mod_hdens)
+```
+
+A few things to note from the results:
+
+* Housing density has a significant negative effect on occupancy of bobcat
+* Housing density has a significant positive effect on red fox
+* No effect of housing density on coyote.
+
+## Plotting covariate effects
+
+To plot the effect of housing density on marginal occupancy, we again use `predict`.
+First, we need to generate sequence of possible `Hdens_5km` values for the X-axis of our plot.
+We'll generate a sequence of 100 values, starting at the minimum observed housing density and ending at the maximum observed value.
+
+```{r}
+hdens_range <- range(siteCovs(umf)$HDens_5km)
+hdens_seq <- seq(hdens_range[1], hdens_range[2], length.out=100)
+```
+
+Next, we'll `predict` marginal coyote occupancy at each value of `Hdens_5km` along our sequence.
+Our custom housing density values should be in a data frame and provided to the `newdata` argument.
+Because we used `scale()` in our formulas above, there is no need to manually scale these new housing density values - `unmarked` will do it for us.
+
+```{r}
+nd <- data.frame(HDens_5km = hdens_seq)
+occ_hdens_coy <- predict(mod_hdens, type="state", species="coyote", newdata=nd)
+occ_hdens_coy$Species <- "Coyote"
+occ_hdens_coy$Hdens <- hdens_seq
+head(occ_hdens_coy)
+```
+
+We'll do the same thing for the other two species.
+
+```{r}
+occ_hdens_bob <- predict(mod_hdens, type="state", species="bobcat", newdata=nd)
+occ_hdens_fox <- predict(mod_hdens, type="state", species="redfox", newdata=nd)
+occ_hdens_bob$Species <- "Bobcat"
+occ_hdens_fox$Species <- "Red fox"
+occ_hdens_bob$Hdens <- hdens_seq
+occ_hdens_fox$Hdens <- hdens_seq
+```
+
+Finally, we'll build our plot.
+Housing density will be on the x-axis, marginal occupancy on the y-axis, and species will be identified by colors.
+
+```{r, fig.height=5}
+plot(occ_hdens_coy$Hdens, occ_hdens_coy$Predicted, type='l', ylim=c(0,0.6),
+ col='red', lwd=2, xlab="Housing density", ylab="Marginal occupancy")
+lines(occ_hdens_bob$Hdens, occ_hdens_bob$Predicted, col='blue', lwd=2)
+lines(occ_hdens_fox$Hdens, occ_hdens_fox$Predicted, col='green', lwd=2)
+legend('topleft', col=c('red', 'blue', 'green'), lty=1,
+ legend=c("Coyote", "Bobcat", "Red fox"))
+```
+
+# Model selection
+
+`unmarked` can calculate AIC, $\Delta$AIC, and weights for a list of models automatically.
+Start by creating a `fitList` object containing our two models:
+
+```{r}
+mods <- fitList(mod_null, mod_hdens)
+```
+
+Then call the function `modSel` on our list of models to generate a model selection table:
+
+```{r}
+modSel(mods)
+```
+
+Looks like the model with housing density is better.
+
+# Model fitting challenges
+
+Multispecies occupancy models often have many parameters, and can be difficult to fit in some situations.
+You might get poor estimates (i.e., very large absolute values and/or large SEs) under certain conditions:
+
+* Sparse data (many 0s)
+* Boundary estimates (occupancy close to 0 or 1)
+* Few observations where multiple species are detected
+* Separation (perfect correlation with covariate)
+
+Here's an example of a complex model with many covariates that results in poor estimates.
+
+```{r, eval=FALSE}
+state_complex <- c(rep("~scale(Dist_5km)+scale(HDens_5km)", 6), 0)
+det_complex <- rep("~Trail",3)
+
+mod_complex <- occuMulti(stateformulas=state_complex, detformulas=det_complex, umf)
+summary(mod_complex)
+```
+
+```
+##
+## Call:
+## occuMulti(detformulas = det_complex, stateformulas = state_complex,
+## data = umf, maxOrder = 3L)
+##
+## Occupancy (logit-scale):
+## Estimate SE z P(>|z|)
+## [bobcat] (Intercept) -23.0171 5.784 -3.980 6.90e-05
+## [bobcat] scale(Dist_5km) -2.4249 0.689 -3.519 4.34e-04
+## [bobcat] scale(HDens_5km) -82.3836 19.788 -4.163 3.14e-05
+## [coyote] (Intercept) -0.6789 0.225 -3.017 2.55e-03
+## [coyote] scale(Dist_5km) -0.0176 0.139 -0.127 8.99e-01
+## [coyote] scale(HDens_5km) -0.5534 0.748 -0.740 4.59e-01
+## [redfox] (Intercept) -1.3946 0.257 -5.425 5.78e-08
+## [redfox] scale(Dist_5km) -0.5293 0.250 -2.115 3.45e-02
+## [redfox] scale(HDens_5km) 0.2108 0.261 0.808 4.19e-01
+## [bobcat:coyote] (Intercept) 6.7598 6.384 1.059 2.90e-01
+## [bobcat:coyote] scale(Dist_5km) 1.6979 0.695 2.445 1.45e-02
+## [bobcat:coyote] scale(HDens_5km) 17.9202 21.442 0.836 4.03e-01
+## [bobcat:redfox] (Intercept) 15.3983 3.462 4.448 8.67e-06
+## [bobcat:redfox] scale(Dist_5km) 0.8836 0.439 2.014 4.40e-02
+## [bobcat:redfox] scale(HDens_5km) 64.1330 12.377 5.182 2.20e-07
+## [coyote:redfox] (Intercept) 1.1084 0.363 3.050 2.29e-03
+## [coyote:redfox] scale(Dist_5km) 0.1149 0.340 0.338 7.35e-01
+## [coyote:redfox] scale(HDens_5km) 0.9046 0.781 1.159 2.47e-01
+##
+## Detection (logit-scale):
+## Estimate SE z P(>|z|)
+## [bobcat] (Intercept) -2.83 0.1419 -19.91 3.10e-88
+## [bobcat] Trail 1.74 0.1542 11.26 2.10e-29
+## [coyote] (Intercept) -1.96 0.0984 -19.88 5.89e-88
+## [coyote] Trail 2.17 0.1220 17.75 1.63e-70
+## [redfox] (Intercept) -1.59 0.1601 -9.93 2.97e-23
+## [redfox] Trail 1.78 0.1997 8.93 4.12e-19
+##
+## AIC: 5958.196
+## Number of sites: 1437
+## optim convergence code: 0
+## optim iterations: 196
+## Bootstrap iterations: 0
+```
+
+
+Note that several estimates are very large (>10) and also have large SEs.
+You should be very skeptical about using a model with poor estimates, like this one, for inference.
+Potential solutions when you get poor estimates include:
+
+* Fit simpler models with fewer covariates
+* If possible, fit the model with fewer species
+* Adjust observation period length if possible (e.g. collapse from one-week periods to three-week periods)
+* Use penalized likelihood to fit the model
+
+# Penalized likelihood
+
+`occuMulti` uses maximum likelihood to estimate parameters.
+We can add a "penalty" to the calculated likelihood to keep parameter estimates from getting stuck at huge values
+Use of penalized likelihood has been shown to help with separation/boundary issues, eliminate unreasonably large estimates, and reduce error,
+However, note that the penalty term introduces a small amount of bias in the parameter estimates: thus, we are making a tradeoff between bias and variance
+With huge SEs as with the previous model, this may be a good tradeoff to make.
+
+One type of penalty is the "Bayes" penalty:
+$$
+-\lambda\frac{1}{2}\sum_i{}\theta_i^2
+$$
+In the formula above, $\lambda$ is the penalty value, and $\theta$ is the vector of estimated parameters.
+As the parameter values get bigger, the total penalty increases.
+
+## Penalized likelihood with occuMulti
+
+`occuMulti` can use penalized likelihood to fit models.
+You can provide a value to the `penalty` argument directly, or use the `optimizePenalty` function on a fitted model to choose the best value of $\lambda$ using K-fold cross-validation, and re-fit the model using the optimal penalty term value.
+
+```{r,eval=FALSE}
+set.seed(123)
+mod_penalty <- optimizePenalty(mod_complex, penalties=c(0.5,1))
+summary(mod_penalty)
+```
+
+```
+## Optimal penalty is 1
+## Bootstraping covariance matrix
+
+## Call:
+## occuMulti(detformulas = c("~Trail", "~Trail", "~Trail"), stateformulas = c("~scale(Dist_5km)+scale(HDens_5km)",
+## "~scale(Dist_5km)+scale(HDens_5km)", "~scale(Dist_5km)+scale(HDens_5km)",
+## "~scale(Dist_5km)+scale(HDens_5km)", "~scale(Dist_5km)+scale(HDens_5km)",
+## "~scale(Dist_5km)+scale(HDens_5km)", "0"), data = object@data,
+## maxOrder = 3L, penalty = 1, boot = boot)
+
+## Occupancy (logit-scale):
+## Estimate SE z P(>|z|)
+## [bobcat] (Intercept) -1.7810 0.221 -8.054 8.00e-16
+## [bobcat] scale(Dist_5km) -1.3143 0.337 -3.903 9.48e-05
+## [bobcat] scale(HDens_5km) -2.8200 0.529 -5.334 9.61e-08
+## [coyote] (Intercept) -0.6049 0.178 -3.407 6.56e-04
+## [coyote] scale(Dist_5km) 0.0285 0.150 0.190 8.49e-01
+## [coyote] scale(HDens_5km) -1.0908 0.397 -2.748 5.99e-03
+## [redfox] (Intercept) -1.5659 0.310 -5.059 4.22e-07
+## [redfox] scale(Dist_5km) -0.3068 0.138 -2.226 2.60e-02
+## [redfox] scale(HDens_5km) 0.4730 0.797 0.593 5.53e-01
+## [bobcat:coyote] (Intercept) 1.1871 0.372 3.195 1.40e-03
+## [bobcat:coyote] scale(Dist_5km) 0.9347 0.368 2.537 1.12e-02
+## [bobcat:coyote] scale(HDens_5km) -0.3218 1.043 -0.309 7.58e-01
+## [bobcat:redfox] (Intercept) -0.8831 0.346 -2.553 1.07e-02
+## [bobcat:redfox] scale(Dist_5km) 0.0364 0.233 0.156 8.76e-01
+## [bobcat:redfox] scale(HDens_5km) 2.5609 1.074 2.384 1.71e-02
+## [coyote:redfox] (Intercept) 1.0001 0.249 4.009 6.09e-05
+## [coyote:redfox] scale(Dist_5km) 0.0236 0.229 0.103 9.18e-01
+## [coyote:redfox] scale(HDens_5km) 1.3920 0.424 3.281 1.03e-03
+
+## Detection (logit-scale):
+## Estimate SE z P(>|z|)
+## [bobcat] (Intercept) -2.44 0.150 -16.22 3.72e-59
+## [bobcat] Trail 1.74 0.164 10.61 2.59e-26
+## [coyote] (Intercept) -1.89 0.117 -16.24 2.72e-59
+## [coyote] Trail 2.10 0.150 14.00 1.52e-44
+## [redfox] (Intercept) -1.49 0.206 -7.21 5.66e-13
+## [redfox] Trail 1.72 0.254 6.79 1.14e-11
+
+## AIC: 6135.555
+## Number of sites: 1437
+## optim convergence code: 0
+## optim iterations: 100
+## Bootstrap iterations: 30
+```
+
+Notice that parameter estimates and SEs for the model using penalized likelihood are no longer gigantic.
+For more info on the use of penalized likelihood with multispecies occupancy models, see @Clipp_2021.
+
+
+# References
diff --git a/vignettes/powerAnalysis.Rmd b/vignettes/powerAnalysis.Rmd
new file mode 100644
index 0000000..f2cce35
--- /dev/null
+++ b/vignettes/powerAnalysis.Rmd
@@ -0,0 +1,928 @@
+---
+title: Power Analysis in unmarked
+author: Ken Kellner
+date: November 7, 2022
+bibliography: unmarked.bib
+csl: ecology.csl
+output:
+ rmarkdown::html_vignette:
+ fig_width: 5
+ fig_height: 3.5
+ number_sections: true
+ toc: true
+vignette: >
+ %\VignetteIndexEntry{Power Analysis in unmarked}
+ %\VignetteEngine{knitr::rmarkdown}
+ \usepackage[utf8]{inputenc}
+---
+
+
+
+# Hypothesis Testing
+
+For many analyses in `unmarked`, a primary goal is to determine if a certain covariate affects the state or detection process.
+For example, we may want to determine if elevation has an effect on probability of site occupancy, or if wind speed has an effect on detection.
+We can formulate this idea as set of statistical hypotheses: the null hypothesis ($H_0$) and the alternative hypothesis ($H_a$):
+
+* $H_0$: There is no effect of elevation on occupancy
+* $H_a$: Elevation has an effect on occupancy
+
+In order to test these hypotheses, we must collected appropriate data, perhaps by sampling a series of sites at varying elevation for the presence of the species.
+We can then fit a model in `unmarked`, specifying in the formula that we are interested in estimating the effect of elevation on occupancy.
+For example, here is a simple model fit to the `crossbill` presence-absence dataset included with `unmarked`:
+
+
+```r
+set.seed(123)
+library(unmarked)
+data(crossbill)
+
+umf <- unmarkedFrameOccu(y=crossbill[,11:13],
+ siteCovs=data.frame(elev=scale(crossbill$ele)))
+(mod <- occu(~1~elev, umf))
+```
+
+```
+##
+## Call:
+## occu(formula = ~1 ~ elev, data = umf)
+##
+## Occupancy:
+## Estimate SE z P(>|z|)
+## (Intercept) -1.223 0.168 -7.27 3.61e-13
+## elev 0.594 0.166 3.59 3.35e-04
+##
+## Detection:
+## Estimate SE z P(>|z|)
+## 0.326 0.186 1.75 0.0798
+##
+## AIC: 480.8533
+```
+
+## Wald tests
+
+In the code{unmarked} output, we obtain an estimate ($\hat{\theta}$) of the regression coefficient associated with elevation (`elev`) along with its standard error.
+Our null hypothesis is that elevation has no effect on occupancy, i.e. $\theta_0 = 0$.
+With this information, we can conduct a statistical hypothesis test called a Wald test:
+$$
+\sqrt{W} = \frac{(\hat{\theta} -\theta_0)}{se(\hat{\theta})}
+$$
+
+Or simplified:
+$$
+\sqrt{W} = \frac{(0.5939 - 0)}{0.1656} = 3.59
+$$
+
+It turns out that the square root of the Wald statistic, $\sqrt{W}$, follows a standard normal distribution.
+Thus, we can calculate the probability that our observed statistic, $\sqrt{W} = 3.59$, occurred by chance assuming that the null hypothesis $\theta = 0$ is true.
+In R, for a two-tailed test, this can be calculated as:
+
+
+```r
+z = sqrt_w = coef(mod)[2] / SE(mod)[2]
+2*pnorm(abs(z), lower.tail=FALSE)
+```
+
+```
+## psi(elev)
+## 0.0003350055
+```
+
+This is the p-value. These values we calculated manually match the results that `unmarked` gave us in the summary output.
+
+## Making a conclusion
+
+Before conducting our study, we should have defined a threshold p-value (the significance level or $\alpha$) below which we reject the null hypothesis.
+Traditionally, $\alpha = 0.05$.
+Our calculated p-value is less than $\alpha$, so we reject the null hypothesis that elevation has no effect on occupancy.
+
+## Types of error
+
+There are two types of errors that we could be making at this point:
+
+1. Type I error: We reject the null hypothesis when in fact it is true. Type I error is conceptually the same as $\alpha$. If we set $\alpha$ larger, we have a greater chance of Type I error.
+2. Type II error: We fail to reject the null hypothesis when in fact it is false. This can occur, for example, if we did not have enough data to detect an effect.
+
+In this vignette, we are most concerned with Type II error.
+How do we know we have enough data to detect if a covariate has a certain effect?
+To answer this question we can use power analysis.
+
+# Power Analysis in unmarked
+
+## Introduction
+
+Statistical power is defined as 1 - Type II error.
+So more power means less chance of false negatives, i.e., less chance of failing to reject the null hypothesis when it is false.
+Statistical power depends on three other pieces of information:
+
+1. The effect size: the magnitude of the effect of the covariate. The larger the effect, the more power we have to detect it.
+2. The sample size: how many sites or surveys we've done. The more samples, the more power we have.
+3. The significance level, $\alpha$. The smaller we make $\alpha$, the less power we have: thus there is a tradeoff between Type I and Type II error.
+
+Of the three factors (2) is the one that makes the most sense for researchers to manipulate in order to increase power.
+However, increasing the sample size requires additional effort and money - so how large does it need to be?
+
+For many statistical models, mathematical formulas have been developed so that power can be calculated for any combination of values for factors 1-3 above.
+This is not true for most occupancy and abundance models available in `unmarked` (but see @Guillera_2012 for one example with occupancy models).
+Thus, `unmarked` uses a simulation-based approach for estimating power under various combinations of values for effect size, sample size, and significance level.
+
+## Inputs
+
+When conducting power analysis, `unmarked` needs three pieces of information corresponding to 1-3 above.
+Of these, (1) the effect size and (3) the significance level are easy to set depending on our hypotheses and desired Type I error.
+The sample size (2) is trickier: it isn't enough to just provide the number of sites, since datasets in `unmarked` also require a variety of other information such as number of surveys per site, number of distance bins, or number of primary periods.
+Thus, power analysis in `unmarked` requires a complete dataset in the form of an appropriate `unmarkedFrame`.
+
+In some cases, we may want to calculate power using an already collected dataset.
+Importantly, this step must be done \textit{before} running our final analysis.
+If power analysis is done after the final model is fit, and the effect sizes are defined based on what was observed in that fitted model, we have done what is called a *post-hoc* power analysis, which is a bad idea (see [this post](https://statmodeling.stat.columbia.edu/2018/09/24/dont-calculate-post-hoc-power-using-observed-estimate-effect-size/) for an example of why this is so bad).
+In most cases, the real value of power analysis comes before we actually go collect any data, because it helps us decide how much data to collect.
+But how to get an `unmarkedFrame` of data before we've done our study?
+Once again the solution is simulation: `unmarked` provides a set of tools for simulating datasets for any of its supported model types.
+
+## Simulating datasets
+
+To simulate a dataset for a given `unmarked` model, we need at a minimum four pieces of information:
+
+1. The type of model (the name of the corresponding fitting function)
+2. The covariates affecting each submodel, such as occupancy or detection (supplied as formulas)
+3. The effect size for each intercept and covariate
+4. Study design parameters such as number of sites and number of surveys
+
+For example, suppose we want to simulate an occupancy dataset (`"occu"`) in which site occupancy is affected by elevation.
+The first step is to organize the model structure as a list of formulas, one per submodel.
+This list must be named in a specific way depending on the model type.
+To get the required names for a given model, fit an example of that model (the documentation should have one) and call `names(model)`.
+A single-season occupancy model requires a list with two named components: `state` and `det`.
+We supply a formula for each including an effect of elevation on occupancy (note we could name this whatever we want, here we call it `elev`).
+
+
+```r
+forms <- list(state=~elev, det=~1)
+```
+
+Next we must tell `unmarked` what the values for the intercept and regression coefficients in each submodel should be.
+Once again, this is a named list, one element for each submodel.
+Within each element we need a named vector with names that match the covariates in our list of formulas above.
+Note also that each must include a value for the intercept term (this can be named `intercept` or `Intercept`).
+If we are not sure exactly how to structure this list, just skip it for now: `unmarked` can generate a template for us to fill in later.
+
+
+```r
+coefs <- list(state=c(intercept=0, elev=-0.4), det=c(intercept=0))
+```
+
+Finally, we need to give `unmarked` information about the study design.
+This is pretty simple: we just need a list containing values for `M`, the number of sites, and `J` the number of surveys per site.
+For models with multiple primary periods, we'd also need a value of `T`, the number of primary periods.
+
+
+```r
+design <- list(M=300, J=8) # 300 sites, 8 occasions per site
+```
+
+We're now ready to simulate a dataset.
+To do this we use the `simulate` function, providing as arguments the name of the model `"occu"` and the three lists we constructed above.
+Actually, first, let's not supply the `coefs` list, to show how `unmarked` will generate a template for us to use:
+
+
+```r
+simulate("occu", formulas=forms, design=design)
+```
+
+
+```
+## coefs argument should be a named list of named vectors, with the following structure
+## (replacing 0s with your desired coefficient values):
+##
+## $state
+## intercept elev
+## 0 0
+##
+## $det
+## intercept
+## 0
+##
+## Error : Supply coefs argument as specified above
+```
+
+Once we have our covariates set up properly, add them to the function call:
+
+
+```r
+occu_umf <- simulate("occu", formulas=forms, coefs=coefs, design=design)
+head(occu_umf)
+```
+
+```
+## Data frame representation of unmarkedFrame object.
+## y.1 y.2 y.3 y.4 y.5 y.6 y.7 y.8 elev
+## 1 0 0 0 0 0 0 0 0 -0.7152422
+## 2 0 0 0 0 0 0 0 0 -0.7526890
+## 3 0 0 0 0 1 0 1 0 -0.9385387
+## 4 0 0 0 0 0 0 0 0 -1.0525133
+## 5 1 0 0 0 0 0 1 0 -0.4371595
+## 6 0 1 0 1 1 0 0 0 0.3311792
+## 7 1 1 1 0 0 0 0 0 -2.0142105
+## 8 0 0 0 0 0 0 0 0 0.2119804
+## 9 1 0 0 1 0 1 0 0 1.2366750
+## 10 0 0 0 0 0 0 0 0 2.0375740
+```
+
+`unmarked` has generated a presence-absence dataset as well as values for covariate `elev`.
+
+### Customizing the covariates
+
+By default, a covariate will be continuous and come from a standard normal distribution.
+However, we can control this using the `guide` argument.
+For example, suppose we want elevation to have a mean of 2 and a standard deviation of 0.5, and we also want a categorical covariate called `landcover`.
+The corresponding formulas and list to supply to `guide` would look like this:
+
+
+```r
+forms2 <- list(state=~elev+landcover, det=~1)
+guide <- list(landcover=factor(levels=c("forest","grass")), # landcover is factor
+ elev=list(dist=rnorm, mean=2, sd=0.5)) # custom distribution
+```
+
+We'd also need an updated `coefs`:
+
+
+```r
+coefs2 <- list(state=c(intercept=0, elev=-0.4, landcovergrass=0.2), det=c(intercept=0))
+```
+
+
+```r
+head(simulate("occu", formulas=forms2, coefs=coefs2, design=design, guide=guide))
+```
+
+```
+## Data frame representation of unmarkedFrame object.
+## y.1 y.2 y.3 y.4 y.5 y.6 y.7 y.8 elev landcover
+## 1 0 0 0 0 0 0 0 0 2.063074 forest
+## 2 0 0 0 0 0 0 0 0 2.236400 forest
+## 3 0 0 0 0 0 0 0 0 1.829623 grass
+## 4 0 0 0 0 0 0 0 0 1.879105 forest
+## 5 0 0 0 0 0 0 0 0 2.689377 grass
+## 6 0 0 0 0 0 0 0 0 1.830558 forest
+## 7 0 0 0 0 0 0 0 0 2.010068 forest
+## 8 0 0 0 0 0 0 0 0 2.188481 grass
+## 9 1 0 1 1 1 0 0 0 1.784138 forest
+## 10 0 0 0 0 0 0 0 0 2.979532 grass
+```
+
+Our output dataset now includes a new categorical covariate, and the elevation values are adjusted.
+
+### Models that require more information
+
+More complex models might require more information for simulation, such as the distribution to use for abundance with `pcount`.
+This information is simply added as additional arguments to `simulate`.
+For example, we can simulate a `pcount` dataset using the negative binomial (`"NB"`) distribution.
+The negative binomial has an additional parameter to estimate (`alpha`) so we must also add an element to `coefs`.
+
+
+```r
+coefs$alpha <- c(alpha=0.5)
+head(simulate("pcount", formulas=forms, coefs=coefs, design=design, mixture="NB"))
+```
+
+```
+## Data frame representation of unmarkedFrame object.
+## y.1 y.2 y.3 y.4 y.5 y.6 y.7 y.8 elev
+## 1 0 0 0 0 0 0 0 0 -1.42329439
+## 2 0 0 0 0 0 0 0 0 1.02230366
+## 3 0 1 1 0 1 0 0 0 0.68781508
+## 4 0 0 0 0 0 0 0 0 -0.30745489
+## 5 0 0 1 0 0 1 0 1 -0.01974906
+## 6 0 1 1 1 0 0 1 0 0.48839839
+## 7 0 0 0 0 0 0 0 0 0.66050081
+## 8 0 1 0 1 1 1 0 1 -1.71404333
+## 9 0 0 0 0 0 0 0 0 1.45885698
+## 10 0 0 0 0 0 0 0 0 -1.40789548
+```
+
+## Conducting a power analysis
+
+Power analyses are conducted with the `powerAnalysis` function.
+A `powerAnalysis` power analysis depends on the input dataset, as well as the covariates of interest and other settings depending on the model (e.g. the distribution used in an N-mixture model or the detection key function in a distance sampling analysis).
+The easiest way combine all this information and send it to `powerAnalysis` is to actually fit a model with all the correct settings and our simulated dataset and send *that* to `powerAnalysis`.
+This has the added benefit that it checks to make sure we have all the required information for a valid model.
+Note that the actual parameter estimates from this model template don't matter - they aren't used in the power analysis.
+Thus, there are two required arguments to `powerAnalysis`: a fitted model template, and a list of effect sizes.
+
+The first step is to fit a model:
+
+
+```r
+template_model <- occu(~1~elev, occu_umf)
+```
+
+If we run `powerAnalysis` on `template_model` with no other arguments, `unmarked` will again give us a template for the list of effect sizes, which looks exactly like the one for simulation above.
+
+
+```r
+powerAnalysis(template_model)
+```
+
+
+```
+## coefs argument should be a named list of named vectors, with the following structure
+## (replacing 0s with your desired coefficient values):
+##
+## $state
+## intercept elev
+## 0 0
+##
+## $det
+## intercept
+## 0
+##
+## Error : Supply coefs argument as specified above
+```
+
+We will set our desired effect sizes to match what we used for simulation:
+
+
+```r
+effect_sizes <- list(state=c(intercept=0, elev=-0.4), det=c(intercept=0))
+```
+
+It is also possible to set the significance level `alpha`; the default is 0.05.
+We now have all the required information to conduct the power analysis.
+Remember, `unmarked` does this by simulation, so you will see a progress bar as `unmarked` conducts simulations.
+You can control how many with the `nsim` argument; we'll set `nsim=20` just to speed things up, but normally you should use more.
+
+
+```r
+(pa <- powerAnalysis(template_model, coefs=effect_sizes, alpha=0.05, nsim=20))
+```
+
+```
+##
+## Model:
+## occu(formula = ~1 ~ elev, data = occu_umf)
+##
+## Power Statistics:
+## Submodel Parameter Effect Null Power
+## state (Intercept) 0.0 0 0.00
+## state elev -0.4 0 0.95
+## det (Intercept) 0.0 0 0.00
+```
+
+The result is an object `pa` of class `unmarkedPower`.
+If you look at `pa` in the console you will get a summary of power for each parameter in the model.
+The summary includes the submodel, parameter name, supplied effect size, null hypothesis, and the calculated power based on simulation.
+By default the null for each parameter is 0, you can change this by supplying a list to the `nulls` argument with the same structure as `coefs`.
+
+We have power = 0.95 for the effect of elevation on occupancy probability.
+This power is calculated by simulating a bunch of datasets based on the template model and supplied effect sizes, fitting a model to each simulated dataset, and then calculating the proportion of these models for which an effect of the covariate would have been detected at the given value of `alpha`.
+You can see the raw results from each simulated model with
+
+
+```r
+pa@estimates
+```
+
+### Varying the sample size
+
+One approach to determining how sample size affects power for our model is to simulate a range of `unmarkedFrames` with varying number of sites, observations, etc. and do a power analysis for each.
+However `powerAnalysis` also has a argument `design` which can help do this automatically.
+
+The `design` argument will subsample within the original data to generate datasets which are smaller or larger than the original, and conduct power analyses for each scenario.
+For example, to test power for a dataset with only 50 sites and 3 sample occasions at each:
+
+
+```r
+# 50 sites and 3 obs per site
+(pa2 <- powerAnalysis(template_model, effect_sizes, design=list(M=50, J=3), nsim=20))
+```
+
+```
+##
+## Model:
+## occu(formula = ~1 ~ elev, data = occu_umf)
+##
+## Power Statistics:
+## Submodel Parameter Effect Null Power
+## state (Intercept) 0.0 0 0.0
+## state elev -0.4 0 0.1
+## det (Intercept) 0.0 0 0.0
+```
+
+With fewer sites and sampling occasions, our power to detect the elevation effect is reduced.
+
+You can also get a larger number of sites via sampling the original sites with replacement:
+
+
+```r
+(pa3 <- powerAnalysis(template_model, effect_sizes, design=list(M=400, J=4), nsim=20))
+```
+
+```
+##
+## Model:
+## occu(formula = ~1 ~ elev, data = occu_umf)
+##
+## Power Statistics:
+## Submodel Parameter Effect Null Power
+## state (Intercept) 0.0 0 0.00
+## state elev -0.4 0 0.95
+## det (Intercept) 0.0 0 0.00
+```
+
+### Combining unmarkedPower objects
+
+The `unmarkedPowerList` function creates a `unmarkedPowerList` object for holding multiple `unmarkedPower` objects so they can be easily compared.
+The summary of an `unmarkedPowerList` is a `data.frame` with all the outputs shown together, including relevant sample sizes.
+
+
+```r
+unmarkedPowerList(list(pa, pa2, pa3))
+```
+
+```
+## M T J Submodel Parameter Effect Null Power
+## 1 300 1 8 state (Intercept) 0.0 0 0.00
+## 2 300 1 8 state elev -0.4 0 0.95
+## 3 300 1 8 det (Intercept) 0.0 0 0.00
+## 4 50 1 3 state (Intercept) 0.0 0 0.00
+## 5 50 1 3 state elev -0.4 0 0.10
+## 6 50 1 3 det (Intercept) 0.0 0 0.00
+## 7 400 1 4 state (Intercept) 0.0 0 0.00
+## 8 400 1 4 state elev -0.4 0 0.95
+## 9 400 1 4 det (Intercept) 0.0 0 0.00
+```
+
+We can also create an `unmarkedPowerList` by providing a template model and a range of design scenarios in the `design` argument.
+A power analysis will be run for each scenario (sampling the original dataset as shown above) and the results combined.
+
+
+```r
+scenarios <- expand.grid(M=c(50,200,400),
+ J=c(3,5,8))
+pl <- unmarkedPowerList(template_model, effect_sizes, design=scenarios, nsim=20)
+```
+
+```
+## M = 50, J = 3
+## M = 200, J = 3
+## M = 400, J = 3
+## M = 50, J = 5
+## M = 200, J = 5
+## M = 400, J = 5
+## M = 50, J = 8
+## M = 200, J = 8
+## M = 400, J = 8
+```
+
+```r
+head(summary(pl))
+```
+
+```
+## M T J Submodel Parameter Effect Null Power
+## 1 50 1 3 state (Intercept) 0.0 0 0.00
+## 2 50 1 3 state elev -0.4 0 0.05
+## 3 50 1 3 det (Intercept) 0.0 0 0.00
+## 4 200 1 3 state (Intercept) 0.0 0 0.00
+## 5 200 1 3 state elev -0.4 0 0.70
+## 6 200 1 3 det (Intercept) 0.0 0 0.00
+```
+
+```r
+tail(summary(pl))
+```
+
+```
+## M T J Submodel Parameter Effect Null Power
+## 22 200 1 8 state (Intercept) 0.0 0 0.0
+## 23 200 1 8 state elev -0.4 0 0.7
+## 24 200 1 8 det (Intercept) 0.0 0 0.0
+## 25 400 1 8 state (Intercept) 0.0 0 0.0
+## 26 400 1 8 state elev -0.4 0 1.0
+## 27 400 1 8 det (Intercept) 0.0 0 0.0
+```
+
+There is a built-in `plot` method for `unmarkedPowerList`.
+You can specify a target power on the plot to the `power` argument.
+You also need to specify the parameter of interest (`"elev"`).
+
+
+```r
+plot(pl, power=0.8, param="elev")
+```
+
+![plot of chunk poweranalysis-list](figures/poweranalysis-list-1.png)
+
+# A more realistic example: Acadian Flycatchers
+
+## Introduction
+
+Normally it is crucial to conduct a power analysis before designing the study or collecting data.
+For this example, however, we will demonstrate a more complicated power analysis for a dataset that has already been collected.
+The real data (not shown here) are observations of Acadian Flycatchers (ACFL; *Empidonax virescens*) at 50 locations in two habitats over 17 years (2005-2022).
+We will assess our power to detect differences in ACFL abundance in between habitats, and our power to detect a trend over time.
+We'll test power for three different sample sizes: 25 survey points, 50 survey points, and 100 survey points each sampled once per year for 15 years.
+
+## Simulation
+
+The main input for the `powerAnalysis` function is a fitted `unmarked` model with the desired sample sizes, covariates, and additional arguments included.
+In typical situations, you won't have your real dataset collected yet, so you'll have to first generate a simulated dataset that is similar to what your final dataset will look like.
+The `simulate` function in `unmarked` can do this for you.
+
+As a reminder the key arguments for `simulate` are `forms`, `coefs`, `design`, and `guide`.
+The `forms` argument is a list of formulas, one per submodel.
+The covariates named in the formulas will become the covariates included in the final simulated dataset.
+We need three covariates associated with abundance (lambda): habitat type, year, and point ID (so that we can include point as a random effect).
+For the other submodels we're not including covariates so they are just intercept-only formulas.
+
+
+```r
+forms <- list(lambda = ~Habitat+Year+(1|Point), dist=~1, rem=~1)
+```
+
+By default, the covariates we specify in the formulas will be generated randomly from standard normal distributions.
+In many cases this is fine, but in our example we need to be more specific given our complex dataset structure.
+We need to tell `unmarked` that `Habitat` should be a factor with two levels, and year should take on values 0 through 14 (since we want to have 15 years in the study).
+In addition we need the covariates to be structured so that we have 15 rows for point 1 (years 0-14), 15 rows for point 2 (years 0-14) and so on, with each row getting the proper `Point` ID value.
+Specifying all this information is the job of the `guide` argument.
+We'll supply a custom function for each covariate to `guide`.
+
+First the function for `Point`, the covariate which identifies which survey point each row of the dataset belongs to.
+If we have 10 points and we sample each point for 15 years, we'll need 150 total rows (10*15) in our dataset.
+The first 15 rows will correspond to point 1, 16-30 for point 2, and so on.
+The following function takes the total number of rows `n` as input, figures out how many points that corresponds to (`n/15`), creates a unique ID for each site, and repeats each ID 15 times.
+
+
+```r
+point_function <- function(n){
+ stopifnot(n %% 15 == 0)
+ sites <- n/15
+ factor(rep(1:sites, each=15))
+}
+point_function(30) # example
+```
+
+```
+## [1] 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2
+## Levels: 1 2
+```
+
+Next, `Habitat`.
+Since each point's `Habitat` value should stay same the same for all 15 years, we need to (1) sample a random `Habitat` value for each point out of two possible habitats, and (2) repeat this value 15 times for each point.
+Given a dataset with a number of total rows `n`, the following function figures out how many unique points there should be (`n`/15), samples a habitat for each point, and repeats the value 15 times per point.
+
+
+```r
+hab_function <- function(n){
+ stopifnot(n %% 15 == 0)
+ sites <- n/15
+ hab <- sample(c("A","B"), sites, replace=TRUE)
+ factor(rep(hab, each=15))
+}
+hab_function(30) # example
+```
+
+```
+## [1] B B B B B B B B B B B B B B B A A A A A A A A A A A A A A A
+## Levels: A B
+```
+
+Finally, `Year`.
+This function works similarly to the two above, except that for each unique point, it assigns year values from 0-14.
+
+
+```r
+yr_function <- function(n){
+ stopifnot(n %% 15 == 0)
+ sites <- n/15
+ rep(0:14, sites) # 15 years of surveys
+}
+yr_function(30) # example
+```
+
+```
+## [1] 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 0 1 2 3 4 5 6 7 8 9
+## [26] 10 11 12 13 14
+```
+
+These functions are combined together in a named list of lists to supply to `guide`.
+
+
+```r
+guide <- list(Point = list(dist=point_function),
+ Year = list(dist=yr_function),
+ Habitat = list(dist=hab_function))
+```
+
+Next, the sample sizes with `design`.
+We'll first simulate a dataset with 25 unique points, so we'll need 25*15 site-years since each point is sampled 15 times.
+To match the real dataset we'll specify 2 distance bins and 3 removal periods.
+
+
+```r
+design <- list(M = 25*15, Jdist=2, Jrem=3)
+```
+
+Since this dataset will have distance bin data in it, we also want to specify how the distance bins will look.
+We want two bins, with breaks at 0, 25 m, and 50 m.
+
+
+```r
+db <- c(0,25,50)
+```
+
+Finally, we need to provide the parameter values used to actually simulate the response (`y`) according to our specifications (e.g., the intercepts and slopes).
+These are provided as a list of vectors to the `coefs` argument.
+At this point, we don't actually care what these values are.
+We just want to simulate a dataset with the correct structure and covariate values (to use as a template), we don't care what the values in the output `y` matrix actually are since they will be discarded later.
+Therefore, we'll just set most parameter values to 0.
+However we need to set the distance function intercept to something slightly more realistic - e.g. the log of the median value of the distance breaks.
+
+
+```r
+coefs_temp <- list(lambda = c(intercept=0, HabitatB=0, Year=0, Point=0),
+ dist = c(intercept=log(median(db))), rem=c(intercept=0))
+```
+
+We're finally ready to simulate the template dataset with all the pieces created above.
+We also need to add a bit more information - our units should be in meters, and we want the output on the abundance scale.
+
+
+```r
+set.seed(1)
+umf25 <- simulate("gdistremoval", formulas=forms, design=design, coefs=coefs_temp,
+ guide=guide, unitsIn='m', dist.breaks=db, output='abund')
+head(umf25)
+```
+
+```
+## Data frame representation of unmarkedFrame object.
+## yDist.1 yDist.2 yRem.1 yRem.2 yRem.3 Habitat Year Point
+## 1 1 0 1 0 0 A 0 1
+## 2 0 0 0 0 0 A 1 1
+## 3 1 0 0 0 1 A 2 1
+## 4 0 0 0 0 0 A 3 1
+## 5 0 0 0 0 0 A 4 1
+## 6 1 0 1 0 0 A 5 1
+## 7 1 0 1 0 0 A 6 1
+## 8 0 1 0 1 0 A 7 1
+## 9 0 0 0 0 0 A 8 1
+## 10 1 0 1 0 0 A 9 1
+```
+
+In the output you can see we have covariates for Habitat, Year, and Point which seem to be structured the way we want.
+Remember we don't care what's actually *in* the `y` matrix, we just want it to be the right size.
+We can double check that the number of rows in the dataset is correct - it should be 25*15 = 375.
+
+
+```r
+numSites(umf25)
+```
+
+```
+## [1] 375
+```
+
+## Creating the template model
+
+The final step is to fit the correct model to the dataset.
+Again, we don't care at all about the *results* of this model, we just want to make sure all the relevant information and arguments are included so that `powerAnalysis` is working with the right information about our proposed study.
+
+
+```r
+mod25 <- gdistremoval(lambdaformula=~Habitat+Year+(1|Point), distanceformula=~1,
+ removalformula=~1, data=umf25, output='abund')
+```
+
+## Running the power analysis
+
+With the template model for a 25 point study design in hand, we can now move on to the actual power analysis.
+In addition to the template model, we now need to tell `unmarked` what the "true" values of the parameters in the model are.
+These are essentially the effect sizes we want to test our ability to identify given our study design.
+This is a step where you have to use your expert knowledge to make some guesses about the true state of the system you are studying.
+
+Below are coefficients which describe a system where abundance in Habitat A is roughly 5, Habitat B is roughly 6, abundance declines about 2% per year, and the random variance among points is relatively small (0.1).
+Furthermore, the value of the detection function parameter $\sigma$ is equal to the median of the distance breaks (25), and the removal probability of detection is about 0.27.
+These are roughly based on our knowledge of the real study system.
+
+
+```r
+coefs <- list(lambda = c(intercept=log(5), HabitatB=0.18,
+ # 2% decline in abundance per year
+ Year=log(0.98),
+ # standard deviation on point random effect
+ Point=0.1),
+ # detection sigma = median distance
+ dist = c(intercept=log(median(db))),
+ # removal p = ~0.27
+ rem = c(intercept=-1))
+```
+
+By specifying the `coefs` this way, we will be testing our power to detect that Habitat B has significantly greater abundance than Habitat A, given that the true difference between Habitat B and A is 0.2 units (on the log scale) or 1 bird (on the real scale).
+We are also testing our power to detect a significant declining trend in abundance, given that the "true" trend is a yearly decline of about 2%.
+
+Now, run the analysis.
+We're using 50 simulations for speed but you should typically use more.
+
+
+```r
+(pa25 <- powerAnalysis(mod25, coefs=coefs, nsim=100))
+```
+
+```
+##
+## Model:
+## gdistremoval(lambdaformula = ~Habitat + Year + (1 | Point), removalformula = ~1,
+## distanceformula = ~1, data = umf25, output = "abund")
+##
+## Power Statistics:
+## Submodel Parameter Effect Null Power
+## lambda (Intercept) 1.60943791 0 1.00
+## lambda HabitatB 0.18000000 0 0.45
+## lambda Year -0.02020271 0 0.47
+## dist (Intercept) 3.21887582 0 1.00
+## rem (Intercept) -1.00000000 0 1.00
+```
+
+In this case we only care about the `HabitatB` and `Year` rows in the output table, we're ignoring the intercepts.
+We found we have weak power (<0.5) to detect both effects with this sample size.
+
+To test the other two sample sizes (50 and 100 sites x 15 years), we just simulate new datasets and repeat the process.
+We only need to change the `design` argument to simulate.
+
+
+```r
+umf50 <- simulate("gdistremoval", formulas=forms,
+ design=list(M = 50*15, Jdist=2, Jrem=3), # change here
+ coefs=coefs_temp,
+ guide=guide, unitsIn='m', dist.breaks=db, output='abund')
+mod50 <- gdistremoval(lambdaformula=~Habitat+Year+(1|Point), distanceformula=~1,
+ removalformula=~1, data=umf50, output='abund')
+pa50 <- powerAnalysis(mod50, coefs=coefs, nsim=100)
+
+umf100 <- simulate("gdistremoval", formulas=forms,
+ design=list(M = 100*15, Jdist=2, Jrem=3), # change here
+ coefs=coefs_temp,
+ guide=guide, unitsIn='m', dist.breaks=db, output='abund')
+mod100 <- gdistremoval(lambdaformula=~Habitat+Year+(1|Point), distanceformula=~1,
+ removalformula=~1, data=umf100, output='abund')
+pa100 <- powerAnalysis(mod100, coefs=coefs, nsim=100)
+```
+
+## Examining the results
+
+In addition to looking at the summary table outputs of `pa25`, `pa50`, and `pa100`, they can also be combined into an `unmarkedPowerList` for easier comparison.
+
+
+```r
+(pl <- unmarkedPowerList(list(pa25, pa50, pa100)))
+```
+
+```
+## M T J Submodel Parameter Effect Null Power
+## 1 375 1 3 lambda (Intercept) 1.60943791 0 1.00
+## 2 375 1 3 lambda HabitatB 0.18000000 0 0.45
+## 3 375 1 3 lambda Year -0.02020271 0 0.47
+## 4 375 1 3 dist (Intercept) 3.21887582 0 1.00
+## 5 375 1 3 rem (Intercept) -1.00000000 0 1.00
+## 6 750 1 3 lambda (Intercept) 1.60943791 0 1.00
+## 7 750 1 3 lambda HabitatB 0.18000000 0 0.58
+## 8 750 1 3 lambda Year -0.02020271 0 0.80
+## 9 750 1 3 dist (Intercept) 3.21887582 0 1.00
+## 10 750 1 3 rem (Intercept) -1.00000000 0 1.00
+## 11 1500 1 3 lambda (Intercept) 1.60943791 0 1.00
+## 12 1500 1 3 lambda HabitatB 0.18000000 0 0.97
+## 13 1500 1 3 lambda Year -0.02020271 0 0.96
+## 14 1500 1 3 dist (Intercept) 3.21887582 0 1.00
+## 15 1500 1 3 rem (Intercept) -1.00000000 0 1.00
+```
+
+There's a default plotting method for `unmarkedPowerLists`.
+You need to specify the parameter of interest, and you can optionally define a target power level to add to the plot:
+
+
+```r
+plot(pl, par="HabitatB", power=0.8)
+```
+
+![plot of chunk poweranalysis-acfl](figures/poweranalysis-acfl-1.png)
+
+```r
+plot(pl, par="Year", power=0.8)
+```
+
+![plot of chunk poweranalysis-acfl](figures/poweranalysis-acfl-2.png)
+
+Note that the x-axis shows sites as the number of site-years (e.g., sites x years).
+It looks like only the largest tested sample size (100 sites) has power > 0.8 to detect a significant effect of habitat type and year in the correct direction.
+
+# Shiny webapp
+
+`unmarked` now includes a [Shiny](https://shiny.rstudio.com/) webapp that can be used to conduct power analyses.
+The Shiny app is launched with the `shinyPower()` function, which takes as a template model as an input argument (see above).
+This function opens a window in your web browser.
+Once the application is loaded, you can experiment with different settings and generate summaries and figures for the resulting power estimates.
+
+## Demonstration
+
+First, we simulate a template model for a single-species occupancy analysis, using the `simulate` function as described above.
+We have one covariate of interest on occupancy (`elev`) and one on detection (`wind`).
+
+
+```r
+umf <- simulate("occu", formulas=list(state=~elev, det=~wind),
+ coefs=list(state=c(intercept=0, elev=0.3),
+ det=c(intercept=0.4, wind=-0.2)),
+ design=list(M=100, J=5))
+
+(mod <- occu(~wind~elev, umf))
+```
+
+```
+##
+## Call:
+## occu(formula = ~wind ~ elev, data = umf)
+##
+## Occupancy:
+## Estimate SE z P(>|z|)
+## (Intercept) -0.0624 0.203 -0.308 0.758
+## elev 0.1965 0.232 0.849 0.396
+##
+## Detection:
+## Estimate SE z P(>|z|)
+## (Intercept) 0.4736 0.137 3.457 0.000546
+## wind -0.0599 0.125 -0.479 0.632033
+##
+## AIC: 463.2808
+```
+
+Next call the `shinyPower` function on our template model, which starts the Shiny app in your web browser.
+
+
+```r
+shinyPower(mod)
+```
+
+A demo version of the app you can experiment with can be found [here](https://kenkellner.shinyapps.io/unmarked-power/).
+The next section provides a more detailed tutorial for the app using screenshots.
+
+## Tutorial
+
+### Inputs
+
+The shaded vertical bar on the left is where we set the options for the analysis
+At the top left you will see the name and type of the model you provided to `shinyPower`.
+
+![](figures/poweranalysis-modinfo.png)
+
+Next you can set the value for $\alpha$, and the number of simulations to run in each power analysis.
+The default is 10, but you should usually set it to something higher.
+
+![](figures/poweranalysis-alpha.png)
+
+After that you can, if you wish, specify one or more sample size scenarios by manipulating the number of sites and number of observations.
+If you set a number of sites/observations smaller than what was in the original template model dataset, the dataset will be subsampled; if larger, the new dataset(s) will be bootstrapped.
+It's a good idea to simulate the template model with the largest sample size you want to test here to avoid the bootstrapping.
+
+![](figures/poweranalysis-scenarios.png)
+
+Next you must set the effect sizes you want to test in the power analysis.
+Each submodel has its own section.
+In this case state = occupancy and det = detection.
+Effect sizes for all parameters in the model default to 0; you'll want to change them to reflect your expectations about the study system.
+Here we are simulating datasets with an elevation effect of 0.4 (on the logit scale), with occupancy and detection intercepts equal to 0 (equivalent to probabilities of 0.5).
+
+![](figures/poweranalysis-effectsizes.png)
+
+You can also set the null hypotheses manually if you want by clicking on the "Null hypotheses" tab.
+By default they are all set at 0.
+
+![](figures/poweranalysis-nulls.png)
+
+Finally, click the run button.
+You should see one or more progress bars in the lower right of the application.
+
+![](figures/poweranalysis-run.png)
+
+### Outputs
+
+To the right of the input sidebar is a set of tabs showing output.
+The "Summary" tab shows a table with estimates of power for each parameter under each scenario you specified earlier.
+The "Plot" tab shows a plot of how power changes for a given parameter based on sample size (it will not be useful if you only have one sample size scenario).
+Here's the first few lines of a summary table with three scenarios for number of sites (100, 75, 50) and two for number of observations (2, 5), testing for an `elev` effect size of 0.4:
+
+![](figures/poweranalysis-summarytable.png)
+
+And the corresponding summary figure for `elev`:
+
+![](figures/poweranalysis-summaryplot.png)
+
+# Conclusion
+
+Power analysis is an important step in the research process that is often overlooked in studies of animal abundance and occurrence.
+Getting an estimate of the sample size required to detect a particular effect can help with efficient data collection and set expectations for what covariate relationships might be possible to detect.
+The power analysis tools in `unmarked` should help make this part of the research process quick and easy for researchers as the begin to develop study designs.
+
+# References
diff --git a/vignettes/powerAnalysis.Rmd.orig b/vignettes/powerAnalysis.Rmd.orig
new file mode 100644
index 0000000..fad2fb0
--- /dev/null
+++ b/vignettes/powerAnalysis.Rmd.orig
@@ -0,0 +1,618 @@
+---
+title: Power Analysis in unmarked
+author: Ken Kellner
+date: November 7, 2022
+bibliography: unmarked.bib
+csl: ecology.csl
+output:
+ rmarkdown::html_vignette:
+ fig_width: 5
+ fig_height: 3.5
+ number_sections: true
+ toc: true
+vignette: >
+ %\VignetteIndexEntry{Power Analysis in unmarked}
+ %\VignetteEngine{knitr::rmarkdown}
+ \usepackage[utf8]{inputenc}
+---
+
+```{r,echo=FALSE}
+knitr::opts_chunk$set(fig.path="figures/")
+```
+
+# Hypothesis Testing
+
+For many analyses in `unmarked`, a primary goal is to determine if a certain covariate affects the state or detection process.
+For example, we may want to determine if elevation has an effect on probability of site occupancy, or if wind speed has an effect on detection.
+We can formulate this idea as set of statistical hypotheses: the null hypothesis ($H_0$) and the alternative hypothesis ($H_a$):
+
+* $H_0$: There is no effect of elevation on occupancy
+* $H_a$: Elevation has an effect on occupancy
+
+In order to test these hypotheses, we must collected appropriate data, perhaps by sampling a series of sites at varying elevation for the presence of the species.
+We can then fit a model in `unmarked`, specifying in the formula that we are interested in estimating the effect of elevation on occupancy.
+For example, here is a simple model fit to the `crossbill` presence-absence dataset included with `unmarked`:
+
+```{r, warning=FALSE}
+set.seed(123)
+library(unmarked)
+data(crossbill)
+
+umf <- unmarkedFrameOccu(y=crossbill[,11:13],
+ siteCovs=data.frame(elev=scale(crossbill$ele)))
+(mod <- occu(~1~elev, umf))
+```
+
+## Wald tests
+
+In the code{unmarked} output, we obtain an estimate ($\hat{\theta}$) of the regression coefficient associated with elevation (`elev`) along with its standard error.
+Our null hypothesis is that elevation has no effect on occupancy, i.e. $\theta_0 = 0$.
+With this information, we can conduct a statistical hypothesis test called a Wald test:
+$$
+\sqrt{W} = \frac{(\hat{\theta} -\theta_0)}{se(\hat{\theta})}
+$$
+
+Or simplified:
+$$
+\sqrt{W} = \frac{(0.5939 - 0)}{0.1656} = 3.59
+$$
+
+It turns out that the square root of the Wald statistic, $\sqrt{W}$, follows a standard normal distribution.
+Thus, we can calculate the probability that our observed statistic, $\sqrt{W} = 3.59$, occurred by chance assuming that the null hypothesis $\theta = 0$ is true.
+In R, for a two-tailed test, this can be calculated as:
+
+```{r}
+z = sqrt_w = coef(mod)[2] / SE(mod)[2]
+2*pnorm(abs(z), lower.tail=FALSE)
+```
+
+This is the p-value. These values we calculated manually match the results that `unmarked` gave us in the summary output.
+
+## Making a conclusion
+
+Before conducting our study, we should have defined a threshold p-value (the significance level or $\alpha$) below which we reject the null hypothesis.
+Traditionally, $\alpha = 0.05$.
+Our calculated p-value is less than $\alpha$, so we reject the null hypothesis that elevation has no effect on occupancy.
+
+## Types of error
+
+There are two types of errors that we could be making at this point:
+
+1. Type I error: We reject the null hypothesis when in fact it is true. Type I error is conceptually the same as $\alpha$. If we set $\alpha$ larger, we have a greater chance of Type I error.
+2. Type II error: We fail to reject the null hypothesis when in fact it is false. This can occur, for example, if we did not have enough data to detect an effect.
+
+In this vignette, we are most concerned with Type II error.
+How do we know we have enough data to detect if a covariate has a certain effect?
+To answer this question we can use power analysis.
+
+# Power Analysis in unmarked
+
+## Introduction
+
+Statistical power is defined as 1 - Type II error.
+So more power means less chance of false negatives, i.e., less chance of failing to reject the null hypothesis when it is false.
+Statistical power depends on three other pieces of information:
+
+1. The effect size: the magnitude of the effect of the covariate. The larger the effect, the more power we have to detect it.
+2. The sample size: how many sites or surveys we've done. The more samples, the more power we have.
+3. The significance level, $\alpha$. The smaller we make $\alpha$, the less power we have: thus there is a tradeoff between Type I and Type II error.
+
+Of the three factors (2) is the one that makes the most sense for researchers to manipulate in order to increase power.
+However, increasing the sample size requires additional effort and money - so how large does it need to be?
+
+For many statistical models, mathematical formulas have been developed so that power can be calculated for any combination of values for factors 1-3 above.
+This is not true for most occupancy and abundance models available in `unmarked` (but see @Guillera_2012 for one example with occupancy models).
+Thus, `unmarked` uses a simulation-based approach for estimating power under various combinations of values for effect size, sample size, and significance level.
+
+## Inputs
+
+When conducting power analysis, `unmarked` needs three pieces of information corresponding to 1-3 above.
+Of these, (1) the effect size and (3) the significance level are easy to set depending on our hypotheses and desired Type I error.
+The sample size (2) is trickier: it isn't enough to just provide the number of sites, since datasets in `unmarked` also require a variety of other information such as number of surveys per site, number of distance bins, or number of primary periods.
+Thus, power analysis in `unmarked` requires a complete dataset in the form of an appropriate `unmarkedFrame`.
+
+In some cases, we may want to calculate power using an already collected dataset.
+Importantly, this step must be done \textit{before} running our final analysis.
+If power analysis is done after the final model is fit, and the effect sizes are defined based on what was observed in that fitted model, we have done what is called a *post-hoc* power analysis, which is a bad idea (see [this post](https://statmodeling.stat.columbia.edu/2018/09/24/dont-calculate-post-hoc-power-using-observed-estimate-effect-size/) for an example of why this is so bad).
+In most cases, the real value of power analysis comes before we actually go collect any data, because it helps us decide how much data to collect.
+But how to get an `unmarkedFrame` of data before we've done our study?
+Once again the solution is simulation: `unmarked` provides a set of tools for simulating datasets for any of its supported model types.
+
+## Simulating datasets
+
+To simulate a dataset for a given `unmarked` model, we need at a minimum four pieces of information:
+
+1. The type of model (the name of the corresponding fitting function)
+2. The covariates affecting each submodel, such as occupancy or detection (supplied as formulas)
+3. The effect size for each intercept and covariate
+4. Study design parameters such as number of sites and number of surveys
+
+For example, suppose we want to simulate an occupancy dataset (`"occu"`) in which site occupancy is affected by elevation.
+The first step is to organize the model structure as a list of formulas, one per submodel.
+This list must be named in a specific way depending on the model type.
+To get the required names for a given model, fit an example of that model (the documentation should have one) and call `names(model)`.
+A single-season occupancy model requires a list with two named components: `state` and `det`.
+We supply a formula for each including an effect of elevation on occupancy (note we could name this whatever we want, here we call it `elev`).
+
+```{r}
+forms <- list(state=~elev, det=~1)
+```
+
+Next we must tell `unmarked` what the values for the intercept and regression coefficients in each submodel should be.
+Once again, this is a named list, one element for each submodel.
+Within each element we need a named vector with names that match the covariates in our list of formulas above.
+Note also that each must include a value for the intercept term (this can be named `intercept` or `Intercept`).
+If we are not sure exactly how to structure this list, just skip it for now: `unmarked` can generate a template for us to fill in later.
+
+```{r}
+coefs <- list(state=c(intercept=0, elev=-0.4), det=c(intercept=0))
+```
+
+Finally, we need to give `unmarked` information about the study design.
+This is pretty simple: we just need a list containing values for `M`, the number of sites, and `J` the number of surveys per site.
+For models with multiple primary periods, we'd also need a value of `T`, the number of primary periods.
+
+```{r}
+design <- list(M=300, J=8) # 300 sites, 8 occasions per site
+```
+
+We're now ready to simulate a dataset.
+To do this we use the `simulate` function, providing as arguments the name of the model `"occu"` and the three lists we constructed above.
+Actually, first, let's not supply the `coefs` list, to show how `unmarked` will generate a template for us to use:
+
+```{r, eval=FALSE}
+simulate("occu", formulas=forms, design=design)
+```
+
+```{r, echo=FALSE}
+try(simulate("occu", formulas=forms, design=design))
+```
+
+Once we have our covariates set up properly, add them to the function call:
+
+```{r}
+occu_umf <- simulate("occu", formulas=forms, coefs=coefs, design=design)
+head(occu_umf)
+```
+
+`unmarked` has generated a presence-absence dataset as well as values for covariate `elev`.
+
+### Customizing the covariates
+
+By default, a covariate will be continuous and come from a standard normal distribution.
+However, we can control this using the `guide` argument.
+For example, suppose we want elevation to have a mean of 2 and a standard deviation of 0.5, and we also want a categorical covariate called `landcover`.
+The corresponding formulas and list to supply to `guide` would look like this:
+
+```{r}
+forms2 <- list(state=~elev+landcover, det=~1)
+guide <- list(landcover=factor(levels=c("forest","grass")), # landcover is factor
+ elev=list(dist=rnorm, mean=2, sd=0.5)) # custom distribution
+```
+
+We'd also need an updated `coefs`:
+
+```{r}
+coefs2 <- list(state=c(intercept=0, elev=-0.4, landcovergrass=0.2), det=c(intercept=0))
+```
+
+```{r}
+head(simulate("occu", formulas=forms2, coefs=coefs2, design=design, guide=guide))
+```
+
+Our output dataset now includes a new categorical covariate, and the elevation values are adjusted.
+
+### Models that require more information
+
+More complex models might require more information for simulation, such as the distribution to use for abundance with `pcount`.
+This information is simply added as additional arguments to `simulate`.
+For example, we can simulate a `pcount` dataset using the negative binomial (`"NB"`) distribution.
+The negative binomial has an additional parameter to estimate (`alpha`) so we must also add an element to `coefs`.
+
+```{r}
+coefs$alpha <- c(alpha=0.5)
+head(simulate("pcount", formulas=forms, coefs=coefs, design=design, mixture="NB"))
+```
+
+## Conducting a power analysis
+
+Power analyses are conducted with the `powerAnalysis` function.
+A `powerAnalysis` power analysis depends on the input dataset, as well as the covariates of interest and other settings depending on the model (e.g. the distribution used in an N-mixture model or the detection key function in a distance sampling analysis).
+The easiest way combine all this information and send it to `powerAnalysis` is to actually fit a model with all the correct settings and our simulated dataset and send *that* to `powerAnalysis`.
+This has the added benefit that it checks to make sure we have all the required information for a valid model.
+Note that the actual parameter estimates from this model template don't matter - they aren't used in the power analysis.
+Thus, there are two required arguments to `powerAnalysis`: a fitted model template, and a list of effect sizes.
+
+The first step is to fit a model:
+
+```{r}
+template_model <- occu(~1~elev, occu_umf)
+```
+
+If we run `powerAnalysis` on `template_model` with no other arguments, `unmarked` will again give us a template for the list of effect sizes, which looks exactly like the one for simulation above.
+
+```{r, eval=FALSE}
+powerAnalysis(template_model)
+```
+
+```{r, echo=FALSE}
+try(powerAnalysis(template_model))
+```
+
+We will set our desired effect sizes to match what we used for simulation:
+
+```{r}
+effect_sizes <- list(state=c(intercept=0, elev=-0.4), det=c(intercept=0))
+```
+
+It is also possible to set the significance level `alpha`; the default is 0.05.
+We now have all the required information to conduct the power analysis.
+Remember, `unmarked` does this by simulation, so you will see a progress bar as `unmarked` conducts simulations.
+You can control how many with the `nsim` argument; we'll set `nsim=20` just to speed things up, but normally you should use more.
+
+```{r}
+(pa <- powerAnalysis(template_model, coefs=effect_sizes, alpha=0.05, nsim=20))
+```
+
+The result is an object `pa` of class `unmarkedPower`.
+If you look at `pa` in the console you will get a summary of power for each parameter in the model.
+The summary includes the submodel, parameter name, supplied effect size, null hypothesis, and the calculated power based on simulation.
+By default the null for each parameter is 0, you can change this by supplying a list to the `nulls` argument with the same structure as `coefs`.
+
+We have power = 0.95 for the effect of elevation on occupancy probability.
+This power is calculated by simulating a bunch of datasets based on the template model and supplied effect sizes, fitting a model to each simulated dataset, and then calculating the proportion of these models for which an effect of the covariate would have been detected at the given value of `alpha`.
+You can see the raw results from each simulated model with
+
+```{r, eval=FALSE}
+pa@estimates
+```
+
+### Varying the sample size
+
+One approach to determining how sample size affects power for our model is to simulate a range of `unmarkedFrames` with varying number of sites, observations, etc. and do a power analysis for each.
+However `powerAnalysis` also has a argument `design` which can help do this automatically.
+
+The `design` argument will subsample within the original data to generate datasets which are smaller or larger than the original, and conduct power analyses for each scenario.
+For example, to test power for a dataset with only 50 sites and 3 sample occasions at each:
+
+```{r}
+# 50 sites and 3 obs per site
+(pa2 <- powerAnalysis(template_model, effect_sizes, design=list(M=50, J=3), nsim=20))
+```
+
+With fewer sites and sampling occasions, our power to detect the elevation effect is reduced.
+
+You can also get a larger number of sites via sampling the original sites with replacement:
+
+```{r}
+(pa3 <- powerAnalysis(template_model, effect_sizes, design=list(M=400, J=4), nsim=20))
+```
+
+### Combining unmarkedPower objects
+
+The `unmarkedPowerList` function creates a `unmarkedPowerList` object for holding multiple `unmarkedPower` objects so they can be easily compared.
+The summary of an `unmarkedPowerList` is a `data.frame` with all the outputs shown together, including relevant sample sizes.
+
+```{r}
+unmarkedPowerList(list(pa, pa2, pa3))
+```
+
+We can also create an `unmarkedPowerList` by providing a template model and a range of design scenarios in the `design` argument.
+A power analysis will be run for each scenario (sampling the original dataset as shown above) and the results combined.
+
+```{r}
+scenarios <- expand.grid(M=c(50,200,400),
+ J=c(3,5,8))
+pl <- unmarkedPowerList(template_model, effect_sizes, design=scenarios, nsim=20)
+head(summary(pl))
+tail(summary(pl))
+```
+
+There is a built-in `plot` method for `unmarkedPowerList`.
+You can specify a target power on the plot to the `power` argument.
+You also need to specify the parameter of interest (`"elev"`).
+
+```{r poweranalysis-list, fig.height=5}
+plot(pl, power=0.8, param="elev")
+```
+
+# A more realistic example: Acadian Flycatchers
+
+## Introduction
+
+Normally it is crucial to conduct a power analysis before designing the study or collecting data.
+For this example, however, we will demonstrate a more complicated power analysis for a dataset that has already been collected.
+The real data (not shown here) are observations of Acadian Flycatchers (ACFL; *Empidonax virescens*) at 50 locations in two habitats over 17 years (2005-2022).
+We will assess our power to detect differences in ACFL abundance in between habitats, and our power to detect a trend over time.
+We'll test power for three different sample sizes: 25 survey points, 50 survey points, and 100 survey points each sampled once per year for 15 years.
+
+## Simulation
+
+The main input for the `powerAnalysis` function is a fitted `unmarked` model with the desired sample sizes, covariates, and additional arguments included.
+In typical situations, you won't have your real dataset collected yet, so you'll have to first generate a simulated dataset that is similar to what your final dataset will look like.
+The `simulate` function in `unmarked` can do this for you.
+
+As a reminder the key arguments for `simulate` are `forms`, `coefs`, `design`, and `guide`.
+The `forms` argument is a list of formulas, one per submodel.
+The covariates named in the formulas will become the covariates included in the final simulated dataset.
+We need three covariates associated with abundance (lambda): habitat type, year, and point ID (so that we can include point as a random effect).
+For the other submodels we're not including covariates so they are just intercept-only formulas.
+
+```{r}
+forms <- list(lambda = ~Habitat+Year+(1|Point), dist=~1, rem=~1)
+```
+
+By default, the covariates we specify in the formulas will be generated randomly from standard normal distributions.
+In many cases this is fine, but in our example we need to be more specific given our complex dataset structure.
+We need to tell `unmarked` that `Habitat` should be a factor with two levels, and year should take on values 0 through 14 (since we want to have 15 years in the study).
+In addition we need the covariates to be structured so that we have 15 rows for point 1 (years 0-14), 15 rows for point 2 (years 0-14) and so on, with each row getting the proper `Point` ID value.
+Specifying all this information is the job of the `guide` argument.
+We'll supply a custom function for each covariate to `guide`.
+
+First the function for `Point`, the covariate which identifies which survey point each row of the dataset belongs to.
+If we have 10 points and we sample each point for 15 years, we'll need 150 total rows (10*15) in our dataset.
+The first 15 rows will correspond to point 1, 16-30 for point 2, and so on.
+The following function takes the total number of rows `n` as input, figures out how many points that corresponds to (`n/15`), creates a unique ID for each site, and repeats each ID 15 times.
+
+```{r}
+point_function <- function(n){
+ stopifnot(n %% 15 == 0)
+ sites <- n/15
+ factor(rep(1:sites, each=15))
+}
+point_function(30) # example
+```
+
+Next, `Habitat`.
+Since each point's `Habitat` value should stay same the same for all 15 years, we need to (1) sample a random `Habitat` value for each point out of two possible habitats, and (2) repeat this value 15 times for each point.
+Given a dataset with a number of total rows `n`, the following function figures out how many unique points there should be (`n`/15), samples a habitat for each point, and repeats the value 15 times per point.
+
+```{r}
+hab_function <- function(n){
+ stopifnot(n %% 15 == 0)
+ sites <- n/15
+ hab <- sample(c("A","B"), sites, replace=TRUE)
+ factor(rep(hab, each=15))
+}
+hab_function(30) # example
+```
+
+Finally, `Year`.
+This function works similarly to the two above, except that for each unique point, it assigns year values from 0-14.
+
+```{r}
+yr_function <- function(n){
+ stopifnot(n %% 15 == 0)
+ sites <- n/15
+ rep(0:14, sites) # 15 years of surveys
+}
+yr_function(30) # example
+```
+
+These functions are combined together in a named list of lists to supply to `guide`.
+
+```{r}
+guide <- list(Point = list(dist=point_function),
+ Year = list(dist=yr_function),
+ Habitat = list(dist=hab_function))
+```
+
+Next, the sample sizes with `design`.
+We'll first simulate a dataset with 25 unique points, so we'll need 25*15 site-years since each point is sampled 15 times.
+To match the real dataset we'll specify 2 distance bins and 3 removal periods.
+
+```{r}
+design <- list(M = 25*15, Jdist=2, Jrem=3)
+```
+
+Since this dataset will have distance bin data in it, we also want to specify how the distance bins will look.
+We want two bins, with breaks at 0, 25 m, and 50 m.
+
+```{r}
+db <- c(0,25,50)
+```
+
+Finally, we need to provide the parameter values used to actually simulate the response (`y`) according to our specifications (e.g., the intercepts and slopes).
+These are provided as a list of vectors to the `coefs` argument.
+At this point, we don't actually care what these values are.
+We just want to simulate a dataset with the correct structure and covariate values (to use as a template), we don't care what the values in the output `y` matrix actually are since they will be discarded later.
+Therefore, we'll just set most parameter values to 0.
+However we need to set the distance function intercept to something slightly more realistic - e.g. the log of the median value of the distance breaks.
+
+```{r}
+coefs_temp <- list(lambda = c(intercept=0, HabitatB=0, Year=0, Point=0),
+ dist = c(intercept=log(median(db))), rem=c(intercept=0))
+```
+
+We're finally ready to simulate the template dataset with all the pieces created above.
+We also need to add a bit more information - our units should be in meters, and we want the output on the abundance scale.
+
+```{r}
+set.seed(1)
+umf25 <- simulate("gdistremoval", formulas=forms, design=design, coefs=coefs_temp,
+ guide=guide, unitsIn='m', dist.breaks=db, output='abund')
+head(umf25)
+```
+
+In the output you can see we have covariates for Habitat, Year, and Point which seem to be structured the way we want.
+Remember we don't care what's actually *in* the `y` matrix, we just want it to be the right size.
+We can double check that the number of rows in the dataset is correct - it should be 25*15 = 375.
+
+```{r}
+numSites(umf25)
+```
+
+## Creating the template model
+
+The final step is to fit the correct model to the dataset.
+Again, we don't care at all about the *results* of this model, we just want to make sure all the relevant information and arguments are included so that `powerAnalysis` is working with the right information about our proposed study.
+
+```{r}
+mod25 <- gdistremoval(lambdaformula=~Habitat+Year+(1|Point), distanceformula=~1,
+ removalformula=~1, data=umf25, output='abund')
+```
+
+## Running the power analysis
+
+With the template model for a 25 point study design in hand, we can now move on to the actual power analysis.
+In addition to the template model, we now need to tell `unmarked` what the "true" values of the parameters in the model are.
+These are essentially the effect sizes we want to test our ability to identify given our study design.
+This is a step where you have to use your expert knowledge to make some guesses about the true state of the system you are studying.
+
+Below are coefficients which describe a system where abundance in Habitat A is roughly 5, Habitat B is roughly 6, abundance declines about 2% per year, and the random variance among points is relatively small (0.1).
+Furthermore, the value of the detection function parameter $\sigma$ is equal to the median of the distance breaks (25), and the removal probability of detection is about 0.27.
+These are roughly based on our knowledge of the real study system.
+
+```{r}
+coefs <- list(lambda = c(intercept=log(5), HabitatB=0.18,
+ # 2% decline in abundance per year
+ Year=log(0.98),
+ # standard deviation on point random effect
+ Point=0.1),
+ # detection sigma = median distance
+ dist = c(intercept=log(median(db))),
+ # removal p = ~0.27
+ rem = c(intercept=-1))
+```
+
+By specifying the `coefs` this way, we will be testing our power to detect that Habitat B has significantly greater abundance than Habitat A, given that the true difference between Habitat B and A is 0.2 units (on the log scale) or 1 bird (on the real scale).
+We are also testing our power to detect a significant declining trend in abundance, given that the "true" trend is a yearly decline of about 2%.
+
+Now, run the analysis.
+We're using 50 simulations for speed but you should typically use more.
+
+```{r}
+(pa25 <- powerAnalysis(mod25, coefs=coefs, nsim=100))
+```
+
+In this case we only care about the `HabitatB` and `Year` rows in the output table, we're ignoring the intercepts.
+We found we have weak power (<0.5) to detect both effects with this sample size.
+
+To test the other two sample sizes (50 and 100 sites x 15 years), we just simulate new datasets and repeat the process.
+We only need to change the `design` argument to simulate.
+
+```{r}
+umf50 <- simulate("gdistremoval", formulas=forms,
+ design=list(M = 50*15, Jdist=2, Jrem=3), # change here
+ coefs=coefs_temp,
+ guide=guide, unitsIn='m', dist.breaks=db, output='abund')
+mod50 <- gdistremoval(lambdaformula=~Habitat+Year+(1|Point), distanceformula=~1,
+ removalformula=~1, data=umf50, output='abund')
+pa50 <- powerAnalysis(mod50, coefs=coefs, nsim=100)
+
+umf100 <- simulate("gdistremoval", formulas=forms,
+ design=list(M = 100*15, Jdist=2, Jrem=3), # change here
+ coefs=coefs_temp,
+ guide=guide, unitsIn='m', dist.breaks=db, output='abund')
+mod100 <- gdistremoval(lambdaformula=~Habitat+Year+(1|Point), distanceformula=~1,
+ removalformula=~1, data=umf100, output='abund')
+pa100 <- powerAnalysis(mod100, coefs=coefs, nsim=100)
+```
+
+## Examining the results
+
+In addition to looking at the summary table outputs of `pa25`, `pa50`, and `pa100`, they can also be combined into an `unmarkedPowerList` for easier comparison.
+
+```{r}
+(pl <- unmarkedPowerList(list(pa25, pa50, pa100)))
+```
+
+There's a default plotting method for `unmarkedPowerLists`.
+You need to specify the parameter of interest, and you can optionally define a target power level to add to the plot:
+
+```{r poweranalysis-acfl}
+plot(pl, par="HabitatB", power=0.8)
+plot(pl, par="Year", power=0.8)
+```
+
+Note that the x-axis shows sites as the number of site-years (e.g., sites x years).
+It looks like only the largest tested sample size (100 sites) has power > 0.8 to detect a significant effect of habitat type and year in the correct direction.
+
+# Shiny webapp
+
+`unmarked` now includes a [Shiny](https://shiny.rstudio.com/) webapp that can be used to conduct power analyses.
+The Shiny app is launched with the `shinyPower()` function, which takes as a template model as an input argument (see above).
+This function opens a window in your web browser.
+Once the application is loaded, you can experiment with different settings and generate summaries and figures for the resulting power estimates.
+
+## Demonstration
+
+First, we simulate a template model for a single-species occupancy analysis, using the `simulate` function as described above.
+We have one covariate of interest on occupancy (`elev`) and one on detection (`wind`).
+
+```{r}
+umf <- simulate("occu", formulas=list(state=~elev, det=~wind),
+ coefs=list(state=c(intercept=0, elev=0.3),
+ det=c(intercept=0.4, wind=-0.2)),
+ design=list(M=100, J=5))
+
+(mod <- occu(~wind~elev, umf))
+```
+
+Next call the `shinyPower` function on our template model, which starts the Shiny app in your web browser.
+
+```{r,eval=FALSE}
+shinyPower(mod)
+```
+
+A demo version of the app you can experiment with can be found [here](https://kenkellner.shinyapps.io/unmarked-power/).
+The next section provides a more detailed tutorial for the app using screenshots.
+
+## Tutorial
+
+### Inputs
+
+The shaded vertical bar on the left is where we set the options for the analysis
+At the top left you will see the name and type of the model you provided to `shinyPower`.
+
+![](figures/poweranalysis-modinfo.png)
+
+Next you can set the value for $\alpha$, and the number of simulations to run in each power analysis.
+The default is 10, but you should usually set it to something higher.
+
+![](figures/poweranalysis-alpha.png)
+
+After that you can, if you wish, specify one or more sample size scenarios by manipulating the number of sites and number of observations.
+If you set a number of sites/observations smaller than what was in the original template model dataset, the dataset will be subsampled; if larger, the new dataset(s) will be bootstrapped.
+It's a good idea to simulate the template model with the largest sample size you want to test here to avoid the bootstrapping.
+
+![](figures/poweranalysis-scenarios.png)
+
+Next you must set the effect sizes you want to test in the power analysis.
+Each submodel has its own section.
+In this case state = occupancy and det = detection.
+Effect sizes for all parameters in the model default to 0; you'll want to change them to reflect your expectations about the study system.
+Here we are simulating datasets with an elevation effect of 0.4 (on the logit scale), with occupancy and detection intercepts equal to 0 (equivalent to probabilities of 0.5).
+
+![](figures/poweranalysis-effectsizes.png)
+
+You can also set the null hypotheses manually if you want by clicking on the "Null hypotheses" tab.
+By default they are all set at 0.
+
+![](figures/poweranalysis-nulls.png)
+
+Finally, click the run button.
+You should see one or more progress bars in the lower right of the application.
+
+![](figures/poweranalysis-run.png)
+
+### Outputs
+
+To the right of the input sidebar is a set of tabs showing output.
+The "Summary" tab shows a table with estimates of power for each parameter under each scenario you specified earlier.
+The "Plot" tab shows a plot of how power changes for a given parameter based on sample size (it will not be useful if you only have one sample size scenario).
+Here's the first few lines of a summary table with three scenarios for number of sites (100, 75, 50) and two for number of observations (2, 5), testing for an `elev` effect size of 0.4:
+
+![](figures/poweranalysis-summarytable.png)
+
+And the corresponding summary figure for `elev`:
+
+![](figures/poweranalysis-summaryplot.png)
+
+# Conclusion
+
+Power analysis is an important step in the research process that is often overlooked in studies of animal abundance and occurrence.
+Getting an estimate of the sample size required to detect a particular effect can help with efficient data collection and set expectations for what covariate relationships might be possible to detect.
+The power analysis tools in `unmarked` should help make this part of the research process quick and easy for researchers as the begin to develop study designs.
+
+# References
diff --git a/vignettes/simulate.Rmd b/vignettes/simulate.Rmd
new file mode 100644
index 0000000..5b7decf
--- /dev/null
+++ b/vignettes/simulate.Rmd
@@ -0,0 +1,274 @@
+---
+title: Simulating datasets
+author: Ken Kellner
+date: September 10, 2021
+bibliography: unmarked.bib
+csl: ecology.csl
+output:
+ rmarkdown::html_vignette:
+ fig_width: 5
+ fig_height: 3.5
+ number_sections: true
+ toc: true
+vignette: >
+ %\VignetteIndexEntry{Simulating datasets}
+ %\VignetteEngine{knitr::rmarkdown}
+ \usepackage[utf8]{inputenc}
+---
+
+# Introduction
+
+Simulating datasets is a powerful and varied tool when conducting `unmarked` analyses.
+Writing our own code to simulate a dataset based on a given model is an excellent learning tool, and can help us test if a given model is generating the expected results.
+If we simulate a series of datasets based on a fitted model, and calculate a statistic from each of those fits, we can generate a distribution of the statistic - this is what the `parboot` function does.
+This can be helpful, for example, when testing goodness of fit.
+Finally, simulation can be a useful component of power analysis when a closed-form equation for power is not available.
+
+`unmarked` provides two different ways of generating simulated datasets, depending on the stage we are at in the modeling process.
+
+1. Generating simulated datasets from a fitted model we already have
+2. Generating simulated datasets from scratch
+
+For (1), we simply call the `simulate` method on our fitted model object and new dataset(s) are generated.
+This is the approach used by `parboot`.
+In this vignette we will focus on (2), a more flexible approach to simulation, also using the `simulate` method, that allows us to generate a dataset corresponding to any `unmarked` model from scratch.
+
+# Components of a call to simulate
+
+We will need to provide, at a minimum, four pieces of information to `simulate` in order to simulate a dataset from scratch in `unmarked`.
+
+1. The name of the fitting function for the model we want to simulate from, as a character string
+2. A list of formulas, one per submodel, containing the names of the covariates we want to include in each
+3. A list of vectors of regression coefficients (intercepts and slopes), one per submodel, matching the formulas
+4. A list of design components; for example, the number of sites and number of observations per site
+
+A number of other arguments are available, e.g. for how to customize how the covariates are randomly generated or for distributions to use when simulating abundances.
+We'll show those later.
+The easiest way to demonstrate how to use `simulate` is to look at an example: we'll start with a simple one for occupancy.
+
+# Simulating an occupancy dataset
+
+Suppose we want to simulate an occupancy dataset in which site occupancy is affected by elevation.
+The first piece of information needed is the name of model to use: the fitting function for occupancy is `occu`, so the first argument to `simulate` and the name of the model will be `"occu"`.
+
+## Formulas
+
+Second we must define the desired model structure as a list of formulas, one per submodel.
+"Submodels" here are the hierarchical components of the model; for example, an occupancy model has a state (occupancy) submodel and an observation (detection) submodel.
+These submodels are identified by short names: `state` and `det`.
+We will use these short names repeatedly.
+In order to identify which submodels are needed and what their short names are, we can simply fit any model of that type (e.g. from the example) and call `names(model)`.
+
+```{r}
+set.seed(123)
+library(unmarked)
+umf <- unmarkedFrameOccu(y=matrix(c(0,1,0,1,1,0,0,0,1), nrow=3))
+mod <- occu(~1~1, umf)
+names(mod)
+```
+
+Formulas are supplied as a named list.
+The list has one element per submodel, and the names of the elements are the short names defined above.
+Each list element is a formula, containing the desired number of covariates to use, and the names of these covariates.
+Below we define our list of formulas, including an effect of elevation on occupancy (note we could name this whatever we want, here we call it `elev`).
+We don't want any covariates on detection probability, so the formula defines the model as intercept only: `~1`.
+
+```{r}
+forms <- list(state=~elev, det=~1)
+```
+
+## Regression coefficients
+
+Next we must tell `unmarked` what the values for the intercept and regression coefficients in each submodel should be.
+Once again, this is a named list, one element for each submodel.
+Each list element is a numeric vector.
+The components of each numeric vector must also be named, matching the covariate names in our list of formulas.
+Don't forget we also must specify a value for the intercept in each submodel (can be named `Intercept` or `intercept`).
+If we are not sure exactly how to structure this list, just skip it for now: `unmarked` can generate a template for us to fill in later.
+
+```{r}
+coefs <- list(state=c(intercept=0, elev=-0.4), det=c(intercept=0))
+```
+
+We have a list with two elements, each a numeric vector.
+Both contain intercept values, and the `state` vector also contains a value corresponding to the desired effect of our covariate `elev`.
+
+## Study design information
+
+Finally, we need to give `unmarked` information about the study design.
+This is pretty simple: we just need a list containing values for `M`, the number of sites, and `J` the number of surveys per site.
+For models with multiple primary periods, we'd also need a value of `T`, the number of primary periods.
+
+```{r}
+design <- list(M=300, J=8) # 300 sites, 8 occasions per site
+```
+
+## Put it all together
+
+We're now ready to simulate a dataset.
+To do this we use the `simulate` function, providing as arguments the name of the model `"occu"` and the three lists we constructed above.
+Actually, first, let's not supply the `coefs` list, to show how `unmarked` will generate a template for us to use:
+
+```{r, eval=FALSE}
+simulate("occu", formulas=forms, design=design)
+```
+
+```{r, echo=FALSE}
+try(simulate("occu", formulas=forms, design=design))
+```
+
+We can replicate this provided list structure and fill in our own numeric values.
+Once we have our coefficients set up properly, add them to the function call:
+
+```{r}
+occu_umf <- simulate("occu", formulas=forms, coefs=coefs, design=design)
+head(occu_umf)
+```
+
+`unmarked` has generated a presence-absence dataset as well as values for covariate `elev`.
+We can check that it worked as expected by fitting the corresponding model to the dataset, and making sure the estimated values are similar:
+
+```{r}
+(occu(~1 ~elev, occu_umf))
+```
+
+## Customizing the covariates
+
+By default, a covariate will be continuous and come from a standard normal distribution (mean 0, SD 1).
+However, we can control this using the `guide` argument.
+For example, suppose we want elevation to come from a random normal, but with a mean of 2 and a standard deviation of 0.5.
+We can provide a named list to the `guide` argument as follows:
+
+```{r}
+guide <- list(elev=list(dist=rnorm, mean=2, sd=0.5))
+```
+
+`guide` contains one element, called `elev`, which is also a list and contains three components:
+
+1. The random distribution function to use, `rnorm`
+2. The mean of the distribution
+3. The SD of the distribution
+
+```{r}
+occu_umf <- simulate("occu", formulas=forms, coefs=coefs, design=design, guide=guide)
+head(occu_umf)
+```
+
+You can see the `elev` covariate now has values corresponding to the desired distribution.
+Note that the elements of the list will depend on the arguments required by the random distribution function.
+For example, to use a uniform distribution instead:
+
+```{r}
+guide <- list(elev=list(dist=runif, min=0, max=1))
+occu_umf <- simulate("occu", formulas=forms, coefs=coefs, design=design, guide=guide)
+head(occu_umf)
+```
+
+It is also possible to define a categorical (factor) covariate.
+We specify an entry in the `guide` list, but instead of a list, we supply a call to `factor` which defines the desired factor levels.
+For example, suppose we want to add a new `landcover` covariate to our simulated model.
+First, define the new formulas:
+
+```{r}
+forms2 <- list(state=~elev+landcover, det=~1)
+```
+
+And then the new guide, including the information about factor levels:
+
+```{r}
+guide <- list(landcover=factor(levels=c("forest","grass","urban")))
+```
+
+We'd also need an updated `coefs` since we have a new covariate.
+Defining the `coefs` when you have factors in your model is a little trickier, since R names the effects as a combination of the factor name and the level name.
+There is no coefficient for the reference level (`"forest"` in our example), but we need to provide coefficients for both `"grass"` and `"urban"`.
+When combined with the factor name the complete coefficient names for these two will be `landcovergrass` and `landcoverurban`.
+The easiest way to make sure we get these names right is to let `unmarked` generate a template `coefs` for you as shown above, and then fill it in.
+
+```{r}
+# forest is the reference level for landcover since it was listed first
+coefs2 <- list(state=c(intercept=0, elev=-0.4, landcovergrass=0.2,
+ landcoverurban=-0.7), det=c(intercept=0))
+```
+
+```{r}
+head(simulate("occu", formulas=forms2, coefs=coefs2, design=design, guide=guide))
+```
+
+Our output dataset now includes a new categorical covariate.
+
+## Models that require more information
+
+More complex models might require more information for simulation.
+Nearly any argument provided to either the fitting function for the model, or the corresponding `unmarkedFrame` constructor, can be provided as an optional argument to `simulate` to customize the simulation.
+For example, we may want to specify that abundance should be simulated as a negative binomial, instead of a Poisson, for `pcount`.
+This information is simply added as additional arguments to `simulate`.
+For example, we can simulate a `pcount` dataset using the negative binomial (`"NB"`) distribution.
+The negative binomial has an additional parameter to estimate (`alpha`) so we must also add an element to `coefs`.
+
+```{r}
+coefs$alpha <- c(alpha=0.5)
+head(simulate("pcount", formulas=forms, coefs=coefs, design=design, mixture="NB"))
+```
+
+In the next section we will show a more detailed example involving these additional arguments.
+
+## Simulating a more complex dataset: gdistremoval
+
+The `gdistremoval` function fits the model of @Amundson_2014, which estimates abundance using a combination of distance sampling and removal sampling data.
+When simulating a dataset based on this model, we have to provide several additional pieces of information related to the structure of the distance and removal sampling analyses.
+
+To begin, we will define the list of formulas.
+A `gdistremoval` model, when there is only one primary period, has three submodels: abundance (`"lambda"`), distance sampling (`"dist"`), and removal sampling (`"rem"`).
+We will fit a model with an effect of elevation `elev` on abundance and an effect of wind `wind` on removal probability.
+
+```{r}
+forms <- list(lambda=~elev, dist=~1, rem=~wind)
+```
+
+Next we will define the corresponding coefficients.
+We will set mean abundance at 5.
+The intercept is on the log scale, thus the intercept for `lambda` will be `log(5)`.
+The scale parameter for the detection function will be 50, and again it is on the log scale.
+The intercept for the removal probability is on the logit scale, so we will set the intercept at -1 (equivalent to a mean removal probability of about 0.27).
+Don't forget the covariate effects on `lambda` and removal.
+
+```{r}
+coefs <- list(lambda=c(intercept=log(5), elev=0.7),
+ dist=c(intercept=log(50)), rem=c(intercept=-1, wind=-0.3))
+```
+
+Our study will have 300 sites.
+This model is unique in that we have to specify the number of two different types of observations: (1) the number of distance sampling bins (`Jdist`), and the number of removal intervals (`Jrem`).
+
+```{r}
+design <- list(M = 300, Jdist=4, Jrem=5)
+```
+
+Finally we are ready to simulate the dataset.
+In addition to the name of the model, `forms`, `coefs` and `design`, we also need to provide some additional information.
+We need to define the distance breaks for the distance sampling part of the model (there should be `Jdist+1` of these), and also the key function to use when simulating the detection process.
+
+```{r}
+umf <- simulate("gdistremoval", formulas=forms, coefs=coefs, design=design,
+ dist.breaks=c(0,25,50,75,100), keyfun="halfnorm", unitsIn="m")
+head(umf)
+```
+
+The result is a dataset containing a combination of distance, removal, and covariate data.
+We can check to see if fitting a model to this dataset recovers our specified coefficient values:
+
+```{r}
+(fit <- gdistremoval(lambdaformula=~elev, removalformula=~wind,
+ distanceformula=~1, data=umf))
+```
+
+Looks good.
+
+# Conclusion
+
+The `simulate` function provides a flexible tool for simulating data from any model in `unmarked`.
+These datasets can be used for a variety of purposes, such as for teaching examples, testing models, or developing new tools that work with `unmarked`.
+Additionally, simulating datasets is a key component of the power analysis workflow in `unmarked` - see the power analysis vignette for more examples.
+
+# References
diff --git a/vignettes/spp-dist-psi2.pdf b/vignettes/spp-dist-psi2.pdf
deleted file mode 100644
index 745774b..0000000
--- a/vignettes/spp-dist-psi2.pdf
+++ /dev/null
Binary files differ
diff --git a/vignettes/spp-dist.Rnw b/vignettes/spp-dist.Rmd
index e63478d..8157e75 100644
--- a/vignettes/spp-dist.Rnw
+++ b/vignettes/spp-dist.Rmd
@@ -1,91 +1,67 @@
-<<echo=false>>=
-options(width=70)
-options(continue=" ")
-@
+---
+title: Modeling and mapping species distributions
+author: Richard Chandler
+date: Feb 5, 2019
+bibliography: unmarked.bib
+csl: ecology.csl
+output:
+ rmarkdown::html_vignette:
+ fig_width: 5
+ fig_height: 3.5
+ number_sections: true
+ toc: true
+vignette: >
+ %\VignetteIndexEntry{Species distributions}
+ %\VignetteEngine{knitr::rmarkdown}
+ \usepackage[utf8]{inputenc}
+---
+
+```{r,echo=FALSE}
+options(rmarkdown.html_vignette.check_title = FALSE)
+```
+
+# Abstract
-\documentclass[a4paper]{article}
-\usepackage[OT1]{fontenc}
-\usepackage{Sweave}
-\usepackage[authoryear,round]{natbib}
-%\usepackage{fullpage}
-\usepackage[vmargin=1in,hmargin=1in]{geometry}
-\usepackage{verbatim}
-\usepackage{color}
-
-%\usepackage[a4paper, hmargin={2cm,2cm}, vmargin={2cm,2cm}]{geometry}
-
-
-\bibliographystyle{ecology}
-
-\DefineVerbatimEnvironment{Sinput}{Verbatim} {xleftmargin=2em}
-\DefineVerbatimEnvironment{Soutput}{Verbatim}{xleftmargin=2em}
-\DefineVerbatimEnvironment{Scode}{Verbatim}{xleftmargin=2em}
-\fvset{listparameters={\setlength{\topsep}{0pt}}}
-\renewenvironment{Schunk}{\vspace{\topsep}}{\vspace{\topsep}}
-
-%%\VignetteIndexEntry{Species distributions}
-
-\title{Modeling and mapping species distributions}
-\author{Richard Chandler}
-\date{Feb 5, 2019}
-
-
-\begin{document}
-
-\maketitle
-
-\abstract{
A species' distribution can be characterized by either
occurrence probability or population density, defined for all
locations in some spatial extent. Defining distribution in terms of
these two parameters %These definitions of species distribution
avoids the ambiguity surrounding the indices of occurrence
or abundance produced by many presence-only algorithms. The
-\texttt{unmarked} package contains methods of fitting
+`unmarked` package contains methods of fitting
occurrence and abundance models, and can be used to
-produce distribution maps with the help of \textbf{R}'s GIS
+produce distribution maps with the help of `R`'s GIS
capabilities,
-%, such as the \texttt{raster} package
-%\citep{hijmans_vanEtten:2012}
as is demonstrated in this vignette.
Unlike many other tools for modeling
-species distributions, the models in \texttt{unmarked} account for
+species distributions, the models in `unmarked` account for
bias due to spatial and temporal heterogeneity in detection
-probability. Furthermore, \texttt{unmarked} includes models
+probability. Furthermore, `unmarked` includes models
of population dynamics, allowing one to map quantities
such as local colonization or extinction probability.
-}
+# Mapping Occurrence Probability
-<<echo=false>>=
-library(unmarked)
-library(raster)
-@
-
-
-\section*{Mapping Occurrence Probability}
-
-
-
-In this example, we use the \verb+occu+ function to fit the
+In this example, we use the `occu` function to fit the
single-season occupancy model of
-\citep{mackenzie_estimating_2002} to data on the European crossbill
-(\emph{Loxia curvirostra}) collected in 267 1-km$^2$ sample
-quadrats in Switzerland, 1999 \citep{schmid_etal:2004}.
+@mackenzie_estimating_2002 to data on the European crossbill
+(*Loxia curvirostra*) collected in 267 1-km$^2$ sample
+quadrats in Switzerland, 1999 [@schmid_etal:2004].
We then use the model to compute the expected probability of
occurrence at each pixel in a raster defining the Swiss
landscape.
-First we load the \verb+crossbill+ data, which contains the
+First we load the `crossbill` data, which contains the
detection/non-detection data and covariates. The dataset actually
contains data from multiple years, but we are only going to analyze
data from the first year, 1999. A multi-year analysis of occupancy
-dynamics could be accomplished using the \verb+colext+ function, and
+dynamics could be accomplished using the `colext` function, and
in addition to mapping occurrence probability, it would be possible to
also map colonization and extinction probabilities. The following
commands format the data.
-<<>>=
+```{r}
+library(unmarked)
data(crossbill)
umf <- unmarkedFrameOccu(
y=as.matrix(crossbill[,c("det991", "det992", "det993")]),
@@ -94,67 +70,85 @@ umf <- unmarkedFrameOccu(
sc <- scale(siteCovs(umf))
siteCovs(umf) <- sc
head(umf)
-@
+```
Notice that the site covariates, elevation and forest, were
-standardized using the \verb+scale+ function. Standardization isn't
+standardized using the `scale` function. Standardization isn't
always necessary, but it can make it easier to find the maximum
likelihood estimates. When standardizing covariates and then making
predictions, it is important to retain the original sample mean and
standard deviation. The reason for this is explained below.
-\newpage
-
Fitting a model is now straight-forward. In many cases, we would fit
several models corresponding to competing hypotheses, but for
simplicity, we stick with this single model.
-<<>>=
+```{r}
(fm.occu <- occu(~date ~ele + I(ele^2) + forest, umf))
-@
+```
Now that we have our fitted model, we can use it to predict occurrence
-probability at each pixel in the Swiss landscape. The \verb+Switzerland+
+probability at each pixel in the Swiss landscape. The `Switzerland`
dataset contains country-wide data. There are many ways to display
it---here is an example of mapping elevation using the
-\verb+levelplot+ function in the \texttt{lattice} package \citep{sarkar:2008}.
+`levelplot` function in the `lattice` package [@sarkar:2008].
-<<swiss,fig=TRUE,include=FALSE,width=5,height=4>>=
+```{r, eval=FALSE}
+library(lattice)
data(Switzerland)
print(levelplot(elevation ~ x + y, Switzerland, aspect="iso",
xlab="Easting (m)", ylab="Northing (m)",
col.regions=terrain.colors(100)))
-@
-\begin{figure}
- \centering
- \includegraphics[width=5in,height=4in]{spp-dist-swiss}
- \caption{Elevation in Switzerland}
- \label{fig:swiss}
-\end{figure}
-
-The \texttt{raster} package \citep{hijmans_vanEtten:2012}
+```
+
+```{r, echo=FALSE, fig.height=4, fig.width=5, fig.cap="Figure 1. Elevation in Switzerland"}
+if(requireNamespace("lattice", quietly = TRUE)){
+ library(lattice)
+ data(Switzerland)
+ print(levelplot(elevation ~ x + y, Switzerland, aspect="iso",
+ xlab="Easting (m)", ylab="Northing (m)",
+ col.regions=terrain.colors(100)))
+} else {
+ message("lattice package is required for this vignette but is not available\n")
+ knitr::knit_exit()
+}
+```
+
+The `raster` package [@hijmans_vanEtten:2012]
provides another alternative. Here we create two raster objects and
specify the coordinate system.
-<<>>=
+```{r,eval=FALSE}
library(raster)
+```
+
+```{r,echo=FALSE}
+if(requireNamespace("raster", quietly = TRUE)){
+ suppressMessages(library(raster))
+} else {
+ message("raster package is required for this vignette but is not available\n")
+ knitr::knit_exit()
+}
+```
+
+```{r}
elevation <- rasterFromXYZ(Switzerland[,c("x","y","elevation")],
crs="+proj=somerc +lat_0=46.95240555555556 +lon_0=7.439583333333333 +k_0=1 +x_0=600000 +y_0=200000 +ellps=bessel +towgs84=674.374,15.056,405.346,0,0,0,0 +units=m +no_defs")
forest <- rasterFromXYZ(Switzerland[,c("x","y","forest")],
crs="+proj=somerc +lat_0=46.95240555555556 +lon_0=7.439583333333333 +k_0=1 +x_0=600000 +y_0=200000 +ellps=bessel +towgs84=674.374,15.056,405.346,0,0,0,0 +units=m +no_defs")
-@
+```
Since we standardized the covariates during the model fitting process,
we need to transform the country-wide data using the same
values. Note, we don't want to use the mean and SD of the rasters
themselves, we want to use the mean and SD of the original covariates
used to fit the models, which are stored as attributes of the
-\verb+sc+ object. The following commands display the original means
+`sc` object. The following commands display the original means
and SDs and then transform the rasters and join them in a raster
-``stack.''
+"stack".
-<<ef,fig=TRUE,include=FALSE,height=3,width=6>>=
+```{r, fig.height=3, fig.width=6, fig.cap="Figure 2. Elevation and forest cover, standardized"}
attr(sc, "scaled:center")
attr(sc, "scaled:scale")
ele.s <- (elevation-1189)/640
@@ -162,114 +156,85 @@ forest.s <- (forest-34.7)/27.7
ef <- stack(ele.s, forest.s)
names(ef) <- c("ele", "forest")
plot(ef, col=terrain.colors(100))
-@
-\begin{figure}
- \centering
- \includegraphics[width=6in,height=3in]{spp-dist-ef}
- \caption{Elevation and forest cover, standardized.}
-\label{fig:ef}
-\end{figure}
-
-It is important to assign \verb+names+
+```
+
+It is important to assign `names`
that exactly match the covariate names used to fit the model. This
-is required by the \verb+predict+ function as demonstrated later.
-The \verb+predict+ function is useful for computing
+is required by the `predict` function as demonstrated later.
+The `predict` function is useful for computing
spatially-referenced model predictions, standard errors, and
confidence intervals, but it is computationally demanding when
there are many pixels in the raster. Thus, if measures of uncertainty
are not required, the following code can be used to quickly produce
-the species distribution map shown in Fig.\ref{fig:psi1}.
+the species distribution map shown in Fig. 3.
-<<psi,fig=TRUE,include=FALSE>>=
+```{r, fig.height=4, fig.width=4, fig.cap="Figure 3. A species distribution map for the European crossbill in Switzerland. The colors represent occurrence probability."}
(beta <- coef(fm.occu, type="state"))
logit.psi <- beta[1] + beta[2]*ele.s + beta[3]*ele.s^2 + beta[4]*forest.s
psi <- exp(logit.psi) / (1 + exp(logit.psi))
-#plot(psi, col=terrain.colors(100))
print(spplot(psi, col.regions=terrain.colors(100)))
-@
-\begin{figure}
- \includegraphics[width=4in,height=4in]{spp-dist-psi}
- \centering
- \caption{A species distribution map for the European crossbill in
- Switzerland. The colors represent occurrence probability.}
-\label{fig:psi1}
-\end{figure}
-
-As of version 0.9-6, the \verb+predict+ method in \texttt{unmarked}
-can make predictions using an object of class \verb+RasterStack+ from the
+```
+
+As of version 0.9-6, the `predict` method in `unmarked`
+can make predictions using an object of class `RasterStack` from the
\texttt{raster} package. As mentioned previously, the rasters must be
-named, perhaps by using the \verb+names(someraster) <- somename+
+named, perhaps by using the `names(someraster) <- somename`
method. The object
-returned by \verb+predict+ is another raster stack with rasters for
+returned by `predict` is another raster stack with rasters for
the expected values of the parameter of interest, the standard errors,
and the upper and lower confidence intervals. The following example
is very slow because there are many of pixels in the raster. The
-resulting map is shown in Fig.~\ref{fig:predict}.
+resulting map is shown in Fig. 4.
-<<psi2,eval=false,echo=false,fig=TRUE,include=FALSE>>=
+```{r, fig.height=5, fig.width=5, fig.cap="Figure 4. Expected occurrence probability along with standard errors and the limits of the asymptotic 95% confidence interval."}
E.psi <- predict(fm.occu, type="state", newdata=ef)
plot(E.psi, axes=FALSE, col=terrain.colors(100))
-@
-\begin{Schunk}
-\begin{Sinput}
-> E.psi <- predict(fm.occu, type="state", newdata=ef)
-\end{Sinput}
-\begin{Sinput}
-> plot(E.psi, axes=FALSE, col=terrain.colors(100))
-\end{Sinput}
-\end{Schunk}
-\begin{figure}%[b!]
- \centering
-\includegraphics[width=5in,height=5in]{spp-dist-psi2}
-\caption{Expected occurrence probability along with standard errors
- and the limits of the asymptotic 95\% confidence interval.}
-\label{fig:predict}
-\end{figure}
+```
Users should be cautious when predicting from models that have
-categorical predictor variables, \emph{i.e.} \verb+factor+s. The
+categorical predictor variables, i.e. `factor`s. The
\texttt{raster} package does not have advanced methods for handling
factors, and thus it is not easy to automatically create dummy
variables from them as can typically be done using
-\verb+model.matrix+. The safest option is to create the dummy
+`model.matrix`. The safest option is to create the dummy
variables manually before fitting the models, and to use the same
variables as rasters for prediction.
A more important consideration when creating species distribution maps
based upon occurrence probability is that of spatial scale. Occurrence
-probability will typically depend upon the area of the ``site'' in
+probability will typically depend upon the area of the "site" in
question. Thus, in our crossbill example, it would not be appropriate
-to use our model to predict occcurrence probability for 10-km$^2$
+to use our model to predict occurrence probability for 10-km$^2$
pixels since the surveys were done in 1-km$^2$ quadrats. In some
cases it might be possible to directly model the effect of site area
on occurrence probability, in which case the effect could be accounted
for in the predictions.
-\section*{Mapping Population Density}
+# Mapping Population Density
Although distribution is typically described in terms of
-ocurrence probability, which is always better than an index of
+occurrence probability, which is always better than an index of
occurrence probability, the best parameter for modeling species
distribution is population density because density allows for
-inference about popualation size in any region of
+inference about population size in any region of
the species' range. Furthermore, occurrence probability is simply the
-probablity that abundance is greater than 0, so with density/abundance
-estimates, it is always possible to compute occurrence probablity as a
+probability that abundance is greater than 0, so with density/abundance
+estimates, it is always possible to compute occurrence probability as a
derived parameter.
In this example, we create a distribution map for the Island Scrub-Jay
-(\textit{Aphelocoma insularis}), which is restricted to Santa Cruz
+(*Aphelocoma insularis*), which is restricted to Santa Cruz
Island, California. To do so, we fit the hierarchical distance
-sampling model of \citet{royle_modeling_2004}, which allows for the
+sampling model of @royle_modeling_2004, which allows for the
estimation of abundance in each of the $300 \times 300$m pixels
representing the island. The data were collected 307, 300-m radius
-point count (or ``point transect'') surveyed during the Fall of 2008.
+point count (or "point transect") surveyed during the Fall of 2008.
-{\color{red} Important} This analysis is for demonstration
+IMPORTANT: This analysis is for demonstration
purposes only, and the estimates of population size should not be used
for conservation or management purposes. Indeed, the Poisson
assumption used here was found to be inadequate by
-\citet{sillett_etal:2012} who conducted a rigorous analysis and
+@sillett_etal:2012 who conducted a rigorous analysis and
reported reliable estimate of population size.
Although we are fitting a model of population density, the steps of
@@ -281,7 +246,7 @@ chapararral cover. We also include include the area of the survey
plots in the analysis so that we can make predictions for regions of
any area. Here is the code to format the data and fit the model.
-<<>>=
+```{r}
data(issj)
covs <- scale(issj[,c("elevation", "forest", "chaparral")])
area <- pi*300^2 / 10000
@@ -294,46 +259,20 @@ fm1 <- distsamp(~chaparral ~chaparral + elevation + offset(log(area)),
jayumf, keyfun="halfnorm", output="abund",
starts=c(-2.8,1,0,4.5,0))
fm1
-@
+```
Remarks. 1) The distance data were binned into 3 distance classes. 2)
-We used \verb+output="abund"+ even though, by specifying the offset,
+We used `output="abund"` even though, by specifying the offset,
we effectively modeled population density. As stated previously, this
allows us to make predictions of abundance for regions of arbitrary size.
-
-
-\begin{comment}
-
-<<fig=TRUE,width=6,height=4>>=
-data(issj)
-data(cruz)
-elev <- rasterFromXYZ(cruz[,c("x","y","elevation")],
- crs="+proj=utm +zone=11 +ellps=GRS80 +datum=NAD83 +units=m +no_defs")
-#plot(elev, col=terrain.colors(100))
-#points(issj[,c("x","y")], cex=0.5)
-@
-print(
-wireframe(elevation ~ x + y, cruz, drape=TRUE,
- screen=list(z=10, x=-10),
- aspect=0.5, xlab="", ylab="", zlab="",
-# xlim=c(229900,267000), ylim=c(3762000,3770000),
- par.settings = list(axis.line = list(col = "transparent")),
- par.box = c(col = "transparent"),
- col.regions=terrain.colors(100),
- colorkey=FALSE)
-)
-
-\end{comment}
-
-
The next thing to do is to format the raster data. For details, see
-the previous section---the process is the same, except that we need a
-raster for ``area'', the size of each pixel in the raster data. This
+the previous section-the process is the same, except that we need a
+raster for `"area"`, the size of each pixel in the raster data. This
is necessary because the survey plots were larger than the pixels for
which we want predictions of abundance.
-<<>>=
+```{r}
data(cruz)
elev <- rasterFromXYZ(cruz[,c("x","y","elevation")],
crs="+proj=utm +zone=11 +ellps=GRS80 +datum=NAD83 +units=m +no_defs")
@@ -350,53 +289,18 @@ forest.s <- (forest-0.0673)/0.137
chap.s <- (chap-0.270)/0.234
habitat <- stack(elev.s, forest.s, chap.s, area.raster)
names(habitat) <- c("elevation", "forest", "chaparral", "area")
-@
-
+```
-Now, when we use \verb+predict+, it will return the expected number of
+Now, when we use `predict`, it will return the expected number of
jays in each pixel along with the standard errors and the 95\%
confidence intervals. We could sum these up to obtain an estimate of
-total population size. \citet{sillett_etal:2012} did this and used the
-parametric boostrap to estimate the variance of total population
+total population size. @sillett_etal:2012 did this and used the
+parametric bootstrap to estimate the variance of total population
size.
-<<issj,fig=TRUE,include=FALSE,width=6,height=5>>=
+```{r, fig.height=5, fig.width=6, fig.cap="Figure 5. Expeted Island Scrub-Jay abundance, SEs, and 95% CIs."}
E <- predict(fm1, type="state", newdata=habitat)
plot(E, axes=FALSE, col=terrain.colors(100))
-@
-\begin{figure}
- \centering
-\includegraphics[width=6in,height=5in]{spp-dist-issj}
-\caption{Expected Island Scrub-Jay abundance, SEs, and 95\% CIs.}
-\label{fig:issj}
-\end{figure}
-
-
-\begin{comment}
-<<>>=
-cruz2 <- data.frame(cruz[,1:2],
- chaparral=(cruz$chaparral-0.270)/0.234,
- elevation=(cruz$elevation-202)/125)
-cruz2$E.N <- exp(-2.827 + 0.957*cruz2$chaparral + -0.244*cruz2$elevation)
-wireframe(E.N ~ x + y, cruz2,
- shade=TRUE, #shade.colors.palette=terrain.colors(100),
-# drape=TRUE,
- aspect=0.5, colorkey=FALSE,
- screen=list(z=10, x=-10))
-
-@
-\end{comment}
-
-
-
-<<echo=FALSE>>=
-detach(package:raster)
-@
-
-
-
-\newpage
-
-\bibliography{unmarked}
+```
-\end{document}
+# References
diff --git a/vignettes/unmarked.Rnw b/vignettes/unmarked.Rmd
index a0d90dc..8c02c5a 100644
--- a/vignettes/unmarked.Rnw
+++ b/vignettes/unmarked.Rmd
@@ -1,44 +1,37 @@
-<<echo=false>>=
-options(width=70)
-options(continue=" ")
-@
-
-\documentclass[a4paper]{article}
-\usepackage[OT1]{fontenc}
-\usepackage{Sweave}
-\usepackage{natbib}
-%\usepackage{fullpage}
-\usepackage[vmargin=1in,hmargin=1in]{geometry}
-\bibliographystyle{plain}
-
-\DefineVerbatimEnvironment{Sinput}{Verbatim} {xleftmargin=2em}
-\DefineVerbatimEnvironment{Soutput}{Verbatim}{xleftmargin=2em}
-\DefineVerbatimEnvironment{Scode}{Verbatim}{xleftmargin=2em}
-\fvset{listparameters={\setlength{\topsep}{0pt}}}
-\renewenvironment{Schunk}{\vspace{\topsep}}{\vspace{\topsep}}
-
-%%\VignetteIndexEntry{Overview of unmarked}
-
-\title{Overview of Unmarked:\\
-An R Package for the Analysis of Data from Unmarked Animals}
-\author{Ian Fiske and Richard Chandler}
-\date{Feb 5, 2019}
-
-
-\begin{document}
-
-\maketitle
-
-\abstract{Unmarked aims to be a complete environment for the
- statistical analysis of data from surveys of unmarked
- animals. Currently, the focus is on hierarchical models that
- separately model a latent state (or states) and an observation
- process. This vignette provides a brief overview of the package ---
- for a more thorough treatment see \citep{fiskeChandler_2011}
-}
-
-
-\section{Overview of unmarked}
+---
+title: "Overview of unmarked: an R Package for the Analysis of Data from Unmarked Animals"
+author:
+- name: Ian Fiske
+- name: Richard Chandler
+date: February 5, 2019
+bibliography: unmarked.bib
+csl: ecology.csl
+output:
+ rmarkdown::html_vignette:
+ fig_width: 5
+ fig_height: 3.5
+ number_sections: true
+ toc: true
+vignette: >
+ %\VignetteIndexEntry{Overview of unmarked}
+ %\VignetteEngine{knitr::rmarkdown}
+ \usepackage[utf8]{inputenc}
+---
+
+```{r,echo=FALSE}
+options(rmarkdown.html_vignette.check_title = FALSE)
+```
+
+# Abstract
+
+`unmarked` aims to be a complete environment for the
+statistical analysis of data from surveys of unmarked
+animals. Currently, the focus is on hierarchical models that
+separately model a latent state (or states) and an observation
+process. This vignette provides a brief overview of the package -
+for a more thorough treatment see @fiskeChandler_2011.
+
+# Overview of unmarked
Unmarked provides methods to estimate site occupancy, abundance, and
density of animals (or possibly other organisms/objects) that cannot be
@@ -54,43 +47,42 @@ way that allows for easy data manipulation, summarization, and model
specification. Table 1 lists the currently implemented models and
their associated fitting functions and data classes.
-\begin{table}[!h] %%\footnotesize
-\centering
-\begin{tabular}{cccc}
-\hline
-Model & Fitting Function & Data & Citation \\ \hline
-Occupancy & occu & unmarkedFrameOccu & \citep{mackenzie_estimating_2002} \\
-Royle-Nichols & occuRN & unmarkedFrameOccu & \citep{royle_estimating_2003} \\
-Point Count & pcount & unmarkedFramePCount & \citep{royle_n-mixture_2004} \\
-Distance-sampling & distsamp & unmarkedFrameDS & \citep{royle_modeling_2004} \\
-Generalized distance-sampling & gdistsamp & unmarkedFrameGDS & \citep{chandlerEA_2011} \\
-Arbitrary multinomial-Poisson & multinomPois & unmarkedFrameMPois & \citep{royle_generalized_2004} \\
-Colonization-extinction & colext & unmarkedMultFrame & \citep{mackenzie_estimating_2003} \\
-Generalized multinomial-mixture & gmultmix & unmarkedFrameGMM & \citep{royle_generalized_2004} \\
-\hline
-\end{tabular}
-\caption{Models handled by unmarked.}
-\label{tab:models}
-\end{table}
+```{r, echo=FALSE}
+tab1 <- data.frame(
+ Model=c("Occupancy", "Royle-Nichols", "Point Count", "Distance-sampling",
+ "Generalized distance-sampling", "Arbitrary multinomial-Poisson",
+ "Colonization-extinction", "Generalized multinomial-mixture"),
+ `Fitting Function`=c("occu","occuRN","pcount","distsamp","gdistsamp",
+ "multinomPois","colext","gmultmix"),
+ Data=c("unmarkedFrameOccu","unmarkedFrameOccu","unmarkedFramePCount",
+ "unmarkedFrameDS","unmarkedFrameGDS","unmarkedFrameMPois",
+ "unmarkedMultFrame","unmarkedFrameGMM"),
+ Citation=c("@mackenzie_estimating_2002","@royle_estimating_2003",
+ "@royle_n-mixture_2004","@royle_modeling_2004",
+ "@chandlerEA_2011","@royle_generalized_2004",
+ "@mackenzie_estimating_2003","@royle_generalized_2004"),
+ check.names=FALSE)
+
+knitr::kable(tab1, format='markdown', align="lccc",
+ caption="Table 1. Models handled by unmarked.")
+```
Each data class can be created with a call to the constructor function
of the same name as described in the examples below.
-%%\newpage
-
-\section{Typical unmarked session}
+# Typical unmarked session
The first step is to import the data into R, which we do below using
-the \textbf{read.csv} function. Next, the data need to be formatted for
+the `read.csv` function. Next, the data need to be formatted for
use with a specific model fitting function. This can be accomplished
-with a call to the appropriate type of \textbf{unmarkedFrame}. For
+with a call to the appropriate type of `unmarkedFrame`. For
example, to prepare the data for a single-season site-occupancy
-analysis, the function \textbf{unmarkedFrameOccu} is used.
+analysis, the function `unmarkedFrameOccu` is used.
-\subsection{Importing and formatting data}
+## Importing and formatting data
-<<>>=
+```{r}
library(unmarked)
wt <- read.csv(system.file("csv","widewt.csv", package="unmarked"))
y <- wt[,2:4]
@@ -99,63 +91,63 @@ obsCovs <- list(date=wt[,c("date.1", "date.2", "date.3")],
ivel=wt[,c("ivel.1", "ivel.2", "ivel.3")])
wt <- unmarkedFrameOccu(y = y, siteCovs = siteCovs, obsCovs = obsCovs)
summary(wt)
-@
+```
-Alternatively, the convenience function \textbf{csvToUMF} can be used
+Alternatively, the convenience function `csvToUMF` can be used
-<<>>=
+```{r}
wt <- csvToUMF(system.file("csv","widewt.csv", package="unmarked"),
long = FALSE, type = "unmarkedFrameOccu")
-@
+```
If not all sites have the same numbers of observations, then manual
-importation of data in long format can be tricky. \textbf{csvToUMF}
+importation of data in long format can be tricky. `csvToUMF`
seamlessly handles this situation.
-<<>>=
+```{r}
pcru <- csvToUMF(system.file("csv","frog2001pcru.csv", package="unmarked"),
long = TRUE, type = "unmarkedFrameOccu")
-@
+```
To help stabilize the numerical optimization algorithm, we recommend
standardizing the covariates.
-<<>>=
+```{r}
obsCovs(pcru) <- scale(obsCovs(pcru))
-@
-
+```
-\subsection{Fitting models}
+## Fitting models
Occupancy models can then be fit with the occu() function:
-<<>>=
+```{r}
fm1 <- occu(~1 ~1, pcru)
fm2 <- occu(~ MinAfterSunset + Temperature ~ 1, pcru)
fm2
-@
+```
Here, we have specified that the detection process is modeled with the
-MinAfterSunset and Temperature covariates. No covariates are
-specified for occupancy here. See ?occu for more details.
+`MinAfterSunset` and `Temperature` covariates. No covariates are
+specified for occupancy here. See `?occu` for more details.
-\subsection{Back-transforming parameter estimates}
+## Back-transforming parameter estimates
-Unmarked fitting functions return unmarkedFit objects which can be
+`unmarked` fitting functions return `unmarkedFit` objects which can be
queried to investigate the model fit. Variables can be
-back-transformed to the unconstrained scale using backTransform.
+back-transformed to the unconstrained scale using `backTransform`.
Standard errors are computed using the delta method.
-<<>>=
+```{r}
backTransform(fm2, 'state')
-@
+```
+
The expected probability that a site was
occupied is 0.823. This estimate applies to the hypothetical
population of all possible sites, not the sites found in our sample.
For a good discussion of population-level vs finite-sample inference,
-see Royle and Dorazio \citep{royle_dorazio:2008} page 117. Note also that finite-sample
-quantities can be computed in \texttt{unmarked} using empirical Bayes
+see @royle_dorazio:2008 page 117. Note also that finite-sample
+quantities can be computed in `unmarked` using empirical Bayes
methods as demonstrated at the end of this document.
Back-transforming the estimate of $\psi$ was easy because there were
@@ -166,50 +158,53 @@ estimate of $p$. Here, we request
the probability of detection given a site is occupied and all
covariates are set to 0.
-<<>>=
+```{r}
backTransform(linearComb(fm2, coefficients = c(1,0,0), type = 'det'))
-@
+```
Thus, we can say that the expected probability of detection was 0.552
when time of day and temperature are fixed at their mean value. A
-predict method also exists, which can be used to obtain estimates of
+`predict` method also exists, which can be used to obtain estimates of
parameters at specific covariate values.
-<<>>=
+```{r}
newData <- data.frame(MinAfterSunset = 0, Temperature = -2:2)
round(predict(fm2, type = 'det', newdata = newData, appendData=TRUE), 2)
-@
+```
-
-Confidence intervals are requested with confint, using either the
+Confidence intervals are requested with `confint`, using either the
asymptotic normal approximation or profiling.
-
-<<>>=
+```{r, eval=FALSE}
confint(fm2, type='det')
confint(fm2, type='det', method = "profile")
-@
+```
+```{r, echo=FALSE}
+confint(fm2, type='det')
+nul <- capture.output(ci <- confint(fm2, type='det', method = "profile"))
+ci
+```
-\subsection{Model selection and model fit}
+## Model selection and model fit
Model selection and multi-model inference can be implemented after
-organizing models using the fitList function.
+organizing models using the `fitList` function.
-<<>>=
+```{r}
fms <- fitList('psi(.)p(.)' = fm1, 'psi(.)p(Time+Temp)' = fm2)
modSel(fms)
predict(fms, type='det', newdata = newData)
-@
+```
The parametric bootstrap can be used to check the adequacy of model fit.
Here we use a $\chi^2$ statistic appropriate for binary data.
-<<>>=
+```{r, warning=FALSE}
chisq <- function(fm) {
- umf <- getData(fm)
- y <- getY(umf)
+ umf <- fm@data
+ y <- umf@y
y[y>1] <- 1
sr <- fm@sitesRemoved
if(length(sr)>0)
@@ -220,44 +215,40 @@ chisq <- function(fm) {
}
(pb <- parboot(fm2, statistic=chisq, nsim=100, parallel=FALSE))
-@
+```
We fail to reject the null hypothesis, and conclude that the model fit
is adequate.
-\subsection{Derived parameters and empirical Bayes methods}
+## Derived parameters and empirical Bayes methods
-The \texttt{parboot} function can be also be used to compute confidence
+The `parboot` function can be also be used to compute confidence
intervals for estimates of derived parameters, such as the proportion
-of sites occupied $\mbox{PAO} = \sum_i z_i$ where $z_i$ is the true
+of $N$ sites occupied $\mbox{PAO} = \frac{\sum_i z_i}{N}$ where $z_i$ is the true
occurrence state at site $i$, which is unknown at sites where no individuals
-were detected. The ``colext'' vignette shows examples of using
-\texttt{parboot} to obtain confidence intervals for such derived
+were detected. The `colext` vignette shows examples of using
+`parboot` to obtain confidence intervals for such derived
quantities. An alternative way achieving this goal is to use empirical Bayes
-methods, which were introduced in \texttt{unmarked} version 0.9-5. These methods estimate
+methods, which were introduced in `unmarked` version 0.9-5. These methods estimate
the posterior distribution of the latent variable given the data and
the estimates of the fixed effects (the MLEs). The mean or the mode of
the estimated posterior distibution is referred to as the empirical
-best unbiased predictor (EBUP), which in \texttt{unmarked} can be
-obtained by applying the \texttt{bup} function to the estimates of the
-posterior distributions returned by the \texttt{ranef} function. The
-following code returns the estimate of PAO and a 90\% confidence
-interval.
+best unbiased predictor (EBUP), which in `unmarked` can be
+obtained by applying the `bup` function to the estimates of the
+posterior distributions returned by the `ranef` function. The
+following code returns an estimate of PAO using EBUP.
-<<>>=
+```{r}
re <- ranef(fm2)
EBUP <- bup(re, stat="mode")
-CI <- confint(re, level=0.9)
-rbind(PAO = c(Estimate = sum(EBUP), colSums(CI)) / 130)
-@
+sum(EBUP) / numSites(pcru)
+```
+
Note that this is similar, but slightly lower than the
population-level estimate of $\psi$ obtained above.
-A plot method also exists for objects returned by \texttt{ranef}, but
+A plot method also exists for objects returned by `ranef`, but
distributions of binary variables are not so pretty. Try it out on a
fitted abundance model instead.
-
-\bibliography{unmarked}
-
-\end{document}
+# References
diff --git a/vignettes/unmarked.bib b/vignettes/unmarked.bib
index 64d6516..c6091c6 100644
--- a/vignettes/unmarked.bib
+++ b/vignettes/unmarked.bib
@@ -68,7 +68,7 @@ year = {2004}
@Article{fiskeChandler_2011,
author = {Ian Fiske and Richard Chandler},
- title = {\textbf{unmarked}: An \textbf{R} Package for Fitting Hierarchical Models of Wildlife Occurrence and Abundance},
+ title = {\textbf{unmarked}: An {\textbf{R}} Package for Fitting Hierarchical Models of Wildlife Occurrence and Abundance},
journal = {Journal of Statistical Software},
year = {2011},
volume = {43},
@@ -142,6 +142,15 @@ year = {2004}
pages = {2248--2255}
}
+@article{Tyre_2002,
+ author = {Tyre, A.J. and Tenhumberg, B. and Field, S.A. and Niejalke, D. and Parris, K.,
+and Possingham, H.P.},
+ year = {2003},
+ title = {Improving precision and reducing bias in biological surveys: estimating false-negative error rates},
+ journal = {Ecological Applications},
+ volume = {13},
+ pages = {1790-1801}
+}
@@ -305,7 +314,9 @@ year = {2008}
title={Hierarchical distance sampling models to estimate population size and habitat-specific abundance of an island endemic},
author={Sillett, S. and Chandler, R.B. and Royle, J.A. and K{\'e}ry, M. and Morrison, S.A.},
journal={Ecological Applications},
- year={{In press}},
+ volume={22},
+ pages={1997-2006},
+ year={2012},
publisher={Eco Soc America}
}
@@ -318,3 +329,142 @@ title = {{Analysis and management of animal populations: modeling, estimation, a
year = {2002}
}
+@article{Guillera_2012,
+author = {Guillera-Arroita, Gurutzeta and Lahoz-Monfort, José J.},
+title = {Designing studies to detect differences in species occupancy: power analysis under imperfect detection},
+journal = {Methods in Ecology and Evolution},
+volume = {3},
+number = {5},
+pages = {860-869},
+keywords = {hypothesis testing, likelihood-ratio test, multiple-season occupancy, sample size, survey design, Wald test},
+doi = {https://doi.org/10.1111/j.2041-210X.2012.00225.x},
+url = {https://besjournals.onlinelibrary.wiley.com/doi/abs/10.1111/j.2041-210X.2012.00225.x},
+year = {2012}
+}
+
+@article{Amundson_2014,
+ author = {Amundson, Courtney L. and Royle, J. Andrew and Handel, Colleen M.},
+ title = "{A hierarchical model combining distance sampling and time removal to estimate detection probability during avian point counts}",
+ journal = {The Auk},
+ volume = {131},
+ number = {4},
+ pages = {476-494},
+ year = {2014},
+ month = {07},
+ issn = {1938-4254},
+ doi = {10.1642/AUK-14-11.1},
+ url = {https://doi.org/10.1642/AUK-14-11.1},
+ eprint = {https://academic.oup.com/auk/article-pdf/131/4/476/26883760/auk0476.pdf},
+}
+
+
+@article{Rota2016,
+ author = {Rota, Christopher T. and Ferreira, Marco A. R. and Kays, Roland and Forrester, Tavis D. and Kalies, Elizabeth L. and McShea, William J. and Parsons, Arielle W. and Millspaugh, Joshua J.},
+ title = {A multi-species occupancy model for two or more interacting species},
+ journal = {Methods in Ecology and Evolution},
+ year = {2016},
+ url = {http://dx.doi.org/10.1111/2041-210X.12587},
+ doi = {10.1111/2041-210X.12587},
+ volume = {7},
+ pages = {1164-1173},
+}
+
+@article{Clipp_2021,
+ author = {Clipp, Hannah L. and Evans, Amber L. and Kessinger, Brin E. and Kellner, Kenneth and Rota, Christopher T.},
+ title = {A penalized likelihood for multispecies occupancy models improves predictions of species interactions},
+ journal = {Ecology},
+ year = {2021},
+ pages = {e03520},
+ addendum = {\href{https://doi.org/10.1002/ecy.3520}{[view]}}
+}
+
+@book{Kery_2010,
+ author = {K\'{e}ry, Marc},
+ title = {{Introduction to WinBUGS for Ecologists}},
+ year = {2010},
+ publisher={Academic Press}
+}
+
+@article{Hanski_1998,
+ author = {Hanski, I},
+ title = {Metapopulation dynamics},
+ year = {1998},
+ journal = {Nature},
+ volume = {396},
+ pages = {41-49}
+}
+
+@book{Kery_2011,
+ author = {K\'{e}ry, Marc and Schaub, Michael},
+ title = {{Bayesian Population Analysis using WinBUGS: A Hierarchical Perspective}},
+ year = {2011},
+ publisher = {Academic Press}
+}
+
+@book{McCullagh_1989,
+ author = {McCullagh, P and Nelder, J. A.},
+ year = {1989},
+ title = {Generalized linear models},
+ publisher = {Chapman and Hall}
+}
+
+@article{Kery_2008,
+ author = {K\'{e}ry, M., and Schmidt, B.R},
+ year = {2008},
+ title = {Imperfect detection and its consequences for monitoring for conservation},
+ journal = {Community Ecology},
+ volume = {9},
+ pages = {207-2016}
+}
+
+@article{Royle_2007,
+ author = {Royle, J.A.,and K\'{e}ry, M.},
+ year = {2007},
+ title = {A {B}ayesian state-space formulation of dynamic occupancy models},
+ journal = {Ecology},
+ volume = {88},
+ pages = {1813-1823}
+}
+
+@article{Moilanen_2002,
+ author = {Moilanen, A.},
+ year = {2002},
+ title = {Implications of empirical data quality to metapopulation model parameter estimation and application},
+ journal = {Oikos},
+ volume = {96},
+ pages = {516-530}
+}
+
+@article{Weir_2009,
+ author = {Weir, L., I.J. Fiske, and J.A. Royle},
+ year = {2009},
+ title = {Trends in anuran occupancy from northeastern states of the {N}orth {A}merican {A}mphibian {M}onitoring {P}rogram},
+ journal = {Herpetological Conservation and Biology},
+ volume = {4},
+ pages = {389-402}
+}
+
+@book{Davison_1997,
+ author = {Davison, A.C and Hinkley, D.V.},
+ year = {1997},
+ title = {Bootstrap Methods and Their Application},
+ publisher = {Cambridge University Press}
+}
+
+@article{Hosmer_1997,
+ author = {Hosmer, D.W. and Hosmer, T. and le Cressie, S. and Lemeshow, S.},
+ year = {1997},
+ title = {A comparision of goodness-of-fit tests for the logistic regression model},
+ journal = {Statistics in Medicine},
+ volume = {16},
+ pages = {965-980}
+}
+
+@article{MacKenzie_2004,
+ author = {MacKenzie, D.I and Bailey, L.},
+ year = {2004},
+ title = {Assessing the fit of site-occupancy models},
+ journal = {Journal of Agricultural, Biological, and Environmental Statistics},
+ volume = {9},
+ pages = {300-318}
+}