aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorKen Kellner <ken@kenkellner.com>2024-01-18 08:38:27 -0500
committerKen Kellner <ken@kenkellner.com>2024-01-18 08:38:27 -0500
commit303c2913f10ac691ec6782d797aeb9b8d05b325b (patch)
treee8ccf6e95d4e6d84265507dce66aafb702280cfb
parent7454da5707aa385ca5c5e7986684b04b6550efa2 (diff)
parent8bc107f0af18f8cc0058a9c0998bf949c8568015 (diff)
Merge branch 'master' into IDS
-rw-r--r--.Rbuildignore2
-rw-r--r--.github/workflows/R-CMD-check.yaml73
-rw-r--r--.gitignore4
-rw-r--r--DESCRIPTION21
-rw-r--r--NAMESPACE12
-rw-r--r--NEWS.md31
-rw-r--r--R/RcppExports.R56
-rw-r--r--R/boot.R5
-rw-r--r--R/distsamp.R6
-rw-r--r--R/distsampOpen.R8
-rw-r--r--R/gdistsamp.R39
-rw-r--r--R/gmultmix.R25
-rw-r--r--R/goccu.R334
-rw-r--r--R/gpcount.R21
-rw-r--r--R/multinomPois.R6
-rw-r--r--R/multmixOpen.R8
-rw-r--r--R/occu.R6
-rw-r--r--R/occuCOP.R964
-rw-r--r--R/occuMS.R7
-rw-r--r--R/occuMulti.R14
-rw-r--r--R/occuPEN.R15
-rw-r--r--R/occuTTD.R6
-rw-r--r--R/pcountOpen.R5
-rw-r--r--R/posteriorSamples.R4
-rw-r--r--R/power.R8
-rw-r--r--R/predict.R9
-rw-r--r--R/ranef.R15
-rw-r--r--R/unmarkedCrossVal.R4
-rw-r--r--R/unmarkedEstimate.R2
-rw-r--r--R/unmarkedFit.R32
-rw-r--r--R/unmarkedFrame.R28
-rw-r--r--R/utils.R26
-rw-r--r--_pkgdown.yml23
-rw-r--r--inst/CITATION26
-rw-r--r--man/MesoCarnivores.Rd14
-rw-r--r--man/fitted-methods.Rd2
-rw-r--r--man/gdistsamp.Rd6
-rw-r--r--man/getP-methods.Rd15
-rw-r--r--man/gmultmix.Rd26
-rw-r--r--man/goccu.Rd105
-rw-r--r--man/gpcount.Rd11
-rw-r--r--man/nonparboot-methods.Rd1
-rw-r--r--man/occuCOP.Rd249
-rw-r--r--man/occuFP.Rd2
-rw-r--r--man/ranef-methods.Rd2
-rw-r--r--man/simulate-methods.Rd2
-rw-r--r--man/unmarked-package.Rd2
-rw-r--r--man/unmarkedFit-class.Rd3
-rw-r--r--man/unmarkedFrame-class.Rd11
-rw-r--r--man/unmarkedFrameOccuCOP.Rd105
-rw-r--r--man/unmarkedMultFrame.Rd3
-rw-r--r--src/RcppExports.cpp418
-rw-r--r--src/TMB/tmb_goccu.hpp130
-rw-r--r--src/TMB/tmb_occu.hpp5
-rw-r--r--src/TMB/unmarked_TMBExports.cpp3
-rw-r--r--src/get_lik_trans.cpp13
-rw-r--r--src/get_lik_trans.h8
-rw-r--r--src/get_mlogit.cpp20
-rw-r--r--src/get_mlogit.h8
-rw-r--r--src/nll_distsamp.cpp24
-rw-r--r--src/nll_distsamp.h10
-rw-r--r--src/nll_distsampOpen.cpp85
-rw-r--r--src/nll_distsampOpen.h19
-rw-r--r--src/nll_multinomPois.cpp38
-rw-r--r--src/nll_multinomPois.h10
-rw-r--r--src/nll_multmixOpen.cpp80
-rw-r--r--src/nll_multmixOpen.h23
-rw-r--r--src/nll_occu.cpp23
-rw-r--r--src/nll_occu.h9
-rw-r--r--src/nll_occuCOP.cpp48
-rw-r--r--src/nll_occuMS.cpp66
-rw-r--r--src/nll_occuMS.h12
-rw-r--r--src/nll_occuMulti.cpp73
-rw-r--r--src/nll_occuMulti.h11
-rw-r--r--src/nll_occuPEN.cpp24
-rw-r--r--src/nll_occuPEN.h9
-rw-r--r--src/nll_occuTTD.cpp40
-rw-r--r--src/nll_occuTTD.h13
-rw-r--r--src/nll_pcountOpen.cpp54
-rw-r--r--src/nll_pcountOpen.h10
-rw-r--r--tests/testthat/test_distsampOpen.R2
-rw-r--r--tests/testthat/test_gdistsamp.R84
-rw-r--r--tests/testthat/test_gmultmix.R40
-rw-r--r--tests/testthat/test_goccu.R141
-rw-r--r--tests/testthat/test_gpcount.R47
-rw-r--r--tests/testthat/test_occu.R41
-rw-r--r--tests/testthat/test_occuCOP.R485
-rw-r--r--tests/testthat/test_occuMS.R2
-rw-r--r--tests/testthat/test_occuMulti.R5
-rw-r--r--tests/testthat/test_parboot.R22
-rw-r--r--tests/testthat/test_predict.R10
-rw-r--r--tests/testthat/test_ranef_predict.R2
-rw-r--r--tests/testthat/test_unmarkedFrame.R15
-rw-r--r--vignettes/contributing_to_unmarked.Rmd318
-rw-r--r--vignettes/figures/COP-model.pngbin0 -> 24595 bytes
-rw-r--r--vignettes/powerAnalysis.Rmd2
-rw-r--r--vignettes/powerAnalysis.Rmd.orig2
-rw-r--r--vignettes/unmarked.bib15
98 files changed, 4151 insertions, 772 deletions
diff --git a/.Rbuildignore b/.Rbuildignore
index 70e8958..1ac8847 100644
--- a/.Rbuildignore
+++ b/.Rbuildignore
@@ -12,3 +12,5 @@ README.Rmd
^\.github$
^_pkgdown\.yml$
^vignettes/colext.Rmd.orig
+^.*\.Rproj$
+^\.Rproj\.user$
diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml
index 90f242b..38b4b13 100644
--- a/.github/workflows/R-CMD-check.yaml
+++ b/.github/workflows/R-CMD-check.yaml
@@ -1,14 +1,14 @@
-# For help debugging build failures open an issue on the RStudio community with the 'github-actions' tag.
-# https://community.rstudio.com/new-topic?category=Package%20development&tags=github-actions
+# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples
+# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help
+#
+# NOTE: This workflow is overkill for most R packages and
+# check-standard.yaml is likely a better choice.
+# usethis::use_github_action("check-standard") will install it.
on:
push:
- branches:
- - main
- - master
+ branches: [main, master]
pull_request:
- branches:
- - main
- - master
+ branches: [main, master]
name: R-CMD-check
@@ -29,57 +29,26 @@ jobs:
- {os: ubuntu-20.04, r: 'oldrel', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"}
env:
- R_REMOTES_NO_ERRORS_FROM_WARNINGS: true
- RSPM: ${{ matrix.config.rspm }}
GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
+ R_KEEP_PKG_SOURCE: yes
steps:
- - uses: actions/checkout@v2
+ - uses: actions/checkout@v3
- - uses: r-lib/actions/setup-r@v1
+ - uses: r-lib/actions/setup-pandoc@v2
+
+ - uses: r-lib/actions/setup-r@v2
with:
r-version: ${{ matrix.config.r }}
+ http-user-agent: ${{ matrix.config.http-user-agent }}
+ use-public-rspm: true
- - 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
- if: runner.os != 'Windows'
- uses: actions/cache@v2
+ - uses: r-lib/actions/setup-r-dependencies@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 system dependencies
- if: runner.os == 'Linux'
- run: |
- while read -r cmd
- do
- eval sudo $cmd
- done < <(Rscript -e 'writeLines(remotes::system_requirements("ubuntu", "20.04"))')
-
- - name: Install dependencies
- run: |
- remotes::install_deps(dependencies = TRUE)
- remotes::install_cran("rcmdcheck")
- shell: Rscript {0}
-
- - name: Check
- env:
- _R_CHECK_CRAN_INCOMING_REMOTE_: false
- run: rcmdcheck::rcmdcheck(args = c("--no-manual", "--ignore-vignettes", "--no-build-vignettes", "--as-cran"), build_args = c("--no-manual", "--no-build-vignettes"), error_on = "warning", check_dir = "check")
- shell: Rscript {0}
+ extra-packages: any::rcmdcheck
+ needs: check
+ upgrade: 'TRUE'
- - name: Upload check results
- if: failure()
- uses: actions/upload-artifact@main
+ - uses: r-lib/actions/check-r-package@v2
with:
- name: ${{ runner.os }}-r${{ matrix.config.r }}-results
- path: check
+ upload-snapshots: true
diff --git a/.gitignore b/.gitignore
index fe18f2a..eaf91ee 100644
--- a/.gitignore
+++ b/.gitignore
@@ -8,6 +8,7 @@
*.Rd~
*.R~
NAMESPACE~
+.RData
# TeX
@@ -28,3 +29,6 @@ bc
.Rhistory
symbols.rds
+# Rproj
+.Rproj.user
+*.Rproj
diff --git a/DESCRIPTION b/DESCRIPTION
index 6f50fcf..17cc15d 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,6 +1,6 @@
Package: unmarked
-Version: 1.2.5.9014
-Date: 2023-04-27
+Version: 1.4.1
+Date: 2024-01-08
Type: Package
Title: Models for Data from Unmarked Animals
Authors@R: c(
@@ -12,13 +12,14 @@ Authors@R: c(
person("Jeff", "Hostetler", role="aut"),
person("Rebecca", "Hutchinson", role="aut"),
person("Adam", "Smith", role="aut"),
+ person("Lea", "Pautrel", role="aut"),
person("Marc", "Kery", role="ctb"),
person("Mike", "Meredith", role="ctb"),
person("Auriel", "Fournier", role="ctb"),
person("Ariel", "Muldoon", role="ctb"),
person("Chris", "Baker", role="ctb")
)
-Depends: R (>= 2.12.0)
+Depends: R (>= 4.0)
Imports:
graphics,
lattice,
@@ -27,13 +28,19 @@ Imports:
Matrix,
methods,
parallel,
- pbapply,
Rcpp (>= 0.8.0),
stats,
TMB (>= 1.7.18),
utils
-Suggests: knitr, rmarkdown, pkgdown, raster, shiny, terra, 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>.
+Suggests:
+ pbapply,
+ knitr,
+ rmarkdown,
+ raster,
+ shiny,
+ testthat,
+ terra
+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. References: Kellner et al. (2023) <doi:10.1111/2041-210X.14123>, Fiske and Chandler (2011) <doi:10.18637/jss.v043.i10>.
License: GPL (>=3)
LazyLoad: yes
LazyData: yes
@@ -52,6 +59,8 @@ Collate: 'classes.R' 'unmarkedEstimate.R' 'mapInfo.R' 'unmarkedFrame.R'
'power.R'
'simulate.R'
'predict.R'
+ 'goccu.R'
+ 'occuCOP.R'
'RcppExports.R'
'zzz.R'
LinkingTo:
diff --git a/NAMESPACE b/NAMESPACE
index 149802c..c4bbc63 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -7,7 +7,7 @@ importFrom(stats, confint, fitted, coef, vcov, predict, update, profile,
pnorm, qchisq, qnorm, quantile, rbinom,
reshape, rmultinom, rnbinom, rpois, runif, sd, uniroot,
update.formula, sigma)
-importFrom(graphics, plot, hist, abline, axis, lines, points, polygon, segments)
+importFrom(graphics, plot, hist, abline, axis, lines, points, polygon, segments, title)
importFrom(utils, head, read.csv)
importFrom(grDevices, devAskNewPage, dev.interactive, palette.colors)
importFrom(MASS, mvrnorm)
@@ -17,14 +17,14 @@ importFrom(methods, is, as, new, show, slot, .hasSlot, callGeneric,
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,
occuMS, computeMPLElambda, pcount.spHDS, occuTTD, distsampOpen,
- multmixOpen, nmixTTD, gdistremoval, IDS)
+ multmixOpen, nmixTTD, gdistremoval, goccu, occuCOP, IDS)
+
export(removalPiFun, doublePiFun)
export(makeRemPiFun, makeCrPiFun, makeCrPiFunMb, makeCrPiFunMh)
@@ -51,7 +51,8 @@ exportMethods(backTransform, coef, confint, coordinates, fitted, getData,
"siteCovs<-", summary, update, vcov, yearlySiteCovs,
"yearlySiteCovs<-", "[", smoothed, projected, nonparboot, logLik,
LRT, ranef, bup, crossVal, posteriorSamples, sigma, randomTerms,
- optimizePenalty, unmarkedPowerList, plotEffectsData, plotEffects)
+ optimizePenalty, unmarkedPowerList, plotEffectsData, plotEffects,
+ getL)
S3method("print", "unmarkedPostSamples")
@@ -61,7 +62,8 @@ export(unmarkedEstimate, fitList, mapInfo, unmarkedFrame,
unmarkedFrameDS, unmarkedMultFrame, unmarkedFrameGMM,
unmarkedFramePCO, unmarkedFrameGDS, unmarkedFrameGPC, unmarkedFrameOccuMulti,
unmarkedFrameOccuMS, unmarkedFrameOccuTTD, unmarkedFrameDSO,
- unmarkedFrameMMO, unmarkedFrameGDR)
+ unmarkedFrameMMO, unmarkedFrameGDR, unmarkedFrameGOccu,
+ unmarkedFrameOccuCOP)
# Formatting
export(csvToUMF, formatLong, formatWide, formatMult, formatDistData)
diff --git a/NEWS.md b/NEWS.md
index 314f645..14b00fd 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -1,3 +1,34 @@
+# unmarked 1.4.0
+
+* Added count-data occupancy model (occuCOP)
+* Added multi-scale occupancy model (goccu)
+* Added ZIP support to gdistsamp, gmultmix, and gpcount
+* Fixed bug in TMB engine for occu that resulted in incorrect detection coefficient estimates when there were many interspersed NAs in the encounter history
+
+# unmarked 1.3.3
+
+* Increase required R version to 4.0
+
+# unmarked 1.3.2
+
+* Modernize some Cpp code to pass new LTO checks
+
+# unmarked 1.3.1
+
+* Remove log.grad function to pass CRAN checks
+
+# unmarked 1.3.0
+
+* Add support for terra package rasters
+* Add plotEffects function for plotting marginal effects
+* Better default names in fitLists
+* Optional Shiny app for power analysis
+* parboot now more robust to errors
+* Add back temporarily removed occuMulti and colext vignettes
+* Remove dependency on plyr package and move methods to imports
+* Expand powerAnalysis vignette
+* Many small bugfixes
+
# unmarked 1.2.4
* Convert vignettes to use rmarkdown
diff --git a/R/RcppExports.R b/R/RcppExports.R
index 2d11a6c..70b57ac 100644
--- a/R/RcppExports.R
+++ b/R/RcppExports.R
@@ -1,6 +1,22 @@
# Generated by using Rcpp::compileAttributes() -> do not edit by hand
# Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
+get_lik_trans <- function(I, I1) {
+ .Call(`_unmarked_get_lik_trans`, I, I1)
+}
+
+get_mlogit <- function(lp_mat, type, S, guide) {
+ .Call(`_unmarked_get_mlogit`, lp_mat, type, S, guide)
+}
+
+nll_distsamp <- function(y, lam, sig, scale, a, u, w, db, keyfun, survey) {
+ .Call(`_unmarked_nll_distsamp`, y, lam, sig, scale, a, u, w, db, keyfun, survey)
+}
+
+nll_distsampOpen <- function(y, yt, Xlam, Xgam, Xom, Xsig, Xiota, beta, bi, Xlam_offset, Xgam_offset, Xom_offset, Xsig_offset, Xiota_offset, ytna, lk, mixture, first, last, first1, M, T, delta, dynamics, survey, fix, go_dims, immigration, I, I1, Ib, Ip, a, u, w, db, keyfun, lfac_k, kmyt, lfac_kmyt, fin, A) {
+ .Call(`_unmarked_nll_distsampOpen`, y, yt, Xlam, Xgam, Xom, Xsig, Xiota, beta, bi, Xlam_offset, Xgam_offset, Xom_offset, Xsig_offset, Xiota_offset, ytna, lk, mixture, first, last, first1, M, T, delta, dynamics, survey, fix, go_dims, immigration, I, I1, Ib, Ip, a, u, w, db, keyfun, lfac_k, kmyt, lfac_kmyt, fin, A)
+}
+
nll_gdistremoval <- function(beta, n_param, yDistance, yRemoval, ysum, mixture, keyfun, Xlam, A, Xphi, Xrem, Xdist, db, a, u, w, pl, K, Kmin, threads) {
.Call(`_unmarked_nll_gdistremoval`, beta, n_param, yDistance, yRemoval, ysum, mixture, keyfun, Xlam, A, Xphi, Xrem, Xdist, db, a, u, w, pl, K, Kmin, threads)
}
@@ -17,15 +33,55 @@ nll_gpcount <- function(ym, Xlam, Xphi, Xp, beta_lam, beta_phi, beta_p, log_alph
.Call(`_unmarked_nll_gpcount`, ym, Xlam, Xphi, Xp, beta_lam, beta_phi, beta_p, log_alpha, Xlam_offset, Xphi_offset, Xp_offset, M, mixture, T, threads)
}
+nll_multinomPois <- function(beta, pi_fun, Xlam, Xlam_offset, Xdet, Xdet_offset, y, navec, nP, nAP) {
+ .Call(`_unmarked_nll_multinomPois`, beta, pi_fun, Xlam, Xlam_offset, Xdet, Xdet_offset, y, navec, nP, nAP)
+}
+
+nll_multmixOpen <- function(y, yt, Xlam, Xgam, Xom, Xp, Xiota, beta, bi, Xlam_offset, Xgam_offset, Xom_offset, Xp_offset, Xiota_offset, ytna, yna, lk, mixture, first, last, first1, M, T, J, R, delta, dynamics, fix, go_dims, immigration, I, I1, Ib, Ip, pi_fun, lfac_k, kmyt, lfac_kmyt, fin) {
+ .Call(`_unmarked_nll_multmixOpen`, y, yt, Xlam, Xgam, Xom, Xp, Xiota, beta, bi, Xlam_offset, Xgam_offset, Xom_offset, Xp_offset, Xiota_offset, ytna, yna, lk, mixture, first, last, first1, M, T, J, R, delta, dynamics, fix, go_dims, immigration, I, I1, Ib, Ip, pi_fun, lfac_k, kmyt, lfac_kmyt, fin)
+}
+
nll_nmixTTD <- function(beta, y, delta, W, V, pinds, mixture, tdist, N, J, K, naflag, threads) {
.Call(`_unmarked_nll_nmixTTD`, beta, y, delta, W, V, pinds, mixture, tdist, N, J, K, naflag, threads)
}
+nll_occu <- function(y, X, V, beta_psi, beta_p, nd, knownOcc, navec, X_offset, V_offset, link_psi) {
+ .Call(`_unmarked_nll_occu`, y, X, V, beta_psi, beta_p, nd, knownOcc, navec, X_offset, V_offset, link_psi)
+}
+
+nll_occuCOP <- function(y, L, Xpsi, Xlambda, beta_psi, beta_lambda, removed) {
+ .Call(`_unmarked_nll_occuCOP`, y, L, Xpsi, Xlambda, beta_psi, beta_lambda, removed)
+}
+
+nll_occuMS <- function(beta, y, dm_state, dm_phi, dm_det, sind, pind, dind, prm, S, T, J, N, naflag, guide) {
+ .Call(`_unmarked_nll_occuMS`, beta, y, dm_state, dm_phi, dm_det, sind, pind, dind, prm, S, T, J, N, naflag, guide)
+}
+
+nll_occuMulti_loglik <- function(fStart, fStop, dmF, dmOcc, beta, dmDet, dStart, dStop, y, yStart, yStop, Iy0, z, fixed0) {
+ .Call(`_unmarked_nll_occuMulti_loglik`, fStart, fStop, dmF, dmOcc, beta, dmDet, dStart, dStop, y, yStart, yStop, Iy0, z, fixed0)
+}
+
+nll_occuMulti <- function(fStart, fStop, dmF, dmOcc, beta, dmDet, dStart, dStop, y, yStart, yStop, Iy0, z, fixed0, penalty) {
+ .Call(`_unmarked_nll_occuMulti`, fStart, fStop, dmF, dmOcc, beta, dmDet, dStart, dStop, y, yStart, yStop, Iy0, z, fixed0, penalty)
+}
+
+nll_occuPEN <- function(y, X, V, beta_psi, beta_p, nd, knownOcc, navec, X_offset, V_offset, penalty) {
+ .Call(`_unmarked_nll_occuPEN`, y, X, V, beta_psi, beta_p, nd, knownOcc, navec, X_offset, V_offset, penalty)
+}
+
nll_occuRN <- function(beta, n_param, y, X, V, X_offset, V_offset, K, Kmin, threads) {
.Call(`_unmarked_nll_occuRN`, beta, n_param, y, X, V, X_offset, V_offset, K, Kmin, threads)
}
+nll_occuTTD <- function(beta, y, delta, W, V, Xgam, Xeps, pind, dind, cind, eind, lpsi, tdist, N, T, J, naflag) {
+ .Call(`_unmarked_nll_occuTTD`, beta, y, delta, W, V, Xgam, Xeps, pind, dind, cind, eind, lpsi, tdist, N, T, J, naflag)
+}
+
nll_pcount <- function(beta, n_param, y, X, V, X_offset, V_offset, K, Kmin, mixture, threads) {
.Call(`_unmarked_nll_pcount`, beta, n_param, y, X, V, X_offset, V_offset, K, Kmin, mixture, threads)
}
+nll_pcountOpen <- function(ym, Xlam, Xgam, Xom, Xp, Xiota, beta_lam, beta_gam, beta_om, beta_p, beta_iota, log_alpha, Xlam_offset, Xgam_offset, Xom_offset, Xp_offset, Xiota_offset, ytna, ynam, lk, mixture, first, last, M, J, T, delta, dynamics, fix, go_dims, immigration, I, I1, Ib, Ip) {
+ .Call(`_unmarked_nll_pcountOpen`, ym, Xlam, Xgam, Xom, Xp, Xiota, beta_lam, beta_gam, beta_om, beta_p, beta_iota, log_alpha, Xlam_offset, Xgam_offset, Xom_offset, Xp_offset, Xiota_offset, ytna, ynam, lk, mixture, first, last, M, J, T, delta, dynamics, fix, go_dims, immigration, I, I1, Ib, Ip)
+}
+
diff --git a/R/boot.R b/R/boot.R
index 2f8cffc..3da4fd0 100644
--- a/R/boot.R
+++ b/R/boot.R
@@ -69,7 +69,7 @@ setMethod("parboot", "unmarkedFit", function(object, statistic=SSE, nsim=10,
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)
+ fit <- update(object, data = simdata, starts = starts, se = FALSE)
statistic(fit, ...)
}, error=function(e){
t0[] <- NA
@@ -77,7 +77,8 @@ setMethod("parboot", "unmarkedFit", function(object, statistic=SSE, nsim=10,
})
}
- t.star <- t(pbapply::pbsapply(simList, run_sim, object=object,
+ # Uses pbapply if available, or parSapply if not (see utils.R)
+ t.star <- t(sapply2(simList, run_sim, object=object,
statistic=statistic, starts=starts, t0=t0,
cl=cl, ...))
if(length(t0) == 1) t.star <- matrix(t.star, ncol=1)
diff --git a/R/distsamp.R b/R/distsamp.R
index 5aa01cc..a6f29c0 100644
--- a/R/distsamp.R
+++ b/R/distsamp.R
@@ -220,11 +220,11 @@ distsamp <- function(formula, data,
if(identical(output, "density"))
lambda <- lambda * A
sigma <- drop(exp(V %*% beta.sig + V.offset))
- .Call("nll_distsamp",
+ nll_distsamp(
y, lambda, sigma, scale,
a, u, w, db,
- keyfun, survey, rel.tol,
- PACKAGE="unmarked")
+ keyfun, survey
+ )
}
}
diff --git a/R/distsampOpen.R b/R/distsampOpen.R
index 0f9f743..92588a4 100644
--- a/R/distsampOpen.R
+++ b/R/distsampOpen.R
@@ -212,7 +212,7 @@ distsampOpen <- function(lambdaformula, gammaformula, omegaformula, pformula,
#finding all unique likelihood transitions
I <- cbind(rep(k, times=lk), rep(k, each=lk))
I1 <- I[I[,1] <= I[,2],]
- lik_trans <- .Call("get_lik_trans", I, I1, PACKAGE="unmarked")
+ lik_trans <- get_lik_trans(I, I1)
beta_ind <- matrix(NA, 7, 2)
beta_ind[1,] <- c(1, nAP) #Abundance
@@ -229,7 +229,7 @@ distsampOpen <- function(lambdaformula, gammaformula, omegaformula, pformula,
yperm <- aperm(y, c(1,3,2))
nll <- function(parms) {
- .Call("nll_distsampOpen",
+ nll_distsampOpen(
yperm, yt,
Xlam, Xgam, Xom, Xsig, Xiota,
parms, beta_ind - 1,
@@ -239,8 +239,8 @@ distsampOpen <- function(lambdaformula, gammaformula, omegaformula, pformula,
delta, dynamics, survey, fix, go.dims, immigration,
I, I1, lik_trans$Ib, lik_trans$Ip,
a, u, w, db,
- keyfun, lfac.k, kmyt, lfac.kmyt, fin, A,
- PACKAGE = "unmarked")
+ keyfun, lfac.k, kmyt, lfac.kmyt, fin, A
+ )
}
if(missing(starts)){
diff --git a/R/gdistsamp.R b/R/gdistsamp.R
index b728d01..c43076a 100644
--- a/R/gdistsamp.R
+++ b/R/gdistsamp.R
@@ -2,7 +2,7 @@
gdistsamp <- function(lambdaformula, phiformula, pformula, data,
keyfun=c("halfnorm", "exp", "hazard", "uniform"),
output=c("abund", "density"), unitsOut=c("ha", "kmsq"),
- mixture=c('P', 'NB'), K, starts, method = "BFGS", se = TRUE, engine=c("C","R"),
+ mixture=c("P", "NB", 'ZIP'), K, starts, method = "BFGS", se = TRUE, engine=c("C","R"),
rel.tol=1e-4, threads=1, ...)
{
if(!is(data, "unmarkedFrameGDS"))
@@ -111,11 +111,13 @@ else {
if(identical(mixture, "NB")) {
nOP <- 1
nbPar <- "alpha"
- }
-else {
+} else if(identical(mixture, "ZIP")) {
+ nOP <- 1
+ nbPar <- "psi"
+} else {
nOP <- 0
nbPar <- character(0)
- }
+}
nLP <- ncol(Xlam)
nP <- nLP + nPP + nDP + nSP + nOP
@@ -163,8 +165,9 @@ halfnorm = {
switch(mixture,
P = f <- sapply(k, function(x) dpois(x, lambda)),
- NB = f <- sapply(k, function(x) dnbinom(x, mu=lambda,
- size=exp(pars[nP]))))
+ NB = f <- sapply(k, function(x) dnbinom(x, mu=lambda, size=exp(pars[nP]))),
+ ZIP = f <- sapply(k, function(x) dzip(rep(x, length(lambda)), lambda=lambda, psi=plogis(pars[nP])))
+ )
for(i in 1:M) {
mn <- matrix(0, lk, T)
for(t in 1:T) {
@@ -231,8 +234,9 @@ exp = {
switch(mixture,
P = f <- sapply(k, function(x) dpois(x, lambda)),
- NB = f <- sapply(k, function(x) dnbinom(x, mu=lambda,
- size=exp(pars[nP]))))
+ NB = f <- sapply(k, function(x) dnbinom(x, mu=lambda, size=exp(pars[nP]))),
+ ZIP = f <- sapply(k, function(x) dzip(rep(x, length(lambda)), lambda=lambda, psi=plogis(pars[nP])))
+ )
for(i in 1:M) {
mn <- matrix(0, lk, T)
for(t in 1:T) {
@@ -301,8 +305,9 @@ hazard = {
switch(mixture,
P = f <- sapply(k, function(x) dpois(x, lambda)),
- NB = f <- sapply(k, function(x) dnbinom(x, mu=lambda,
- size=exp(pars[nP]))))
+ NB = f <- sapply(k, function(x) dnbinom(x, mu=lambda, size=exp(pars[nP]))),
+ ZIP = f <- sapply(k, function(x) dzip(rep(x, length(lambda)), lambda=lambda, psi=plogis(pars[nP])))
+ )
for(i in 1:M) {
mn <- matrix(0, lk, T)
for(t in 1:T) {
@@ -364,8 +369,9 @@ uniform = {
p <- 1
switch(mixture,
P = f <- sapply(k, function(x) dpois(x, lambda)),
- NB = f <- sapply(k, function(x) dnbinom(x, mu=lambda,
- size=exp(pars[nP]))))
+ NB = f <- sapply(k, function(x) dnbinom(x, mu=lambda, size=exp(pars[nP]))),
+ ZIP = f <- sapply(k, function(x) dzip(rep(x, length(lambda)), lambda=lambda, psi=plogis(pars[nP])))
+ )
for(i in 1:M) {
mn <- matrix(0, lk, T)
for(t in 1:T) {
@@ -398,7 +404,7 @@ if(engine =="C"){
if(output!='density'){
A <- rep(1, M)
}
- mixture_code <- switch(mixture, P={1}, NB={2})
+ mixture_code <- switch(mixture, P={1}, NB={2}, ZIP={3})
n_param <- c(nLP, nPP, nDP, nSP, nOP)
Kmin <- apply(yt, 1, max, na.rm=TRUE)
@@ -453,6 +459,13 @@ if(identical(mixture, "NB"))
covMat = as.matrix(covMat[nP, nP]), invlink = "exp",
invlinkGrad = "exp")
+if(identical(mixture,"ZIP")) {
+ estimateList@estimates$psi <- unmarkedEstimate(name="Zero-inflation",
+ short.name = "psi", estimates = ests[nP],
+ covMat=as.matrix(covMat[nP, nP]), invlink = "logistic",
+ invlinkGrad = "logistic.grad")
+}
+
umfit <- new("unmarkedFitGDS", fitType = "gdistsamp",
call = match.call(), formula = form, formlist = formlist,
data = data, estimates = estimateList, sitesRemoved = D$removed.sites,
diff --git a/R/gmultmix.R b/R/gmultmix.R
index 6dabe9b..a6da9d5 100644
--- a/R/gmultmix.R
+++ b/R/gmultmix.R
@@ -1,7 +1,7 @@
# data will need to be an unmarkedMultFrame
gmultmix <- function(lambdaformula, phiformula, pformula, data,
- mixture=c('P', 'NB'), K, starts, method = "BFGS", se = TRUE,
+ mixture=c("P", "NB", "ZIP"), K, starts, method = "BFGS", se = TRUE,
engine=c("C","R"), threads=1, ...)
{
if(!is(data, "unmarkedFrameGMM"))
@@ -59,7 +59,7 @@ if(T==1) {
phiPars <- colnames(Xphi)
}
nDP <- ncol(Xdet)
-nP <- nLP + nPP + nDP + (mixture=='NB')
+nP <- nLP + nPP + nDP + (mixture%in%c('NB','ZIP'))
if(!missing(starts) && length(starts) != nP)
stop(paste("The number of starting values should be", nP))
@@ -102,9 +102,10 @@ nll_R <- function(pars) {
cp[,,R+1] <- 1 - apply(cp[,,1:R,drop=FALSE], 1:2, sum, na.rm=TRUE)
switch(mixture,
- P = f <- sapply(k, function(x) dpois(x, lambda)),
- NB = f <- sapply(k, function(x) dnbinom(x, mu=lambda,
- size=exp(pars[nP]))))
+ P = f <- sapply(k, function(x) dpois(x, lambda)),
+ NB = f <- sapply(k, function(x) dnbinom(x, mu=lambda, size=exp(pars[nP]))),
+ ZIP = f <- sapply(k, function(x) dzip(rep(x, length(lambda)), lambda=lambda, psi=plogis(pars[nP])))
+ )
g <- matrix(as.numeric(NA), M, lk)
for(i in 1:M) {
A <- matrix(0, lk, T)
@@ -134,8 +135,8 @@ if(engine=="R"){
kmytC <- kmyt
kmytC[which(is.na(kmyt))] <- 0
- mixture_code <- switch(mixture, P={1}, NB={2})
- n_param <- c(nLP, nPP, nDP, mixture=="NB")
+ mixture_code <- switch(mixture, P={1}, NB={2}, ZIP={3})
+ n_param <- c(nLP, nPP, nDP, mixture%in%c("NB","ZIP"))
Kmin <- apply(yt, 1, max, na.rm=TRUE)
nll <- function(params) {
@@ -157,8 +158,7 @@ covMat <- invertHessian(fm, nP, se)
ests <- fm$par
fmAIC <- 2 * fm$value + 2 * nP
-if(identical(mixture,"NB")) nbParm <- "alpha"
- else nbParm <- character(0)
+nbParm <- switch(mixture, P={character(0)}, NB={"alpha"}, ZIP={"psi"})
names(ests) <- c(lamPars, phiPars, detPars, nbParm)
@@ -192,6 +192,13 @@ if(identical(mixture,"NB"))
covMat = as.matrix(covMat[nP, nP]), invlink = "exp",
invlinkGrad = "exp")
+if(identical(mixture,"ZIP")) {
+ estimateList@estimates$psi <- unmarkedEstimate(name="Zero-inflation",
+ short.name = "psi", estimates = ests[nP],
+ covMat=as.matrix(covMat[nP, nP]), invlink = "logistic",
+ invlinkGrad = "logistic.grad")
+}
+
umfit <- new("unmarkedFitGMM", fitType = "gmn",
call = match.call(), formula = form, formlist = formlist,
data = data, estimates = estimateList, sitesRemoved = D$removed.sites,
diff --git a/R/goccu.R b/R/goccu.R
new file mode 100644
index 0000000..487fb49
--- /dev/null
+++ b/R/goccu.R
@@ -0,0 +1,334 @@
+setClass("unmarkedFitGOccu",
+ representation(
+ formlist = "list"),
+ contains = "unmarkedFit")
+
+setClass("unmarkedFrameGOccu", contains = "unmarkedFrameG3")
+
+setMethod("getDesign", "unmarkedFrameGOccu",
+ function(umf, formula, na.rm=TRUE){
+ out <- methods::callNextMethod(umf, formula=formula, na.rm=na.rm)
+ names(out)[2] <- "Xpsi"
+ names(out)[5] <- "Xpsi.offset"
+ out
+})
+
+unmarkedFrameGOccu <- function(y, siteCovs=NULL, obsCovs=NULL, numPrimary,
+ yearlySiteCovs=NULL) {
+ y[y > 1] <- 1
+ if(numPrimary < 2) stop("numPrimary < 2, use occu instead")
+ umf <- unmarkedFrameGPC(y, siteCovs=siteCovs, obsCovs=obsCovs,
+ numPrimary=numPrimary, yearlySiteCovs=yearlySiteCovs)
+ class(umf) <- "unmarkedFrameGOccu"
+ umf
+}
+
+goccu <- function(psiformula, phiformula, pformula, data,
+ linkPsi = c("logit", "cloglog"), starts, method = "BFGS",
+ se = TRUE, ...){
+
+ linkPsi <- match.arg(linkPsi, c("logit","cloglog"))
+ psiLinkFunc <- ifelse(linkPsi=="cloglog", cloglog, plogis)
+ psiInvLink <- ifelse(linkPsi=="cloglog", "cloglog", "logistic")
+ psiLinkGrad <- ifelse(linkPsi=="cloglog", "cloglog.grad", "logistic.grad")
+
+ # Pass phiformula as gamma/eps formula so it will be applied to
+ # yearlySiteCovs in getDesign
+ formlist <- list(psiformula=psiformula, phi=phiformula,
+ pformula=pformula)
+
+ formula <- as.formula(paste(unlist(formlist), collapse=" "))
+
+ data@y[data@y > 1] <- 1
+
+ class(data) <- "unmarkedFrameGOccu"
+
+ # handle offsets
+
+ gd <- getDesign(data, formula = formula)
+
+ y <- gd$y
+ Xpsi <- gd$Xpsi
+ Xphi <- gd$Xphi
+ Xp <- gd$Xdet
+
+ M <- nrow(y)
+ T <- data@numPrimary
+ J <- ncol(y) / T
+
+ # Identify entirely missing primary periods at each site
+ y_array <- array(t(y), c(J, T, M))
+ missing_session <- t(apply(y_array, c(2,3),
+ function(x) as.numeric(all(is.na(x)))))
+
+ # Create possible states in each T
+ alpha_potential <- as.matrix(expand.grid(rep(list(c(0, 1)), T)))
+ n_possible <- nrow(alpha_potential)
+
+ # Known present at each site
+ known_present <- rep(0, M)
+ # Known available at each site and T
+ known_available <- matrix(0, nrow=M, ncol=T)
+
+ for (i in 1:M){
+ for (t in 1:T){
+ for (j in 1:J){
+ if(is.na(y_array[j,t,i])) next
+ if(y_array[j, t, i] == 1){
+ known_present[i] <- 1
+ known_available[i,t] <- 1
+ }
+ }
+ }
+ }
+
+ # Bundle data for TMB
+ dataList <- list(y=y, T=T, link=ifelse(linkPsi=='cloglog', 1, 0),
+ Xpsi=Xpsi, Xphi=Xphi, Xp=Xp,
+ n_possible=n_possible,
+ alpha_potential=alpha_potential,
+ known_present=known_present, known_available=known_available,
+ missing_session=missing_session)
+
+ # Provide dimensions and starting values for parameters
+ # This part should change to be more like occu() if we add random effects
+ psi_ind <- 1:ncol(Xpsi)
+ phi_ind <- 1:ncol(Xphi) + max(psi_ind)
+ p_ind <- 1:ncol(Xp) + max(phi_ind)
+ nP <- max(p_ind)
+ params <- list(beta_psi = rep(0, length(psi_ind)),
+ beta_phi = rep(0, length(phi_ind)),
+ beta_p = rep(0, length(p_ind)))
+
+ # Create TMB object
+ tmb_mod <- TMB::MakeADFun(data = c(model = "tmb_goccu", dataList),
+ parameters = params,
+ DLL = "unmarked_TMBExports", silent = TRUE)
+
+ # Optimize TMB object, print and save results
+ if(missing(starts) || is.null(starts)) starts <- tmb_mod$par
+ opt <- optim(starts, fn = tmb_mod$fn, gr = tmb_mod$gr, method = method,
+ hessian = se, ...)
+
+ covMat <- invertHessian(opt, nP, se)
+ ests <- opt$par
+ names(ests) <- c(colnames(Xpsi), colnames(Xphi), colnames(Xp))
+ fmAIC <- 2 * opt$value + 2 * nP
+
+
+ psi_est <- unmarkedEstimate(name = "Occupancy", short.name = "psi",
+ estimates = ests[psi_ind],
+ covMat = covMat[psi_ind, psi_ind, drop=FALSE],
+ fixed = 1:ncol(Xpsi),
+ invlink = psiInvLink,
+ invlinkGrad = psiLinkGrad,
+ randomVarInfo=list()
+ )
+
+ phi_est <- unmarkedEstimate(name = "Availability", short.name = "phi",
+ estimates = ests[phi_ind],
+ covMat = covMat[phi_ind, phi_ind, drop=FALSE],
+ fixed = 1:ncol(Xphi),
+ invlink = "logistic",
+ invlinkGrad = "logistic.grad",
+ randomVarInfo=list()
+ )
+
+ p_est <- unmarkedEstimate(name = "Detection", short.name = "p",
+ estimates = ests[p_ind],
+ covMat = covMat[p_ind, p_ind, drop=FALSE],
+ fixed = 1:ncol(Xp),
+ invlink = "logistic",
+ invlinkGrad = "logistic.grad",
+ randomVarInfo=list()
+ )
+
+ estimate_list <- unmarkedEstimateList(list(psi=psi_est, phi=phi_est,
+ det=p_est))
+
+ # Create unmarkedFit object--------------------------------------------------
+ umfit <- new("unmarkedFitGOccu", fitType = "goccu", call = match.call(),
+ formula = formula, formlist=formlist, data = data,
+ sitesRemoved = gd$removed.sites,
+ estimates = estimate_list, AIC = fmAIC, opt = opt,
+ negLogLike = opt$value,
+ nllFun = tmb_mod$fn, TMB=tmb_mod)
+
+ return(umfit)
+
+}
+
+# Methods
+
+setMethod("predict_inputs_from_umf", "unmarkedFitGOccu",
+ function(object, type, newdata, na.rm, re.form=NA){
+ designMats <- getDesign(newdata, object@formula, na.rm=na.rm)
+ X_idx <- switch(type, psi="Xpsi", phi="Xphi", det="Xdet")
+ off_idx <- paste0(X_idx, ".offset")
+ list(X=designMats[[X_idx]], offset=NULL)
+})
+
+setMethod("get_formula", "unmarkedFitGOccu", function(object, type, ...){
+ fl <- object@formlist
+ switch(type, psi=fl$psiformula, phi=fl$phiformula, det=fl$pformula)
+})
+
+setMethod("get_orig_data", "unmarkedFitGOccu", function(object, type, ...){
+ clean_covs <- clean_up_covs(object@data, drop_final=FALSE)
+ datatype <- switch(type, psi='site_covs', phi='yearly_site_covs',
+ det='obs_covs')
+ clean_covs[[datatype]]
+})
+
+setMethod("getP", "unmarkedFitGOccu",
+ function(object, na.rm=FALSE){
+ gd <- getDesign(object@data, object@formula, na.rm=na.rm)
+ p <- drop(plogis(gd$Xdet %*% coef(object, "det")))
+ M <- numSites(object@data)
+ p <- matrix(p, nrow=M, ncol=obsNum(object@data),
+ byrow=TRUE)
+ p
+})
+
+setMethod("fitted", "unmarkedFitGOccu",
+ function(object, na.rm= FALSE){
+
+ M <- numSites(object@data)
+ JT <- obsNum(object@data)
+ gd <- getDesign(object@data, object@formula, na.rm=na.rm)
+
+ psi <- drop(plogis(gd$Xpsi %*% coef(object, "psi")))
+ psi <- matrix(psi, nrow=M, ncol=JT)
+
+ phi <- drop(plogis(gd$Xphi %*% coef(object, "phi")))
+ phi <- rep(phi, each = JT / object@data@numPrimary)
+ phi <- matrix(phi, nrow=M, ncol=JT, byrow=TRUE)
+
+ p <- getP(object)
+
+ psi * phi * p
+})
+
+
+# based on ranef for GPC
+setMethod("ranef", "unmarkedFitGOccu", function(object, ...){
+
+ M <- numSites(object@data)
+ JT <- obsNum(object@data)
+ T <- object@data@numPrimary
+ J <- JT / T
+
+ gd <- getDesign(object@data, object@formula, na.rm=FALSE)
+ y_array <- array(t(gd$y), c(J, T, M))
+
+ psi <- drop(plogis(gd$Xpsi %*% coef(object, "psi")))
+ phi <- drop(plogis(gd$Xphi %*% coef(object, "phi")))
+ phi <- matrix(phi, nrow=M, ncol=T, byrow=TRUE)
+ p <- getP(object)
+ p_array <- array(t(p), c(J, T, M))
+
+ Z <- ZZ <- 0:1
+ post <- array(0, c(M, 2, 1))
+ colnames(post) <- Z
+
+ for(i in 1:M) {
+ f <- dbinom(Z, 1, psi[i])
+
+ ghi <- rep(0, 2)
+
+ for(t in 1:T) {
+ gh <- matrix(-Inf, 2, 2)
+ for(z in Z) {
+ if(z < max(y_array[,,i], na.rm=TRUE)){
+ gh[,z+1] <- -Inf
+ next
+ }
+ if(is.na(phi[i,t])) {
+ g <- rep(0, 2)
+ g[ZZ>z] <- -Inf
+ } else{
+ g <- dbinom(ZZ, z, phi[i,t], log=TRUE)
+ }
+ h <- rep(0, 2)
+ for(j in 1:J) {
+ if(is.na(y_array[j,t,i]) | is.na(p_array[j,t,i])) next
+ h <- h + dbinom(y_array[j,t,i], ZZ, p_array[j,t,i], log=TRUE)
+ }
+ gh[,z+1] <- g + h
+ }
+ ghi <- ghi + log(colSums(exp(gh)))
+ }
+ fgh <- exp(f + ghi)
+ prM <- fgh/sum(fgh)
+ post[i,,1] <- prM
+ }
+
+ new("unmarkedRanef", post=post)
+})
+
+
+setMethod("simulate", "unmarkedFitGOccu",
+ function(object, nsim = 1, seed = NULL, na.rm = FALSE){
+
+ gd <- getDesign(object@data, object@formula, na.rm=FALSE)
+ M <- nrow(gd$y)
+ T <- object@data@numPrimary
+ JT <- ncol(gd$y)
+ J <- JT / T
+ y_array <- array(t(gd$y), c(J, T, M))
+
+ psi <- drop(plogis(gd$Xpsi %*% coef(object, "psi")))
+ phi <- drop(plogis(gd$Xphi %*% coef(object, "phi")))
+ phi <- matrix(phi, nrow=M, ncol=T, byrow=TRUE)
+ p <- getP(object)
+
+ sim_list <- list()
+
+ for (i in 1:nsim){
+ z <- suppressWarnings(rbinom(M, 1, psi))
+ z <- matrix(z, nrow=M, ncol=T)
+
+ zz <- suppressWarnings(rbinom(M*T, 1, phi*z))
+ zz <- matrix(zz, M, T)
+
+ colrep <- rep(1:T, each=J)
+ zz <- zz[,colrep]
+
+ y <- suppressWarnings(rbinom(M*T*J, 1, zz*p))
+ y <- matrix(y, M, JT)
+ if(na.rm) y[which(is.na(gd$y))] <- NA
+ sim_list[[i]] <- y
+ }
+
+ return(sim_list)
+})
+
+
+setMethod("update", "unmarkedFitGOccu",
+ function(object, psiformula, phiformula, pformula, ...,
+ evaluate = TRUE)
+{
+ call <- object@call
+ if (is.null(call))
+ stop("need an object with call slot")
+ formlist <- object@formlist
+ if (!missing(psiformula))
+ call$psiformula <- update.formula(formlist$psiformula, psiformula)
+ if (!missing(phiformula))
+ call$phiformula <- update.formula(formlist$phiformula, phiformula)
+ if (!missing(pformula))
+ call$pformula <- update.formula(formlist$pformula, pformula)
+ extras <- match.call(call=sys.call(-1),
+ expand.dots = FALSE)$...
+ if(length(extras) > 0) {
+ existing <- !is.na(match(names(extras), names(call)))
+ for (a in names(extras)[existing]) call[[a]] <- extras[[a]]
+ if (any(!existing)) {
+ call <- c(as.list(call), extras[!existing])
+ call <- as.call(call)
+ }
+ }
+ if (evaluate)
+ eval(call, parent.frame(2))
+ else call
+})
diff --git a/R/gpcount.R b/R/gpcount.R
index 2b7afd6..af4dade 100644
--- a/R/gpcount.R
+++ b/R/gpcount.R
@@ -1,15 +1,13 @@
# data will need to be an unmarkedMultFrame
gpcount <- function(lambdaformula, phiformula, pformula, data,
- mixture=c('P', 'NB'), K, starts, method = "BFGS", se = TRUE,
+ mixture=c('P', 'NB', 'ZIP'), K, starts, method = "BFGS", se = TRUE,
engine=c('C', 'R'), threads=1, ...)
{
if(!is(data, "unmarkedFrameGPC"))
stop("Data is not of class unmarkedFrameGPC.")
mixture <- match.arg(mixture)
engine <- match.arg(engine)
-if(identical(mixture, "ZIP") & identical(engine, "R"))
- stop("ZIP mixture not available when 'engine=R'")
formlist <- list(lambdaformula = lambdaformula, phiformula = phiformula,
pformula = pformula)
@@ -49,7 +47,7 @@ nLP <- ncol(Xlam)
nPP <- ncol(Xphi)
phiPars <- colnames(Xphi)
nDP <- ncol(Xdet)
-nP <- nLP + nPP + nDP + (mixture=='NB')
+nP <- nLP + nPP + nDP + (mixture%in%c('NB','ZIP'))
if(!missing(starts) && length(starts) != nP)
stop("There should be", nP, "starting values, not", length(starts))
@@ -66,8 +64,9 @@ nll <- function(pars) {
for(i in 1:I) {
f <- switch(mixture,
P = dpois(M, lam[i], log=TRUE),
- NB = dnbinom(M, mu=lam[i], size=exp(pars[nP]), log=TRUE))
-# ZIP = dzip())
+ NB = dnbinom(M, mu=lam[i], size=exp(pars[nP]), log=TRUE),
+ ZIP = log(dzip(M, lambda=lam[i], psi=plogis(pars[nP])))
+ )
ghi <- rep(0, lM)
for(t in 1:T) {
gh <- matrix(-Inf, lM, lM)
@@ -118,8 +117,7 @@ covMat <- invertHessian(fm, nP, se)
ests <- fm$par
fmAIC <- 2 * fm$value + 2 * nP
-if(identical(mixture,"NB")) nbParm <- "alpha"
- else nbParm <- character(0)
+nbParm <- switch(mixture, P={character(0)}, NB={"alpha"}, ZIP={"psi"})
names(ests) <- c(lamPars, phiPars, detPars, nbParm)
@@ -150,6 +148,13 @@ if(identical(mixture,"NB"))
covMat = as.matrix(covMat[nP, nP]), invlink = "exp",
invlinkGrad = "exp")
+if(identical(mixture,"ZIP")) {
+ estimateList@estimates$psi <- unmarkedEstimate(name="Zero-inflation",
+ short.name = "psi", estimates = ests[nP],
+ covMat=as.matrix(covMat[nP, nP]), invlink = "logistic",
+ invlinkGrad = "logistic.grad")
+}
+
umfit <- new("unmarkedFitGPC", fitType = "gpcount",
call = match.call(), formula = form, formlist = formlist,
data = data, estimates = estimateList, sitesRemoved = D$removed.sites,
diff --git a/R/multinomPois.R b/R/multinomPois.R
index 924e77b..076410f 100644
--- a/R/multinomPois.R
+++ b/R/multinomPois.R
@@ -46,11 +46,11 @@ multinomPois <- function(formula, data, starts, method = "BFGS",
}
nll_C <- function(params) {
- .Call("nll_multinomPois",
+ nll_multinomPois(
params,piFun,
X, X.offset, V, V.offset,
- yC, navecC, nP,nAP,
- PACKAGE = "unmarked")
+ yC, navecC, nP,nAP
+ )
}
if(engine=="R"){
diff --git a/R/multmixOpen.R b/R/multmixOpen.R
index 725c9fc..3d8eede 100644
--- a/R/multmixOpen.R
+++ b/R/multmixOpen.R
@@ -153,7 +153,7 @@ multmixOpen <- function(lambdaformula, gammaformula, omegaformula, pformula,
#finding all unique likelihood transitions
I <- cbind(rep(k, times=lk), rep(k, each=lk))
I1 <- I[I[,1] <= I[,2],]
- lik_trans <- .Call("get_lik_trans", I, I1, PACKAGE="unmarked")
+ lik_trans <- get_lik_trans(I, I1)
beta_ind <- matrix(NA, 6, 2)
beta_ind[1,] <- c(1, nAP) #Abundance
@@ -171,7 +171,7 @@ multmixOpen <- function(lambdaformula, gammaformula, omegaformula, pformula,
yperm <- aperm(yperm, c(3,2,1)) # fix asan problem
nll <- function(parms) {
- .Call("nll_multmixOpen",
+ nll_multmixOpen(
yperm, yt,
D$Xlam, D$Xgam, D$Xom, D$Xp, D$Xiota,
parms, beta_ind - 1,
@@ -180,8 +180,8 @@ multmixOpen <- function(lambdaformula, gammaformula, omegaformula, pformula,
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,
- PACKAGE = "unmarked")
+ piFun, lfac.k, kmyt, lfac.kmyt, fin
+ )
}
if(missing(starts)){
diff --git a/R/occu.R b/R/occu.R
index 0379ca8..3402f5f 100644
--- a/R/occu.R
+++ b/R/occu.R
@@ -52,10 +52,10 @@ occu <- function(formula, data, knownOcc = numeric(0),
nll <- function(params) {
beta.psi <- params[1:nOP]
beta.p <- params[(nOP+1):nP]
- .Call("nll_occu",
+ nll_occu(
yvec, X, V, beta.psi, beta.p, nd, knownOccLog, navec,
- X.offset, V.offset, linkPsi,
- PACKAGE = "unmarked")
+ X.offset, V.offset, linkPsi
+ )
}
} else if (identical(engine, "R")){
diff --git a/R/occuCOP.R b/R/occuCOP.R
new file mode 100644
index 0000000..f22c235
--- /dev/null
+++ b/R/occuCOP.R
@@ -0,0 +1,964 @@
+# Fit the occupancy model COP
+# (Counting Occurrences Process)
+
+# Occupancy
+# z_i ~ Bernoulli(psi_i)
+#
+# with:
+# z_i = Occupancy state of site i
+# = 1 if the site i is occupied
+# = 0 else
+# psi_i = Occupancy probability of site i
+
+# Detection
+# N_ij | z_i = 1 ~ Poisson(lambda_ij*L_ij)
+# N_ij | z_i = 0 ~ 0
+#
+# with:
+# N_ij = Number of detections of site i during observation j
+# z_i = Occupancy state of site i
+# lambda_ij = Detection rate of the observation j in site i
+# L_ij = Length/Duration of the observation j in site i
+
+# CLASSES ----------------------------------------------------------------------
+
+## unmarkedFrameOccuCOP class ----
+setClass(
+ "unmarkedFrameOccuCOP",
+ representation(L = "matrix"),
+ contains = "unmarkedFrame",
+ validity = function(object) {
+ errors <- character(0)
+ M <- nrow(object@y)
+ J <- ncol(object@y)
+ y_integers = sapply(object@y, check.integer, na.ignore = T)
+ if (!all(y_integers)) {
+ errors <- c(errors,
+ paste(
+ "Count detection should be integers. Non-integer values:",
+ paste(object@y[which(!y_integers)], collapse = ', ')
+ ))
+ }
+ if (!all(all(dim(object@L) == dim(object@y)))){
+ errors <- c( errors, paste(
+ "L should be a matrix of the same dimension as y, with M =", M,
+ "rows (sites) and J =", J, "columns (sampling occasions)."
+ ))}
+ if (length(errors) == 0) TRUE
+ else errors
+ }
+)
+
+## unmarkedFitOccuCOP class ----
+setClass("unmarkedFitOccuCOP",
+ representation(removed_obs = "matrix",
+ formlist = "list"),
+ contains = "unmarkedFit")
+
+
+# Methods ----------------------------------------------------------------------
+
+## getDesign method ----
+setMethod(
+ "getDesign", "unmarkedFrameOccuCOP",
+ function(umf, formlist, na.rm = TRUE) {
+
+ "
+ getDesign convert the information in the unmarkedFrame to a format
+ usable by the likelihood function:
+ - It creates model design matrices for fixed effects (X) for each parameter (here lambda, psi)
+ - It creates model design matrices for random effects (Z) for each parameter (here lambda, psi)
+ - It handles missing data
+ "
+
+ # Retrieve useful informations from umf
+ M <- numSites(umf)
+ J <- obsNum(umf)
+ y <- getY(umf)
+ L <- getL(umf)
+
+ # Occupancy submodel -------------------------------------------------------
+ # Retrieve the fixed-effects part of the formula
+ psiformula <- lme4::nobars(as.formula(formlist$psiformula))
+ psiVars <- all.vars(psiformula)
+
+ # Retrieve the site covariates
+ sc <- siteCovs(umf)
+ if(is.null(sc)) {
+ sc <- data.frame(.dummy = rep(0, M))
+ }
+
+ # Check for missing variables
+ psiMissingVars <- psiVars[!(psiVars %in% names(sc))]
+ if (length(psiMissingVars) > 0) {
+ stop(paste0(
+ "Variable(s) '",
+ paste(psiMissingVars, collapse = "', '"),
+ "' not found in siteCovs"
+ ), call. = FALSE)
+ }
+
+ # State model matrix for fixed effects
+ Xpsi <- model.matrix(
+ psiformula,
+ model.frame(psiformula, sc, na.action = NULL)
+ )
+ # State model matrix for random effects
+ Zpsi <- get_Z(formlist$psiformula, sc)
+
+ # Detection submodel -------------------------------------------------------
+
+ # Retrieve the fixed-effects part of the formula
+ lambdaformula <- lme4::nobars(as.formula(formlist$lambdaformula))
+ lambdaVars <- all.vars(lambdaformula)
+
+ # Retrieve the observation covariates
+ oc <- obsCovs(umf)
+ if(is.null(oc)) {
+ oc <- data.frame(.dummy = rep(0, M*J))
+ }
+
+ # Check for missing variables
+ lambdaMissingVars <- lambdaVars[!(lambdaVars %in% names(oc))]
+ if (length(lambdaMissingVars) > 0) {
+ stop(paste(
+ "Variable(s)",
+ paste(lambdaMissingVars, collapse = ", "),
+ "not found in obsCovs"
+ ), call. = FALSE)
+ }
+
+ # Detection model matrix for fixed effects
+ Xlambda <- model.matrix(
+ lambdaformula,
+ model.frame(lambdaformula, oc, na.action = NULL)
+ )
+ # Detection model matrix for random effects
+ Zlambda <- get_Z(formlist$lambdaformula, oc)
+
+ # Missing data -------------------------------------------------------------
+
+ # Missing count data
+ missing_y <- is.na(y)
+
+ # Missing site covariates
+ # (TRUE if at least one site covariate is missing in a site)
+ missing_sc <- apply(Xpsi, 1, function(x) any(is.na(x)))
+
+ # Missing observation covariates
+ # (TRUE if at least one observation covariate is missing in a sampling occasion in a site)
+ missing_oc <- apply(Xlambda, 1, function(x) any(is.na(x)))
+
+ # Matrix MxJ of values to not use because there is some data missing
+ removed_obs <-
+ # If there is count data missing in site i and obs j
+ missing_y |
+ # If there is any site covariate missing in site i
+ replicate(n = J, missing_sc) |
+ # If there is any observation covariate missing in site i and obs j
+ matrix(missing_oc, M, J, byrow = T)
+
+ if (any(removed_obs)) {
+ if (na.rm) {
+ nb_missing_sites <- sum(rowSums(!removed_obs) == 0)
+ nb_missing_observations <- sum(is.na(removed_obs))
+ warning("There is missing data: ",
+ sum(missing_y), " missing count data, ",
+ sum(missing_sc), " missing site covariate(s), ",
+ sum(missing_oc), " missing observation covariate(s). ",
+ "Data from only ", (M*J)-sum(removed_obs), " observations out of ", (M*J), " are used, ",
+ "from ", M-nb_missing_sites, " sites out of ", M, ".\n\t"
+ )
+ } else {
+ stop("na.rm=FALSE and there is missing data :\n\t",
+ sum(missing_y), " missing count data (y)\n\t",
+ sum(missing_sc), " missing site covariates (siteCovs)\n\t",
+ sum(missing_oc), " missing observation covariates (obsCovs)")
+ }
+ }
+
+ # Output -------------------------------------------------------------------
+ return(list(
+ y = y,
+ Xpsi = Xpsi,
+ Zpsi = Zpsi,
+ Xlambda = Xlambda,
+ Zlambda = Zlambda,
+ removed_obs = removed_obs
+ ))
+ })
+
+
+## getL method ----
+setGeneric("getL", function(object) standardGeneric("getL"))
+setMethod("getL", "unmarkedFrameOccuCOP", function(object) {
+ return(object@L)
+})
+
+
+## show method ----
+setMethod("show", "unmarkedFrameOccuCOP", function(object) {
+ J <- ncol(object@L)
+ df_unmarkedFrame <- as(object, "data.frame")
+ df_L <- data.frame(object@L)
+ colnames(df_L) <- paste0("L.", 1:J)
+ if (ncol(df_unmarkedFrame) > J) {
+ df <- cbind(df_unmarkedFrame[, 1:J, drop = FALSE],
+ df_L,
+ df_unmarkedFrame[, (J + 1):ncol(df_unmarkedFrame), drop = FALSE])
+ } else {
+ df <- cbind(df_unmarkedFrame[, 1:J],
+ df_L)
+ }
+ cat("Data frame representation of unmarkedFrame object.\n")
+ print(df)
+})
+# LP note: as is defined in unmarkedFrame.R part "COERCION"
+
+
+## summary method ----
+setMethod("summary", "unmarkedFrameOccuCOP", function(object,...) {
+ cat("unmarkedFrameOccuCOP Object\n\n")
+
+ cat(nrow(object@y), "sites\n")
+ cat("Maximum number of sampling occasions per site:",obsNum(object),"\n")
+ mean.obs <- mean(rowSums(!is.na(getY(object))))
+ cat("Mean number of sampling occasions per site:",round(mean.obs,2),"\n")
+ cat("Sites with at least one detection:",
+ sum(apply(getY(object), 1, function(x) any(x > 0, na.rm=TRUE))),
+ "\n\n")
+
+ cat("Tabulation of y observations:")
+ print(table(object@y, exclude=NULL))
+
+ if(!is.null(object@L)) {
+ cat("\nTabulation of sampling occasions length:")
+ print(table(object@L))
+ }
+
+ if(!is.null(object@siteCovs)) {
+ cat("\nSite-level covariates:\n")
+ print(summary(object@siteCovs))
+ }
+
+ if(!is.null(object@obsCovs)) {
+ cat("\nObservation-level covariates:\n")
+ print(summary(object@obsCovs))
+ }
+})
+
+
+## umf[i, j] ----
+setMethod("[", c("unmarkedFrameOccuCOP", "numeric", "numeric", "missing"),
+ function(x, i, j) {
+ # Gey dimensions of x
+ M <- numSites(x)
+ J <- obsNum(x)
+
+ if (length(i) == 0 & length(j) == 0) {
+ return(x)
+ }
+
+ # Check i
+ if (any(i < 0) &&
+ any(i > 0)) {
+ stop("i must be all positive or all negative indices.")
+ }
+ if (all(i < 0)) {
+ i <- (1:M)[i]
+ }
+
+ # Check j
+ if (any(j < 0) &&
+ any(j > 0)) {
+ stop("j must be all positive or all negative indices.")
+ }
+ if (all(j < 0)) {
+ j <- (1:J)[j]
+ }
+
+ # y observation count data subset
+ y <- getY(x)[i, j, drop = FALSE]
+ if (min(length(i), length(j)) == 1) {
+ y <- t(y)
+ }
+
+ # L subset
+ L <- x@L[i, j, drop = FALSE]
+ if (min(length(i), length(j)) == 1) {
+ L <- t(L)
+ }
+
+ # siteCovs subset
+ siteCovs <- siteCovs(x)
+ if (!is.null(siteCovs)) {
+ siteCovs <- siteCovs(x)[i, , drop = FALSE]
+ }
+
+ # obsCovs subset
+ obsCovs <- obsCovs(x)
+ if (!is.null(obsCovs)) {
+ MJ_site <- rep(1:M, each = J)
+ MJ_obs <- rep(1:J, times = M)
+ obsCovs <- obsCovs[((MJ_obs %in% j) & (MJ_site %in% i)), , drop = FALSE]
+ rownames(obsCovs) <- NULL
+ }
+
+ # Recreate umf
+ new(
+ Class = "unmarkedFrameOccuCOP",
+ y = y,
+ L = L,
+ siteCovs = siteCovs,
+ obsCovs = obsCovs,
+ obsToY = diag(length(j)),
+ mapInfo = x@mapInfo
+ )
+ })
+
+
+## umf[i, ] ----
+setMethod("[", c("unmarkedFrameOccuCOP", "numeric", "missing", "missing"),
+ function(x, i) {
+ x[i, 1:obsNum(x)]
+ })
+
+## umf[, j] ----
+setMethod("[", c("unmarkedFrameOccuCOP", "missing", "numeric", "missing"),
+ function(x, j) {
+ x[1:numSites(x), j]
+ })
+
+
+## fl_getY ----
+setMethod("fl_getY", "unmarkedFitOccuCOP", function(fit, ...){
+ getDesign(getData(fit), fit@formlist)$y
+})
+
+
+## predict_inputs_from_umf ----
+setMethod("predict_inputs_from_umf", "unmarkedFitOccuCOP",
+ function(object, type, newdata, na.rm, re.form = NULL) {
+ designMats = getDesign(umf = newdata,
+ formlist = object@formlist,
+ na.rm = na.rm)
+ if (type == "psi") list_els <- c("Xpsi", "Zpsi")
+ if (type == "lambda") list_els <- c("Xlambda", "Zlambda")
+ X <- designMats[[list_els[1]]]
+ if (is.null(re.form)) X <- cbind(X, designMats[[list_els[2]]])
+ return(list(X = X, offset = NULL))
+ })
+
+
+## get_formula ----
+setMethod("get_formula", "unmarkedFitOccuCOP", function(object, type, ...) {
+ fl <- object@formlist
+ switch(type, psi = fl$psiformula, lambda = fl$lambdaformula)
+})
+
+
+## get_orig_data ----
+setMethod("get_orig_data", "unmarkedFitOccuCOP", function(object, type, ...){
+ clean_covs <- clean_up_covs(object@data, drop_final=FALSE)
+ datatype <- switch(type, psi = 'site_covs', lambda = 'obs_covs')
+ clean_covs[[datatype]]
+})
+
+
+## getP ----
+setMethod("getP", "unmarkedFitOccuCOP", function(object, na.rm = TRUE) {
+ data <- object@data
+ M = nrow(getY(data))
+ J = ncol(getY(data))
+ des <- getDesign(data, object@formlist, na.rm = na.rm)
+ matLambda = do.call(object["lambda"]@invlink,
+ list(matrix(
+ as.numeric(des$Xlambda %*% coef(object, 'lambda')),
+ nrow = M, ncol = J, byrow = T)))
+ return(matLambda)
+})
+
+
+## fitted ----
+setMethod("fitted", "unmarkedFitOccuCOP", function(object, na.rm = FALSE) {
+ data <- object@data
+ M = nrow(getY(data))
+ J = ncol(getY(data))
+ des <- getDesign(data, object@formlist, na.rm = na.rm)
+ estim_psi = as.numeric(do.call(object["psi"]@invlink,
+ list(as.matrix(des$Xpsi %*% coef(object, 'psi')))))
+ estim_lambda = do.call(object["lambda"]@invlink,
+ list(matrix(
+ as.numeric(des$Xlambda %*% coef(object, 'lambda')),
+ nrow = M, ncol = J, byrow = T)))
+ return(estim_psi * estim_lambda)
+})
+
+
+## residuals ----
+setMethod("residuals", "unmarkedFitOccuCOP", function(object) {
+ y <- getY(object@data)
+ e <- fitted(object)
+ r <- y - e
+ return(r)
+})
+
+
+## plot ----
+setMethod("plot", c(x = "unmarkedFitOccuCOP", y = "missing"), function(x, y, ...) {
+ y <- getY(x)
+ r <- residuals(x)
+ e <- fitted(x)
+
+ old_graph <- graphics::par("mfrow", "mar")
+ on.exit(graphics::par(mfrow = old_graph$mfrow, mar = old_graph$mar))
+
+ {
+ graphics::par(mfrow = c(2, 1))
+ graphics::par(mar = c(0, 5, 2, 2))
+ plot(e, y,
+ ylab = "Observed data",
+ xlab = "Predicted data",
+ xaxt = 'n')
+ abline(a = 0, b = 1, lty = 3, col = "red")
+ title(main = "COP model - detection events count", outer = F)
+
+ graphics::par(mar = c(4, 5, 0.5, 2))
+ plot(e, r,
+ ylab = "Residuals",
+ xlab = "Predicted data")
+ abline(h = 0, lty = 3, col = "red")
+ }
+})
+
+
+## get_umf_components ----
+setMethod("get_umf_components", "unmarkedFitOccuCOP",
+ function(object, formulas, guide, design, ...){
+ sc <- generate_data(formulas$psi, guide, design$M)
+ oc <- generate_data(formulas$lambda, guide, design$J*design$M)
+ yblank <- matrix(0, design$M, design$J)
+ list(y=yblank, siteCovs=sc, obsCovs=oc)
+})
+
+
+## simulate_fit ----
+setMethod("simulate_fit", "unmarkedFitOccuCOP",
+ function(object, formulas, guide, design, ...){
+ # Generate covariates and create a y matrix of zeros
+ parts <- get_umf_components(object, formulas, guide, design, ...)
+ umf <- unmarkedFrameOccuCOP(y = parts$y, siteCovs = parts$siteCovs, obsCovs=parts$obsCovs)
+ fit <- suppressMessages(
+ occuCOP(
+ data = umf,
+ psiformula = formula(formulas$psi),
+ lambdaformula = formula(formulas$lambda),
+ se = FALSE,
+ control = list(maxit = 1)
+ )
+ )
+ return(fit)
+})
+
+
+## simulate ----
+setMethod("simulate", "unmarkedFitOccuCOP",
+ function(object, nsim = 1, seed = NULL, na.rm = TRUE){
+ # set.seed(seed)
+ # Purposefully not implemented
+ formula <- object@formula
+ umf <- object@data
+ designMats <- getDesign(umf = umf, formlist = object@formlist, na.rm = na.rm)
+ y <- designMats$y
+ M <- nrow(y)
+ J <- ncol(y)
+
+ # Occupancy probability psi depending on the site covariates
+ psiParms = coef(object, type = "psi", fixedOnly = FALSE)
+ psi <- as.numeric(plogis(as.matrix(designMats$Xpsi %*% psiParms)))
+
+ # Detection rate lambda depending on the observation covariates
+ lambda = getP(object = object)
+
+ # Simulations
+ simList <- vector("list", nsim)
+ for(i in 1:nsim) {
+ Z <- rbinom(M, 1, psi)
+ # Z[object@knownOcc] <- 1
+ y = matrix(rpois(n = M * J, lambda = as.numeric(t(lambda))),
+ nrow = M, ncol = J, byrow = T) * Z
+ simList[[i]] <- y
+ }
+ return(simList)
+})
+
+
+## nonparboot ----
+setMethod("nonparboot", "unmarkedFitOccuCOP",
+ function(object, B = 0, keepOldSamples = TRUE, ...) {
+ stop("Not currently supported for unmarkedFitOccuCOP", call.=FALSE)
+})
+
+
+## ranef ----
+setMethod("ranef", "unmarkedFitOccuCOP", function(object, ...) {
+ # Sites removed (srm) and sites kept (sk)
+ srm <- object@sitesRemoved
+ if (length(srm) > 0) {
+ sk = 1:numSites(getData(object))[-srm]
+ } else{
+ sk = 1:numSites(getData(object))
+ }
+
+ # unmarkedFrame informations
+ M <- length(sk)
+ J <- obsNum(getData(object))
+ y <- getY(getData(object))[sk,]
+
+ # Estimated parameters
+ psi <- predict(object, type = "psi")[sk, 1]
+ lambda <- getP(object)[sk,]
+
+ # Estimate posterior distributions
+ z = c(0, 1)
+ post <- array(0, c(M, 2, 1), dimnames = list(NULL, z))
+ for (i in 1:M) {
+ # psi density
+ f <- dbinom(x = z,
+ size = 1,
+ prob = psi[i])
+
+ # lambda density
+ g <- c(1, 1)
+ for (j in 1:J) {
+ if (is.na(y[i, j]) | is.na(lambda[i, j])) {
+ next
+ }
+ g = g * dpois(x = y[i, j], lambda = lambda[i, j] * z)
+ }
+
+ # psi*lambda density
+ fudge <- f * g
+ post[i, , 1] <- fudge / sum(fudge)
+ }
+
+ new("unmarkedRanef", post = post)
+})
+
+
+# Useful functions -------------------------------------------------------------
+
+check.integer <- function(x, na.ignore = F) {
+ if (is.na(x) & na.ignore) {
+ return(T)
+ }
+ x %% 1 == 0
+}
+
+# unmarkedFrame ----------------------------------------------------------------
+
+unmarkedFrameOccuCOP <- function(y, L, siteCovs = NULL, obsCovs = NULL) {
+
+ # Verification that they are non-NA data in y
+ if (all(is.na(y))) {
+ stop("y only contains NA. y needs to contain non-NA integers.")
+ }
+
+ # Verification that these are count data (and not detection/non-detection)
+ if (max(y, na.rm = T) == 1) {
+ warning("unmarkedFrameOccuCOP is for count data. ",
+ "The data furnished appear to be detection/non-detection.")
+ }
+
+ # Number of sampling occasions
+ J <- ncol(y)
+
+ # If missing L: replace by matrix of 1
+ # and the lambda will be the detection rate per observation length
+ if (missing(L)) {
+ L <- y * 0 + 1
+ warning("L is missing, replacing it by a matrix of 1.")
+ } else if (is.null(L)) {
+ L <- y * 0 + 1
+ warning("L is missing, replacing it by a matrix of 1.")
+ }
+
+ # Transformation observation covariates
+ obsCovs <- covsToDF(
+ covs = obsCovs,
+ name = "obsCovs",
+ obsNum = J,
+ numSites = nrow(y)
+ )
+
+ # Create S4 object of class unmarkedFrameOccuCOP
+ umf <- new(
+ Class = "unmarkedFrameOccuCOP",
+ y = y,
+ L = L,
+ siteCovs = siteCovs,
+ obsCovs = obsCovs,
+ obsToY = diag(J)
+ )
+
+ return(umf)
+}
+
+
+# occuCOP ----------------------------------------------------------------------
+
+occuCOP <- function(data,
+ psiformula = ~1,
+ lambdaformula = ~1,
+ psistarts,
+ lambdastarts,
+ starts,
+ method = "BFGS",
+ se = TRUE,
+ engine = c("C", "R"),
+ na.rm = TRUE,
+ return.negloglik = NULL,
+ L1 = FALSE,
+ ...) {
+ #TODO: random effects
+
+ # Neg loglikelihood COP ------------------------------------------------------
+ R_nll_occuCOP <- function(params) {
+
+ # Reading and transforming params
+ # Taking into account the covariates
+
+ # psi as a function of covariates
+ # psi in params are transformed with a logit transformation (qlogis)
+ # so they're back-transformed to a proba with inverse logit (plogis)
+ # Xpsi is the matrix with occupancy covariates
+ # params is the vector with all the parameters
+ # psiIdx is the index of Occupancy Parameters in params
+ psi <- plogis(Xpsi %*% params[psiIdx])
+
+ # lambda as a function of covariates
+ # lambda in params are transformed with a log-transformation
+ # so they're back-transformed to a rate with exp here
+ # Xlambda is the matrix with detection covariates
+ # params is the vector with all the parameters
+ # lambdaIdx is the index of Occupancy Parameters in params
+ lambda <- exp(Xlambda %*% params[lambdaIdx])
+
+ # Listing sites analysed = sites not removed (due to NAs)
+ if (length(sitesRemoved) > 0) {
+ siteAnalysed = (1:M)[-sitesRemoved]
+ } else {
+ siteAnalysed = (1:M)
+ }
+
+ # Probability for each site (i)
+ iProb <- rep(NA, M)
+
+ for (i in siteAnalysed) {
+ # iIdx is the index to access the vectorised vectors of all obs in site i
+ iIdxall <- ((i - 1) * J + 1):(i * J)
+
+ # Removing NAs
+ iIdx = iIdxall[!removed_obsvec[iIdxall]]
+
+ if (SitesWithDetec[i]) {
+ # If there is at least one detection in site i
+ iProb[i] = psi[i] * (
+ (sum(lambda[iIdx] * Lvec[iIdx])) ^ sum(yvec[iIdx]) /
+ factorial(sum(yvec[iIdx])) *
+ exp(-sum(lambda[iIdx] * Lvec[iIdx]))
+ )
+
+ } else {
+ # If there is zero detection in site i
+ iProb[i] = psi[i] * exp(-sum(lambda[iIdx] * Lvec[iIdx])) + (1 - psi[i])
+
+ }
+ }
+
+ # log-likelihood
+ ll = sum(log(iProb[siteAnalysed]))
+ return(-ll)
+ }
+
+ # Check arguments ------------------------------------------------------------
+ if (!is(data, "unmarkedFrameOccuCOP")) {
+ stop("Data is not an unmarkedFrameOccuCOP object. See ?unmarkedFrameOccuCOP if necessary.")
+ }
+ stopifnot(class(psiformula) == "formula")
+ stopifnot(class(lambdaformula) == "formula")
+ if(!missing(psistarts)){stopifnot(class(psistarts) %in% c("numeric", "double", "integer"))}
+ if(!missing(lambdastarts)){stopifnot(class(lambdastarts) %in% c("numeric", "double", "integer"))}
+ se = as.logical(match.arg(
+ arg = as.character(se),
+ choices = c("TRUE", "FALSE", "0", "1")
+ ))
+ na.rm = as.logical(match.arg(
+ arg = as.character(na.rm),
+ choices = c("TRUE", "FALSE", "0", "1")
+ ))
+ engine <- match.arg(engine, c("C", "R"))
+ L1 = as.logical(match.arg(
+ arg = as.character(L1),
+ choices = c("TRUE", "FALSE", "0", "1")
+ ))
+
+
+ # Do not yet manage random effects!!!
+ if (has_random(psiformula) | has_random(lambdaformula)) {
+ stop("occuCOP does not currently handle random effects.")
+ }
+
+ # Format input data ----------------------------------------------------------
+
+ # Retrieve formlist
+ formlist <- mget(c("psiformula", "lambdaformula"))
+
+ # Get the design matrix (calling the getDesign method for unmarkedFrame)
+ # For more informations, see: getMethod("getDesign", "unmarkedFrameOccuCOP")
+ designMats <- getDesign(umf = data, formlist = formlist, na.rm = na.rm)
+
+ # y is the count detection data (matrix of size M sites x J observations)
+ y <- getY(data)
+
+ # L is the length of observations (matrix of size M sites x J observations)
+ L <- getL(data)
+ if (!L1) {
+ if (!any(is.na(L))) {
+ if (all(L == 1)) {
+ warning(
+ "All observations lengths (L) are set to 1. ",
+ "If they were not user-defined, lambda corresponds to the ",
+ "detection rate multiplied by the observation length, ",
+ "not just the detection rate per time-unit or space-unit.\n",
+ "You can remove this warning by adding 'L1=TRUE' in the function inputs."
+ )
+ }
+ }
+ }
+
+ # Xpsi is the fixed effects design matrix for occupancy
+ Xpsi <- designMats$Xpsi
+
+ # Xlambda is the fixed effects design matrix for detection rate
+ Xlambda <- designMats$Xlambda
+
+ # Zpsi is the random effects design matrix for occupancy
+ Zpsi <- designMats$Zpsi
+
+ # Zlambda is the random effects design matrix for detection rate
+ Zlambda <- designMats$Zlambda
+
+ # removed_obs is a M x J matrix of the observations removed from the analysis
+ removed_obs <- designMats$removed_obs
+ sitesRemoved <- unname(which(apply(removed_obs, 1, function(x) all(x))))
+
+ # Number of sites
+ M <- nrow(y)
+
+ # Number of sampling occasions
+ J <- ncol(y)
+
+ # Total number of detection per site
+ NbDetecPerSite = rowSums(y, na.rm=T)
+
+ # Sites where there was at least one detection
+ SitesWithDetec = NbDetecPerSite > 0
+
+ # Number of sites where there was at least one detection
+ NbSitesWithDetec = sum(SitesWithDetec)
+
+ # Set up parameter names and indices-----------------------------------------
+
+ # ParamPsi Occupancy parameter names
+ ParamPsi <- colnames(Xpsi)
+
+ # ParamLambda Detection parameter names
+ ParamLambda <- colnames(Xlambda)
+
+ # NbParamPsi Number of occupancy parameters
+ NbParamPsi <- ncol(Xpsi)
+
+ # NbParamLambda Number of detection parameters
+ NbParamLambda <- ncol(Xlambda)
+
+ # nP Total number of parameters
+ nP <- NbParamPsi + NbParamLambda
+
+ # psiIdx Index of the occupancy parameters
+ psiIdx <- 1:NbParamPsi
+
+ # lambdaIdx Index of the detection parameters
+ lambdaIdx <- (NbParamPsi+1):nP
+
+ # Re-format some variables for C and R engines
+ # From Matrix of dim MxJ to vector of length MxJ:
+ # c(ySite1Obs1, ySite1Obs2, ..., ySite1ObsJ, ysite2Obs1, ...)
+ yvec <- as.numeric(t(y))
+ Lvec <- as.numeric(t(L))
+ removed_obsvec <- as.logical(t(removed_obs))
+
+ # return.negloglik -----------------------------------------------------------
+ if (!is.null(return.negloglik)) {
+ df_NLL = data.frame(t(as.data.frame(return.negloglik)))
+ rownames(df_NLL) = NULL
+ colnames(df_NLL) = c(paste0("logit(psi).", ParamPsi),
+ paste0("log(lambda).", ParamLambda))
+ df_NLL$nll = NA
+ for (i in 1:nrow(df_NLL)) {
+ df_NLL$nll[i] = R_nll_occuCOP(params = as.numeric(as.vector(df_NLL[i, -ncol(df_NLL)])))
+ }
+ return(df_NLL)
+ }
+
+ # nll function depending on engine -------------------------------------------
+ if (identical(engine, "C")) {
+ nll <- function(params) {
+ nll_occuCOP(
+ y = yvec,
+ L = Lvec,
+ Xpsi = Xpsi,
+ Xlambda = Xlambda,
+ beta_psi = params[psiIdx],
+ beta_lambda = params[lambdaIdx],
+ removed = removed_obsvec
+ )
+ }
+ } else if (identical(engine, "R")) {
+ nll <- R_nll_occuCOP
+ }
+
+
+ # Optimisation ---------------------------------------------------------------
+
+ ## Checking the starting point for optim ----
+ # Check if either (psistarts AND lambdastarts) OR starts is provided
+ if (!missing(psistarts) & !missing(lambdastarts)) {
+ # Both psistarts and lambdastarts provided
+ if (!missing(starts)){
+ if (!all(c(psistarts, lambdastarts) == starts)) {
+ warning(
+ "You provided psistarts, lambdastarts and starts. ",
+ "Please provide either (psistarts AND lambdastarts) OR starts. ",
+ "Using psistarts and lambdastarts."
+ )
+ }
+ }
+ if (length(lambdastarts) != NbParamLambda) {
+ stop("lambdastarts (", paste(lambdastarts, collapse = ", "), ") ",
+ "should be of length ", NbParamLambda, " with lambdaformula ", lambdaformula)
+ }
+ if (length(psistarts) != NbParamPsi) {
+ stop("psistarts (", paste(psistarts, collapse = ", "), ") ",
+ "should be of length ", NbParamPsi, " with psiformula ", psiformula)
+ }
+ starts <- c(psistarts, lambdastarts)
+ } else if (!missing(starts)) {
+ # starts provided
+ if (length(starts) != nP) {
+ stop("starts (", paste(starts, collapse = ", "), ") ",
+ "should be of length ", nP,
+ " with psiformula ", psiformula,
+ " and lambdaformula ", lambdaformula)
+ }
+
+ psistarts <- starts[1:NbParamPsi]
+ lambdastarts <- starts[(NbParamPsi + 1):(NbParamPsi + NbParamLambda)]
+
+ } else {
+ # No arguments provided, apply default values
+
+ if (missing(lambdastarts)) {
+ # If lambda starts argument was not given:
+ # 0 by default
+ # so lambda = exp(0) = 1 by default
+ lambdastarts = rep(0, NbParamLambda)
+ } else if (length(lambdastarts) != NbParamLambda) {
+ stop("lambdastarts (", paste(lambdastarts, collapse = ", "), ") ",
+ "should be of length ", NbParamLambda, " with lambdaformula ", lambdaformula)
+ }
+
+ if (missing(psistarts)) {
+ # If psi starts argument was not given
+ # 0 by default
+ # so psi = plogis(0) = 0.5 by default
+ psistarts = rep(0, NbParamPsi)
+ } else if (length(psistarts) != NbParamPsi) {
+ stop("psistarts (", paste(psistarts, collapse = ", "), ") ",
+ "should be of length ", NbParamPsi, " with psiformula ", psiformula)
+ }
+
+ starts <- c(psistarts, lambdastarts)
+ }
+
+ ## Run optim ----
+ opt <- optim(
+ starts,
+ nll,
+ method = method,
+ hessian = se,
+ ...
+ )
+
+ # Get output -----------------------------------------------------------------
+ covMat <- invertHessian(opt, nP, se)
+ ests <- opt$par
+ tmb_mod <- NULL
+ fmAIC <- 2 * opt$value + 2 * nP
+
+ # Organize effect estimates
+ names(ests) <- c(ParamPsi, ParamLambda)
+ psi_coef <- list(ests = ests[psiIdx], cov = as.matrix(covMat[psiIdx, psiIdx]))
+ lambda_coef <- list(ests = ests[lambdaIdx],
+ cov = as.matrix(covMat[lambdaIdx, lambdaIdx]))
+
+ # No random effects
+ psi_rand_info <- lambda_rand_info <- list()
+
+ # Create unmarkedEstimates ---------------------------------------------------
+ psi_uE <- unmarkedEstimate(
+ name = "Occupancy probability",
+ short.name = "psi",
+ estimates = psi_coef$ests,
+ covMat = psi_coef$cov,
+ fixed = 1:NbParamPsi,
+ invlink = "logistic",
+ invlinkGrad = "logistic.grad",
+ randomVarInfo = psi_rand_info
+ )
+
+ lambda_uE <- unmarkedEstimate(
+ name = "Detection rate",
+ short.name = "lambda",
+ estimates = lambda_coef$ests,
+ covMat = lambda_coef$cov,
+ fixed = 1:NbParamLambda,
+ invlink = "exp",
+ invlinkGrad = "exp",
+ randomVarInfo = lambda_rand_info
+ )
+
+ estimateList <- unmarkedEstimateList(list(psi = psi_uE, lambda = lambda_uE))
+
+ # Create unmarkedFit object--------------------------------------------------
+ umfit <- new(
+ "unmarkedFitOccuCOP",
+ fitType = "occuCOP",
+ call = match.call(),
+ formula = as.formula(paste(
+ formlist["lambdaformula"], formlist["psiformula"], collapse = ""
+ )),
+ formlist = formlist,
+ data = data,
+ estimates = estimateList,
+ sitesRemoved = sitesRemoved,
+ removed_obs = removed_obs,
+ AIC = fmAIC,
+ opt = opt,
+ negLogLike = opt$value,
+ nllFun = nll,
+ TMB = tmb_mod
+ )
+
+ return(umfit)
+}
diff --git a/R/occuMS.R b/R/occuMS.R
index 5bf2d36..3d1bf0f 100644
--- a/R/occuMS.R
+++ b/R/occuMS.R
@@ -177,11 +177,12 @@ occuMS <- function(detformulas, psiformulas, phiformulas=NULL, data,
#Likelihood function in C++--------------------------------------------------
naflag <- is.na(y)
nll_C <- function(params){
- .Call("nll_occuMS",
+ if(!is.matrix(pind)) pind <- matrix()
+ nll_occuMS(
params, y, gd$dm_state, gd$dm_phi, gd$dm_det,
sind-1, pind-1, dind-1, parameterization,
- S, T, J, N, naflag, guide-1,
- PACKAGE = "unmarked")
+ S, T, J, N, naflag, guide-1
+ )
}
#----------------------------------------------------------------------------
diff --git a/R/occuMulti.R b/R/occuMulti.R
index 8b20dd1..7d31d47 100644
--- a/R/occuMulti.R
+++ b/R/occuMulti.R
@@ -88,10 +88,10 @@ occuMulti <- function(detformulas, stateformulas, data, maxOrder,
#Likelihood function in C----------------------------------------------------
nll_C <- function(params) {
- .Call("nll_occuMulti",
+ nll_occuMulti(
fStart-1, fStop-1, t_dmF, dmOcc, params, dmDet, dStart-1, dStop-1,
- y, yStart-1, yStop-1, Iy0, as.matrix(z), fixed0, penalty, 0,
- PACKAGE = "unmarked")
+ y, yStart-1, yStop-1, Iy0, as.matrix(z), fixed0, penalty
+ )
}
#----------------------------------------------------------------------------
@@ -169,13 +169,11 @@ occuMultiLogLik <- function(fit, data){
dmF <- Matrix::Matrix(dm$dmF, sparse=TRUE)
t_dmF <- Matrix::t(dmF)
- out <- .Call("nll_occuMulti",
+ out <- nll_occuMulti_loglik(
dm$fStart-1, dm$fStop-1, t_dmF,
dm$dmOcc, coef(fit), dm$dmDet, dm$dStart-1, dm$dStop-1, dm$y,
- dm$yStart-1, dm$yStop-1, dm$Iy0, as.matrix(dm$z), dm$fixed0, 0,
- #return site likelihoods
- 1,
- PACKAGE = "unmarked")
+ dm$yStart-1, dm$yStop-1, dm$Iy0, as.matrix(dm$z), dm$fixed0
+ )
as.vector(out)
diff --git a/R/occuPEN.R b/R/occuPEN.R
index 2f24ff9..55c7563 100644
--- a/R/occuPEN.R
+++ b/R/occuPEN.R
@@ -77,10 +77,10 @@ occuPEN_CV <- function(formula, data, knownOcc = numeric(0), starts,
nll <- function(params) {
beta.psi <- params[1:nOP]
beta.p <- params[(nOP+1):nP]
- .Call("nll_occu",
+ nll_occu(
yvec, X, V, beta.psi, beta.p, nd, knownOccLog, navec,
- X.offset, V.offset, "logit",
- PACKAGE = "unmarked")
+ X.offset, V.offset, "logit"
+ )
}
} else {
nll <- function(params) { # penalize this function
@@ -252,12 +252,9 @@ occuPEN <- function(formula, data, knownOcc = numeric(0), starts,
} else {
stop("pen.type not found")
}
-
- .Call("nll_occuPEN",
- yvec, X, V, beta.psi, beta.p, nd, knownOccLog, navec,
- X.offset, V.offset, penalty,
- PACKAGE = "unmarked")
- }
+ nll_occuPEN(yvec, X, V, beta.psi, beta.p, nd, knownOccLog, navec,
+ X.offset, V.offset, penalty)
+ }
} else {
nll <- function(params) { # penalize this function
psi <- plogis(X %*% params[1 : nOP] + X.offset)
diff --git a/R/occuTTD.R b/R/occuTTD.R
index c9965f5..5751450 100644
--- a/R/occuTTD.R
+++ b/R/occuTTD.R
@@ -135,12 +135,12 @@ occuTTD <- function(psiformula=~1, gammaformula=~1, epsilonformula=~1,
}
nll_C <- function(params){
- .Call("nll_occuTTD",
+ nll_occuTTD(
params, yvec, delta, W, V, X.gam, X.eps,
range(psi_inds)-1, range(det_inds)-1,
range(col_inds)-1, range(ext_inds)-1,
- linkPsi, ttdDist, N, T, J, naflag,
- PACKAGE = "unmarked")
+ linkPsi, ttdDist, N, T, J, naflag
+ )
}
nll <- nll_C
diff --git a/R/pcountOpen.R b/R/pcountOpen.R
index 6f814f6..9156aad 100644
--- a/R/pcountOpen.R
+++ b/R/pcountOpen.R
@@ -148,7 +148,7 @@ nll <- function(parms) {
log.alpha <- 1
if(mixture %in% c("NB", "ZIP"))
log.alpha <- parms[nP]
- .Call("nll_pcountOpen",
+ nll_pcountOpen(
ym,
Xlam, Xgam, Xom, Xp, Xiota,
beta.lam, beta.gam, beta.om, beta.p, beta.iota, log.alpha,
@@ -156,8 +156,7 @@ nll <- function(parms) {
ytna, yna,
lk, mixture, first, last, M, J, T,
delta, dynamics, fix, go.dims, immigration,
- I, I1, Ib, Ip,
- PACKAGE = "unmarked")
+ I, I1, Ib, Ip)
}
if(missing(starts))
starts <- rep(0, nP)
diff --git a/R/posteriorSamples.R b/R/posteriorSamples.R
index 3b84ef0..9389e14 100644
--- a/R/posteriorSamples.R
+++ b/R/posteriorSamples.R
@@ -57,7 +57,7 @@ print.unmarkedPostSamples <- function(x, ...){
}
setMethod("[", c("unmarkedPostSamples","ANY","ANY","ANY"),
- function(x, i, j, k)
+ function(x, i, j, k, drop = FALSE)
{
- x@samples[i,j,k]
+ x@samples[i,j,k, drop = drop]
})
diff --git a/R/power.R b/R/power.R
index da2072c..3240e8e 100644
--- a/R/power.R
+++ b/R/power.R
@@ -84,6 +84,9 @@ powerAnalysis <- function(object, coefs=NULL, design=NULL, alpha=0.05, nulls=lis
ses <- shiny::getDefaultReactiveDomain()
pb <- shiny::Progress$new(ses, min=0, max=1)
pb$set(message="Running simulations")
+ if(!requireNamespace("pbapply", quietly=TRUE)){
+ stop("You need to install the pbapply package", call.=FALSE)
+ }
fits <- pbapply::pblapply(1:nsim, function(i, sims, fit, bdata=NULL){
if(!is.null(design)) fit@data <- bdata[[i]]
if(inherits(fit, "unmarkedFitOccuMulti")){
@@ -99,7 +102,7 @@ powerAnalysis <- function(object, coefs=NULL, design=NULL, alpha=0.05, nulls=lis
} else {
- fits <- pbapply::pblapply(1:nsim, function(i, sims, fit, bdata=NULL){
+ fits <- lapply2(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]]
@@ -429,6 +432,9 @@ shinyPower <- function(object, ...){
if(!requireNamespace("shiny")){
stop("Install the shiny library to use this function", call.=FALSE)
}
+ if(!requireNamespace("pbapply")){
+ stop("Install the pbapply library to use this function", call.=FALSE)
+ }
options(unmarked_shiny=TRUE)
on.exit(options(unmarked_shiny=FALSE))
.shiny_env$.SHINY_MODEL <- object
diff --git a/R/predict.R b/R/predict.R
index 37b9f87..4f3b5fb 100644
--- a/R/predict.R
+++ b/R/predict.R
@@ -881,9 +881,8 @@ setMethod("predict", "unmarkedFitOccuMS",
out
}
- get_mlogit <- function(lp_mat){
- .Call("get_mlogit",
- lp_mat, type, S, guide-1)
+ get_mlogit_C <- function(lp_mat){
+ get_mlogit(lp_mat, type, S, guide-1) # via Rcpp
}
#----------------------------------------------------------------------------
@@ -919,7 +918,7 @@ setMethod("predict", "unmarkedFitOccuMS",
} else if (object@parameterization == "multinomial"){
lp <- get_lp(coef(object), dm_list, ind)
- pred <- get_mlogit(lp)
+ pred <- get_mlogit_C(lp)
M <- nrow(pred)
upr <- lwr <- se <- matrix(NA,M,P)
@@ -933,7 +932,7 @@ setMethod("predict", "unmarkedFitOccuMS",
get_pr <- function(i){
lp <- get_lp(rparam[i,], dm_list, ind)
- get_mlogit(lp)
+ get_mlogit_C(lp)
}
samp <- sapply(1:nsims, get_pr, simplify='array')
diff --git a/R/ranef.R b/R/ranef.R
index 669dc1a..f99efaf 100644
--- a/R/ranef.R
+++ b/R/ranef.R
@@ -445,12 +445,15 @@ setMethod("ranef", "unmarkedFitGMMorGDS",
post <- array(0, c(nSites, K+1, 1))
colnames(post) <- M
mix <- object@mixture
- if(identical(mix, "NB"))
+ if(identical(mix, "NB")){
alpha <- exp(coef(object, type="alpha"))
+ } else if(identical(mix, "ZIP")){
+ psi <- plogis(coef(object, type="psi"))
+ }
for(i in 1:nSites) {
switch(mix,
P = f <- dpois(M, lambda[i]),
- # FIXME: Add ZIP
+ ZIP = f <- dzip(M, lambda[i], psi),
NB = f <- dnbinom(M, mu=lambda[i], size=alpha))
g <- rep(1, K+1) # outside t loop
for(t in 1:T) {
@@ -528,11 +531,15 @@ setMethod("ranef", "unmarkedFitGPC",
mix <- object@mixture
if(identical(mix, "NB"))
alpha <- exp(coef(object, type="alpha"))
+ if(identical(mix, "ZIP"))
+ psi <- plogis(coef(object, type="psi"))
+
for(i in 1:R) {
switch(mix,
P = f <- dpois(M, lambda[i]),
- # FIXME: Add ZIP
- NB = f <- dnbinom(M, mu=lambda[i], size=alpha))
+ NB = f <- dnbinom(M, mu=lambda[i], size=alpha),
+ ZIP = f <- dzip(M, lambda=lambda[i], psi=psi)
+ )
ghi <- rep(0, lM)
for(t in 1:T) {
gh <- matrix(-Inf, lM, lM)
diff --git a/R/unmarkedCrossVal.R b/R/unmarkedCrossVal.R
index a49d067..4b186ee 100644
--- a/R/unmarkedCrossVal.R
+++ b/R/unmarkedCrossVal.R
@@ -60,10 +60,10 @@ setMethod("crossVal", "unmarkedFit",
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,
+ stat_raw <- lapply2(1:n_reps, do_crossval, object,
partitions, statistic, ..., cl = cl)
} else {
- stat_raw <- pblapply(1:n_reps, do_crossval, object,
+ stat_raw <- lapply2(1:n_reps, do_crossval, object,
partitions, statistic, ...)
}
diff --git a/R/unmarkedEstimate.R b/R/unmarkedEstimate.R
index 86caf40..71f8716 100644
--- a/R/unmarkedEstimate.R
+++ b/R/unmarkedEstimate.R
@@ -294,7 +294,7 @@ setMethod("vcov", "unmarkedEstimate",
setMethod("confint", "unmarkedEstimate",
function(object, parm, level = 0.95)
{
- if(missing(parm)) parm <- 1:length(object@estimates)
+ if(missing(parm)) parm <- object@fixed
ests <- object@estimates[parm]
ses <- SE(object)[parm]
z <- qnorm((1-level)/2, lower.tail = FALSE)
diff --git a/R/unmarkedFit.R b/R/unmarkedFit.R
index d965d48..84740b3 100644
--- a/R/unmarkedFit.R
+++ b/R/unmarkedFit.R
@@ -363,7 +363,7 @@ setMethod("confint", "unmarkedFit", function(object, parm, level = 0.95,
if(missing(type))
stop(paste("Must specify type as one of (", paste(names(object), collapse=", "),").",sep=""))
if(missing(parm))
- parm <- 1:length(object[type]@estimates)
+ parm <- object[type]@fixed
if(method == "normal") {
callGeneric(object[type],parm = parm, level = level)
} else {
@@ -827,6 +827,11 @@ setMethod("fitted", "unmarkedFitGMM",
T <- data@numPrimary
J <- ncol(y) / T
lambda <- drop(exp(Xlam %*% coef(object, 'lambda') + Xlam.offset))
+ if(identical(object@mixture, "ZIP")) {
+ psi <- plogis(coef(object, type="psi"))
+ lambda <- (1-psi)*lambda
+ }
+
if(T==1)
phi <- 1
else
@@ -2872,7 +2877,12 @@ setMethod("simulate", "unmarkedFitGMM",
switch(mixture,
P = M <- rpois(n=n, lambda=lam),
NB = M <- rnbinom(n=n, mu=lam,
- size=exp(coef(object, type="alpha"))))
+ size=exp(coef(object, type="alpha"))),
+ ZIP = {
+ psi <- plogis(coef(object['psi']))
+ M <- rzip(n, lambda=lam, psi=psi)
+ }
+ )
N <- rbinom(n*T, size=M, prob=phi.mat)
# bug fix 3/16/2010
@@ -2938,10 +2948,15 @@ setMethod("simulate", "unmarkedFitGPC",
simList <- list()
for(s in 1:nsim) {
switch(mixture,
- P = M <- rpois(n=R, lambda=lam),
+ P = M <- rpois(n=R, lambda=lam),
# FIXME: Add ZIP
- NB = M <- rnbinom(n=R, mu=lam,
- size=exp(coef(object, type="alpha"))))
+ NB = M <- rnbinom(n=R, mu=lam,
+ size=exp(coef(object, type="alpha"))),
+ ZIP = {
+ psi <- plogis(coef(object['psi']))
+ M <- rzip(R, lambda=lam, psi=psi)
+ }
+ )
N <- rbinom(R*T, size=M, prob=phi.mat)
N <- matrix(N, nrow=R, ncol=T, byrow=FALSE)
@@ -3031,7 +3046,12 @@ setMethod("simulate", "unmarkedFitGDS",
NB = {
alpha <- exp(coef(object, type="alpha"))
Ns <- rnbinom(1, mu=lambda[i], size=alpha)
- })
+ },
+ ZIP = {
+ psi <- plogis(coef(object['psi']))
+ Ns <- rzip(1, lambda[i], psi)
+ }
+ )
for(t in 1:T) {
N <- rbinom(1, Ns, phi[i,t])
cp.it <- cpa[i,,t]
diff --git a/R/unmarkedFrame.R b/R/unmarkedFrame.R
index f2f15e2..b97f23b 100644
--- a/R/unmarkedFrame.R
+++ b/R/unmarkedFrame.R
@@ -160,7 +160,13 @@ setClass("unmarkedFrameDSO",
#Convert covs provided as list of matrices/dfs to data frame
covsToDF <- function(covs, name, obsNum, numSites){
- if(!inherits(covs, "list")) return(covs)
+ if(is.null(covs)) return(covs)
+ if(inherits(covs, "data.frame")){
+ if(nrow(covs) != (obsNum * numSites)){
+ stop("Incorrect number of rows in ", name, " data frame", call.=FALSE)
+ }
+ return(covs)
+ }
if(is.null(names(covs)) | any(is.na(names(covs))) | any(names(covs)=="")){
stop("All elements of list provided to ", name, " argument must be named", call.=FALSE)
@@ -178,8 +184,11 @@ covsToDF <- function(covs, name, obsNum, numSites){
# Constructor for unmarkedFrames.
unmarkedFrame <- function(y, siteCovs = NULL, obsCovs = NULL, mapInfo,
obsToY) {
- if(!missing(obsToY))
+ if(!missing(obsToY)){
obsNum <- nrow(obsToY)
+ } else {
+ obsNum <- ncol(y)
+ }
if(is.null(obsNum) & inherits(obsCovs, "list"))
obsNum <- ncol(obsCovs[[1]]) #??
@@ -1488,14 +1497,21 @@ setMethod("[", c("unmarkedFrameOccuTTD", "missing", "numeric", "missing"),
if(any(j>x@numPrimary)) stop("Can't select primary periods that don't exist", call.=FALSE)
if(!all(j>0)) stop("All indices must be positive", call.=FALSE)
-
- pp_vec <- rep(1:x@numPrimary, each=ncol(getY(x))/x@numPrimary)
+
+ R <- ncol(getY(x))/x@numPrimary
+ pp_vec <- rep(1:x@numPrimary, each=R)
keep_cols <- which(pp_vec%in%j)
y <- getY(x)[,keep_cols,drop=FALSE]
- ysc <- yearlySiteCovs(x)[,j,drop=FALSE]
- oc <- obsCovs(x)[,keep_cols,drop=FALSE]
sl <- x@surveyLength[,keep_cols,drop=FALSE]
+ pp_vec2 <- rep(1:x@numPrimary, numSites(x))
+ keep_rows <- which(pp_vec2 %in% j)
+ ysc <- yearlySiteCovs(x)[keep_rows,,drop=FALSE]
+
+ obs_vec <- rep(rep(1:x@numPrimary, each = R), numSites(x))
+ keep_rows <- which(obs_vec %in% j)
+ oc <- obsCovs(x)[keep_rows,,drop=FALSE]
+
unmarkedFrameOccuTTD(y=y, surveyLength=sl, siteCovs=siteCovs(x),
yearlySiteCovs=ysc, obsCovs=oc,
numPrimary=length(j))
diff --git a/R/utils.R b/R/utils.R
index 9e9dff6..8b977eb 100644
--- a/R/utils.R
+++ b/R/utils.R
@@ -47,9 +47,11 @@ logistic.grad <- function(x) {
}
-log.grad <- function(x) { # duh! (but for clarity)
- 1/x
-}
+# This function causes check failures on CRAN because CRAN thinks it's
+# a method for the log function. I don't think it's actually used in the package?
+#log.grad <- function(x) { # duh! (but for clarity)
+# 1/x
+#}
explink <- function(x) exp(x)
@@ -907,3 +909,21 @@ E_loglam <- function(log_lam, object, name){
ll <- log_lam + v/2
ll
}
+
+sapply2 <- function(X, FUN, ..., cl = NULL){
+ if(requireNamespace("pbapply", quietly=TRUE)){
+ return(pbapply::pbsapply(X=X, FUN=FUN, ..., cl = cl))
+ } else if(!is.null(cl)){
+ return(parallel::parSapply(cl=cl, X=X, FUN=FUN, ...))
+ }
+ sapply(X=X, FUN=FUN, ...)
+}
+
+lapply2 <- function(X, FUN, ..., cl = NULL){
+ if(requireNamespace("pbapply", quietly=TRUE)){
+ return(pbapply::pblapply(X=X, FUN=FUN, ..., cl = cl))
+ } else if(!is.null(cl)){
+ return(parallel::parLapply(cl=cl, X=X, fun=FUN, ...))
+ }
+ lapply(X=X, FUN=FUN, ...)
+}
diff --git a/_pkgdown.yml b/_pkgdown.yml
index 25e44c8..831489f 100644
--- a/_pkgdown.yml
+++ b/_pkgdown.yml
@@ -19,6 +19,7 @@ reference:
- occuMulti
- occuPEN
- occuTTD
+ - occuCOP
- title: Abundance models
contents:
- occuRN
@@ -48,6 +49,28 @@ reference:
- fitList
- modSel
- crossVal,unmarkedFit-method
+ - title: Model data
+ - unmarkedFrame
+ - unmarkedFrame-class
+ - unmarkedMultFrame
+ - unmarkedFrameDS
+ - unmarkedFrameOccu
+ - unmarkedFrameOccuFP
+ - unmarkedFrameOccuMulti
+ - unmarkedFramePCount
+ - unmarkedFrameMPois
+ - unmarkedFrameOccuCOP
+ - unmarkedFrameOccuMS
+ - unmarkedFrameOccuTTD
+ - unmarkedFrameG3
+ - unmarkedFramePCO
+ - unmarkedFrameGDR
+ - unmarkedFrameGMM
+ - unmarkedFrameGDS
+ - unmarkedFrameGPC
+ - unmarkedFrameGOccu
+ - unmarkedFrameMMO
+ - unmarkedFrameDSO
- title: Model results
contents:
- coef,unmarkedFit-method
diff --git a/inst/CITATION b/inst/CITATION
index c0e67d6..66c3000 100644
--- a/inst/CITATION
+++ b/inst/CITATION
@@ -1,8 +1,30 @@
citHeader("To cite unmarked in publications use:")
-citEntry(entry = "Article",
+bibentry(bibtype = "Article",
+ title = "The {unmarked} {R} package: Twelve years of advances in occurrence and abundance modelling in ecology",
+ author = c(as.person("Kenneth F. Kellner"),
+ as.person("Adam D. Smith"),
+ as.person("J. Andrew Royle"),
+ as.person("Marc Kery"),
+ as.person("Jerrold L. Belant"),
+ as.person("Richard B. Chandler")),
+ journal = "Methods in Ecology and Evolution",
+ year = "2023",
+ volume = "14",
+ number = "6",
+ pages = "1408--1415",
+ url = "https://www.jstatsoft.org/v43/i10/",
+
+ textVersion =
+ paste("Kellner KF, Smith AD, Royle JA, Kery M, Belant JL, Chandler RB (2023).",
+ "The unmarked R package: Twelve years of advances in occurrence and abundance modelling in ecology.",
+ "Methods in Ecology and Evolution, 14(6), 1408-1415.",
+ "URL https://doi.org/10.1111/2041-210X.14123")
+)
+
+bibentry(bibtype = "Article",
title = "{unmarked}: An {R} Package for Fitting Hierarchical Models of Wildlife Occurrence and Abundance",
- author = personList(as.person("Ian Fiske"),
+ author = c(as.person("Ian Fiske"),
as.person("Richard Chandler")),
journal = "Journal of Statistical Software",
year = "2011",
diff --git a/man/MesoCarnivores.Rd b/man/MesoCarnivores.Rd
index c51e06f..7a58077 100644
--- a/man/MesoCarnivores.Rd
+++ b/man/MesoCarnivores.Rd
@@ -17,13 +17,13 @@
\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}}
+ \describe{
+ \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}
}
}
}
diff --git a/man/fitted-methods.Rd b/man/fitted-methods.Rd
index 8c594d4..9ead41c 100644
--- a/man/fitted-methods.Rd
+++ b/man/fitted-methods.Rd
@@ -16,6 +16,8 @@
\alias{fitted,unmarkedFitGDR-method}
\alias{fitted,unmarkedFitIDS-method}
\alias{fitted,unmarkedFitDailMadsen-method}
+\alias{fitted,unmarkedFitGOccu-method}
+\alias{fitted,unmarkedFitOccuCOP-method}
\title{Methods for Function fitted in Package `unmarked'}
\description{Extracted fitted values from a fitted model.
diff --git a/man/gdistsamp.Rd b/man/gdistsamp.Rd
index 323f5cc..1e15cac 100644
--- a/man/gdistsamp.Rd
+++ b/man/gdistsamp.Rd
@@ -11,7 +11,7 @@ to be modeled using the negative binomial distribution.
\usage{
gdistsamp(lambdaformula, phiformula, pformula, data, keyfun =
c("halfnorm", "exp", "hazard", "uniform"), output = c("abund",
-"density"), unitsOut = c("ha", "kmsq"), mixture = c("P", "NB"), K,
+"density"), unitsOut = c("ha", "kmsq"), mixture = c("P", "NB", "ZIP"), K,
starts, method = "BFGS", se = TRUE, engine=c("C","R"), rel.tol=1e-4, threads=1, ...)
}
\arguments{
@@ -39,8 +39,8 @@ starts, method = "BFGS", se = TRUE, engine=c("C","R"), rel.tol=1e-4, threads=1,
kilometers, respectively.
}
\item{mixture}{
- Either "P" or "NB" for the Poisson and negative binomial models of
- abundance.
+ Either "P", "NB", or "ZIP" for the Poisson, negative binomial, or
+ zero-inflated Poisson models of abundance.
}
\item{K}{
An integer value specifying the upper bound used in the integration.
diff --git a/man/getP-methods.Rd b/man/getP-methods.Rd
index 4ea45ee..32028ab 100644
--- a/man/getP-methods.Rd
+++ b/man/getP-methods.Rd
@@ -18,16 +18,19 @@
\alias{getP,unmarkedFitMMO-method}
\alias{getP,unmarkedFitGDR-method}
\alias{getP,unmarkedFitIDS-method}
+\alias{getP,unmarkedFitGOccu-method}
+\alias{getP,unmarkedFitOccuCOP-method}
+
\title{Methods for Function getP in Package `unmarked'}
\description{
-Methods for function \code{getP} in Package `unmarked'. These methods
-return a matrix of detection probabilities.
+Methods for function \code{getP} in Package `unmarked'. These methods return a matrix of the back-transformed detection parameter (\eqn{p} the detection probability or \eqn{\lambda} the detection rate, depending on the model). The matrix is of dimension MxJ, with M the number of sites and J the number of sampling periods; or of dimension MxJT for models with multiple primary periods T.
}
\section{Methods}{
\describe{
-\item{object = "unmarkedFit"}{A fitted model object}
-\item{object = "unmarkedFitDS"}{A fitted model object}
-\item{object = "unmarkedFitMPois"}{A fitted model object}
-\item{object = "unmarkedFitGMM"}{A fitted model object}
+\item{\code{signature(object = "unmarkedFit")}}{A fitted model object}
+\item{\code{signature(object = "unmarkedFitDS")}}{A fitted model object}
+\item{\code{signature(object = "unmarkedFitMPois")}}{A fitted model object}
+\item{\code{signature(object = "unmarkedFitGMM")}}{A fitted model object}
+\item{\code{signature(object = "unmarkedFitOccuCOP")}}{With \code{unmarkedFitOccuCOP} the object of a model fitted with \code{occuCOP}. Returns a matrix of \eqn{\lambda} the detection rate.}
}}
\keyword{methods}
diff --git a/man/gmultmix.Rd b/man/gmultmix.Rd
index b54701c..40f6007 100644
--- a/man/gmultmix.Rd
+++ b/man/gmultmix.Rd
@@ -9,7 +9,7 @@ The three model parameters are abundance, availability, and detection
probability.
}
\usage{
-gmultmix(lambdaformula, phiformula, pformula, data, mixture = c("P", "NB"), K,
+gmultmix(lambdaformula, phiformula, pformula, data, mixture = c("P", "NB", "ZIP"), K,
starts, method = "BFGS", se = TRUE, engine=c("C","R"), threads=1, ...)
}
\arguments{
@@ -18,8 +18,8 @@ gmultmix(lambdaformula, phiformula, pformula, data, mixture = c("P", "NB"), K,
\item{phiformula}{RHS formula describing availability covariates}
\item{pformula}{RHS formula describing detection covariates}
\item{data}{An object of class unmarkedFrameGMM}
- \item{mixture}{Either "P" or "NB" for Poisson and Negative Binomial mixing
- distributions.}
+ \item{mixture}{Either "P", "NB", or "ZIP" for the Poisson, negative binomial, or
+ zero-inflated Poisson models of abundance}
\item{K}{The upper bound of integration}
\item{starts}{Starting values}
\item{method}{Optimization method used by \code{\link{optim}}}
@@ -35,16 +35,16 @@ gmultmix(lambdaformula, phiformula, pformula, data, mixture = c("P", "NB"), K,
}
\details{
The latent transect-level super-population abundance distribution
-\eqn{f(M | \mathbf{\theta})}{f(M | theta)} can be set as either a
-Poisson or
-a negative binomial random variable, depending on the setting of the
-\code{mixture} argument. \code{mixture = "P"} or \code{mixture = "NB"}
-select
-the Poisson or negative binomial distribution respectively. The mean of
-\eqn{M_i} is \eqn{\lambda_i}{lambda_i}. If \eqn{M_i \sim NB}{M_i ~ NB},
-then an
-additional parameter, \eqn{\alpha}{alpha}, describes dispersion (lower
-\eqn{\alpha}{alpha} implies higher variance).
+\eqn{f(M | \mathbf{\theta})}{f(M | theta)} can be set as a
+Poisson, negative binomial, or zero-inflated Poisson random variable,
+depending on the setting of the \code{mixture} argument.
+\code{mixture = "P"}, \code{mixture = "NB"}, and \code{mixture = "ZIP"}
+select the Poisson, negative binomial, and zero-inflated Poisson distributions
+respectively. The mean of \eqn{M_i} is \eqn{\lambda_i}{lambda_i}.
+If \eqn{M_i \sim NB}{M_i ~ NB}, then an additional parameter, \eqn{\alpha}{alpha},
+describes dispersion (lower \eqn{\alpha}{alpha} implies higher variance). If
+\eqn{M_i \sim ZIP}{M_i ~ ZIP}, then an additional zero-inflation parameter
+\eqn{\psi}{psi} is estimated.
The number of individuals available for detection at time j
is a modeled as binomial:
diff --git a/man/goccu.Rd b/man/goccu.Rd
new file mode 100644
index 0000000..ef9f08c
--- /dev/null
+++ b/man/goccu.Rd
@@ -0,0 +1,105 @@
+\name{goccu}
+\alias{goccu}
+\title{
+Fit multi-scale occupancy models
+}
+\description{
+Fit multi-scale occupancy models as described in Nichols et al. (2008) to
+repeated presence-absence data collected using the robust design. This model
+allows for inference about occupancy, availability, and detection probability.
+}
+\usage{
+goccu(psiformula, phiformula, pformula, data, linkPsi = c("logit", "cloglog"),
+ starts, method = "BFGS", se = TRUE, ...)
+}
+\arguments{
+ \item{psiformula}{
+ Right-hand sided formula describing occupancy covariates
+}
+ \item{phiformula}{
+ Right-hand sided formula describing availability covariates
+}
+ \item{pformula}{
+ Right-hand sided formula for detection probability covariates
+}
+ \item{data}{
+ An object of class unmarkedFrameGOccu or unmarkedMultFrame
+}
+\item{linkPsi}{Link function for the occupancy model. Options are
+ \code{"logit"} for the standard occupancy model or \code{"cloglog"}
+ for the complimentary log-log link, which relates occupancy
+ to site-level abundance.
+}
+\item{starts}{
+ Starting values
+}
+ \item{method}{
+ Optimization method used by \code{\link{optim}}
+}
+ \item{se}{
+ Logical. Should standard errors be calculated?
+}
+\item{\dots}{
+ Additional arguments to \code{\link{optim}}, such as lower and upper
+ bounds
+}
+}
+\details{
+ Primary periods could represent spatial or temporal sampling replicates.
+ For example, you could have several spatial sub-units within each site, where each
+ sub-unit was then sampled repeatedly. This is a frequent design for eDNA studies.
+ Or, you could have multiple primary periods of sampling at each site
+ (conducted at different times within a season), each of which contains
+ several secondary sampling periods. In both cases the robust design structure
+ can be used to estimate an availability probability in addition to
+ detection probability. See Kery and Royle (2015) 10.10 for more details.
+}
+\value{
+ An object of class unmarkedFitGOccu
+}
+\references{
+ Kery, M., & Royle, J. A. (2015). Applied hierarchical modeling in ecology:
+ Volume 1: Prelude and static models. Elsevier Science.
+
+ Nichols, J. D., Bailey, L. L., O'Connell Jr, A. F., Talancy, N. W.,
+ Campbell Grant, E. H., Gilbert, A. T., Annand E. M., Husband, T. P., & Hines, J. E.
+ (2008). Multi-scale occupancy estimation and modelling using multiple detection methods.
+ Journal of Applied Ecology, 45(5), 1321-1329.
+}
+\author{
+ Ken Kellner \email{contact@kenkellner.com}
+}
+
+\seealso{
+\code{\link{occu}}, \code{\link{colext}},
+ \code{\link{unmarkedMultFrame}}, \code{\link{unmarkedFrameGOccu}}
+}
+
+\examples{
+
+set.seed(123)
+M <- 100
+T <- 5
+J <- 4
+
+psi <- 0.5
+phi <- 0.3
+p <- 0.4
+
+z <- rbinom(M, 1, psi)
+zmat <- matrix(z, nrow=M, ncol=T)
+
+zz <- rbinom(M*T, 1, zmat*phi)
+zz <- matrix(zz, nrow=M, ncol=T)
+
+zzmat <- zz[,rep(1:T, each=J)]
+y <- rbinom(M*T*J, 1, zzmat*p)
+y <- matrix(y, M, J*T)
+umf <- unmarkedMultFrame(y=y, numPrimary=T)
+
+\dontrun{
+ mod <- goccu(psiformula = ~1, phiformula = ~1, pformula = ~1, umf)
+ plogis(coef(mod))
+}
+
+}
diff --git a/man/gpcount.Rd b/man/gpcount.Rd
index f847baa..b7e3b1a 100644
--- a/man/gpcount.Rd
+++ b/man/gpcount.Rd
@@ -10,7 +10,7 @@ population size, availability, and detection probability.
}
\usage{
gpcount(lambdaformula, phiformula, pformula, data,
-mixture = c("P", "NB"), K, starts, method = "BFGS", se = TRUE,
+mixture = c("P", "NB", "ZIP"), K, starts, method = "BFGS", se = TRUE,
engine = c("C", "R"), threads=1, ...)
}
\arguments{
@@ -27,7 +27,8 @@ engine = c("C", "R"), threads=1, ...)
An object of class unmarkedFrameGPC
}
\item{mixture}{
- Either "P" or "NB" for Poisson and negative binomial distributions
+ Either "P", "NB", or "ZIP" for Poisson, negative binomial, or
+ zero-inflated Poisson distributions
}
\item{K}{
The maximum possible value of M, the super-population size.
@@ -58,11 +59,13 @@ engine = c("C", "R"), threads=1, ...)
\details{
The latent transect-level super-population abundance distribution
\eqn{f(M | \mathbf{\theta})}{f(M | theta)} can be set as either a
- Poisson or a negative binomial random variable, depending on the
+ Poisson, negative binomial, or zero-inflated Poisson random variable, depending on the
setting of the \code{mixture} argument. The expected value of
\eqn{M_i} is \eqn{\lambda_i}{lambda_i}. If \eqn{M_i \sim NB}{M_i ~ NB},
then an additional parameter, \eqn{\alpha}{alpha}, describes
- dispersion (lower \eqn{\alpha}{alpha} implies higher variance).
+ dispersion (lower \eqn{\alpha}{alpha} implies higher variance). If
+ \eqn{M_i \sim ZIP}{M_i ~ ZIP}, then an additional zero-inflation parameter
+ \eqn{\psi}{psi} is estimated.
The number of individuals available for detection at time j
is a modeled as binomial:
diff --git a/man/nonparboot-methods.Rd b/man/nonparboot-methods.Rd
index e13df14..53ff723 100644
--- a/man/nonparboot-methods.Rd
+++ b/man/nonparboot-methods.Rd
@@ -19,6 +19,7 @@
\alias{nonparboot,unmarkedFitGDR-method}
\alias{nonparboot,unmarkedFitIDS-method}
\alias{nonparboot,unmarkedFitDailMadsen-method}
+\alias{nonparboot,unmarkedFitOccuCOP-method}
\title{ Nonparametric bootstrapping in unmarked }
diff --git a/man/occuCOP.Rd b/man/occuCOP.Rd
new file mode 100644
index 0000000..7549ca3
--- /dev/null
+++ b/man/occuCOP.Rd
@@ -0,0 +1,249 @@
+\name{occuCOP}
+
+\alias{occuCOP}
+
+\encoding{UTF-8}
+
+\title{Fit the occupancy model using count dta}
+
+\usage{
+occuCOP(data,
+ psiformula = ~1, lambdaformula = ~1,
+ psistarts, lambdastarts, starts,
+ method = "BFGS", se = TRUE,
+ engine = c("C", "R"), na.rm = TRUE,
+ return.negloglik = NULL, L1 = FALSE, ...)}
+
+\arguments{
+
+ \item{data}{An \code{\link{unmarkedFrameOccuCOP}} object created with the \code{\link{unmarkedFrameOccuCOP}} function.}
+
+ \item{psiformula}{Formula describing the occupancy covariates.}
+
+ \item{lambdaformula}{Formula describing the detection covariates.}
+
+ \item{psistarts}{Vector of starting values for likelihood maximisation with \code{\link{optim}} for occupancy probability \eqn{\psi}{psi}. These values must be logit-transformed (with \code{\link{qlogis}}) (see details). By default, optimisation will start at 0, corresponding to an occupancy probability of 0.5 (\code{plogis(0)} is 0.5).}
+
+ \item{lambdastarts}{Vector of starting values for likelihood maximisation with \code{\link{optim}} for detection rate \eqn{\lambda}{lambda}. These values must be log-transformed (with \code{\link{log}}) (see details). By default, optimisation will start at 0, corresponding to detection rate of 1 (\code{exp(0)} is 1).}
+
+ \item{starts}{Vector of starting values for likelihood maximisation with \code{\link{optim}}. If \code{psistarts} and \code{lambdastarts} are provided, \code{starts = c(psistarts, lambdastarts)}.}
+
+ \item{method}{Optimisation method used by \code{\link{optim}}.}
+
+ \item{se}{Logical specifying whether to compute (\code{se=TRUE}) standard errors or not (\code{se=FALSE}).}
+
+ \item{engine}{Code to use for optimisation. Either \code{"C"} for fast C++ code, or \code{"R"} for native R code.}
+
+ \item{na.rm}{Logical specifying whether to fit the model (\code{na.rm=TRUE}) or not (\code{na.rm=FALSE}) if there are NAs in the \code{\link{unmarkedFrameOccuCOP}} object.}
+
+ \item{return.negloglik}{A list of vectors of parameters (\code{c(psiparams, lambdaparams)}). If specified, the function will not maximise likelihood but return the negative log-likelihood for the those parameters in the \code{nll} column of a dataframe. See an example below.}
+
+ \item{L1}{Logical specifying whether the length of observations (\code{L}) are purposefully set to 1 (\code{L1=TRUE}) or not (\code{L1=FALSE}).}
+
+ \item{\dots}{Additional arguments to pass to \code{\link{optim}}, such as lower and upper bounds or a list of control parameters.}
+ }
+
+\description{This function fits a single season occupancy model using count data.}
+
+\details{
+
+ See \code{\link{unmarkedFrameOccuCOP}} for a description of how to supply data to the \code{data} argument. See \code{\link{unmarkedFrame}} for a more general documentation of \code{unmarkedFrame} objects for the different models implemented in \pkg{unmarked}.
+
+ \subsection{The COP occupancy model}{
+
+ \code{occuCOP} fits a single season occupancy model using count data, as described in Pautrel et al. (2023).
+
+ The \strong{occupancy sub-model} is:
+
+ \deqn{z_i \sim \text{Bernoulli}(\psi_i)}{z_i ~ Bernoulli(psi_i)}
+
+ \itemize{
+ \item With \eqn{z_i}{z_i} the occupany state of site \eqn{i}{i}. \eqn{z_i=1}{z_i = 1} if site \eqn{i}{i} is occupied by the species, \emph{i.e.} if the species is present in site \eqn{i}{i}. \eqn{z_i=0}{z_i = 0} if site \eqn{i}{i} is not occupied.
+ \item With \eqn{\psi_i}{psi_i} the occupancy probability of site \eqn{i}{i}.
+ }
+
+ The \strong{observation sub-model} is:
+
+ \deqn{
+ N_{ij} | z_i = 1 \sim \text{Poisson}(\lambda_{ij} L_{ij}) \\
+ N_{ij} | z_i = 0 \sim 0
+ }{
+ N_ij | z_i = 1 ~ Poisson(lambda_is*L_is)
+ N_ij | z_i = 0 ~ 0
+ }
+
+ \itemize{
+ \item With \eqn{N_{ij}}{N_ij} the count of detection events in site \eqn{i}{i} during observation \eqn{j}{j}.
+ \item With \eqn{\lambda_{ij}}{lambda_ij} the detection rate in site \eqn{i}{i} during observation \eqn{j}{j} (\emph{for example, 1 detection per day.}).
+ \item With \eqn{L_{ij}}{L_ij} the length of observation \eqn{j}{j} in site \eqn{i}{i} (\emph{for example, 7 days.}).
+ }
+
+ What we call "observation" (\eqn{j}{j}) here can be a sampling occasion, a transect, a discretised session. Consequently, the unit of \eqn{\lambda_{ij}}{lambda_ij} and \eqn{L_{ij}}{L_ij} can be either a time-unit (day, hour, ...) or a space-unit (kilometer, meter, ...).
+ }
+
+ \subsection{The transformation of parameters \eqn{\psi} and \eqn{\lambda}}{
+ In order to perform unconstrained optimisation, parameters are transformed.
+
+ The occupancy probability (\eqn{\psi}) is transformed with the logit function (\code{psi_transformed = qlogis(psi)}). It can be back-transformed with the "inverse logit" function (\code{psi = plogis(psi_transformed)}).
+
+ The detection rate (\eqn{\lambda}) is transformed with the log function (\code{lambda_transformed = log(lambda)}). It can be back-transformed with the exponential function (\code{lambda = exp(lambda_transformed)}).
+ }
+
+}
+
+\value{\code{unmarkedFitOccuCOP} object describing the model fit. See the \code{\linkS4class{unmarkedFit}} classes.}
+
+\references{
+
+Pautrel, L., Moulherat, S., Gimenez, O. & Etienne, M.-P. Submitted. \emph{Analysing biodiversity observation data collected in continuous time: Should we use discrete or continuous-time occupancy models?} Preprint at \doi{10.1101/2023.11.17.567350}.
+
+}
+
+\author{Léa Pautrel}
+
+\seealso{
+ \code{\link{unmarked}},
+ \code{\link{unmarkedFrameOccuCOP}},
+ \code{\link{unmarkedFit-class}}
+}
+
+
+\examples{
+set.seed(123)
+options(max.print = 50)
+
+# We simulate data in 100 sites with 3 observations of 7 days per site.
+nSites <- 100
+nObs <- 3
+
+# For an occupancy covariate, we associate each site to a land-use category.
+landuse <- sample(factor(c("Forest", "Grassland", "City"), ordered = TRUE),
+ size = nSites, replace = TRUE)
+simul_psi <- ifelse(landuse == "Forest", 0.8,
+ ifelse(landuse == "Grassland", 0.4, 0.1))
+z <- rbinom(n = nSites, size = 1, prob = simul_psi)
+
+# For a detection covariate, we create a fake wind variable.
+wind <- matrix(rexp(n = nSites * nObs), nrow = nSites, ncol = nObs)
+simul_lambda <- wind / 5
+L = matrix(7, nrow = nSites, ncol = nObs)
+
+# We now simulate count detection data
+y <- matrix(rpois(n = nSites * nObs, lambda = simul_lambda * L),
+ nrow = nSites, ncol = nObs) * z
+
+# We create our unmarkedFrameOccuCOP object
+umf <- unmarkedFrameOccuCOP(
+ y = y,
+ L = L,
+ siteCovs = data.frame("landuse" = landuse),
+ obsCovs = list("wind" = wind)
+)
+print(umf)
+
+# We fit our model without covariates
+fitNull <- occuCOP(data = umf)
+print(fitNull)
+
+# We fit our model with covariates
+fitCov <- occuCOP(data = umf, psiformula = ~ landuse, lambdaformula = ~ wind)
+print(fitCov)
+
+# We back-transform the parameter's estimates
+## Back-transformed occupancy probability with no covariates
+backTransform(fitNull, "psi")
+
+## Back-transformed occupancy probability depending on habitat use
+predict(fitCov,
+ "psi",
+ newdata = data.frame("landuse" = c("Forest", "Grassland", "City")),
+ appendData = TRUE)
+
+## Back-transformed detection rate with no covariates
+backTransform(fitNull, "lambda")
+
+## Back-transformed detection rate depending on wind
+predict(fitCov,
+ "lambda",
+ appendData = TRUE)
+
+## This is not easily readable. We can show the results in a clearer way, by:
+## - adding the site and observation
+## - printing only the wind covariate used to get the predicted lambda
+cbind(
+ data.frame(
+ "site" = rep(1:nSites, each = nObs),
+ "observation" = rep(1:nObs, times = nSites),
+ "wind" = getData(fitCov)@obsCovs
+ ),
+ predict(fitCov, "lambda", appendData = FALSE)
+)
+
+# We can choose the initial parameters when fitting our model.
+# For psi, intituively, the initial value can be the proportion of sites
+# in which we have observations.
+(psi_init <- mean(rowSums(y) > 0))
+
+# For lambda, the initial value can be the mean count of detection events
+# in sites in which there was at least one observation.
+(lambda_init <- mean(y[rowSums(y) > 0, ]))
+
+# We have to transform them.
+occuCOP(
+ data = umf,
+ psiformula = ~ 1,
+ lambdaformula = ~ 1,
+ psistarts = qlogis(psi_init),
+ lambdastarts = log(lambda_init)
+)
+
+# If we have covariates, we need to have the right length for the start vectors.
+# psi ~ landuse --> 3 param to estimate: Intercept, landuseForest, landuseGrassland
+# lambda ~ wind --> 2 param to estimate: Intercept, wind
+occuCOP(
+ data = umf,
+ psiformula = ~ landuse,
+ lambdaformula = ~ wind,
+ psistarts = rep(qlogis(psi_init), 3),
+ lambdastarts = rep(log(lambda_init), 2)
+)
+
+# And with covariates, we could have chosen better initial values, such as the
+# proportion of sites in which we have observations per land-use category.
+(psi_init_covs <- c(
+ "City" = mean(rowSums(y[landuse == "City", ]) > 0),
+ "Forest" = mean(rowSums(y[landuse == "Forest", ]) > 0),
+ "Grassland" = mean(rowSums(y[landuse == "Grassland", ]) > 0)
+))
+occuCOP(
+ data = umf,
+ psiformula = ~ landuse,
+ lambdaformula = ~ wind,
+ psistarts = qlogis(psi_init_covs))
+
+# We can fit our model with a different optimisation algorithm.
+occuCOP(data = umf, method = "Nelder-Mead")
+
+# We can run our model with a C++ or with a R likelihood function.
+## They give the same result.
+occuCOP(data = umf, engine = "C", psistarts = 0, lambdastarts = 0)
+occuCOP(data = umf, engine = "R", psistarts = 0, lambdastarts = 0)
+
+## The C++ (the default) is faster.
+system.time(occuCOP(data = umf, engine = "C", psistarts = 0, lambdastarts = 0))
+system.time(occuCOP(data = umf, engine = "R", psistarts = 0, lambdastarts = 0))
+
+## However, if you want to understand how the likelihood is calculated,
+## you can easily access the R likelihood function.
+print(occuCOP(data = umf, engine = "R", psistarts = 0, lambdastarts = 0)@nllFun)
+
+# Finally, if you do not want to fit your model but only get the likelihood,
+# you can get the negative log-likelihood for a given set of parameters.
+occuCOP(data = umf, return.negloglik = list(
+ c("psi" = qlogis(0.25), "lambda" = log(2)),
+ c("psi" = qlogis(0.5), "lambda" = log(1)),
+ c("psi" = qlogis(0.75), "lambda" = log(0.5))
+))
+}
+
+\keyword{models}
diff --git a/man/occuFP.Rd b/man/occuFP.Rd
index 64feff2..daadb4e 100644
--- a/man/occuFP.Rd
+++ b/man/occuFP.Rd
@@ -45,7 +45,7 @@ are specified to belong to 1 of the 3 data types and all or a subset of the data
For type 1 data, the detection process is assumed to fit the assumptions of the standard MacKenzie model
where false negative probabilities are estimated but false positive detections are assumed not to occur. If all of your
-data is of this type you should use code{occu} to analyze data. The detection parameter p, which is modeled using the
+data is of this type you should use \code{occu} to analyze data. The detection parameter p, which is modeled using the
detformula is the only observation parameter for these data.
For type 2 data, both false negative and false positive detection probabilities are estimated. If all data is of this
diff --git a/man/ranef-methods.Rd b/man/ranef-methods.Rd
index abf0c68..1eb0704 100644
--- a/man/ranef-methods.Rd
+++ b/man/ranef-methods.Rd
@@ -20,6 +20,8 @@
\alias{ranef,unmarkedFitNmixTTD-method}
\alias{ranef,unmarkedFitGDR-method}
\alias{ranef,unmarkedFitDailMadsen-method}
+\alias{ranef,unmarkedFitGOccu-method}
+\alias{ranef,unmarkedFitOccuCOP-method}
\title{ Methods for Function \code{ranef} in Package \pkg{unmarked} }
\description{
Estimate posterior distributions of the random variables (latent
diff --git a/man/simulate-methods.Rd b/man/simulate-methods.Rd
index 392e9db..5d37dad 100644
--- a/man/simulate-methods.Rd
+++ b/man/simulate-methods.Rd
@@ -19,6 +19,8 @@
\alias{simulate,unmarkedFitGDR-method}
\alias{simulate,unmarkedFitIDS-method}
\alias{simulate,unmarkedFitDailMadsen-method}
+\alias{simulate,unmarkedFitGOccu-method}
+\alias{simulate,unmarkedFitOccuCOP-method}
\alias{simulate,character-method}
\title{Methods for Function simulate in Package `unmarked'}
diff --git a/man/unmarked-package.Rd b/man/unmarked-package.Rd
index 3bf8db0..c0595a3 100644
--- a/man/unmarked-package.Rd
+++ b/man/unmarked-package.Rd
@@ -260,6 +260,6 @@ Sillett, S. and Chandler, R.B. and Royle, J.A. and Kery, M. and
\docType{package}
-\author{Ian Fiske, Richard Chandler, Andy Royle, Marc K\'{e}ry, David
+\author{Ian Fiske, Richard Chandler, Andy Royle, Marc Kery, David
Miller, and Rebecca Hutchinson}
\keyword{package}
diff --git a/man/unmarkedFit-class.Rd b/man/unmarkedFit-class.Rd
index d7e8469..8237311 100644
--- a/man/unmarkedFit-class.Rd
+++ b/man/unmarkedFit-class.Rd
@@ -19,6 +19,7 @@
\alias{plot,unmarkedFitOccuMulti,missing-method}
\alias{plot,unmarkedFitGDR,missing-method}
\alias{plot,unmarkedFitIDS,missing-method}
+\alias{plot,unmarkedFitOccuCOP,missing-method}
\alias{profile,unmarkedFit-method}
\alias{residuals,unmarkedFit-method}
\alias{residuals,unmarkedFitOccu-method}
@@ -28,6 +29,7 @@
\alias{residuals,unmarkedFitOccuTTD-method}
\alias{residuals,unmarkedFitGDR-method}
\alias{residuals,unmarkedFitIDS-method}
+\alias{residuals,unmarkedFitOccuCOP-method}
\alias{update,unmarkedFit-method}
\alias{update,unmarkedFitColExt-method}
\alias{update,unmarkedFitGMM-method}
@@ -38,6 +40,7 @@
\alias{update,unmarkedFitGDR-method}
\alias{update,unmarkedFitIDS-method}
\alias{update,unmarkedFitDailMadsen-method}
+\alias{update,unmarkedFitGOccu-method}
\alias{sampleSize}
\alias{sampleSize,unmarkedFit-method}
\alias{unmarkedFitOccu-class}
diff --git a/man/unmarkedFrame-class.Rd b/man/unmarkedFrame-class.Rd
index 9df4157..ab41506 100644
--- a/man/unmarkedFrame-class.Rd
+++ b/man/unmarkedFrame-class.Rd
@@ -51,11 +51,13 @@
\alias{show,unmarkedFrameOccuMulti-method}
\alias{show,unmarkedFrameOccuTTD-method}
\alias{show,unmarkedMultFrame-method}
+\alias{show,unmarkedFrameOccuCOP-method}
\alias{summary,unmarkedFrame-method}
\alias{summary,unmarkedFrameDS-method}
\alias{summary,unmarkedMultFrame-method}
\alias{summary,unmarkedFrameOccuMulti-method}
\alias{summary,unmarkedFrameOccuTTD-method}
+\alias{summary,unmarkedFrameOccuCOP-method}
\alias{[,unmarkedFrameOccuMulti,missing,numeric,missing-method}
\alias{[,unmarkedFrameOccuTTD,missing,numeric,missing-method}
\alias{[,unmarkedFrameGDR,missing,numeric,missing-method}
@@ -65,6 +67,9 @@
\alias{[,unmarkedFrameDSO,numeric,missing,missing-method}
\alias{[,unmarkedFrameGDR,numeric,missing,missing-method}
\alias{[,unmarkedFrameGDR,logical,missing,missing-method}
+\alias{[,unmarkedFrameOccuCOP,missing,numeric,missing-method}
+\alias{[,unmarkedFrameOccuCOP,numeric,missing,missing-method}
+\alias{[,unmarkedFrameOccuCOP,numeric,numeric,missing-method}
\title{Class "unmarkedFrame" }
\description{Methods for manipulating, summarizing and viewing
@@ -120,15 +125,19 @@ argument of the fitting functions.
modify site-level covariates }
\item{summary}{\code{signature(object = "unmarkedFrame")}: summarize
data }
+ \item{getL}{\code{signature(object = "unmarkedFrameOccuCOP")}: extract L }
}
}
-\note{ This is a superclass with child classes for each fitting function }
+\note{ This is a superclass with child classes for each fitting function.}
\seealso{\code{\link{unmarkedFrame}}, \code{\linkS4class{unmarkedFit}},
\code{\link{unmarked-package}}
}
\examples{
+# List all the child classes of unmarkedFrame
+showClass("unmarkedFrame")
+
# Organize data for pcount()
data(mallard)
mallardUMF <- unmarkedFramePCount(mallard.y, siteCovs = mallard.site,
diff --git a/man/unmarkedFrameOccuCOP.Rd b/man/unmarkedFrameOccuCOP.Rd
new file mode 100644
index 0000000..3bc1cb0
--- /dev/null
+++ b/man/unmarkedFrameOccuCOP.Rd
@@ -0,0 +1,105 @@
+\name{unmarkedFrameOccuCOP}
+\alias{unmarkedFrameOccuCOP}
+\alias{getL}
+\alias{getL,unmarkedFrameOccuCOP-method}
+
+\title{Organize data for the occupancy model using count data fit by \code{occuCOP}}
+
+\usage{unmarkedFrameOccuCOP(y, L, siteCovs = NULL, obsCovs = NULL)}
+
+\description{Organizes count data along with the covariates. The \linkS4class{unmarkedFrame} S4 class required by the \code{data} argument of \code{\link{occuCOP}}.}
+
+\arguments{
+
+ \item{y}{An MxJ matrix of the count data, where M is the number of sites, J is the maximum number of observation periods (sampling occasions, transects, discretised sessions...) per site.}
+
+ \item{L}{An MxJ matrix of the length of the observation periods. For example, duration of the sampling occasion in hours, duration of the discretised session in days, or length of the transect in meters.}
+
+ \item{siteCovs}{A \code{\link{data.frame}} of covariates that vary at the site level. This should have M rows and one column per covariate}
+
+ \item{obsCovs}{A named list of dataframes of dimension MxJ, with one dataframe per covariate that varies between sites and observation periods}
+
+ %% \item{mapInfo}{Currently ignored}
+}
+
+\details{
+ unmarkedFrameOccuCOP is the \linkS4class{unmarkedFrame} S4 class that holds data to be passed to the \code{\link{occuCOP}} model-fitting function.
+}
+
+\value{an object of class \code{unmarkedFrameOccuCOP}}
+
+\seealso{
+ \code{\link{unmarkedFrame-class}},
+ \code{\link{unmarkedFrame}},
+ \code{\link{occuCOP}}
+}
+
+\examples{
+# Fake data
+M <- 4 # Number of sites
+J <- 3 # Number of observation periods
+
+# Count data
+(y <- matrix(
+ c(1, 3, 0,
+ 0, 0, 0,
+ 2, 0, 5,
+ 1, NA, 0),
+ nrow = M,
+ ncol = J,
+ byrow = TRUE
+))
+
+# Length of observation periods
+(L <- matrix(
+ c(1, 3, NA,
+ 2, 2, 2,
+ 1, 2, 1,
+ 7, 1, 3),
+ nrow = M,
+ ncol = J,
+ byrow = TRUE
+))
+
+# Site covariates
+(site.covs <- data.frame(
+ "elev" = rexp(4),
+ "habitat" = factor(c("forest", "forest", "grassland", "grassland"))
+))
+
+# Observation covariates (as a list)
+(obs.covs.list <- list(
+ "rain" = matrix(rexp(M * J), nrow = M, ncol = J),
+ "wind" = matrix(
+ sample(letters[1:3], replace = TRUE, size = M * J),
+ nrow = M, ncol = J)
+))
+
+# Organise data in a unmarkedFrameOccuCOP object
+umf <- unmarkedFrameOccuCOP(
+ y = y,
+ L = L,
+ siteCovs = site.covs,
+ obsCovs = obs.covs.list
+)
+
+# Extract L
+getL(umf)
+
+# Look at data
+print(umf) # Print the whole data set
+print(umf[1, 2]) # Print the data of the 1st site, 2nd observation
+summary(umf) # Summarise the data set
+plot(umf) # Plot the count of detection events
+
+
+# L is optional, if absent, it will be replaced by a MxJ matrix of 1
+unmarkedFrameOccuCOP(
+ y = y,
+ siteCovs = site.covs,
+ obsCovs = obs.covs.list
+)
+
+# Covariates are optional
+unmarkedFrameOccuCOP(y = y)
+}
diff --git a/man/unmarkedMultFrame.Rd b/man/unmarkedMultFrame.Rd
index 622b3ff..97533ee 100644
--- a/man/unmarkedMultFrame.Rd
+++ b/man/unmarkedMultFrame.Rd
@@ -8,6 +8,7 @@
\alias{unmarkedFrameGMM}
\alias{unmarkedFrameGDS}
\alias{unmarkedFrameGPC}
+\alias{unmarkedFrameGOccu}
\title{Create an unmarkedMultFrame, unmarkedFrameGMM, unmarkedFrameGDS,
or unmarkedFrameGPC object}
@@ -154,7 +155,7 @@ o2y
umfGMM2 <- unmarkedFrameGMM(y=y,
siteCovs = data.frame(site=site),
obsCovs=list(occasion=occasions),
- yearlySiteCovs=data.frame(year=years),
+ yearlySiteCovs=data.frame(year=c(t(years))),
numPrimary=T, obsToY=o2y, piFun="instRemPiFun")
str(umfGMM2)
diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp
index 8af3b75..0fe45a8 100644
--- a/src/RcppExports.cpp
+++ b/src/RcppExports.cpp
@@ -12,6 +12,104 @@ Rcpp::Rostream<true>& Rcpp::Rcout = Rcpp::Rcpp_cout_get();
Rcpp::Rostream<false>& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get();
#endif
+// get_lik_trans
+List get_lik_trans(arma::umat I, arma::umat I1);
+RcppExport SEXP _unmarked_get_lik_trans(SEXP ISEXP, SEXP I1SEXP) {
+BEGIN_RCPP
+ Rcpp::RObject rcpp_result_gen;
+ Rcpp::RNGScope rcpp_rngScope_gen;
+ Rcpp::traits::input_parameter< arma::umat >::type I(ISEXP);
+ Rcpp::traits::input_parameter< arma::umat >::type I1(I1SEXP);
+ rcpp_result_gen = Rcpp::wrap(get_lik_trans(I, I1));
+ return rcpp_result_gen;
+END_RCPP
+}
+// get_mlogit
+arma::mat get_mlogit(arma::mat lp_mat, std::string type, int S, arma::mat guide);
+RcppExport SEXP _unmarked_get_mlogit(SEXP lp_matSEXP, SEXP typeSEXP, SEXP SSEXP, SEXP guideSEXP) {
+BEGIN_RCPP
+ Rcpp::RObject rcpp_result_gen;
+ Rcpp::RNGScope rcpp_rngScope_gen;
+ Rcpp::traits::input_parameter< arma::mat >::type lp_mat(lp_matSEXP);
+ Rcpp::traits::input_parameter< std::string >::type type(typeSEXP);
+ Rcpp::traits::input_parameter< int >::type S(SSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type guide(guideSEXP);
+ rcpp_result_gen = Rcpp::wrap(get_mlogit(lp_mat, type, S, guide));
+ return rcpp_result_gen;
+END_RCPP
+}
+// nll_distsamp
+double nll_distsamp(Rcpp::IntegerMatrix y, Rcpp::NumericVector lam, Rcpp::NumericVector sig, double scale, Rcpp::NumericMatrix a, Rcpp::NumericMatrix u, Rcpp::NumericVector w, Rcpp::NumericVector db, std::string keyfun, std::string survey);
+RcppExport SEXP _unmarked_nll_distsamp(SEXP ySEXP, SEXP lamSEXP, SEXP sigSEXP, SEXP scaleSEXP, SEXP aSEXP, SEXP uSEXP, SEXP wSEXP, SEXP dbSEXP, SEXP keyfunSEXP, SEXP surveySEXP) {
+BEGIN_RCPP
+ Rcpp::RObject rcpp_result_gen;
+ Rcpp::RNGScope rcpp_rngScope_gen;
+ Rcpp::traits::input_parameter< Rcpp::IntegerMatrix >::type y(ySEXP);
+ Rcpp::traits::input_parameter< Rcpp::NumericVector >::type lam(lamSEXP);
+ Rcpp::traits::input_parameter< Rcpp::NumericVector >::type sig(sigSEXP);
+ Rcpp::traits::input_parameter< double >::type scale(scaleSEXP);
+ Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type a(aSEXP);
+ Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type u(uSEXP);
+ Rcpp::traits::input_parameter< Rcpp::NumericVector >::type w(wSEXP);
+ Rcpp::traits::input_parameter< Rcpp::NumericVector >::type db(dbSEXP);
+ Rcpp::traits::input_parameter< std::string >::type keyfun(keyfunSEXP);
+ Rcpp::traits::input_parameter< std::string >::type survey(surveySEXP);
+ rcpp_result_gen = Rcpp::wrap(nll_distsamp(y, lam, sig, scale, a, u, w, db, keyfun, survey));
+ return rcpp_result_gen;
+END_RCPP
+}
+// nll_distsampOpen
+double nll_distsampOpen(arma::ucube y, arma::imat yt, arma::mat Xlam, arma::mat Xgam, arma::mat Xom, arma::mat Xsig, arma::mat Xiota, arma::vec beta, arma::umat bi, arma::colvec Xlam_offset, arma::colvec Xgam_offset, arma::colvec Xom_offset, arma::colvec Xsig_offset, arma::colvec Xiota_offset, arma::imat ytna, int lk, std::string mixture, Rcpp::IntegerVector first, Rcpp::IntegerVector last, int first1, int M, int T, arma::imat delta, std::string dynamics, std::string survey, std::string fix, std::string go_dims, bool immigration, arma::imat I, arma::imat I1, Rcpp::List Ib, Rcpp::List Ip, arma::mat a, arma::mat u, arma::vec w, arma::vec db, std::string keyfun, arma::vec lfac_k, arma::cube kmyt, arma::cube lfac_kmyt, arma::icube fin, arma::vec A);
+RcppExport SEXP _unmarked_nll_distsampOpen(SEXP ySEXP, SEXP ytSEXP, SEXP XlamSEXP, SEXP XgamSEXP, SEXP XomSEXP, SEXP XsigSEXP, SEXP XiotaSEXP, SEXP betaSEXP, SEXP biSEXP, SEXP Xlam_offsetSEXP, SEXP Xgam_offsetSEXP, SEXP Xom_offsetSEXP, SEXP Xsig_offsetSEXP, SEXP Xiota_offsetSEXP, SEXP ytnaSEXP, SEXP lkSEXP, SEXP mixtureSEXP, SEXP firstSEXP, SEXP lastSEXP, SEXP first1SEXP, SEXP MSEXP, SEXP TSEXP, SEXP deltaSEXP, SEXP dynamicsSEXP, SEXP surveySEXP, SEXP fixSEXP, SEXP go_dimsSEXP, SEXP immigrationSEXP, SEXP ISEXP, SEXP I1SEXP, SEXP IbSEXP, SEXP IpSEXP, SEXP aSEXP, SEXP uSEXP, SEXP wSEXP, SEXP dbSEXP, SEXP keyfunSEXP, SEXP lfac_kSEXP, SEXP kmytSEXP, SEXP lfac_kmytSEXP, SEXP finSEXP, SEXP ASEXP) {
+BEGIN_RCPP
+ Rcpp::RObject rcpp_result_gen;
+ Rcpp::RNGScope rcpp_rngScope_gen;
+ Rcpp::traits::input_parameter< arma::ucube >::type y(ySEXP);
+ Rcpp::traits::input_parameter< arma::imat >::type yt(ytSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type Xlam(XlamSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type Xgam(XgamSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type Xom(XomSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type Xsig(XsigSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type Xiota(XiotaSEXP);
+ Rcpp::traits::input_parameter< arma::vec >::type beta(betaSEXP);
+ Rcpp::traits::input_parameter< arma::umat >::type bi(biSEXP);
+ Rcpp::traits::input_parameter< arma::colvec >::type Xlam_offset(Xlam_offsetSEXP);
+ Rcpp::traits::input_parameter< arma::colvec >::type Xgam_offset(Xgam_offsetSEXP);
+ Rcpp::traits::input_parameter< arma::colvec >::type Xom_offset(Xom_offsetSEXP);
+ Rcpp::traits::input_parameter< arma::colvec >::type Xsig_offset(Xsig_offsetSEXP);
+ Rcpp::traits::input_parameter< arma::colvec >::type Xiota_offset(Xiota_offsetSEXP);
+ Rcpp::traits::input_parameter< arma::imat >::type ytna(ytnaSEXP);
+ Rcpp::traits::input_parameter< int >::type lk(lkSEXP);
+ Rcpp::traits::input_parameter< std::string >::type mixture(mixtureSEXP);
+ Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type first(firstSEXP);
+ Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type last(lastSEXP);
+ Rcpp::traits::input_parameter< int >::type first1(first1SEXP);
+ Rcpp::traits::input_parameter< int >::type M(MSEXP);
+ Rcpp::traits::input_parameter< int >::type T(TSEXP);
+ Rcpp::traits::input_parameter< arma::imat >::type delta(deltaSEXP);
+ Rcpp::traits::input_parameter< std::string >::type dynamics(dynamicsSEXP);
+ Rcpp::traits::input_parameter< std::string >::type survey(surveySEXP);
+ Rcpp::traits::input_parameter< std::string >::type fix(fixSEXP);
+ Rcpp::traits::input_parameter< std::string >::type go_dims(go_dimsSEXP);
+ Rcpp::traits::input_parameter< bool >::type immigration(immigrationSEXP);
+ Rcpp::traits::input_parameter< arma::imat >::type I(ISEXP);
+ Rcpp::traits::input_parameter< arma::imat >::type I1(I1SEXP);
+ Rcpp::traits::input_parameter< Rcpp::List >::type Ib(IbSEXP);
+ Rcpp::traits::input_parameter< Rcpp::List >::type Ip(IpSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type a(aSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type u(uSEXP);
+ Rcpp::traits::input_parameter< arma::vec >::type w(wSEXP);
+ Rcpp::traits::input_parameter< arma::vec >::type db(dbSEXP);
+ Rcpp::traits::input_parameter< std::string >::type keyfun(keyfunSEXP);
+ Rcpp::traits::input_parameter< arma::vec >::type lfac_k(lfac_kSEXP);
+ Rcpp::traits::input_parameter< arma::cube >::type kmyt(kmytSEXP);
+ Rcpp::traits::input_parameter< arma::cube >::type lfac_kmyt(lfac_kmytSEXP);
+ Rcpp::traits::input_parameter< arma::icube >::type fin(finSEXP);
+ Rcpp::traits::input_parameter< arma::vec >::type A(ASEXP);
+ rcpp_result_gen = Rcpp::wrap(nll_distsampOpen(y, yt, Xlam, Xgam, Xom, Xsig, Xiota, beta, bi, Xlam_offset, Xgam_offset, Xom_offset, Xsig_offset, Xiota_offset, ytna, lk, mixture, first, last, first1, M, T, delta, dynamics, survey, fix, go_dims, immigration, I, I1, Ib, Ip, a, u, w, db, keyfun, lfac_k, kmyt, lfac_kmyt, fin, A));
+ return rcpp_result_gen;
+END_RCPP
+}
// nll_gdistremoval
double nll_gdistremoval(arma::vec beta, arma::uvec n_param, arma::vec yDistance, arma::vec yRemoval, arma::mat ysum, int mixture, std::string keyfun, arma::mat Xlam, arma::vec A, arma::mat Xphi, arma::mat Xrem, arma::mat Xdist, arma::vec db, arma::mat a, arma::mat u, arma::vec w, arma::uvec pl, int K, arma::uvec Kmin, int threads);
RcppExport SEXP _unmarked_nll_gdistremoval(SEXP betaSEXP, SEXP n_paramSEXP, SEXP yDistanceSEXP, SEXP yRemovalSEXP, SEXP ysumSEXP, SEXP mixtureSEXP, SEXP keyfunSEXP, SEXP XlamSEXP, SEXP ASEXP, SEXP XphiSEXP, SEXP XremSEXP, SEXP XdistSEXP, SEXP dbSEXP, SEXP aSEXP, SEXP uSEXP, SEXP wSEXP, SEXP plSEXP, SEXP KSEXP, SEXP KminSEXP, SEXP threadsSEXP) {
@@ -127,6 +225,75 @@ BEGIN_RCPP
return rcpp_result_gen;
END_RCPP
}
+// nll_multinomPois
+double nll_multinomPois(arma::vec beta, std::string pi_fun, arma::mat Xlam, arma::vec Xlam_offset, arma::mat Xdet, arma::vec Xdet_offset, arma::vec y, arma::vec navec, int nP, int nAP);
+RcppExport SEXP _unmarked_nll_multinomPois(SEXP betaSEXP, SEXP pi_funSEXP, SEXP XlamSEXP, SEXP Xlam_offsetSEXP, SEXP XdetSEXP, SEXP Xdet_offsetSEXP, SEXP ySEXP, SEXP navecSEXP, SEXP nPSEXP, SEXP nAPSEXP) {
+BEGIN_RCPP
+ Rcpp::RObject rcpp_result_gen;
+ Rcpp::RNGScope rcpp_rngScope_gen;
+ Rcpp::traits::input_parameter< arma::vec >::type beta(betaSEXP);
+ Rcpp::traits::input_parameter< std::string >::type pi_fun(pi_funSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type Xlam(XlamSEXP);
+ Rcpp::traits::input_parameter< arma::vec >::type Xlam_offset(Xlam_offsetSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type Xdet(XdetSEXP);
+ Rcpp::traits::input_parameter< arma::vec >::type Xdet_offset(Xdet_offsetSEXP);
+ Rcpp::traits::input_parameter< arma::vec >::type y(ySEXP);
+ Rcpp::traits::input_parameter< arma::vec >::type navec(navecSEXP);
+ Rcpp::traits::input_parameter< int >::type nP(nPSEXP);
+ Rcpp::traits::input_parameter< int >::type nAP(nAPSEXP);
+ rcpp_result_gen = Rcpp::wrap(nll_multinomPois(beta, pi_fun, Xlam, Xlam_offset, Xdet, Xdet_offset, y, navec, nP, nAP));
+ return rcpp_result_gen;
+END_RCPP
+}
+// nll_multmixOpen
+double nll_multmixOpen(arma::ucube y, arma::imat yt, arma::mat Xlam, arma::mat Xgam, arma::mat Xom, arma::mat Xp, arma::mat Xiota, arma::vec beta, arma::umat bi, arma::colvec Xlam_offset, arma::colvec Xgam_offset, arma::colvec Xom_offset, arma::colvec Xp_offset, arma::colvec Xiota_offset, arma::imat ytna, arma::ucube yna, int lk, std::string mixture, Rcpp::IntegerVector first, Rcpp::IntegerVector last, int first1, int M, int T, int J, int R, arma::imat delta, std::string dynamics, std::string fix, std::string go_dims, bool immigration, arma::imat I, arma::imat I1, Rcpp::List Ib, Rcpp::List Ip, std::string pi_fun, arma::vec lfac_k, arma::cube kmyt, arma::cube lfac_kmyt, arma::icube fin);
+RcppExport SEXP _unmarked_nll_multmixOpen(SEXP ySEXP, SEXP ytSEXP, SEXP XlamSEXP, SEXP XgamSEXP, SEXP XomSEXP, SEXP XpSEXP, SEXP XiotaSEXP, SEXP betaSEXP, SEXP biSEXP, SEXP Xlam_offsetSEXP, SEXP Xgam_offsetSEXP, SEXP Xom_offsetSEXP, SEXP Xp_offsetSEXP, SEXP Xiota_offsetSEXP, SEXP ytnaSEXP, SEXP ynaSEXP, SEXP lkSEXP, SEXP mixtureSEXP, SEXP firstSEXP, SEXP lastSEXP, SEXP first1SEXP, SEXP MSEXP, SEXP TSEXP, SEXP JSEXP, SEXP RSEXP, SEXP deltaSEXP, SEXP dynamicsSEXP, SEXP fixSEXP, SEXP go_dimsSEXP, SEXP immigrationSEXP, SEXP ISEXP, SEXP I1SEXP, SEXP IbSEXP, SEXP IpSEXP, SEXP pi_funSEXP, SEXP lfac_kSEXP, SEXP kmytSEXP, SEXP lfac_kmytSEXP, SEXP finSEXP) {
+BEGIN_RCPP
+ Rcpp::RObject rcpp_result_gen;
+ Rcpp::RNGScope rcpp_rngScope_gen;
+ Rcpp::traits::input_parameter< arma::ucube >::type y(ySEXP);
+ Rcpp::traits::input_parameter< arma::imat >::type yt(ytSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type Xlam(XlamSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type Xgam(XgamSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type Xom(XomSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type Xp(XpSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type Xiota(XiotaSEXP);
+ Rcpp::traits::input_parameter< arma::vec >::type beta(betaSEXP);
+ Rcpp::traits::input_parameter< arma::umat >::type bi(biSEXP);
+ Rcpp::traits::input_parameter< arma::colvec >::type Xlam_offset(Xlam_offsetSEXP);
+ Rcpp::traits::input_parameter< arma::colvec >::type Xgam_offset(Xgam_offsetSEXP);
+ Rcpp::traits::input_parameter< arma::colvec >::type Xom_offset(Xom_offsetSEXP);
+ Rcpp::traits::input_parameter< arma::colvec >::type Xp_offset(Xp_offsetSEXP);
+ Rcpp::traits::input_parameter< arma::colvec >::type Xiota_offset(Xiota_offsetSEXP);
+ Rcpp::traits::input_parameter< arma::imat >::type ytna(ytnaSEXP);
+ Rcpp::traits::input_parameter< arma::ucube >::type yna(ynaSEXP);
+ Rcpp::traits::input_parameter< int >::type lk(lkSEXP);
+ Rcpp::traits::input_parameter< std::string >::type mixture(mixtureSEXP);
+ Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type first(firstSEXP);
+ Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type last(lastSEXP);
+ Rcpp::traits::input_parameter< int >::type first1(first1SEXP);
+ Rcpp::traits::input_parameter< int >::type M(MSEXP);
+ Rcpp::traits::input_parameter< int >::type T(TSEXP);
+ Rcpp::traits::input_parameter< int >::type J(JSEXP);
+ Rcpp::traits::input_parameter< int >::type R(RSEXP);
+ Rcpp::traits::input_parameter< arma::imat >::type delta(deltaSEXP);
+ Rcpp::traits::input_parameter< std::string >::type dynamics(dynamicsSEXP);
+ Rcpp::traits::input_parameter< std::string >::type fix(fixSEXP);
+ Rcpp::traits::input_parameter< std::string >::type go_dims(go_dimsSEXP);
+ Rcpp::traits::input_parameter< bool >::type immigration(immigrationSEXP);
+ Rcpp::traits::input_parameter< arma::imat >::type I(ISEXP);
+ Rcpp::traits::input_parameter< arma::imat >::type I1(I1SEXP);
+ Rcpp::traits::input_parameter< Rcpp::List >::type Ib(IbSEXP);
+ Rcpp::traits::input_parameter< Rcpp::List >::type Ip(IpSEXP);
+ Rcpp::traits::input_parameter< std::string >::type pi_fun(pi_funSEXP);
+ Rcpp::traits::input_parameter< arma::vec >::type lfac_k(lfac_kSEXP);
+ Rcpp::traits::input_parameter< arma::cube >::type kmyt(kmytSEXP);
+ Rcpp::traits::input_parameter< arma::cube >::type lfac_kmyt(lfac_kmytSEXP);
+ Rcpp::traits::input_parameter< arma::icube >::type fin(finSEXP);
+ rcpp_result_gen = Rcpp::wrap(nll_multmixOpen(y, yt, Xlam, Xgam, Xom, Xp, Xiota, beta, bi, Xlam_offset, Xgam_offset, Xom_offset, Xp_offset, Xiota_offset, ytna, yna, lk, mixture, first, last, first1, M, T, J, R, delta, dynamics, fix, go_dims, immigration, I, I1, Ib, Ip, pi_fun, lfac_k, kmyt, lfac_kmyt, fin));
+ return rcpp_result_gen;
+END_RCPP
+}
// nll_nmixTTD
double nll_nmixTTD(const arma::vec beta, const arma::vec y, const arma::vec delta, const arma::mat W, const arma::mat V, const arma::umat pinds, const std::string mixture, const std::string tdist, int N, int J, int K, const arma::vec naflag, int threads);
RcppExport SEXP _unmarked_nll_nmixTTD(SEXP betaSEXP, SEXP ySEXP, SEXP deltaSEXP, SEXP WSEXP, SEXP VSEXP, SEXP pindsSEXP, SEXP mixtureSEXP, SEXP tdistSEXP, SEXP NSEXP, SEXP JSEXP, SEXP KSEXP, SEXP naflagSEXP, SEXP threadsSEXP) {
@@ -150,6 +317,139 @@ BEGIN_RCPP
return rcpp_result_gen;
END_RCPP
}
+// nll_occu
+double nll_occu(arma::icolvec y, arma::mat X, arma::mat V, arma::colvec beta_psi, arma::colvec beta_p, Rcpp::IntegerVector nd, Rcpp::LogicalVector knownOcc, Rcpp::LogicalVector navec, arma::colvec X_offset, arma::colvec V_offset, std::string link_psi);
+RcppExport SEXP _unmarked_nll_occu(SEXP ySEXP, SEXP XSEXP, SEXP VSEXP, SEXP beta_psiSEXP, SEXP beta_pSEXP, SEXP ndSEXP, SEXP knownOccSEXP, SEXP navecSEXP, SEXP X_offsetSEXP, SEXP V_offsetSEXP, SEXP link_psiSEXP) {
+BEGIN_RCPP
+ Rcpp::RObject rcpp_result_gen;
+ Rcpp::RNGScope rcpp_rngScope_gen;
+ Rcpp::traits::input_parameter< arma::icolvec >::type y(ySEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type X(XSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type V(VSEXP);
+ Rcpp::traits::input_parameter< arma::colvec >::type beta_psi(beta_psiSEXP);
+ Rcpp::traits::input_parameter< arma::colvec >::type beta_p(beta_pSEXP);
+ Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type nd(ndSEXP);
+ Rcpp::traits::input_parameter< Rcpp::LogicalVector >::type knownOcc(knownOccSEXP);
+ Rcpp::traits::input_parameter< Rcpp::LogicalVector >::type navec(navecSEXP);
+ Rcpp::traits::input_parameter< arma::colvec >::type X_offset(X_offsetSEXP);
+ Rcpp::traits::input_parameter< arma::colvec >::type V_offset(V_offsetSEXP);
+ Rcpp::traits::input_parameter< std::string >::type link_psi(link_psiSEXP);
+ rcpp_result_gen = Rcpp::wrap(nll_occu(y, X, V, beta_psi, beta_p, nd, knownOcc, navec, X_offset, V_offset, link_psi));
+ return rcpp_result_gen;
+END_RCPP
+}
+// nll_occuCOP
+double nll_occuCOP(arma::icolvec y, arma::icolvec L, arma::mat Xpsi, arma::mat Xlambda, arma::colvec beta_psi, arma::colvec beta_lambda, Rcpp::LogicalVector removed);
+RcppExport SEXP _unmarked_nll_occuCOP(SEXP ySEXP, SEXP LSEXP, SEXP XpsiSEXP, SEXP XlambdaSEXP, SEXP beta_psiSEXP, SEXP beta_lambdaSEXP, SEXP removedSEXP) {
+BEGIN_RCPP
+ Rcpp::RObject rcpp_result_gen;
+ Rcpp::RNGScope rcpp_rngScope_gen;
+ Rcpp::traits::input_parameter< arma::icolvec >::type y(ySEXP);
+ Rcpp::traits::input_parameter< arma::icolvec >::type L(LSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type Xpsi(XpsiSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type Xlambda(XlambdaSEXP);
+ Rcpp::traits::input_parameter< arma::colvec >::type beta_psi(beta_psiSEXP);
+ Rcpp::traits::input_parameter< arma::colvec >::type beta_lambda(beta_lambdaSEXP);
+ Rcpp::traits::input_parameter< Rcpp::LogicalVector >::type removed(removedSEXP);
+ rcpp_result_gen = Rcpp::wrap(nll_occuCOP(y, L, Xpsi, Xlambda, beta_psi, beta_lambda, removed));
+ return rcpp_result_gen;
+END_RCPP
+}
+// nll_occuMS
+double nll_occuMS(arma::vec beta, arma::mat y, Rcpp::List dm_state, Rcpp::List dm_phi, Rcpp::List dm_det, arma::mat sind, arma::mat pind, arma::mat dind, std::string prm, int S, int T, int J, int N, arma::mat naflag, arma::mat guide);
+RcppExport SEXP _unmarked_nll_occuMS(SEXP betaSEXP, SEXP ySEXP, SEXP dm_stateSEXP, SEXP dm_phiSEXP, SEXP dm_detSEXP, SEXP sindSEXP, SEXP pindSEXP, SEXP dindSEXP, SEXP prmSEXP, SEXP SSEXP, SEXP TSEXP, SEXP JSEXP, SEXP NSEXP, SEXP naflagSEXP, SEXP guideSEXP) {
+BEGIN_RCPP
+ Rcpp::RObject rcpp_result_gen;
+ Rcpp::RNGScope rcpp_rngScope_gen;
+ Rcpp::traits::input_parameter< arma::vec >::type beta(betaSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type y(ySEXP);
+ Rcpp::traits::input_parameter< Rcpp::List >::type dm_state(dm_stateSEXP);
+ Rcpp::traits::input_parameter< Rcpp::List >::type dm_phi(dm_phiSEXP);
+ Rcpp::traits::input_parameter< Rcpp::List >::type dm_det(dm_detSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type sind(sindSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type pind(pindSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type dind(dindSEXP);
+ Rcpp::traits::input_parameter< std::string >::type prm(prmSEXP);
+ Rcpp::traits::input_parameter< int >::type S(SSEXP);
+ Rcpp::traits::input_parameter< int >::type T(TSEXP);
+ Rcpp::traits::input_parameter< int >::type J(JSEXP);
+ Rcpp::traits::input_parameter< int >::type N(NSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type naflag(naflagSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type guide(guideSEXP);
+ rcpp_result_gen = Rcpp::wrap(nll_occuMS(beta, y, dm_state, dm_phi, dm_det, sind, pind, dind, prm, S, T, J, N, naflag, guide));
+ return rcpp_result_gen;
+END_RCPP
+}
+// nll_occuMulti_loglik
+arma::vec nll_occuMulti_loglik(Rcpp::IntegerVector fStart, Rcpp::IntegerVector fStop, arma::sp_mat dmF, Rcpp::List dmOcc, arma::colvec beta, Rcpp::List dmDet, Rcpp::IntegerVector dStart, Rcpp::IntegerVector dStop, arma::mat y, Rcpp::IntegerVector yStart, Rcpp::IntegerVector yStop, arma::mat Iy0, arma::mat z, Rcpp::LogicalVector fixed0);
+RcppExport SEXP _unmarked_nll_occuMulti_loglik(SEXP fStartSEXP, SEXP fStopSEXP, SEXP dmFSEXP, SEXP dmOccSEXP, SEXP betaSEXP, SEXP dmDetSEXP, SEXP dStartSEXP, SEXP dStopSEXP, SEXP ySEXP, SEXP yStartSEXP, SEXP yStopSEXP, SEXP Iy0SEXP, SEXP zSEXP, SEXP fixed0SEXP) {
+BEGIN_RCPP
+ Rcpp::RObject rcpp_result_gen;
+ Rcpp::RNGScope rcpp_rngScope_gen;
+ Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type fStart(fStartSEXP);
+ Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type fStop(fStopSEXP);
+ Rcpp::traits::input_parameter< arma::sp_mat >::type dmF(dmFSEXP);
+ Rcpp::traits::input_parameter< Rcpp::List >::type dmOcc(dmOccSEXP);
+ Rcpp::traits::input_parameter< arma::colvec >::type beta(betaSEXP);
+ Rcpp::traits::input_parameter< Rcpp::List >::type dmDet(dmDetSEXP);
+ Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type dStart(dStartSEXP);
+ Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type dStop(dStopSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type y(ySEXP);
+ Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type yStart(yStartSEXP);
+ Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type yStop(yStopSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type Iy0(Iy0SEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type z(zSEXP);
+ Rcpp::traits::input_parameter< Rcpp::LogicalVector >::type fixed0(fixed0SEXP);
+ rcpp_result_gen = Rcpp::wrap(nll_occuMulti_loglik(fStart, fStop, dmF, dmOcc, beta, dmDet, dStart, dStop, y, yStart, yStop, Iy0, z, fixed0));
+ return rcpp_result_gen;
+END_RCPP
+}
+// nll_occuMulti
+double nll_occuMulti(Rcpp::IntegerVector fStart, Rcpp::IntegerVector fStop, arma::sp_mat dmF, Rcpp::List dmOcc, arma::colvec beta, Rcpp::List dmDet, Rcpp::IntegerVector dStart, Rcpp::IntegerVector dStop, arma::mat y, Rcpp::IntegerVector yStart, Rcpp::IntegerVector yStop, arma::mat Iy0, arma::mat z, Rcpp::LogicalVector fixed0, double penalty);
+RcppExport SEXP _unmarked_nll_occuMulti(SEXP fStartSEXP, SEXP fStopSEXP, SEXP dmFSEXP, SEXP dmOccSEXP, SEXP betaSEXP, SEXP dmDetSEXP, SEXP dStartSEXP, SEXP dStopSEXP, SEXP ySEXP, SEXP yStartSEXP, SEXP yStopSEXP, SEXP Iy0SEXP, SEXP zSEXP, SEXP fixed0SEXP, SEXP penaltySEXP) {
+BEGIN_RCPP
+ Rcpp::RObject rcpp_result_gen;
+ Rcpp::RNGScope rcpp_rngScope_gen;
+ Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type fStart(fStartSEXP);
+ Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type fStop(fStopSEXP);
+ Rcpp::traits::input_parameter< arma::sp_mat >::type dmF(dmFSEXP);
+ Rcpp::traits::input_parameter< Rcpp::List >::type dmOcc(dmOccSEXP);
+ Rcpp::traits::input_parameter< arma::colvec >::type beta(betaSEXP);
+ Rcpp::traits::input_parameter< Rcpp::List >::type dmDet(dmDetSEXP);
+ Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type dStart(dStartSEXP);
+ Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type dStop(dStopSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type y(ySEXP);
+ Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type yStart(yStartSEXP);
+ Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type yStop(yStopSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type Iy0(Iy0SEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type z(zSEXP);
+ Rcpp::traits::input_parameter< Rcpp::LogicalVector >::type fixed0(fixed0SEXP);
+ Rcpp::traits::input_parameter< double >::type penalty(penaltySEXP);
+ rcpp_result_gen = Rcpp::wrap(nll_occuMulti(fStart, fStop, dmF, dmOcc, beta, dmDet, dStart, dStop, y, yStart, yStop, Iy0, z, fixed0, penalty));
+ return rcpp_result_gen;
+END_RCPP
+}
+// nll_occuPEN
+double nll_occuPEN(arma::icolvec y, arma::mat X, arma::mat V, arma::colvec beta_psi, arma::colvec beta_p, Rcpp::IntegerVector nd, Rcpp::LogicalVector knownOcc, Rcpp::LogicalVector navec, arma::colvec X_offset, arma::colvec V_offset, double penalty);
+RcppExport SEXP _unmarked_nll_occuPEN(SEXP ySEXP, SEXP XSEXP, SEXP VSEXP, SEXP beta_psiSEXP, SEXP beta_pSEXP, SEXP ndSEXP, SEXP knownOccSEXP, SEXP navecSEXP, SEXP X_offsetSEXP, SEXP V_offsetSEXP, SEXP penaltySEXP) {
+BEGIN_RCPP
+ Rcpp::RObject rcpp_result_gen;
+ Rcpp::RNGScope rcpp_rngScope_gen;
+ Rcpp::traits::input_parameter< arma::icolvec >::type y(ySEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type X(XSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type V(VSEXP);
+ Rcpp::traits::input_parameter< arma::colvec >::type beta_psi(beta_psiSEXP);
+ Rcpp::traits::input_parameter< arma::colvec >::type beta_p(beta_pSEXP);
+ Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type nd(ndSEXP);
+ Rcpp::traits::input_parameter< Rcpp::LogicalVector >::type knownOcc(knownOccSEXP);
+ Rcpp::traits::input_parameter< Rcpp::LogicalVector >::type navec(navecSEXP);
+ Rcpp::traits::input_parameter< arma::colvec >::type X_offset(X_offsetSEXP);
+ Rcpp::traits::input_parameter< arma::colvec >::type V_offset(V_offsetSEXP);
+ Rcpp::traits::input_parameter< double >::type penalty(penaltySEXP);
+ rcpp_result_gen = Rcpp::wrap(nll_occuPEN(y, X, V, beta_psi, beta_p, nd, knownOcc, navec, X_offset, V_offset, penalty));
+ return rcpp_result_gen;
+END_RCPP
+}
// nll_occuRN
double nll_occuRN(const arma::vec beta, const arma::uvec n_param, const arma::mat y, const arma::mat X, const arma::mat V, const arma::vec X_offset, const arma::vec V_offset, int K, const arma::uvec Kmin, int threads);
RcppExport SEXP _unmarked_nll_occuRN(SEXP betaSEXP, SEXP n_paramSEXP, SEXP ySEXP, SEXP XSEXP, SEXP VSEXP, SEXP X_offsetSEXP, SEXP V_offsetSEXP, SEXP KSEXP, SEXP KminSEXP, SEXP threadsSEXP) {
@@ -170,6 +470,33 @@ BEGIN_RCPP
return rcpp_result_gen;
END_RCPP
}
+// nll_occuTTD
+double nll_occuTTD(arma::vec beta, arma::vec y, arma::vec delta, arma::mat W, arma::mat V, arma::mat Xgam, arma::mat Xeps, arma::vec pind, arma::vec dind, arma::vec cind, arma::vec eind, std::string lpsi, std::string tdist, int N, int T, int J, arma::vec naflag);
+RcppExport SEXP _unmarked_nll_occuTTD(SEXP betaSEXP, SEXP ySEXP, SEXP deltaSEXP, SEXP WSEXP, SEXP VSEXP, SEXP XgamSEXP, SEXP XepsSEXP, SEXP pindSEXP, SEXP dindSEXP, SEXP cindSEXP, SEXP eindSEXP, SEXP lpsiSEXP, SEXP tdistSEXP, SEXP NSEXP, SEXP TSEXP, SEXP JSEXP, SEXP naflagSEXP) {
+BEGIN_RCPP
+ Rcpp::RObject rcpp_result_gen;
+ Rcpp::RNGScope rcpp_rngScope_gen;
+ Rcpp::traits::input_parameter< arma::vec >::type beta(betaSEXP);
+ Rcpp::traits::input_parameter< arma::vec >::type y(ySEXP);
+ Rcpp::traits::input_parameter< arma::vec >::type delta(deltaSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type W(WSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type V(VSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type Xgam(XgamSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type Xeps(XepsSEXP);
+ Rcpp::traits::input_parameter< arma::vec >::type pind(pindSEXP);
+ Rcpp::traits::input_parameter< arma::vec >::type dind(dindSEXP);
+ Rcpp::traits::input_parameter< arma::vec >::type cind(cindSEXP);
+ Rcpp::traits::input_parameter< arma::vec >::type eind(eindSEXP);
+ Rcpp::traits::input_parameter< std::string >::type lpsi(lpsiSEXP);
+ Rcpp::traits::input_parameter< std::string >::type tdist(tdistSEXP);
+ Rcpp::traits::input_parameter< int >::type N(NSEXP);
+ Rcpp::traits::input_parameter< int >::type T(TSEXP);
+ Rcpp::traits::input_parameter< int >::type J(JSEXP);
+ Rcpp::traits::input_parameter< arma::vec >::type naflag(naflagSEXP);
+ rcpp_result_gen = Rcpp::wrap(nll_occuTTD(beta, y, delta, W, V, Xgam, Xeps, pind, dind, cind, eind, lpsi, tdist, N, T, J, naflag));
+ return rcpp_result_gen;
+END_RCPP
+}
// nll_pcount
double nll_pcount(const arma::vec beta, const arma::uvec n_param, const arma::mat y, const arma::mat X, const arma::mat V, const arma::vec X_offset, const arma::vec V_offset, int K, const arma::uvec Kmin, int mixture, int threads);
RcppExport SEXP _unmarked_nll_pcount(SEXP betaSEXP, SEXP n_paramSEXP, SEXP ySEXP, SEXP XSEXP, SEXP VSEXP, SEXP X_offsetSEXP, SEXP V_offsetSEXP, SEXP KSEXP, SEXP KminSEXP, SEXP mixtureSEXP, SEXP threadsSEXP) {
@@ -191,44 +518,79 @@ BEGIN_RCPP
return rcpp_result_gen;
END_RCPP
}
+// nll_pcountOpen
+double nll_pcountOpen(arma::imat ym, arma::mat Xlam, arma::mat Xgam, arma::mat Xom, arma::mat Xp, arma::mat Xiota, arma::colvec beta_lam, arma::colvec beta_gam, arma::colvec beta_om, arma::colvec beta_p, arma::colvec beta_iota, double log_alpha, arma::colvec Xlam_offset, arma::colvec Xgam_offset, arma::colvec Xom_offset, arma::colvec Xp_offset, arma::colvec Xiota_offset, arma::imat ytna, arma::imat ynam, int lk, std::string mixture, Rcpp::IntegerVector first, Rcpp::IntegerVector last, int M, int J, int T, arma::imat delta, std::string dynamics, std::string fix, std::string go_dims, bool immigration, arma::imat I, arma::imat I1, Rcpp::List Ib, Rcpp::List Ip);
+RcppExport SEXP _unmarked_nll_pcountOpen(SEXP ymSEXP, SEXP XlamSEXP, SEXP XgamSEXP, SEXP XomSEXP, SEXP XpSEXP, SEXP XiotaSEXP, SEXP beta_lamSEXP, SEXP beta_gamSEXP, SEXP beta_omSEXP, SEXP beta_pSEXP, SEXP beta_iotaSEXP, SEXP log_alphaSEXP, SEXP Xlam_offsetSEXP, SEXP Xgam_offsetSEXP, SEXP Xom_offsetSEXP, SEXP Xp_offsetSEXP, SEXP Xiota_offsetSEXP, SEXP ytnaSEXP, SEXP ynamSEXP, SEXP lkSEXP, SEXP mixtureSEXP, SEXP firstSEXP, SEXP lastSEXP, SEXP MSEXP, SEXP JSEXP, SEXP TSEXP, SEXP deltaSEXP, SEXP dynamicsSEXP, SEXP fixSEXP, SEXP go_dimsSEXP, SEXP immigrationSEXP, SEXP ISEXP, SEXP I1SEXP, SEXP IbSEXP, SEXP IpSEXP) {
+BEGIN_RCPP
+ Rcpp::RObject rcpp_result_gen;
+ Rcpp::RNGScope rcpp_rngScope_gen;
+ Rcpp::traits::input_parameter< arma::imat >::type ym(ymSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type Xlam(XlamSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type Xgam(XgamSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type Xom(XomSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type Xp(XpSEXP);
+ Rcpp::traits::input_parameter< arma::mat >::type Xiota(XiotaSEXP);
+ Rcpp::traits::input_parameter< arma::colvec >::type beta_lam(beta_lamSEXP);
+ Rcpp::traits::input_parameter< arma::colvec >::type beta_gam(beta_gamSEXP);
+ Rcpp::traits::input_parameter< arma::colvec >::type beta_om(beta_omSEXP);
+ Rcpp::traits::input_parameter< arma::colvec >::type beta_p(beta_pSEXP);
+ Rcpp::traits::input_parameter< arma::colvec >::type beta_iota(beta_iotaSEXP);
+ Rcpp::traits::input_parameter< double >::type log_alpha(log_alphaSEXP);
+ Rcpp::traits::input_parameter< arma::colvec >::type Xlam_offset(Xlam_offsetSEXP);
+ Rcpp::traits::input_parameter< arma::colvec >::type Xgam_offset(Xgam_offsetSEXP);
+ Rcpp::traits::input_parameter< arma::colvec >::type Xom_offset(Xom_offsetSEXP);
+ Rcpp::traits::input_parameter< arma::colvec >::type Xp_offset(Xp_offsetSEXP);
+ Rcpp::traits::input_parameter< arma::colvec >::type Xiota_offset(Xiota_offsetSEXP);
+ Rcpp::traits::input_parameter< arma::imat >::type ytna(ytnaSEXP);
+ Rcpp::traits::input_parameter< arma::imat >::type ynam(ynamSEXP);
+ Rcpp::traits::input_parameter< int >::type lk(lkSEXP);
+ Rcpp::traits::input_parameter< std::string >::type mixture(mixtureSEXP);
+ Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type first(firstSEXP);
+ Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type last(lastSEXP);
+ Rcpp::traits::input_parameter< int >::type M(MSEXP);
+ Rcpp::traits::input_parameter< int >::type J(JSEXP);
+ Rcpp::traits::input_parameter< int >::type T(TSEXP);
+ Rcpp::traits::input_parameter< arma::imat >::type delta(deltaSEXP);
+ Rcpp::traits::input_parameter< std::string >::type dynamics(dynamicsSEXP);
+ Rcpp::traits::input_parameter< std::string >::type fix(fixSEXP);
+ Rcpp::traits::input_parameter< std::string >::type go_dims(go_dimsSEXP);
+ Rcpp::traits::input_parameter< bool >::type immigration(immigrationSEXP);
+ Rcpp::traits::input_parameter< arma::imat >::type I(ISEXP);
+ Rcpp::traits::input_parameter< arma::imat >::type I1(I1SEXP);
+ Rcpp::traits::input_parameter< Rcpp::List >::type Ib(IbSEXP);
+ Rcpp::traits::input_parameter< Rcpp::List >::type Ip(IpSEXP);
+ rcpp_result_gen = Rcpp::wrap(nll_pcountOpen(ym, Xlam, Xgam, Xom, Xp, Xiota, beta_lam, beta_gam, beta_om, beta_p, beta_iota, log_alpha, Xlam_offset, Xgam_offset, Xom_offset, Xp_offset, Xiota_offset, ytna, ynam, lk, mixture, first, last, M, J, T, delta, dynamics, fix, go_dims, immigration, I, I1, Ib, Ip));
+ return rcpp_result_gen;
+END_RCPP
+}
-RcppExport SEXP get_lik_trans(SEXP, SEXP);
-RcppExport SEXP get_mlogit(SEXP, SEXP, SEXP, SEXP);
-RcppExport SEXP getDetVecs(SEXP, SEXP, SEXP, SEXP, SEXP);
-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, 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);
-RcppExport SEXP nll_occuPEN(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP);
-RcppExport SEXP nll_occuTTD(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP);
-RcppExport SEXP nll_pcountOpen(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 getDetVecs(void *, void *, void *, void *, void *);
+RcppExport SEXP getSingleDetVec(void *, void *, void *);
static const R_CallMethodDef CallEntries[] = {
+ {"_unmarked_get_lik_trans", (DL_FUNC) &_unmarked_get_lik_trans, 2},
+ {"_unmarked_get_mlogit", (DL_FUNC) &_unmarked_get_mlogit, 4},
+ {"_unmarked_nll_distsamp", (DL_FUNC) &_unmarked_nll_distsamp, 10},
+ {"_unmarked_nll_distsampOpen", (DL_FUNC) &_unmarked_nll_distsampOpen, 42},
{"_unmarked_nll_gdistremoval", (DL_FUNC) &_unmarked_nll_gdistremoval, 20},
{"_unmarked_nll_gdistsamp", (DL_FUNC) &_unmarked_nll_gdistsamp, 23},
{"_unmarked_nll_gmultmix", (DL_FUNC) &_unmarked_nll_gmultmix, 17},
{"_unmarked_nll_gpcount", (DL_FUNC) &_unmarked_nll_gpcount, 15},
+ {"_unmarked_nll_multinomPois", (DL_FUNC) &_unmarked_nll_multinomPois, 10},
+ {"_unmarked_nll_multmixOpen", (DL_FUNC) &_unmarked_nll_multmixOpen, 39},
{"_unmarked_nll_nmixTTD", (DL_FUNC) &_unmarked_nll_nmixTTD, 13},
+ {"_unmarked_nll_occu", (DL_FUNC) &_unmarked_nll_occu, 11},
+ {"_unmarked_nll_occuCOP", (DL_FUNC) &_unmarked_nll_occuCOP, 7},
+ {"_unmarked_nll_occuMS", (DL_FUNC) &_unmarked_nll_occuMS, 15},
+ {"_unmarked_nll_occuMulti_loglik", (DL_FUNC) &_unmarked_nll_occuMulti_loglik, 14},
+ {"_unmarked_nll_occuMulti", (DL_FUNC) &_unmarked_nll_occuMulti, 15},
+ {"_unmarked_nll_occuPEN", (DL_FUNC) &_unmarked_nll_occuPEN, 11},
{"_unmarked_nll_occuRN", (DL_FUNC) &_unmarked_nll_occuRN, 10},
+ {"_unmarked_nll_occuTTD", (DL_FUNC) &_unmarked_nll_occuTTD, 17},
{"_unmarked_nll_pcount", (DL_FUNC) &_unmarked_nll_pcount, 11},
- {"get_lik_trans", (DL_FUNC) &get_lik_trans, 2},
- {"get_mlogit", (DL_FUNC) &get_mlogit, 4},
- {"getDetVecs", (DL_FUNC) &getDetVecs, 5},
- {"getSingleDetVec", (DL_FUNC) &getSingleDetVec, 3},
- {"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, 39},
- {"nll_occu", (DL_FUNC) &nll_occu, 11},
- {"nll_occuMS", (DL_FUNC) &nll_occuMS, 15},
- {"nll_occuMulti", (DL_FUNC) &nll_occuMulti, 16},
- {"nll_occuPEN", (DL_FUNC) &nll_occuPEN, 11},
- {"nll_occuTTD", (DL_FUNC) &nll_occuTTD, 17},
- {"nll_pcountOpen", (DL_FUNC) &nll_pcountOpen, 35},
+ {"_unmarked_nll_pcountOpen", (DL_FUNC) &_unmarked_nll_pcountOpen, 35},
+ {"getDetVecs", (DL_FUNC) &getDetVecs, 5},
+ {"getSingleDetVec", (DL_FUNC) &getSingleDetVec, 3},
{NULL, NULL, 0}
};
diff --git a/src/TMB/tmb_goccu.hpp b/src/TMB/tmb_goccu.hpp
new file mode 100644
index 0000000..7788ad6
--- /dev/null
+++ b/src/TMB/tmb_goccu.hpp
@@ -0,0 +1,130 @@
+#undef TMB_OBJECTIVE_PTR
+#define TMB_OBJECTIVE_PTR obj
+
+// Adapted from Stan code by Maxwell B. Joseph,
+// https://discourse.mc-stan.org/t/divergent-transition-every-iteration-multi-scale-occupancy-model/13739/5
+
+// name of function below **MUST** match filename
+template<class Type>
+Type tmb_goccu(objective_function<Type>* obj) {
+ //Describe input data
+ DATA_MATRIX(y); //observations
+ DATA_INTEGER(T);
+
+ DATA_INTEGER(link);
+
+ DATA_MATRIX(Xpsi);
+ DATA_MATRIX(Xphi);
+ DATA_MATRIX(Xp);
+
+ DATA_INTEGER(n_possible);
+ DATA_MATRIX(alpha_potential);
+ DATA_VECTOR(known_present);
+ DATA_MATRIX(known_available);
+ DATA_MATRIX(missing_session);
+
+ PARAMETER_VECTOR(beta_psi);
+ PARAMETER_VECTOR(beta_phi);
+ PARAMETER_VECTOR(beta_p);
+
+ vector<Type> psi = Xpsi * beta_psi;
+ vector<Type> phi = Xphi * beta_phi;
+ vector<Type> p = Xp * beta_p;
+
+ if(link == 1){
+ //psi = cloglog(psi);
+ } else {
+ psi = invlogit(psi);
+ }
+
+ phi = invlogit(phi);
+ p = invlogit(p);
+
+ Type loglik = 0.0;
+
+ int M = y.rows();
+ int J = y.cols() / T;
+
+ Type obs_lp;
+ Type poss_lp;
+ Type exp_poss_lp;
+
+ int ystart;
+ vector<Type> ysite;
+ vector<Type> psite;
+ vector<Type> ysub;
+ vector<Type> psub;
+
+ int tstart;
+ int pstart;
+
+ for (int i=0; i<M; i++){
+
+ tstart = i*T;
+ pstart = i*(T*J);
+
+ ysite = y.row(i);
+ psite = p.segment(pstart, T*J);
+
+ if(known_present(i) == 1){
+ for (int t=0; t<T; t++){
+
+ if(missing_session(i, t) == 1) continue;
+
+ ystart = t*J;
+
+ psub = psite.segment(ystart, J);
+ ysub = ysite.segment(ystart, J);
+
+ obs_lp = log(phi(tstart+t));
+ for (int j=0; j<J; j++){
+ if(R_IsNA(asDouble(ysub(j)))) continue;
+ obs_lp += dbinom(ysub(j), Type(1), psub(j), true);
+ }
+ if(known_available(i, t) == 1){
+ loglik += obs_lp;
+ } else {
+ loglik += log(exp(obs_lp) + exp(log(1-phi(tstart+t))));
+ }
+ }
+ loglik += log(psi(i));
+ } else {
+
+ exp_poss_lp = 0.0;
+
+ for (int k=0; k<n_possible; k++){
+ poss_lp = log(psi(i));
+
+ for (int t=0; t<T; t++){
+
+ if(missing_session(i, t) == 1) continue;
+
+ ystart = t*J;
+
+ psub = psite.segment(ystart, J);
+ ysub = ysite.segment(ystart, J);
+
+ if(alpha_potential(k, t) == 0){
+ poss_lp += log(1 - phi(tstart+t));
+ } else {
+ poss_lp += log(phi(tstart+t));
+ for (int j=0; j<J; j++){
+ if(R_IsNA(asDouble(ysub(j)))) continue;
+ poss_lp += dbinom(ysub(j), Type(1), psub(j), true);
+ }
+ }
+ }
+ exp_poss_lp += exp(poss_lp);
+ }
+ exp_poss_lp += exp(log(1-psi(i)));
+
+ loglik += log(exp_poss_lp);
+ }
+ }
+
+ return -loglik;
+
+}
+
+#undef TMB_OBJECTIVE_PTR
+#define TMB_OBJECTIVE_PTR this
diff --git a/src/TMB/tmb_occu.hpp b/src/TMB/tmb_occu.hpp
index 0fef715..c282542 100644
--- a/src/TMB/tmb_occu.hpp
+++ b/src/TMB/tmb_occu.hpp
@@ -56,7 +56,10 @@ Type tmb_occu(objective_function<Type>* obj) {
int pind = i * J;
Type cp = 1.0;
for (int j=0; j<J; j++){
- if(R_IsNA(asDouble(y(i,j)))) continue;
+ if(R_IsNA(asDouble(y(i,j)))){
+ pind += 1;
+ continue;
+ }
cp *= pow(p(pind), y(i,j)) * pow(1-p(pind), 1-y(i,j));
pind += 1;
}
diff --git a/src/TMB/unmarked_TMBExports.cpp b/src/TMB/unmarked_TMBExports.cpp
index 2f9c7a2..a8fdc7c 100644
--- a/src/TMB/unmarked_TMBExports.cpp
+++ b/src/TMB/unmarked_TMBExports.cpp
@@ -10,6 +10,7 @@
#include "tmb_distsamp.hpp"
#include "tmb_gdistremoval.hpp"
#include "tmb_IDS.hpp"
+#include "tmb_goccu.hpp"
template<class Type>
Type objective_function<Type>::operator() () {
@@ -26,6 +27,8 @@ Type objective_function<Type>::operator() () {
return tmb_gdistremoval(this);
} else if(model == "tmb_IDS"){
return tmb_IDS(this);
+ } else if(model == "tmb_goccu"){
+ return tmb_goccu(this);
} else {
error("Unknown model.");
}
diff --git a/src/get_lik_trans.cpp b/src/get_lik_trans.cpp
index 472bdb2..d4ae6af 100644
--- a/src/get_lik_trans.cpp
+++ b/src/get_lik_trans.cpp
@@ -1,12 +1,11 @@
-#include "get_lik_trans.h"
+#include <RcppArmadillo.h>
using namespace Rcpp;
using namespace arma;
-SEXP get_lik_trans(SEXP I_, SEXP I1_){
+// [[Rcpp::export]]
- umat I = as<umat>(I_);
- umat I1 = as<umat>(I1_);
+List get_lik_trans(arma::umat I, arma::umat I1){
List Ib(I.n_rows);
List Ip(I.n_rows);
@@ -16,15 +15,15 @@ SEXP get_lik_trans(SEXP I_, SEXP I1_){
IntegerVector Ztmp = seq(0, minI);
uvec Z = as<uvec>(Ztmp);
-
+
uvec Ib_el = find( I1.col(0) <= minI && I1.col(1) == I(i,0) );
- uvec Ip_el = I(i, 1) - Z;
+ uvec Ip_el = I(i, 1) - Z;
Ib[i] = Ib_el;
Ip[i] = Ip_el;
}
List out = List::create(Named("Ib") = Ib , _["Ip"] = Ip);
- return(wrap(out));
+ return out;
}
diff --git a/src/get_lik_trans.h b/src/get_lik_trans.h
deleted file mode 100644
index d903b48..0000000
--- a/src/get_lik_trans.h
+++ /dev/null
@@ -1,8 +0,0 @@
-#ifndef _unmarked_NLL_LIKTRANS_H
-#define _unmarked_NLL_LIKTRANS_H
-
-#include <RcppArmadillo.h>
-
-RcppExport SEXP get_lik_trans(SEXP I_, SEXP I1_);
-
-#endif
diff --git a/src/get_mlogit.cpp b/src/get_mlogit.cpp
index 77eb15c..70c52ff 100644
--- a/src/get_mlogit.cpp
+++ b/src/get_mlogit.cpp
@@ -1,14 +1,10 @@
-#include "get_mlogit.h"
+#include <RcppArmadillo.h>
using namespace Rcpp;
using namespace arma;
-SEXP get_mlogit(SEXP lp_mat_, SEXP type_, SEXP S_, SEXP guide_){
-
- const mat lp_mat = as<mat>(lp_mat_);
- const std::string type = as<std::string>(type_);
- int S = as<int>(S_);
- const mat guide = as<mat>(guide_);
+// [[Rcpp::export]]
+arma::mat get_mlogit(arma::mat lp_mat, std::string type, int S, arma::mat guide){
int R = lp_mat.n_rows;
int C = lp_mat.n_cols;
@@ -22,7 +18,7 @@ SEXP get_mlogit(SEXP lp_mat_, SEXP type_, SEXP S_, SEXP guide_){
out(r,c) = out(r,c) / row_sum;
}
}
- return(wrap(out));
+ return out;
} else if(type == "phi"){
@@ -37,9 +33,9 @@ SEXP get_mlogit(SEXP lp_mat_, SEXP type_, SEXP S_, SEXP guide_){
ix += (S-1);
}
}
- return(wrap(out));
+ return out;
} else if(type == "det"){
-
+
mat out(R,C);
for(int r=0; r<R; r++){
mat sdp = zeros(S,S);
@@ -52,12 +48,12 @@ SEXP get_mlogit(SEXP lp_mat_, SEXP type_, SEXP S_, SEXP guide_){
for (int j=0; j<S; j++){
sdp(s,j) = sdp(s,j) / row_sum;
}
- }
+ }
for(int c=0; c<C; c++){
out(r,c) = sdp( guide(c,0), guide(c,1) );
}
}
- return(wrap(out));
+ return out;
} else {
stop("type must be 'psi','phi',or 'det'");
}
diff --git a/src/get_mlogit.h b/src/get_mlogit.h
deleted file mode 100644
index f143c7a..0000000
--- a/src/get_mlogit.h
+++ /dev/null
@@ -1,8 +0,0 @@
-#ifndef _unmarked_NLL_MULTPROB_H
-#define _unmarked_NLL_MULTPROB_H
-
-#include <RcppArmadillo.h>
-
-RcppExport SEXP get_mlogit(SEXP lp_mat_, SEXP type_, SEXP S_, SEXP guide_);
-
-#endif
diff --git a/src/nll_distsamp.cpp b/src/nll_distsamp.cpp
index 2cdd3d7..6b0956a 100644
--- a/src/nll_distsamp.cpp
+++ b/src/nll_distsamp.cpp
@@ -1,18 +1,12 @@
-#include "nll_distsamp.h"
+#include <RcppArmadillo.h>
+#include <float.h>
+#include "detfuns.h"
-
-SEXP nll_distsamp( SEXP y_, SEXP lam_, SEXP sig_, SEXP scale_, SEXP a_, SEXP u_, SEXP w_, SEXP db_, SEXP keyfun_, SEXP survey_, SEXP reltol_ ) {
-
- Rcpp::IntegerMatrix y(y_);
- Rcpp::NumericVector lam(lam_);
- Rcpp::NumericVector sig(sig_);
- double scale = Rcpp::as<double>(scale_);
- Rcpp::NumericMatrix a(a_);
- Rcpp::NumericMatrix u(u_);
- Rcpp::NumericVector w(w_);
- Rcpp::NumericVector db(db_);
- std::string keyfun = Rcpp::as<std::string>(keyfun_);
- std::string survey = Rcpp::as<std::string>(survey_);
+// [[Rcpp::export]]
+double nll_distsamp(Rcpp::IntegerMatrix y, Rcpp::NumericVector lam,
+ Rcpp::NumericVector sig, double scale, Rcpp::NumericMatrix a,
+ Rcpp::NumericMatrix u, Rcpp::NumericVector w, Rcpp::NumericVector db,
+ std::string keyfun, std::string survey) {
int R = y.nrow(); //y.n_rows;
int J = y.ncol(); // y.n_cols;
@@ -66,5 +60,5 @@ SEXP nll_distsamp( SEXP y_, SEXP lam_, SEXP sig_, SEXP scale_, SEXP a_, SEXP u_,
ll += std::max(Rf_dpois(y(i,j), lam[i]*cp, true), lnmin);
}
}
- return Rcpp::wrap(-ll);
+ return -ll;
}
diff --git a/src/nll_distsamp.h b/src/nll_distsamp.h
deleted file mode 100644
index 8bb31e3..0000000
--- a/src/nll_distsamp.h
+++ /dev/null
@@ -1,10 +0,0 @@
-#ifndef _UNMARKED_NLL_DISTSAMP_H
-#define _UNMARKED_NLL_DISTSAMP_H
-
-#include <Rcpp.h>
-#include <float.h>
-#include "detfuns.h"
-
-RcppExport SEXP nll_distsamp( SEXP y_, SEXP lam_, SEXP sig_, SEXP scale_, SEXP a_, SEXP u_, SEXP w_, SEXP db_, SEXP keyfun_, SEXP survey_, SEXP reltol_ ) ;
-
-#endif
diff --git a/src/nll_distsampOpen.cpp b/src/nll_distsampOpen.cpp
index 9b7482f..0f289af 100644
--- a/src/nll_distsampOpen.cpp
+++ b/src/nll_distsampOpen.cpp
@@ -1,78 +1,31 @@
-#include "nll_distsampOpen.h"
+#include <RcppArmadillo.h>
+#include <float.h>
+#include "tranprobs.h"
+#include "distprob.h"
+#include "distr.h"
using namespace Rcpp;
using namespace arma;
-SEXP nll_distsampOpen( SEXP y_, SEXP yt_, SEXP Xlam_, SEXP Xgam_, SEXP Xom_,
- SEXP Xsig_, SEXP Xiota_,
- SEXP beta_, SEXP beta_ind_,
- SEXP Xlam_offset_,
- SEXP Xgam_offset_, SEXP Xom_offset_, SEXP Xsig_offset_, SEXP Xiota_offset_,
- SEXP ytna_, SEXP lk_, SEXP mixture_, SEXP first_, SEXP last_, SEXP first1_,
- SEXP M_, SEXP T_, SEXP delta_, SEXP dynamics_, SEXP survey_,
- SEXP fix_, SEXP go_dims_, SEXP immigration_, SEXP I_, SEXP I1_, SEXP Ib_,
- SEXP Ip_,
- SEXP a_, SEXP u_, SEXP w_, SEXP db_, SEXP keyfun_,
- SEXP lfac_k_, SEXP kmyt_, SEXP lfac_kmyt_, SEXP fin_, SEXP A_ ) {
+// [[Rcpp::export]]
+double nll_distsampOpen(arma::ucube y, arma::imat yt,
+ arma::mat Xlam, arma::mat Xgam, arma::mat Xom, arma::mat Xsig, arma::mat Xiota,
+ arma::vec beta, arma::umat bi,
+ arma::colvec Xlam_offset, arma::colvec Xgam_offset, arma::colvec Xom_offset,
+ arma::colvec Xsig_offset, arma::colvec Xiota_offset,
+ arma::imat ytna, int lk, std::string mixture,
+ Rcpp::IntegerVector first, Rcpp::IntegerVector last, int first1,
+ int M, int T, arma::imat delta, std::string dynamics, std::string survey,
+ std::string fix, std::string go_dims, bool immigration,
+ arma::imat I, arma::imat I1, Rcpp::List Ib, Rcpp::List Ip,
+ arma::mat a, arma::mat u, arma::vec w, arma::vec db, std::string keyfun,
+ arma::vec lfac_k, arma::cube kmyt, arma::cube lfac_kmyt, arma::icube fin, arma::vec A ) {
//Indices
- int lk = as<int>(lk_);
Rcpp::IntegerVector N = seq_len(lk)-1;
- int M = as<int>(M_);
- int T = as<int>(T_);
- ucube y = as<ucube>(y_);
- imat yt = as<imat>(yt_);
- Rcpp::IntegerVector first(first_);
- Rcpp::IntegerVector last(last_);
- int first1 = as<int>(first1_);
- arma::imat ytna = as<arma::imat>(ytna_); // y[i,,t] are all NA
- arma::imat delta = as<arma::imat>(delta_);
-
- vec lfac_k = as<vec>(lfac_k_);
- cube lfac_kmyt = as<cube>(lfac_kmyt_);
- cube kmyt = as<cube>(kmyt_);
- icube fin = as<icube>(fin_);
- imat I = as<arma::imat>(I_);
- imat I1 = as<arma::imat>(I1_);
- List Ib(Ib_);
- List Ip(Ip_);
int nrI = I.n_rows;
int nrI1 = I1.n_rows;
- //Distance sampling info
- mat a = as<mat>(a_);
- mat u = as<mat>(u_);
- vec w = as<vec>(w_);
- vec db = as<vec>(db_);
- vec A = as<vec>(A_);
-
- //Covariate matrices
- mat Xlam = as<mat>(Xlam_);
- mat Xgam = as<mat>(Xgam_);
- mat Xom = as<mat>(Xom_);
- mat Xsig = as<mat>(Xsig_);
- mat Xiota = as<mat>(Xiota_);
-
- //Offsets
- colvec Xlam_offset = as<colvec>(Xlam_offset_);
- colvec Xgam_offset = as<colvec>(Xgam_offset_);
- colvec Xom_offset = as<colvec>(Xom_offset_);
- colvec Xsig_offset = as<colvec>(Xsig_offset_);
- colvec Xiota_offset = as<colvec>(Xiota_offset_);
-
- //Model types
- std::string keyfun = as<std::string>(keyfun_);
- std::string mixture = as<std::string>(mixture_);
- std::string dynamics = as<std::string>(dynamics_);
- std::string fix = as<std::string>(fix_);
- std::string go_dims = as<std::string>(go_dims_);
- bool immigration = as<bool>(immigration_);
- std::string survey = as<std::string>(survey_);
-
- //Parameters
- vec beta = as<vec>(beta_);
- umat bi = as<umat>(beta_ind_);
-
//Lambda
vec beta_lam = beta.subvec(bi(0,0), bi(0,1));
vec lam = exp(Xlam*beta_lam + Xlam_offset) % A;
@@ -328,5 +281,5 @@ SEXP nll_distsampOpen( SEXP y_, SEXP yt_, SEXP Xlam_, SEXP Xgam_, SEXP Xom_,
}
- return wrap(-ll);
+ return -ll;
}
diff --git a/src/nll_distsampOpen.h b/src/nll_distsampOpen.h
deleted file mode 100644
index 00850fd..0000000
--- a/src/nll_distsampOpen.h
+++ /dev/null
@@ -1,19 +0,0 @@
-#ifndef _unmarked_NLL_DISTSAMPOPEN_H
-#define _unmarked_NLL_DISTSAMPOPEN_H
-
-#include <RcppArmadillo.h>
-#include <float.h>
-#include "tranprobs.h"
-#include "distprob.h"
-#include "distr.h"
-
-RcppExport SEXP nll_distsampOpen( SEXP y_, SEXP yt_, SEXP Xlam_, SEXP Xgam_, SEXP Xom_,
- SEXP Xsig_, SEXP Xiota_, SEXP beta_, SEXP beta_ind_,
- SEXP Xlam_offset_, SEXP Xgam_offset_, SEXP Xom_offset_, SEXP Xsig_offset_,
- SEXP Xiota_offset_, SEXP ytna_, SEXP lk_, SEXP mixture_, SEXP first_,
- SEXP last_, SEXP first1_, SEXP M_, SEXP T_, SEXP delta_, SEXP dynamics_,
- SEXP survey_, SEXP fix_, SEXP go_dims_, SEXP immigration_, SEXP I_,
- SEXP I1_, SEXP Ib_, SEXP Ip_, SEXP a_, SEXP u_, SEXP w_, SEXP db_,
- SEXP keyfun_, SEXP lfac_k_, SEXP kmyt_, SEXP lfac_kmyt_, SEXP fin_, SEXP A_ ) ;
-
-#endif
diff --git a/src/nll_multinomPois.cpp b/src/nll_multinomPois.cpp
index 581ab53..e12ba82 100644
--- a/src/nll_multinomPois.cpp
+++ b/src/nll_multinomPois.cpp
@@ -1,4 +1,4 @@
-#include "nll_multinomPois.h"
+#include <RcppArmadillo.h>
#include "pifun.h"
using namespace Rcpp;
@@ -8,32 +8,18 @@ mat inv_logit_( mat inp ){
return(1 / (1 + exp(-1 * inp)));
}
-SEXP nll_multinomPois(SEXP betaR, SEXP pi_funR,
- SEXP XlamR, SEXP Xlam_offsetR, SEXP XdetR, SEXP Xdet_offsetR,
- SEXP yR, SEXP navecR, SEXP nPr, SEXP nAPr){
-
- //Inputs
- vec beta = as<vec>(betaR);
- std::string pi_fun = as<std::string>(pi_funR);
-
- mat Xlam = as<mat>(XlamR);
- vec Xlam_offset = as<vec>(Xlam_offsetR);
- mat Xdet = as<mat>(XdetR);
- vec Xdet_offset = as<vec>(Xdet_offsetR);
-
- vec y = as<vec>(yR);
- vec navec = as<vec>(navecR);
-
- int nP = as<int>(nPr);
- int nAP = as<int>(nAPr);
+// [[Rcpp::export]]
+double nll_multinomPois(arma::vec beta, std::string pi_fun,
+ arma::mat Xlam, arma::vec Xlam_offset, arma::mat Xdet, arma::vec Xdet_offset,
+ arma::vec y, arma::vec navec, int nP, int nAP){
int M = Xlam.n_rows;
vec lambda = exp( Xlam * beta.subvec(0, (nAP - 1) ) + Xlam_offset );
-
+
int J = Xdet.n_rows / M;
- int R = y.size() / M;
+ int R = y.size() / M;
vec p = inv_logit_( Xdet * beta.subvec(nAP,(nP-1)) + Xdet_offset);
-
+
int y_ind = 0;
int p_ind = 0;
@@ -43,11 +29,11 @@ SEXP nll_multinomPois(SEXP betaR, SEXP pi_funR,
int y_stop = y_ind + R - 1;
int p_stop = p_ind + J - 1;
- vec na_sub = navec.subvec(y_ind, y_stop);
+ vec na_sub = navec.subvec(y_ind, y_stop);
if( ! all(na_sub) ){
- vec pi_lam = piFun( p.subvec(p_ind, p_stop), pi_fun ) * lambda(m);
-
+ vec pi_lam = piFun( p.subvec(p_ind, p_stop), pi_fun ) * lambda(m);
+
for (int r=0; r<R; r++){
if( ! na_sub(r) ){
ll(m,r) = R::dpois(y(y_ind+r), pi_lam(r), 1);
@@ -59,6 +45,6 @@ SEXP nll_multinomPois(SEXP betaR, SEXP pi_funR,
p_ind += J;
}
- return(wrap(-accu(ll)));
+ return -accu(ll);
}
diff --git a/src/nll_multinomPois.h b/src/nll_multinomPois.h
deleted file mode 100644
index 19f503f..0000000
--- a/src/nll_multinomPois.h
+++ /dev/null
@@ -1,10 +0,0 @@
-#ifndef _unmarked_NLL_MULTINOMPOIS_H
-#define _unmarked_NLL_MULTINOMPOIS_H
-
-#include <RcppArmadillo.h>
-
-RcppExport SEXP nll_multinomPois(SEXP betaR, SEXP pi_funR,
- SEXP XlamR, SEXP Xlam_offsetR, SEXP XdetR, SEXP Xdet_offsetR,
- SEXP yR, SEXP navecR, SEXP nPr, SEXP nAPr) ;
-
-#endif
diff --git a/src/nll_multmixOpen.cpp b/src/nll_multmixOpen.cpp
index 2e4c480..6fb755a 100644
--- a/src/nll_multmixOpen.cpp
+++ b/src/nll_multmixOpen.cpp
@@ -1,73 +1,31 @@
-#include "nll_multmixOpen.h"
+#include <RcppArmadillo.h>
+#include <float.h>
+#include "tranprobs.h"
+#include "distr.h"
+#include "pifun.h"
+#include "utils.h"
using namespace Rcpp;
using namespace arma;
-SEXP nll_multmixOpen( SEXP y_, SEXP yt_, SEXP Xlam_, SEXP Xgam_, SEXP Xom_,
- SEXP Xp_, SEXP Xiota_,
- SEXP beta_, SEXP beta_ind_,
- SEXP Xlam_offset_,
- 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 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_) {
+// [[Rcpp::export]]
+double nll_multmixOpen(arma::ucube y, arma::imat yt,
+ arma::mat Xlam, arma::mat Xgam, arma::mat Xom, arma::mat Xp, arma::mat Xiota,
+ arma::vec beta, arma::umat bi,
+ arma::colvec Xlam_offset, arma::colvec Xgam_offset, arma::colvec Xom_offset,
+ arma::colvec Xp_offset, arma::colvec Xiota_offset,
+ arma::imat ytna, arma::ucube yna, int lk, std::string mixture,
+ Rcpp::IntegerVector first, Rcpp::IntegerVector last, int first1,
+ int M, int T, int J, int R, arma::imat delta, std::string dynamics,
+ std::string fix, std::string go_dims, bool immigration,
+ arma::imat I, arma::imat I1, Rcpp::List Ib, Rcpp::List Ip, std::string pi_fun,
+ arma::vec lfac_k, arma::cube kmyt, arma::cube lfac_kmyt, arma::icube fin) {
//Indices
- int lk = as<int>(lk_);
Rcpp::IntegerVector N = seq_len(lk)-1;
- 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_);
- Rcpp::IntegerVector last(last_);
- int first1 = as<int>(first1_);
- arma::imat ytna = as<arma::imat>(ytna_); // y[i,,t] are all NA
- ucube yna = as<ucube>(yna_);
- arma::imat delta = as<arma::imat>(delta_);
-
- vec lfac_k = as<vec>(lfac_k_);
- cube lfac_kmyt = as<cube>(lfac_kmyt_);
- cube kmyt = as<cube>(kmyt_);
- icube fin = as<icube>(fin_);
- imat I = as<arma::imat>(I_);
- imat I1 = as<arma::imat>(I1_);
- List Ib(Ib_);
- List Ip(Ip_);
int nrI = I.n_rows;
int nrI1 = I1.n_rows;
- //Covariate matrices
- mat Xlam = as<mat>(Xlam_);
- mat Xgam = as<mat>(Xgam_);
- mat Xom = as<mat>(Xom_);
- mat Xp = as<mat>(Xp_);
- mat Xiota = as<mat>(Xiota_);
-
- //Offsets
- colvec Xlam_offset = as<colvec>(Xlam_offset_);
- colvec Xgam_offset = as<colvec>(Xgam_offset_);
- colvec Xom_offset = as<colvec>(Xom_offset_);
- colvec Xp_offset = as<colvec>(Xp_offset_);
- colvec Xiota_offset = as<colvec>(Xiota_offset_);
-
- //Model types
- std::string mixture = as<std::string>(mixture_);
- std::string pi_fun = as<std::string>(pi_fun_);
- std::string dynamics = as<std::string>(dynamics_);
- std::string fix = as<std::string>(fix_);
- std::string go_dims = as<std::string>(go_dims_);
- bool immigration = as<bool>(immigration_);
-
- //Parameters
- vec beta = as<vec>(beta_);
- umat bi = as<umat>(beta_ind_);
-
//Lambda
vec beta_lam = beta.subvec(bi(0,0), bi(0,1));
vec lam = exp(Xlam*beta_lam + Xlam_offset);
@@ -322,5 +280,5 @@ SEXP nll_multmixOpen( SEXP y_, SEXP yt_, SEXP Xlam_, SEXP Xgam_, SEXP Xom_,
}
- return wrap(-ll);
+ return -ll;
}
diff --git a/src/nll_multmixOpen.h b/src/nll_multmixOpen.h
deleted file mode 100644
index 50fc2f1..0000000
--- a/src/nll_multmixOpen.h
+++ /dev/null
@@ -1,23 +0,0 @@
-#ifndef _unmarked_NLL_MULTMIXOPEN_H
-#define _unmarked_NLL_MULTMIXOPEN_H
-
-#include <RcppArmadillo.h>
-#include <float.h>
-#include "tranprobs.h"
-#include "distr.h"
-#include "pifun.h"
-#include "utils.h"
-
-RcppExport SEXP nll_multmixOpen( SEXP y_, SEXP yt_, SEXP Xlam_, SEXP Xgam_, SEXP Xom_,
- SEXP Xp_, SEXP Xiota_,
- SEXP beta_, SEXP beta_ind_,
- SEXP Xlam_offset_,
- 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 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_) ;
-
-#endif
diff --git a/src/nll_occu.cpp b/src/nll_occu.cpp
index 7d8bf1b..0a8abe4 100644
--- a/src/nll_occu.cpp
+++ b/src/nll_occu.cpp
@@ -1,19 +1,13 @@
-#include "nll_occu.h"
+#include <RcppArmadillo.h>
+#include <float.h>
using namespace Rcpp ;
-SEXP nll_occu( SEXP yR, SEXP Xr, SEXP Vr, SEXP beta_psiR, SEXP beta_pR, SEXP ndR, SEXP knownOccR, SEXP navecR, SEXP X_offsetR, SEXP V_offsetR, SEXP link_psiR ) {
- arma::icolvec y = as<arma::icolvec>(yR);
- arma::mat X = as<arma::mat>(Xr);
- arma::mat V = as<arma::mat>(Vr);
- arma::colvec beta_psi = as<arma::colvec>(beta_psiR);
- arma::colvec beta_p = as<arma::colvec>(beta_pR);
- Rcpp::IntegerVector nd(ndR);
- Rcpp::LogicalVector knownOcc(knownOccR);
- Rcpp::LogicalVector navec(navecR);
- arma::colvec X_offset = as<arma::colvec>(X_offsetR);
- arma::colvec V_offset = as<arma::colvec>(V_offsetR);
- std::string link_psi = as<std::string>(link_psiR);
+// [[Rcpp::export]]
+double nll_occu(arma::icolvec y, arma::mat X, arma::mat V,
+ arma::colvec beta_psi, arma::colvec beta_p,
+ Rcpp::IntegerVector nd, Rcpp::LogicalVector knownOcc, Rcpp::LogicalVector navec,
+ arma::colvec X_offset, arma::colvec V_offset, std::string link_psi) {
int R = X.n_rows;
int J = y.n_elem / R;
@@ -47,6 +41,5 @@ SEXP nll_occu( SEXP yR, SEXP Xr, SEXP Vr, SEXP beta_psiR, SEXP beta_pR, SEXP ndR
else if(nd(i)==1)
ll += log(cp * psi(i) + (1-psi(i)) + DBL_MIN);
}
- return wrap(-ll);
+ return -ll;
}
-
diff --git a/src/nll_occu.h b/src/nll_occu.h
deleted file mode 100644
index e8592f6..0000000
--- a/src/nll_occu.h
+++ /dev/null
@@ -1,9 +0,0 @@
-#ifndef _unmarked_NLL_OCCU_H
-#define _unmarked_NLL_OCCU_H
-
-#include <RcppArmadillo.h>
-#include <float.h>
-
-RcppExport SEXP nll_occu( SEXP yR, SEXP Xr, SEXP Vr, SEXP beta_psiR, SEXP beta_pR, SEXP ndR, SEXP knownOccR, SEXP navecR, SEXP X_offsetR, SEXP V_offsetR, SEXP link_psiR ) ;
-
-#endif
diff --git a/src/nll_occuCOP.cpp b/src/nll_occuCOP.cpp
new file mode 100644
index 0000000..8c18bbf
--- /dev/null
+++ b/src/nll_occuCOP.cpp
@@ -0,0 +1,48 @@
+#include <RcppArmadillo.h>
+#include <float.h>
+
+using namespace Rcpp ;
+
+// [[Rcpp::export]]
+double nll_occuCOP(arma::icolvec y, arma::icolvec L,
+ arma::mat Xpsi, arma::mat Xlambda,
+ arma::colvec beta_psi, arma::colvec beta_lambda,
+ Rcpp::LogicalVector removed) {
+
+ // Number of sites M and obs J
+ int M = Xpsi.n_rows;
+ int J = y.n_elem / M;
+
+ //Calculate psi back-transformed from logit
+ arma::colvec psi = 1.0/(1.0+exp(-Xpsi*beta_psi));
+
+ //Calculate lambda back-transformed from log
+ arma::colvec lambda = exp(Xlambda*beta_lambda);
+
+ double ll=0.0;
+ int k=0; // counter
+ // for each site i in 1:M
+ for(int i=0; i<M; i++) {
+ double iLambdaL=0.0; // init sum(lambda_ij * L_ij)
+ double iN=0.0; // init sum(y) = total count of detec at site i
+ int NbRemoved=0; // init count of the removed observations at site i
+ for(int j=0; j<J; j++) {
+ if(!removed(k)) {
+ // If the observation is not removed from the analysis
+ // (removed if there is a NA in y, L or in the relevant covariates for this site and obs)
+ iLambdaL += lambda(k)*L(k);
+ iN += y(k);
+ NbRemoved += 1;
+ }
+ k++;
+ }
+ if ((!NbRemoved) < J) {
+ if(iN>0) {
+ ll += log(psi(i) * pow(iLambdaL, iN) / tgamma(iN + 1) * exp(-iLambdaL));
+ } else {
+ ll += log(psi(i) * exp(-iLambdaL) + 1-psi(i));
+ }
+ }
+ }
+ return -ll;
+}
diff --git a/src/nll_occuMS.cpp b/src/nll_occuMS.cpp
index 70ff5d1..da2bf8f 100644
--- a/src/nll_occuMS.cpp
+++ b/src/nll_occuMS.cpp
@@ -1,4 +1,4 @@
-#include "nll_occuMS.h"
+#include <RcppArmadillo.h>
using namespace Rcpp;
using namespace arma;
@@ -15,7 +15,7 @@ mat get_param(const List& dm_list, const vec& beta, const mat& ind){
mat X = as<mat>(dm_list[i]);
out.col(i) = X * beta.subvec(ind(i,0), ind(i,1));
}
-
+
return(out);
}
@@ -34,12 +34,12 @@ rowvec multinom_logit(const rowvec& lp){
//calculate final psi depending on parameterization
mat get_psi(const mat& lp, const std::string& prm){
int R = lp.n_rows;
-
+
if(prm == "multinomial"){
//[ 1 - psi_1:psi_m, psi_1:psi_m ]
mat out(R, lp.n_cols + 1);
for (int i=0; i<R; i++){
- out.row(i) = multinom_logit(lp.row(i));
+ out.row(i) = multinom_logit(lp.row(i));
}
return(out);
@@ -60,9 +60,9 @@ mat get_psi(const mat& lp, const std::string& prm){
//calculate phi matrix for a site-year depending on parameterization
mat get_phi(int S, const rowvec& lp, const std::string& prm){
-
+
mat out(S,S);
-
+
if(prm == "multinomial"){
int index = 0;
for (int i=0; i<S; i++){ //row
@@ -78,7 +78,7 @@ mat get_phi(int S, const rowvec& lp, const std::string& prm){
out.row(i) = lp_row / sum(lp_row);
}
return(out);
-
+
} else if(prm == "condbinom"){
rowvec lp_logit = 1 / ( 1 + exp(-lp));
for(int i=0; i<S; i++){
@@ -92,12 +92,12 @@ mat get_phi(int S, const rowvec& lp, const std::string& prm){
}
}
-mat get_sdp(int S, const rowvec& lp, const mat& guide,
+mat get_sdp(int S, const rowvec& lp, const mat& guide,
const std::string& prm){
mat out = zeros(S,S);
- if(prm == "multinomial"){
+ if(prm == "multinomial"){
for (unsigned int i=0; i<lp.size(); i++){
out( guide(i,0), guide(i,1) ) = exp(lp(i));
}
@@ -125,9 +125,9 @@ mat get_sdp(int S, const rowvec& lp, const mat& guide,
}
}
-vec get_ph(const int S, const rowvec& y, const mat& probs,
+vec get_ph(const int S, const rowvec& y, const mat& probs,
const rowvec& navec, const mat& guide, const std::string prm){
-
+
int J = probs.n_rows;
vec out = ones(S);
@@ -143,42 +143,20 @@ vec get_ph(const int S, const rowvec& y, const mat& probs,
return(out);
}
-SEXP nll_occuMS( SEXP beta_, SEXP y_,
- SEXP dm_state_, SEXP dm_phi_, SEXP dm_det_,
- SEXP sind_, SEXP pind_, SEXP dind_, SEXP prm_,
- SEXP S_, SEXP T_, SEXP J_, SEXP N_,
- SEXP naflag_, SEXP guide_){
-
- //Inputs
- const vec beta = as<vec>(beta_);
- const mat y = as<mat>(y_);
- const List dm_state(dm_state_);
- const List dm_phi(dm_phi_);
- const List dm_det(dm_det_);
-
- const mat sind = as<mat>(sind_);
- const mat dind = as<mat>(dind_);
- const mat guide = as<mat>(guide_);
-
- const std::string prm = as<std::string>(prm_);
-
- const mat naflag = as<mat>(naflag_);
-
- int N = as<int>(N_);
- int S = as<int>(S_);
- int T = as<int>(T_);
- int J = as<int>(J_);
-
+// [[Rcpp::export]]
+double nll_occuMS(arma::vec beta, arma::mat y,
+ Rcpp::List dm_state, Rcpp::List dm_phi, Rcpp::List dm_det,
+ arma::mat sind, arma::mat pind, arma::mat dind, std::string prm,
+ int S, int T, int J, int N,
+ arma::mat naflag, arma::mat guide){
//Get psi values
const mat raw_psi = get_param(dm_state, beta, sind);
const mat psi = get_psi(raw_psi, prm);
-
+
//Get phi values
mat raw_phi;
- mat pind;
if(T>1){
- pind = as<mat>(pind_);
raw_phi = get_param(dm_phi, beta, pind);
}
@@ -197,7 +175,7 @@ SEXP nll_occuMS( SEXP beta_, SEXP y_,
rowvec nasub = naflag.row(n);
ystart = 0;
mat phi_prod = eye(S,S);
-
+
if(T>1){
for(int t=0; t<(T-1); t++){
pend = pstart + J - 1;
@@ -214,7 +192,7 @@ SEXP nll_occuMS( SEXP beta_, SEXP y_,
phi_index += 1;
}
}
-
+
pend = pstart + J - 1;
yend = ystart + J - 1;
@@ -222,12 +200,12 @@ SEXP nll_occuMS( SEXP beta_, SEXP y_,
p.rows(span(pstart, pend)),
nasub.subvec(ystart,yend), guide, prm);
pstart += J;
-
+
rowvec psi_phi = psi.row(n) * phi_prod;
lik(n) = dot(psi_phi, ph_T);
}
- return(wrap(-sum(log(lik))));
+ return -sum(log(lik));
}
diff --git a/src/nll_occuMS.h b/src/nll_occuMS.h
deleted file mode 100644
index 847c099..0000000
--- a/src/nll_occuMS.h
+++ /dev/null
@@ -1,12 +0,0 @@
-#ifndef _unmarked_NLL_OCCUMS_H
-#define _unmarked_NLL_OCCUMS_H
-
-#include <RcppArmadillo.h>
-
-RcppExport SEXP nll_occuMS( SEXP beta_, SEXP y_,
- SEXP dm_state_, SEXP dm_phi_, SEXP dm_det_,
- SEXP sind_, SEXP pind_, SEXP dind_, SEXP prm_,
- SEXP S_, SEXP T_, SEXP J_, SEXP N_,
- SEXP naflag_, SEXP guide_) ;
-
-#endif
diff --git a/src/nll_occuMulti.cpp b/src/nll_occuMulti.cpp
index 3a44c7d..5310097 100644
--- a/src/nll_occuMulti.cpp
+++ b/src/nll_occuMulti.cpp
@@ -1,46 +1,21 @@
-#include "nll_occuMulti.h"
+#include <RcppArmadillo.h>
using namespace Rcpp;
using namespace arma;
-SEXP nll_occuMulti( SEXP fStartR, SEXP fStopR, SEXP dmFr, SEXP dmOccR,
- SEXP betaR, SEXP dmDetR, SEXP dStartR, SEXP dStopR, SEXP yR, SEXP yStartR,
- SEXP yStopR, SEXP Iy0r, SEXP zR, SEXP fixed0r, SEXP penaltyR,
- SEXP returnLLr){
-
- //Inputs
- IntegerVector fStart(fStartR);
- IntegerVector fStop(fStopR);
-
- //if Matrix is a dependency
- sp_mat dmF = as<sp_mat>(dmFr); //already transposed
-
- //if Matrix not a dependency
- //sp_mat dmF( as<mat>(dmFr) );
-
- int nF = dmF.n_rows;
- List dmOcc(dmOccR);
-
- colvec beta = as<colvec>(betaR);
- LogicalVector fixed0(fixed0r);
-
- List dmDet(dmDetR);
- IntegerVector dStart(dStartR);
- IntegerVector dStop(dStopR);
-
- mat y = as<mat>(yR);
+// [[Rcpp::export]]
+arma::vec nll_occuMulti_loglik(Rcpp::IntegerVector fStart, Rcpp::IntegerVector fStop,
+ arma::sp_mat dmF, Rcpp::List dmOcc,
+ arma::colvec beta, Rcpp::List dmDet,
+ Rcpp::IntegerVector dStart, Rcpp::IntegerVector dStop,
+ arma::mat y, Rcpp::IntegerVector yStart, Rcpp::IntegerVector yStop,
+ arma::mat Iy0, arma::mat z, Rcpp::LogicalVector fixed0){
+
+ int nF = dmF.n_rows; //dmF is already transposed
int S = y.n_cols;
int J = y.n_rows;
- IntegerVector yStart(yStartR);
- IntegerVector yStop(yStopR);
int N = yStart.size();
- mat Iy0 = as<mat>(Iy0r);
-
- mat z = as<mat>(zR);
- double penalty = as<double>(penaltyR);
- int returnLL = as<int>(returnLLr);
-
//psi calculation
int index = 0;
mat f(N, nF);
@@ -54,7 +29,7 @@ SEXP nll_occuMulti( SEXP fStartR, SEXP fStopR, SEXP dmFr, SEXP dmOccR,
}
}
- mat psi = exp( f * dmF );
+ mat psi = exp( f * dmF );
for(unsigned int i = 0; i < psi.n_rows; i++){
psi.row(i) = psi.row(i) / sum( psi.row(i) );
}
@@ -72,15 +47,15 @@ SEXP nll_occuMulti( SEXP fStartR, SEXP fStopR, SEXP dmFr, SEXP dmOccR,
vec logLik(N);
for(int i = 0; i < N; i++){
-
+
mat ysub = y.rows(yStart[i], yStop[i]);
mat psub = p.rows(yStart[i], yStop[i]);
rowvec cdp(S);
for(int j = 0; j < S; j++){
- cdp(j) = exp( sum( ysub.col(j) % log(psub.col(j)) ) +
+ cdp(j) = exp( sum( ysub.col(j) % log(psub.col(j)) ) +
sum( (1 - ysub.col(j)) % log( 1 - psub.col(j)) ) );
}
-
+
rowvec prdProbY(M);
for(int j = 0; j < M; j++){
prdProbY(j) = prod( z.row(j) % cdp + (1 - z.row(j)) % Iy0.row(i) );
@@ -89,11 +64,21 @@ SEXP nll_occuMulti( SEXP fStartR, SEXP fStopR, SEXP dmFr, SEXP dmOccR,
logLik(i) = log( sum( psi.row(i) % prdProbY ) );
}
-
- if(returnLL){
- return(wrap(logLik));
- }
+
+ return logLik;
+}
+
+// [[Rcpp::export]]
+double nll_occuMulti(Rcpp::IntegerVector fStart, Rcpp::IntegerVector fStop,
+ arma::sp_mat dmF, Rcpp::List dmOcc,
+ arma::colvec beta, Rcpp::List dmDet,
+ Rcpp::IntegerVector dStart, Rcpp::IntegerVector dStop,
+ arma::mat y, Rcpp::IntegerVector yStart, Rcpp::IntegerVector yStop,
+ arma::mat Iy0, arma::mat z, Rcpp::LogicalVector fixed0, double penalty){
+
+ vec logLik = nll_occuMulti_loglik(fStart, fStop, dmF, dmOcc, beta, dmDet,
+ dStart, dStop, y, yStart, yStop, Iy0, z, fixed0);
double pen = penalty * 0.5 * accu(pow(beta, 2));
- return(wrap(-1.0 * (sum(logLik) - pen)));
+ return -1.0 * (sum(logLik) - pen);
}
diff --git a/src/nll_occuMulti.h b/src/nll_occuMulti.h
deleted file mode 100644
index 47cb53e..0000000
--- a/src/nll_occuMulti.h
+++ /dev/null
@@ -1,11 +0,0 @@
-#ifndef _unmarked_NLL_OCCUMULTI_H
-#define _unmarked_NLL_OCCUMULTI_H
-
-#include <RcppArmadillo.h>
-
-RcppExport SEXP nll_occuMulti( SEXP fStartR, SEXP fStopR, SEXP dmFr, SEXP dmOccR,
- SEXP betaR, SEXP dmDetR, SEXP dStartR, SEXP dStopR, SEXP yR, SEXP yStartR,
- SEXP yStopR, SEXP Iy0r, SEXP zR, SEXP fixed0r, SEXP penaltyR,
- SEXP returnLLr) ;
-
-#endif
diff --git a/src/nll_occuPEN.cpp b/src/nll_occuPEN.cpp
index 5e41a50..32c362a 100644
--- a/src/nll_occuPEN.cpp
+++ b/src/nll_occuPEN.cpp
@@ -1,20 +1,14 @@
-#include "nll_occuPEN.h"
+#include <RcppArmadillo.h>
+#include <float.h>
using namespace Rcpp ;
-SEXP nll_occuPEN( SEXP yR, SEXP Xr, SEXP Vr, SEXP beta_psiR, SEXP beta_pR, SEXP ndR, SEXP knownOccR, SEXP navecR, SEXP X_offsetR, SEXP V_offsetR, SEXP penaltyR ) {
- arma::icolvec y = as<arma::icolvec>(yR);
- arma::mat X = as<arma::mat>(Xr);
- arma::mat V = as<arma::mat>(Vr);
- arma::colvec beta_psi = as<arma::colvec>(beta_psiR);
- arma::colvec beta_p = as<arma::colvec>(beta_pR);
- Rcpp::IntegerVector nd(ndR);
- Rcpp::LogicalVector knownOcc(knownOccR);
- Rcpp::LogicalVector navec(navecR);
- arma::colvec X_offset = as<arma::colvec>(X_offsetR);
- arma::colvec V_offset = as<arma::colvec>(V_offsetR);
- //std::double penalty = as<std::double>(penaltyR);
- double penalty = as<double>(penaltyR);
+// [[Rcpp::export]]
+double nll_occuPEN(arma::icolvec y, arma::mat X, arma::mat V,
+ arma::colvec beta_psi, arma::colvec beta_p, Rcpp::IntegerVector nd,
+ Rcpp::LogicalVector knownOcc, Rcpp::LogicalVector navec,
+ arma::colvec X_offset, arma::colvec V_offset, double penalty) {
+
int R = X.n_rows;
int J = y.n_elem / R;
arma::colvec logit_psi = X*beta_psi + X_offset;
@@ -38,6 +32,6 @@ SEXP nll_occuPEN( SEXP yR, SEXP Xr, SEXP Vr, SEXP beta_psiR, SEXP beta_pR, SEXP
ll += log(cp * psi(i) + (1-psi(i)) + DBL_MIN);
}
ll = ll - penalty;
- return wrap(-ll);
+ return -ll;
}
diff --git a/src/nll_occuPEN.h b/src/nll_occuPEN.h
deleted file mode 100644
index b5875fd..0000000
--- a/src/nll_occuPEN.h
+++ /dev/null
@@ -1,9 +0,0 @@
-#ifndef _unmarked_NLL_OCCUPEN_H
-#define _unmarked_NLL_OCCUPEN_H
-
-#include <RcppArmadillo.h>
-#include <float.h>
-
-RcppExport SEXP nll_occuPEN( SEXP yR, SEXP Xr, SEXP Vr, SEXP beta_psiR, SEXP beta_pR, SEXP ndR, SEXP knownOccR, SEXP navecR, SEXP X_offsetR, SEXP V_offsetR, SEXP penaltyR ) ;
-
-#endif
diff --git a/src/nll_occuTTD.cpp b/src/nll_occuTTD.cpp
index 4324403..8005f2a 100644
--- a/src/nll_occuTTD.cpp
+++ b/src/nll_occuTTD.cpp
@@ -1,4 +1,4 @@
-#include "nll_occuTTD.h"
+#include <RcppArmadillo.h>
using namespace Rcpp;
using namespace arma;
@@ -30,35 +30,15 @@ using namespace arma;
//}
-SEXP nll_occuTTD( SEXP beta_, SEXP y_, SEXP delta_,
- SEXP W_, SEXP V_, SEXP Xgam_, SEXP Xeps_,
- SEXP pind_, SEXP dind_, SEXP cind_, SEXP eind_,
- SEXP lpsi_, SEXP tdist_,
- SEXP N_, SEXP T_, SEXP J_,
- SEXP naflag_){
-
- //Inputs
- const vec beta = as<vec>(beta_);
- const vec y = as<vec>(y_);
- const vec delta = as<vec>(delta_);
- const vec naflag = as<vec>(naflag_);
- const mat W = as<mat>(W_);
- const mat V = as<mat>(V_);
- const vec pind = as<vec>(pind_);
- const vec dind = as<vec>(dind_);
- const std::string lpsi = as<std::string>(lpsi_);
- const std::string tdist = as<std::string>(tdist_);
-
- int N = as<int>(N_);
- int T = as<int>(T_);
- int J = as<int>(J_);
- int ys = y.size();
+// [[Rcpp::export]]
+double nll_occuTTD( arma::vec beta, arma::vec y, arma::vec delta,
+ arma::mat W, arma::mat V, arma::mat Xgam, arma::mat Xeps,
+ arma::vec pind, arma::vec dind, arma::vec cind, arma::vec eind,
+ std::string lpsi, std::string tdist,
+ int N, int T, int J,
+ arma::vec naflag){
- //Dynamic stuff
- const mat Xgam = as<mat>(Xgam_);
- const mat Xeps = as<mat>(Xeps_);
- const vec cind = as<vec>(cind_);
- const vec eind = as<vec>(eind_);
+ int ys = y.size();
//Get psi values
colvec raw_psi = W * beta.subvec(pind(0), pind(1));
@@ -131,6 +111,6 @@ SEXP nll_occuTTD( SEXP beta_, SEXP y_, SEXP delta_,
}
- return(wrap(-sum(log(lik))));
+ return -sum(log(lik));
}
diff --git a/src/nll_occuTTD.h b/src/nll_occuTTD.h
deleted file mode 100644
index 2991898..0000000
--- a/src/nll_occuTTD.h
+++ /dev/null
@@ -1,13 +0,0 @@
-#ifndef _unmarked_NLL_OCCUTTD_H
-#define _unmarked_NLL_OCCUTTD_H
-
-#include <RcppArmadillo.h>
-
-RcppExport SEXP nll_occuTTD( SEXP beta_, SEXP y_, SEXP delta_,
- SEXP W_, SEXP V_, SEXP Xgam_, SEXP Xeps_,
- SEXP pind_, SEXP dind_, SEXP cind_, SEXP eind_,
- SEXP lpsi_, SEXP tdist_,
- SEXP N_, SEXP T_, SEXP J_,
- SEXP naflag_) ;
-
-#endif
diff --git a/src/nll_pcountOpen.cpp b/src/nll_pcountOpen.cpp
index 9d31e8e..235976c 100644
--- a/src/nll_pcountOpen.cpp
+++ b/src/nll_pcountOpen.cpp
@@ -1,44 +1,24 @@
-#include "nll_pcountOpen.h"
-#include "tranprobs.h"
+#include <RcppArmadillo.h>
+#include <float.h>
#include "distr.h"
+#include "tranprobs.h"
using namespace Rcpp ;
+// [[Rcpp::export]]
+double nll_pcountOpen(arma::imat ym, arma::mat Xlam, arma::mat Xgam, arma::mat Xom,
+ arma::mat Xp, arma::mat Xiota, arma::colvec beta_lam, arma::colvec beta_gam,
+ arma::colvec beta_om, arma::colvec beta_p, arma::colvec beta_iota,
+ double log_alpha, arma::colvec Xlam_offset, arma::colvec Xgam_offset,
+ arma::colvec Xom_offset, arma::colvec Xp_offset, arma::colvec Xiota_offset,
+ arma::imat ytna, arma::imat ynam, int lk, std::string mixture,
+ Rcpp::IntegerVector first, Rcpp::IntegerVector last, int M, int J, int T,
+ arma::imat delta, std::string dynamics, std::string fix, std::string go_dims,
+ bool immigration, arma::imat I, arma::imat I1, Rcpp::List Ib, Rcpp::List Ip) {
-SEXP nll_pcountOpen( SEXP y_, SEXP Xlam_, SEXP Xgam_, SEXP Xom_, SEXP Xp_, SEXP Xiota_, SEXP beta_lam_, SEXP beta_gam_, SEXP beta_om_, SEXP beta_p_, SEXP beta_iota_, SEXP log_alpha_, SEXP Xlam_offset_, 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 M_, SEXP J_, SEXP T_, SEXP delta_, SEXP dynamics_, SEXP fix_, SEXP go_dims_, SEXP immigration_, SEXP I_, SEXP I1_, SEXP Ib_, SEXP Ip_) {
- int lk = as<int>(lk_);
Rcpp::IntegerVector N = seq_len(lk)-1;
- int M = as<int>(M_);
- int J = as<int>(J_);
- int T = as<int>(T_);
- arma::imat ym = as<arma::imat>(y_);
- arma::mat Xlam = as<arma::mat>(Xlam_);
- arma::mat Xgam = as<arma::mat>(Xgam_);
- arma::mat Xom = as<arma::mat>(Xom_);
- arma::mat Xp = as<arma::mat>(Xp_);
- arma::mat Xiota = as<arma::mat>(Xiota_);
- arma::colvec beta_lam = as<arma::colvec>(beta_lam_);
- arma::colvec beta_gam = as<arma::colvec>(beta_gam_);
- arma::colvec beta_om = as<arma::colvec>(beta_om_);
- arma::colvec beta_p = as<arma::colvec>(beta_p_);
- arma::colvec beta_iota = as<arma::colvec>(beta_iota_);
- double log_alpha = as<double>(log_alpha_);
- arma::colvec Xlam_offset = as<arma::colvec>(Xlam_offset_);
- arma::colvec Xgam_offset = as<arma::colvec>(Xgam_offset_);
- arma::colvec Xom_offset = as<arma::colvec>(Xom_offset_);
- arma::colvec Xp_offset = as<arma::colvec>(Xp_offset_);
- arma::colvec Xiota_offset = as<arma::colvec>(Xiota_offset_);
- std::string mixture = as<std::string>(mixture_);
- std::string dynamics = as<std::string>(dynamics_);
- std::string fix = as<std::string>(fix_);
- std::string go_dims = as<std::string>(go_dims_);
- bool immigration = as<bool>(immigration_);
- arma::imat I = as<arma::imat>(I_);
- arma::imat I1 = as<arma::imat>(I1_);
- Rcpp::List Ib(Ib_);
- Rcpp::List Ip(Ip_);
int nrI = I.n_rows;
int nrI1 = I1.n_rows;
double alpha=0.0, psi=0.0;
@@ -46,11 +26,7 @@ SEXP nll_pcountOpen( SEXP y_, SEXP Xlam_, SEXP Xgam_, SEXP Xom_, SEXP Xp_, SEXP
alpha = exp(log_alpha);
else if(mixture=="ZIP")
psi = 1.0/(1.0+exp(-log_alpha));
- Rcpp::IntegerVector first(first_);
- Rcpp::IntegerVector last(last_);
- arma::imat ytna = as<arma::imat>(ytna_); // y[i,,t] are all NA
- arma::imat ynam = as<arma::imat>(yna_); // y[i,j,t] is NA
- arma::imat delta = as<arma::imat>(delta_);
+
// linear predictors
arma::colvec lam = exp(Xlam*beta_lam + Xlam_offset);
arma::mat omv = arma::ones<arma::colvec>(M*(T-1));
@@ -232,5 +208,5 @@ SEXP nll_pcountOpen( SEXP y_, SEXP Xlam_, SEXP Xgam_, SEXP Xom_, SEXP Xp_, SEXP
}
ll += log(ll_i + DBL_MIN);
}
- return wrap(-ll);
+ return -ll;
}
diff --git a/src/nll_pcountOpen.h b/src/nll_pcountOpen.h
deleted file mode 100644
index 34549bc..0000000
--- a/src/nll_pcountOpen.h
+++ /dev/null
@@ -1,10 +0,0 @@
-#ifndef _unmarked_NLL_PCOUNTOPEN_H
-#define _unmarked_NLL_PCOUNTOPEN_H
-
-#include "tranprobs.h"
-#include <float.h>
-
-RcppExport SEXP nll_pcountOpen( SEXP y_, SEXP Xlam_, SEXP Xgam_, SEXP Xom_, SEXP Xp_, SEXP Ximm_, SEXP beta_lam_, SEXP beta_gam_, SEXP beta_om_, SEXP beta_p_, SEXP beta_imm_, SEXP log_alpha_, SEXP Xlam_offset_, SEXP Xgam_offset_, SEXP Xom_offset_, SEXP Xp_offset_, SEXP Ximm_offset_, SEXP ytna_, SEXP yna_, SEXP lk_, SEXP mixture_, SEXP first_, SEXP last_, SEXP M_, SEXP J_, SEXP T_, SEXP delta_, SEXP dynamics_, SEXP fix_, SEXP go_dims_, SEXP immigration_, SEXP I_, SEXP I1_, SEXP Ib_, SEXP Ip_) ;
-
-
-#endif
diff --git a/tests/testthat/test_distsampOpen.R b/tests/testthat/test_distsampOpen.R
index bd25e8b..2797b80 100644
--- a/tests/testthat/test_distsampOpen.R
+++ b/tests/testthat/test_distsampOpen.R
@@ -325,7 +325,7 @@ test_that("distsampOpen dynamics models work",{
fm <- distsampOpen(~1, ~1, ~1, data = umf, K=25, keyfun="unif",
dynamics="autoreg")
- expect_equivalent(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-4)
#Sketchy estimates
#Maybe just because data were simulated using a different process?
diff --git a/tests/testthat/test_gdistsamp.R b/tests/testthat/test_gdistsamp.R
index f215d90..96636d0 100644
--- a/tests/testthat/test_gdistsamp.R
+++ b/tests/testthat/test_gdistsamp.R
@@ -111,7 +111,8 @@ test_that("gdistsamp with halfnorm keyfunction works",{
#expect_equivalent(coef(fm_R),coef(fm_C),tol=1e-4)
#With covariates
- umf <- unmarkedFrameGDS(y = y, siteCovs=covs, yearlySiteCovs=covs,
+ ysc <- as.data.frame(rbind(covs, covs, covs))
+ umf <- unmarkedFrameGDS(y = y, siteCovs=covs, yearlySiteCovs=ysc,
survey="line", unitsIn="m",
dist.breaks=breaks,
tlength=rep(transect.length, R), numPrimary=T)
@@ -149,7 +150,7 @@ test_that("gdistsamp with halfnorm keyfunction works",{
#With missing values
yna <- y
yna[1,c(1,6)] <- NA
- umf <- unmarkedFrameGDS(y = yna, siteCovs=covs, yearlySiteCovs=covs,
+ umf <- unmarkedFrameGDS(y = yna, siteCovs=covs, yearlySiteCovs=ysc,
survey="line", unitsIn="m",
dist.breaks=breaks,
tlength=rep(transect.length, R), numPrimary=T)
@@ -166,7 +167,7 @@ test_that("gdistsamp with halfnorm keyfunction works",{
#With an entire session missing
yna <- y
yna[1,1:J] <- NA
- umf <- unmarkedFrameGDS(y = yna, siteCovs=covs, yearlySiteCovs=covs,
+ umf <- unmarkedFrameGDS(y = yna, siteCovs=covs, yearlySiteCovs=ysc,
survey="line", unitsIn="m",
dist.breaks=breaks,
tlength=rep(transect.length, R), numPrimary=T)
@@ -250,7 +251,8 @@ test_that("gdistsamp with uniform keyfunction works",{
}
y <- matrix(y, nrow=R) # convert array to matrix
- umf <- unmarkedFrameGDS(y = y, siteCovs=covs, yearlySiteCovs=covs,
+ ysc <- as.data.frame(rbind(covs, covs, covs))
+ umf <- unmarkedFrameGDS(y = y, siteCovs=covs, yearlySiteCovs=ysc,
survey="line", unitsIn="m",
dist.breaks=breaks,
tlength=rep(transect.length, R), numPrimary=T)
@@ -328,7 +330,8 @@ test_that("gdistsamp with exp keyfunction works",{
y <- matrix(y, nrow=R) # convert array to matrix
#With covariates
- umf <- unmarkedFrameGDS(y = y, siteCovs=covs, yearlySiteCovs=covs,
+ ysc <- as.data.frame(rbind(covs, covs, covs))
+ umf <- unmarkedFrameGDS(y = y, siteCovs=covs, yearlySiteCovs=ysc,
survey="line", unitsIn="m",
dist.breaks=breaks,
tlength=rep(transect.length, R), numPrimary=T)
@@ -415,7 +418,8 @@ test_that("gdistsamp with hazard keyfunction works",{
y <- matrix(y, nrow=R) # convert array to matrix
#With covariates
- umf <- unmarkedFrameGDS(y = y, siteCovs=covs, yearlySiteCovs=covs,
+ ysc <- as.data.frame(rbind(covs, covs, covs))
+ umf <- unmarkedFrameGDS(y = y, siteCovs=covs, yearlySiteCovs=ysc,
survey="line", unitsIn="m",
dist.breaks=breaks,
tlength=rep(transect.length, R), numPrimary=T)
@@ -625,7 +629,8 @@ test_that("gdistsamp simulate method works",{
y <- matrix(y, nrow=R) # convert array to matrix
covs$par1[2] <- NA
- umf <- unmarkedFrameGDS(y = y, siteCovs=covs, yearlySiteCovs=covs,
+ ysc <- as.data.frame(rbind(covs, covs, covs))
+ umf <- unmarkedFrameGDS(y = y, siteCovs=covs, yearlySiteCovs=ysc,
survey="line", unitsIn="m",
dist.breaks=breaks,
tlength=rep(transect.length, R), numPrimary=T)
@@ -644,3 +649,68 @@ test_that("gdistsamp simulate method works",{
})
+test_that("gdistsamp with ZIP mixture works",{
+ #Line
+ set.seed(343)
+ #R <- 500 # for accuracy checks
+ #T <- 10
+ R <- 50
+ T <- 5
+ 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)
+ x <- rnorm(R)
+ lambda <- exp(1.3 + beta[1]*x)
+ psi <- 0.3
+ phi <- plogis(as.matrix(0.4 + beta[2]*covs))
+ sigma <- exp(3)
+ J <- length(breaks)-1
+ y <- array(0, c(R, J, T))
+ M <- numeric(R)
+ for(i in 1:R) {
+ M[i] <- unmarked:::rzip(1, lambda[i], psi=psi) # Individuals within the 1-ha strip
+ for(t in 1:T) {
+ # Distances from point
+ d <- runif(M[i], 0, strip.width)
+ # Detection process
+ if(length(d)) {
+ cp <- phi[i,t]*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
+
+ umf <- unmarkedFrameGDS(y = y, survey="line", unitsIn="m",
+ siteCovs=data.frame(par1=x),
+ yearlySiteCovs=list(par2=covs),
+ dist.breaks=breaks,
+ tlength=rep(transect.length, R), numPrimary=T)
+
+ # R and C give same result
+ fm_R <- gdistsamp(~par1, ~par2, ~1, umf, mixture="ZIP", output="abund", se=FALSE, engine="R",
+ control=list(maxit=1))
+ fm_C <- gdistsamp(~par1, ~par2, ~1, umf, mixture="ZIP", output="abund", se=FALSE, engine="C",
+ control=list(maxit=1))
+ expect_equal(coef(fm_R), coef(fm_C))
+
+ # Fit model
+ fm_C <- gdistsamp(~par1, ~par2, ~1, umf, mixture="ZIP", output="abund")
+
+ expect_equivalent(coef(fm_C), c(2.4142,0.3379,-1.2809,0.25916,2.91411,-1.12557), tol=1e-4)
+
+ # Check ZIP-specific methods
+ ft <- fitted(fm_C)
+ r <- ranef(fm_C)
+ b <- bup(r)
+ #plot(M, b)
+ #abline(a=0,b=1)
+ s <- simulate(fm_C)
+
+})
diff --git a/tests/testthat/test_gmultmix.R b/tests/testthat/test_gmultmix.R
index 8389b66..5caafa6 100644
--- a/tests/testthat/test_gmultmix.R
+++ b/tests/testthat/test_gmultmix.R
@@ -287,3 +287,43 @@ test_that("getP works when there is only 1 site", {
expect_equal(dim(gp), c(1,4))
})
+
+test_that("gmultmix ZIP model works",{
+ # Simulate independent double observer data
+ nSites <- 50
+ lambda <- 10
+ psi <- 0.3
+ p1 <- 0.5
+ p2 <- 0.3
+ cp <- c(p1*(1-p2), p2*(1-p1), p1*p2)
+ set.seed(9023)
+ N <- unmarked:::rzip(nSites, lambda, psi)
+ y <- matrix(NA, nSites, 3)
+ for(i in 1:nSites) {
+ y[i,] <- rmultinom(1, N[i], c(cp, 1-sum(cp)))[1:3]
+ }
+
+ # Make unmarkedFrame
+ observer <- matrix(c('A','B'), nSites, 2, byrow=TRUE)
+ expect_warning(umf <- unmarkedFrameGMM(y=y, obsCovs=list(observer=observer),
+ type="double",numPrimary=1))
+
+ # Compare R and C engines
+ fmR <- gmultmix(~1, ~1, ~observer, umf, mixture="ZIP", engine="R", se=FALSE,
+ control=list(maxit=1))
+ fmC <- gmultmix(~1, ~1, ~observer, umf, mixture="ZIP", engine="C", se=FALSE,
+ control=list(maxit=1))
+ expect_equal(coef(fmR), coef(fmC))
+
+ # Fit model full
+ fm <- gmultmix(~1,~1,~observer, umf, mixture="ZIP")
+ expect_equivalent(coef(fm), c(2.2289,0.1858,-0.9285,-0.9501), tol=1e-4)
+
+ # Check methods
+ ft <- fitted(fm)
+ r <- ranef(fm)
+ b <- bup(r)
+ #plot(N, b)
+ s <- simulate(fm)
+
+})
diff --git a/tests/testthat/test_goccu.R b/tests/testthat/test_goccu.R
new file mode 100644
index 0000000..48f6031
--- /dev/null
+++ b/tests/testthat/test_goccu.R
@@ -0,0 +1,141 @@
+context("goccu fitting function")
+skip_on_cran()
+
+set.seed(123)
+M <- 100
+T <- 5
+J <- 4
+
+psi <- 0.5
+phi <- 0.3
+p <- 0.4
+
+z <- rbinom(M, 1, psi)
+zmat <- matrix(z, nrow=M, ncol=T)
+
+zz <- rbinom(M*T, 1, zmat*phi)
+zz <- matrix(zz, nrow=M, ncol=T)
+
+zzmat <- zz[,rep(1:T, each=J)]
+y <- rbinom(M*T*J, 1, zzmat*p)
+y <- matrix(y, M, J*T)
+umf <- unmarkedMultFrame(y=y, numPrimary=T)
+
+test_that("unmarkedFrameGOccu can be constructed", {
+ set.seed(123)
+ sc <- data.frame(x=rnorm(M))
+ ysc <- matrix(rnorm(M*T), M, T)
+ oc <- matrix(rnorm(M*T*J), M, T*J)
+
+ umf2 <- unmarkedFrameGOccu(y, siteCovs=sc, obsCovs=list(x2=oc),
+ yearlySiteCovs=list(x3=ysc), numPrimary=T)
+ expect_is(umf2, "unmarkedFrameGOccu")
+ expect_equal(names(umf2@yearlySiteCovs), "x3")
+})
+
+test_that("goccu can fit models", {
+
+ # Without covariates
+ mod <- goccu(~1, ~1, ~1, umf)
+ expect_equivalent(coef(mod), c(0.16129, -0.97041, -0.61784), tol=1e-5)
+
+ # With covariates
+ set.seed(123)
+ sc <- data.frame(x=rnorm(M))
+ ysc <- matrix(rnorm(M*T), M, T)
+ oc <- matrix(rnorm(M*T*J), M, T*J)
+
+ umf2 <- unmarkedMultFrame(y=y, siteCovs=sc, yearlySiteCovs=list(x2=ysc),
+ obsCovs=list(x3=oc), numPrimary=T)
+
+ mod2 <- goccu(~x, ~x2, ~x3, umf2)
+ expect_equivalent(coef(mod2), c(0.18895, -0.23629,-0.97246,-0.094335,-0.61808,
+ -0.0040056), tol=1e-5)
+
+ # predict
+ pr <- predict(mod2, 'psi')
+ expect_equal(dim(pr), c(M, 4))
+ expect_equal(pr$Predicted[1], 0.5796617, tol=1e-5)
+
+ # phi should not drop last level
+ pr2 <- predict(mod2, 'phi')
+ expect_equal(dim(pr2), c(M*T, 4))
+
+ nd <- data.frame(x=1)
+ pr3 <- predict(mod2, 'psi', newdata=nd)
+ expect_true(nrow(pr3) == 1)
+ expect_equal(pr3$Predicted[1], 0.488168, tol=1e-5)
+
+ # Other methods
+ ft <- fitted(mod2)
+ expect_equal(dim(ft), dim(umf2@y))
+ expect_true(all(ft >=0 & ft <= 1))
+
+ res <- residuals(mod2)
+ expect_equal(dim(res), dim(umf2@y))
+
+ gp <- getP(mod2)
+ expect_equal(dim(gp), dim(umf2@y))
+ expect_equal(gp[1,1], 0.349239, tol=1e-5)
+
+ set.seed(123)
+ s <- simulate(mod2, nsim=2)
+ expect_equal(length(s), 2)
+ expect_equal(dim(s[[1]]), dim(mod2@data@y))
+ simumf <- umf2
+ simumf@y <- s[[1]]
+ simmod <- update(mod2, data=simumf)
+ expect_equivalent(coef(simmod),
+ c(0.174991, -0.27161, -1.32766, 0.054459,-0.41610,-0.073922), tol=1e-5)
+
+ r <- ranef(mod2)
+ expect_equal(dim(r@post), c(M, 2, 1))
+ expect_equal(sum(bup(r)), 53.13565, tol=1e-4)
+
+ pb <- parboot(mod2, nsim=2)
+ expect_is(pb, "parboot")
+
+ npb <- nonparboot(mod2, B=2, bsType='site')
+
+
+})
+
+test_that("goccu handles missing values", {
+
+ set.seed(123)
+ y2 <- y
+ y2[1,1] <- NA
+ y2[2,1:J] <- NA
+
+ sc <- data.frame(x=rnorm(M))
+ sc$x[3] <- NA
+ ysc <- matrix(rnorm(M*T), M, T)
+ ysc[4,1] <- NA
+ oc <- matrix(rnorm(M*T*J), M, T*J)
+ oc[5,1] <- NA
+ oc[6,1:J] <- NA
+
+ umf_na <- unmarkedMultFrame(y=y2, siteCovs=sc, yearlySiteCovs=list(x2=ysc),
+ obsCovs=list(x3=oc), numPrimary=T)
+
+ mod_na <- expect_warning(goccu(~x, ~x2, ~x3, umf_na))
+
+ pr <- expect_warning(predict(mod_na, 'psi'))
+ expect_equal(nrow(pr), M-1)
+
+ # Need to re-write these to use the design matrix instead of predict
+ gp <- getP(mod_na)
+ expect_equal(dim(gp), c(100, 20))
+ expect_true(is.na(gp[5,1]))
+ expect_true(all(is.na(gp[6, 1:4])))
+ s <- simulate(mod_na)
+ expect_equal(dim(s[[1]]), dim(mod_na@data@y))
+ ft <- fitted(mod_na)
+ expect_equal(dim(ft), dim(mod_na@data@y))
+ r <- ranef(mod_na)
+ expect_equal(dim(r@post), c(100, 2, 1))
+ expect_true(is.na(bup(r)[3]))
+
+ pb <- expect_warning(parboot(mod_na, nsim=2))
+ expect_is(pb, "parboot")
+})
diff --git a/tests/testthat/test_gpcount.R b/tests/testthat/test_gpcount.R
index 022c2ce..7f23a76 100644
--- a/tests/testthat/test_gpcount.R
+++ b/tests/testthat/test_gpcount.R
@@ -117,3 +117,50 @@ test_that("gpcount R and C++ engines give same results",{
fmR <- gpcount(~x, ~yr, ~o1, data = umf, K=23, engine="R", control=list(maxit=1))
expect_equal(coef(fm), coef(fmR))
})
+
+test_that("gpcount ZIP mixture works", {
+
+ set.seed(123)
+ M <- 100
+ J <- 5
+ T <- 3
+ lam <- 3
+ psi <- 0.3
+ p <- 0.5
+ phi <- 0.7
+
+ y <- array(NA, c(M, J, T))
+
+ N <- unmarked:::rzip(M, lambda=lam, psi=psi)
+
+ for (i in 1:M){
+ for (t in 1:T){
+ n <- rbinom(1, N[i], phi)
+ for (j in 1:J){
+ y[i,j,t] <- rbinom(1, n, p)
+ }
+ }
+ }
+
+ ywide <- cbind(y[,,1], y[,,2], y[,,3])
+ umf <- unmarkedFrameGPC(y=ywide, numPrimary=T)
+
+ # check R and C engines match
+ fitC <- gpcount(~1, ~1, ~1, umf, mixture="ZIP", K=10, engine="C",
+ se=FALSE, control=list(maxit=1))
+ fitR <- gpcount(~1, ~1, ~1, umf, mixture="ZIP", K=10, engine="R",
+ se=FALSE, control=list(maxit=1))
+ expect_equal(coef(fitC), coef(fitR))
+
+ # Properly fit model
+ fit <- gpcount(~1, ~1, ~1, umf, mixture="ZIP", K=10)
+ expect_equivalent(coef(fit), c(1.02437, 0.85104, -0.019588, -1.16139), tol=1e-4)
+
+ # Check methods
+ ft <- fitted(fit)
+ r <- ranef(fit)
+ b <- bup(r)
+ #plot(N, b)
+ #abline(a=0, b=1)
+ s <- simulate(fit)
+})
diff --git a/tests/testthat/test_occu.R b/tests/testthat/test_occu.R
index fdcede8..2538e68 100644
--- a/tests/testthat/test_occu.R
+++ b/tests/testthat/test_occu.R
@@ -250,7 +250,8 @@ test_that("occu cloglog link function works",{
test_that("occu predict works",{
skip_on_cran()
- skip_if(!require(raster), "raster package unavailable")
+ skip_if(!requireNamespace("raster", quietly=TRUE),
+ "raster package unavailable")
set.seed(55)
R <- 20
J <- 4
@@ -273,9 +274,9 @@ test_that("occu predict works",{
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))
+ r1 <- raster::raster(matrix(rnorm(100), 10))
expect_error(predict(fm1, type="state", newdata=r1))
- s1 <- stack(r1)
+ s1 <- raster::stack(r1)
expect_error(predict(fm1, type="state", newdata=s1))
names(s1) <- c("x3")
E1.5 <- predict(fm1, type="det", newdata=s1)
@@ -373,6 +374,13 @@ test_that("occu can handle random effects",{
pb <- parboot(fm, nsim=1)
expect_is(pb, "parboot")
+ # confint should only show fixed effects
+ ci <- confint(fm, type = 'state')
+ expect_equal(nrow(ci), 2)
+
+ ci <- confint(fm['state'])
+ expect_equal(nrow(ci), 2)
+
# 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))
@@ -406,3 +414,30 @@ test_that("occu can handle random effects",{
test <- modSel(fl) # shouldn't warn
#options(warn=0)
})
+
+test_that("TMB engine gives correct det estimates when there are lots of NAs", {
+
+ skip_on_cran()
+ set.seed(123)
+ M <- 200
+ J <- 10
+ psi <- 0.5
+
+ z <- rbinom(M, 1, psi)
+
+ x <- matrix(rnorm(M*J), M, J)
+
+ p <- plogis(0 + 0.3*x)
+
+ y <- matrix(NA, M, J)
+ for (i in 1:M){
+ y[i,] <- rbinom(J, 1, p[i,]) * z[i]
+ }
+ y[sample(1:(M*J), (M*J/2), replace=FALSE)] <- NA
+
+ umf <- unmarkedFrameOccu(y=y, obsCovs=list(x=x))
+
+ fit <- occu(~x~1, umf)
+ fitT <- occu(~x~1, umf, engine="TMB")
+ expect_equal(coef(fit), coef(fitT), tol=1e-5)
+})
diff --git a/tests/testthat/test_occuCOP.R b/tests/testthat/test_occuCOP.R
new file mode 100644
index 0000000..ca880bd
--- /dev/null
+++ b/tests/testthat/test_occuCOP.R
@@ -0,0 +1,485 @@
+context("occuCOP fitting function")
+skip_on_cran()
+
+COPsimul <- function(psi = 0.5,
+ lambda = 1,
+ M = 100,
+ J = 5) {
+
+ z_i <- sample(
+ x = c(0, 1),
+ size = M,
+ prob = c(1 - psi, psi),
+ replace = T
+ )
+
+ y = matrix(rpois(n = M * J, lambda = lambda), nrow = M, ncol = J) * z_i
+
+ return(y)
+}
+
+
+test_that("unmarkedFrameOccuCOP is constructed correctly", {
+ set.seed(123)
+
+ # Simulate data
+ M = 100
+ J = 5
+ y = COPsimul(psi = .5,
+ lambda = 1,
+ M = M,
+ J = J)
+ L = y * 0 + 1
+
+ psiCovs = data.frame(
+ "psiNum" = rnorm(M),
+ "psiInt" = as.integer(rpois(n = M, lambda = 5)),
+ "psiBool" = sample(c(T, F), size = M, replace = T),
+ "psiChar" = sample(letters[1:5], size = M, replace = T),
+ "psiFactUnord" = factor(sample(
+ letters[5:10], size = M, replace = T
+ )),
+ "psiFactOrd" = sample(factor(c("A", "B", "C"), ordered = T), size =
+ M, replace = T)
+ )
+
+ lambdaCovs = list(
+ "lambdaNum" = matrix(
+ rnorm(M * J),
+ nrow = M, ncol = J
+ ),
+ "lambdaInt" = matrix(
+ as.integer(rpois(n = M * J, lambda = 1e5)),
+ nrow = M, ncol = J
+ ),
+ "lambdaBool" = matrix(
+ sample(c(T, F), size = M * J, replace = T),
+ nrow = M, ncol = J
+ ),
+ "lambdaChar" = matrix(
+ sample(letters[1:5], size = M * J, replace = T),
+ nrow = M, ncol = J
+ ),
+ "lambdaFactUnord" = matrix(
+ factor(sample(letters[5:10], size = M * J, replace = T)),
+ nrow = M, ncol = J
+ ),
+ "lambdaFactOrd" = matrix(
+ sample(factor(c("A", "B", "C"), ordered = T), size = M * J, replace = T),
+ nrow = M, ncol = J
+ )
+ )
+
+
+ # Creating a unmarkedFrameOccuCOP object
+ expect_warning(umf <- unmarkedFrameOccuCOP(y = y))
+ expect_no_error(umf <- unmarkedFrameOccuCOP(y = y, L = L))
+
+
+ # Create subsets
+ expect_no_error(umf_sub_i <- umf[1:3, ])
+ expect_no_error(umf_sub_j <- umf[, 1:2])
+ expect_no_error(umf_sub_ij <- umf[1:3, 1:2])
+
+ # unmarkedFrameOccuCOP organisation ----------------------------------------------
+ expect_true(inherits(umf, "unmarkedFrameOccuCOP"))
+ expect_equivalent(numSites(umf_sub_i), 3)
+ expect_equivalent(obsNum(umf_sub_j), 2)
+ expect_equivalent(numSites(umf_sub_ij), 3)
+ expect_equivalent(obsNum(umf_sub_ij), 2)
+
+ # unmarkedFrameOccuCOP display ---------------------------------------------------
+
+ # print method
+ expect_output(print(umf), "Data frame representation of unmarkedFrame object")
+ expect_output(print(umf_sub_i), "Data frame representation of unmarkedFrame object")
+ expect_output(print(umf[1,]), "Data frame representation of unmarkedFrame object")
+ expect_output(print(umf[,1]), "Data frame representation of unmarkedFrame object")
+ expect_output(print(umf[1,1]), "Data frame representation of unmarkedFrame object")
+
+ # summary method for unmarkedFrameOccuCOP
+ expect_output(summary(umf), "unmarkedFrameOccuCOP Object")
+ expect_output(summary(umf_sub_ij), "unmarkedFrameOccuCOP Object")
+
+ # plot method for unmarkedFrameOccuCOP
+ expect_no_error(plot(umf))
+ expect_no_error(plot(umf_sub_ij))
+
+
+ # Input handling: covariates -------------------------------------------------
+ expect_no_error(umfCovs <- unmarkedFrameOccuCOP(
+ y = y,
+ L = L,
+ siteCovs = psiCovs,
+ obsCovs = lambdaCovs
+ ))
+ expect_output(print(umfCovs), "Data frame representation of unmarkedFrame object")
+ expect_output(summary(umfCovs), "unmarkedFrameOccuCOP Object")
+ expect_no_error(plot(umfCovs))
+
+ # Input handling: NA ---------------------------------------------------------
+
+ # NA should not pose problems when creating the unmarkedFrameOccuCOP object.
+ # The warnings and potential errors will be displayed when fitting the model.
+ # Except when y only contains NA: then there's an error.
+
+ ## NA in y
+ yNA <- y
+ yNA[1:2,] <- NA
+ yNA[3:5, 3:4] <- NA
+ yNA[,3] <- NA
+ expect_no_error(umfNA <- unmarkedFrameOccuCOP(y = yNA, L = L))
+ expect_output(print(umfNA), "Data frame representation of unmarkedFrame object")
+ expect_output(summary(umfNA), "unmarkedFrameOccuCOP Object")
+ expect_no_error(plot(umfNA))
+
+ ## NA in L
+ obsLengthNA <- L
+ obsLengthNA[1:2,] <- NA
+ obsLengthNA[3:5, 3:4] <- NA
+ obsLengthNA[,5] <- NA
+ expect_no_error(umfNA <- unmarkedFrameOccuCOP(y = y, L = obsLengthNA))
+ expect_output(print(umfNA), "Data frame representation of unmarkedFrame object")
+ expect_output(summary(umfNA), "unmarkedFrameOccuCOP Object")
+
+ expect_no_error(plot(umfNA))
+
+ ## NA also in covariates
+ psiCovsNA <- psiCovs
+ psiCovsNA[1:5,] <- NA
+ psiCovsNA[c(8,10,12), 3] <- NA
+ psiCovsNA[,1] <- NA
+ lambdaCovsNA <- lambdaCovs
+ lambdaCovsNA[[1]][1:5,] <- NA
+ lambdaCovsNA[[1]][,3] <- NA
+ lambdaCovsNA[[3]][,5] <- NA
+ expect_no_error(umfCovsNA <- unmarkedFrameOccuCOP(
+ y = yNA,
+ L = obsLengthNA,
+ siteCovs = psiCovsNA,
+ obsCovs = lambdaCovsNA
+ ))
+ expect_output(print(umfCovsNA), "Data frame representation of unmarkedFrame object")
+ expect_output(summary(umfCovsNA), "unmarkedFrameOccuCOP Object")
+ expect_no_error(plot(umfCovsNA))
+
+ ## all NA in y
+ yallNA <- y
+ yallNA[1:M, 1:J] <- NA
+ expect_error(unmarkedFrameOccuCOP(y = yallNA, L = L))
+
+ # Input handling: error and warnings -----------------------------------------
+ # Error when there are decimals in y
+ y_with_decimals = y
+ y_with_decimals[1, 1] = .5
+ expect_error(unmarkedFrameOccuCOP(y = y_with_decimals, L = L))
+
+ # Warning if y is detection/non-detection instead of count
+ y_detec_nodetec = (y > 0) * 1
+ expect_warning(unmarkedFrameOccuCOP(y = y_detec_nodetec, L = L))
+
+ # Error if the dimension of L is different than that of y
+ expect_error(unmarkedFrameOccuCOP(y = y, L = L[1:2, 1:2]))
+})
+
+
+test_that("occuCOP can fit simple models", {
+ # Simulate data
+ set.seed(123)
+ M = 100
+ J = 5
+ y = COPsimul(psi = .5,
+ lambda = 1,
+ M = M,
+ J = J)
+ L = y * 0 + 1
+
+ # Create umf
+ umf <- unmarkedFrameOccuCOP(y = y, L = L)
+
+ # Fitting options ----
+
+ ## With default parameters ----
+ expect_no_error(fit_default <- occuCOP(data = umf, L1 = TRUE))
+ expect_warning(occuCOP(data = umf, psiformula = ~ 1, lambdaformula = ~ 1, psistarts = 0, lambdastarts = 0))
+
+ ## With chosen starting points ----
+ expect_no_error(occuCOP(data = umf,
+ psiformula = ~ 1, lambdaformula = ~ 1,
+ psistarts = qlogis(.7),
+ lambdastarts = log(0.1), L1=T))
+ expect_no_error(occuCOP(data = umf,
+ psiformula = ~ 1, lambdaformula = ~ 1,
+ starts = c(qlogis(.7), log(0.1)), L1 = T))
+ # warning if all starts and psistarts and lambdastarts were furnished
+ # and starts != c(psistarts, lambdastarts)
+ expect_no_error(occuCOP(data = umf, starts = c(0, 0),
+ psistarts = c(0), lambdastarts = c(0), L1 = T))
+ expect_warning(occuCOP(data = umf, starts = c(0, 1),
+ psistarts = c(0), lambdastarts = c(0), L1 = T))
+ # errors if starting vectors of the wrong length
+ expect_error(occuCOP(data = umf, starts = c(0), L1 = T))
+ expect_error(occuCOP(data = umf, psistarts = c(0, 0), lambdastarts = 0, L1 = T))
+ expect_error(occuCOP(data = umf, lambdastarts = c(0, 0), L1 = T))
+
+ # With different options
+ expect_no_error(occuCOP(data = umf, method = "Nelder-Mead", psistarts = 0, lambdastarts = 0, L1=T))
+ expect_error(occuCOP(data = umf, method = "ABC", psistarts = 0, lambdastarts = 0, L1=T))
+
+ expect_no_error(occuCOP(data = umf, se = F, psistarts = 0, lambdastarts = 0, L1=T))
+ expect_error(occuCOP(data = umf, se = "ABC"))
+
+ expect_no_error(occuCOP(data = umf, engine = "R", psistarts = 0, lambdastarts = 0, L1=T))
+ expect_error(occuCOP(data = umf, engine = "julia", psistarts = 0, lambdastarts = 0, L1=T))
+
+ expect_no_error(occuCOP(data = umf, na.rm = F, psistarts = 0, lambdastarts = 0, L1=T))
+ expect_error(occuCOP(data = umf, na.rm = "no", psistarts = 0, lambdastarts = 0, L1=T))
+
+ # Looking at at COP model outputs ----
+ expect_is(fit_default, "unmarkedFitOccuCOP")
+ expect_equivalent(coef(fit_default), c(0.13067954, 0.06077929), tol = 1e-5)
+
+ ## backTransform
+ expect_no_error(backTransform(fit_default, type = "psi"))
+ expect_no_error(backTransform(fit_default, type = "lambda"))
+ expect_error(backTransform(fit_default, type = "state"))
+ expect_error(backTransform(fit_default, type = "det"))
+ expect_is(backTransform(fit_default, type = "psi"), "unmarkedBackTrans")
+
+ ## predict with newdata = fit@data
+ expect_no_error(umpredpsi <- predict(object = fit_default, type = "psi"))
+ expect_equal(umpredpsi$Predicted[1], 0.5326235, tol = 1e-5)
+ expect_no_error(umpredlambda <- predict(object = fit_default, type = "lambda"))
+ expect_equal(umpredlambda$Predicted[1], 1.062664, tol = 1e-5)
+ expect_error(predict(object = fit_default, type = "state"))
+
+ ## predict with newdata = 1
+ expect_no_error(predict(
+ object = fit_default,
+ newdata = data.frame(1),
+ type = "psi"
+ ))
+ expect_no_error(predict(
+ object = fit_default,
+ newdata = data.frame(1),
+ type = "lambda"
+ ))
+ expect_no_error(predict(
+ object = fit_default,
+ newdata = data.frame("a"=1:5,"b"=10:14),
+ type = "psi"
+ ))
+
+ # Fitting accurately ----
+ ## psi = 0.50, lambda = 1 ----
+ psi_test = .5
+ lambda_test = 1
+ fit_accur <- occuCOP(data = unmarkedFrameOccuCOP(
+ y = COPsimul(
+ psi = psi_test,
+ lambda = lambda_test,
+ M = 1000,
+ J = 10
+ ),
+ L = matrix(1, nrow = 1000, ncol = 10)
+ ), psistarts = 0, lambdastarts = 0, L1=T)
+ psi_estimate = backTransform(fit_accur, type = "psi")@estimate
+ lambda_estimate = backTransform(fit_accur, type = "lambda")@estimate
+ expect_equivalent(
+ psi_estimate,
+ psi_test,
+ tol = 0.05
+ )
+ expect_equivalent(
+ lambda_estimate,
+ lambda_test,
+ tol = 0.05
+ )
+
+ ## psi = 0.25, lambda = 5 ----
+ psi_test = 0.25
+ lambda_test = 5
+ fit_accur <- occuCOP(data = unmarkedFrameOccuCOP(
+ y = COPsimul(
+ psi = psi_test,
+ lambda = lambda_test,
+ M = 1000,
+ J = 10
+ ),
+ L = matrix(1, nrow = 1000, ncol = 10)
+ ), psistarts = 0, lambdastarts = 0, L1=T)
+ psi_estimate = backTransform(fit_accur, type = "psi")@estimate
+ lambda_estimate = backTransform(fit_accur, type = "lambda")@estimate
+ expect_equivalent(
+ psi_estimate,
+ psi_test,
+ tol = 0.05
+ )
+ expect_equivalent(
+ lambda_estimate,
+ lambda_test,
+ tol = 0.05
+ )
+
+ ## psi = 0.75, lambda = 0.5 ----
+ psi_test = 0.75
+ lambda_test = 0.5
+ fit_accur <- occuCOP(data = unmarkedFrameOccuCOP(
+ y = COPsimul(
+ psi = psi_test,
+ lambda = lambda_test,
+ M = 1000,
+ J = 10
+ ),
+ L = matrix(1, nrow = 1000, ncol = 10)
+ ), psistarts = 0, lambdastarts = 0, L1=T)
+ psi_estimate = backTransform(fit_accur, type = "psi")@estimate
+ lambda_estimate = backTransform(fit_accur, type = "lambda")@estimate
+ expect_equivalent(
+ psi_estimate,
+ psi_test,
+ tol = 0.05
+ )
+ expect_equivalent(
+ lambda_estimate,
+ lambda_test,
+ tol = 0.05
+ )
+
+ # With NAs ----
+ yNA <- y
+ yNA[1,] <- NA
+ yNA[3, 1] <- NA
+ yNA[4, 3] <- NA
+ yNA[, 5] <- NA
+ expect_no_error(umfNA <- unmarkedFrameOccuCOP(y = yNA, L = L))
+
+ expect_warning(fit_NA <- occuCOP(data = umfNA, psistarts = 0, lambdastarts = 0, L1=T))
+ expect_error(occuCOP(data = umfNA, psistarts = 0, lambdastarts = 0, na.rm = F))
+})
+
+test_that("We can simulate COP data", {
+
+ # From scratch ----
+
+ # With no covariates
+ expect_no_error(simulate(
+ "occuCOP",
+ formulas = list(psi = ~ 1, lambda = ~ 1),
+ coefs = list(
+ psi = c(intercept = 0),
+ lambda = c(intercept = 0)
+ ),
+ design = list(M = 100, J = 100)
+ ))
+
+ # With quantitative covariates
+ expect_no_error(simulate(
+ "occuCOP",
+ formulas = list(psi = ~ elev, lambda = ~ rain),
+ coefs = list(
+ psi = c(intercept = qlogis(.5), elev = -0.5),
+ lambda = c(intercept = log(3), rain = -1)
+ ),
+ design = list(M = 100, J = 5)
+ ))
+
+ # With guides
+ expect_no_error(simulate(
+ "occuCOP",
+ formulas = list(psi = ~ elev, lambda = ~ rain),
+ coefs = list(
+ psi = c(intercept = qlogis(.5), elev = -0.5),
+ lambda = c(intercept = log(3), rain = -1)
+ ),
+ design = list(M = 100, J = 5),
+ guide = list(elev=list(dist=rnorm, mean=12, sd=0.5))
+ ))
+
+ # With qualitative covariates
+ expect_no_error(umf <- simulate(
+ "occuCOP",
+ formulas = list(psi = ~ elev + habitat, lambda = ~ 1),
+ coefs = list(
+ psi = c(
+ intercept = qlogis(.2),
+ elev = -0.5,
+ habitatB = .5,
+ habitatC = .8
+ ),
+ lambda = c(intercept = log(3))
+ ),
+ design = list(M = 100, J = 5),
+ guide = list(habitat = factor(levels = c("A", "B", "C")))
+ ))
+
+ # From unmarkedFitOccuCOP ----
+ expect_no_error(umfit <- occuCOP(
+ umf,
+ psiformula = ~ habitat,
+ L1 = T,
+ psistarts = c(0,0,0),
+ lambdastarts = 0
+ ))
+ expect_no_error(simulate(umfit))
+})
+
+test_that("occuCOP can fit and predict models with covariates", {
+ # Simulate data with covariates ----
+ set.seed(123)
+ expect_no_error(umf <- simulate(
+ "occuCOP",
+ formulas = list(psi = ~ elev + habitat, lambda = ~ rain),
+ coefs = list(
+ psi = c(
+ intercept = qlogis(.2),
+ elev = -0.5,
+ habitatB = .5,
+ habitatC = .8
+ ),
+ lambda = c(intercept = log(3), rain = -1)
+ ),
+ design = list(M = 100, J = 5),
+ guide = list(habitat = factor(levels = c("A", "B", "C")))
+ ))
+
+ # Fit ----
+ expect_no_error(umfit <- occuCOP(
+ umf,
+ psiformula = ~ habitat + elev,
+ lambdaformula = ~ rain,
+ L1 = T,
+ psistarts = c(0,0,0,0),
+ lambdastarts = c(0,0)
+ ))
+
+ expect_error(occuCOP(
+ umf,
+ psiformula = ~ habitat+elev,
+ lambdaformula = ~ rain,
+ L1 = T,
+ psistarts = c(0),
+ lambdastarts = c(0,0)
+ ))
+
+ expect_equivalent(
+ coef(umfit),
+ c(-1.5350679, 0.4229763, 0.7398768, -1.0456397, 1.2333424, -0.8344109),
+ tol = 1e-5
+ )
+
+ # Predict ----
+ expect_no_error(predict(umfit, type = "psi"))
+ expect_no_error(umpredpsi <- predict(
+ umfit,
+ type = "psi",
+ newdata = data.frame("habitat" = c("A", "B", "C"), "elev" = c(0, 0, 0)),
+ appendData = TRUE
+ ))
+ expect_equivalent(umpredpsi$Predicted, c(0.1772534, 0.2474811, 0.3110551), tol = 1e-5)
+
+ expect_no_error(umpredlambda <- predict(umfit, type = "lambda", appendData = TRUE))
+ expect_no_error(predict(umfit, type = "lambda", level = 0.5))
+ expect_equal(umpredlambda$Predicted[1], 1.092008, tol = 1e-5)
+})
+
diff --git a/tests/testthat/test_occuMS.R b/tests/testthat/test_occuMS.R
index 7c25acf..2455373 100644
--- a/tests/testthat/test_occuMS.R
+++ b/tests/testthat/test_occuMS.R
@@ -94,7 +94,7 @@ test_that("occuMS R and C engines return same results",{
})
test_that("occuMS can fit the multinomial model",{
-
+ skip_on_ci()
#Simulate data
set.seed(123)
N <- 50; J <- 5; S <- 3
diff --git a/tests/testthat/test_occuMulti.R b/tests/testthat/test_occuMulti.R
index d37cbc5..6ce7921 100644
--- a/tests/testthat/test_occuMulti.R
+++ b/tests/testthat/test_occuMulti.R
@@ -536,7 +536,10 @@ test_that("occuMulti penalized likelihood works",{
set.seed(123)
opt_fit <- optimizePenalty(fm, penalties=c(0,1), boot=2)
expect_equal(opt_fit@call$penalty, 1)
-
+
+ ll <- unmarked:::occuMultiLogLik(fm, fm@data)
+ expect_equal(length(ll), numSites(fm@data))
+ expect_equal(-sum(ll), fm@negLogLike)
})
diff --git a/tests/testthat/test_parboot.R b/tests/testthat/test_parboot.R
index ca7e5e5..33a620b 100644
--- a/tests/testthat/test_parboot.R
+++ b/tests/testthat/test_parboot.R
@@ -68,7 +68,20 @@ test_that("parboot handles failing model fits", {
set.seed(123)
expect_warning(pb <- parboot(fm, nsim=20, statistic=fail_func))
expect_equal(nrow(pb@t.star), 13)
+})
+
+test_that("parboot handles failing model fits in parallel", {
+ skip_on_cran()
+ skip_on_ci()
+ 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, parallel=TRUE))
expect_true(nrow(pb@t.star) < 20)
@@ -84,6 +97,15 @@ test_that("parboot handles statistic functions with additional arguments", {
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))
+})
+
+test_that("parboot handles statistic functions with additional arguments in parallel", {
+ skip_on_cran()
+ skip_on_ci()
+ 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, parallel=TRUE)
expect_equal(colnames(pb@t.star), c("res", "y"))
diff --git a/tests/testthat/test_predict.R b/tests/testthat/test_predict.R
index 686da9b..440d87e 100644
--- a/tests/testthat/test_predict.R
+++ b/tests/testthat/test_predict.R
@@ -103,7 +103,8 @@ test_that("clean_up_covs works with models where length(y) != length(p)",{
test_that("predicting from raster works",{
- skip_if(!require(raster), "raster package unavailable")
+ skip_if(!requireNamespace("raster", quietly=TRUE),
+ "raster package unavailable")
set.seed(123)
# Create rasters
@@ -127,7 +128,7 @@ test_that("predicting from raster works",{
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))
+ expect_equal(raster::crs(pr), raster::crs(nd_raster))
#append data
pr <- predict(mod, 'state', newdata=nd_raster, appendData=TRUE)
@@ -141,7 +142,8 @@ test_that("predicting from raster works",{
test_that("predicting from terra::rast works",{
- skip_if(!require(terra), "terra package unavailable")
+ skip_if(!requireNamespace("terra", quietly=TRUE),
+ "terra package unavailable")
set.seed(123)
# Create rasters
@@ -165,7 +167,7 @@ test_that("predicting from terra::rast works",{
expect_is(pr, 'SpatRaster')
expect_equal(names(pr), c("Predicted","SE","lower","upper"))
expect_equivalent(pr[1,1][1], 0.3675313, tol=1e-5)
- expect_equal(crs(pr), crs(nd_raster))
+ expect_equal(terra::crs(pr), terra::crs(nd_raster))
#append data
pr <- predict(mod, 'state', newdata=nd_raster, appendData=TRUE)
diff --git a/tests/testthat/test_ranef_predict.R b/tests/testthat/test_ranef_predict.R
index 251ed29..7da3f54 100644
--- a/tests/testthat/test_ranef_predict.R
+++ b/tests/testthat/test_ranef_predict.R
@@ -29,7 +29,7 @@ test_that("ranef predict method works",{
expect_equivalent(dim(ps@samples), c(9,1,10))
# Brackets
- expect_equal(ps[1,1,1], ps@samples[1,1,1])
+ expect_equal(ps[1,1,1], ps@samples[1,1,1,drop=FALSE])
# Method for unmarkedFit objects
set.seed(123)
diff --git a/tests/testthat/test_unmarkedFrame.R b/tests/testthat/test_unmarkedFrame.R
index c3194fe..66bc902 100644
--- a/tests/testthat/test_unmarkedFrame.R
+++ b/tests/testthat/test_unmarkedFrame.R
@@ -256,3 +256,18 @@ test_that("lists provided to obsCovs or yearlySiteCovs must be named", {
obsCovs = oc,
numPrimary = 3))
})
+
+test_that("covsToDF", {
+ expect_equal(covsToDF(NULL, "obsCovs", 2, 3), NULL)
+
+ df <- data.frame(x = rnorm(6), y = rnorm(6))
+ expect_equal(covsToDF(df, "obsCovs", 2, 3),
+ df)
+ expect_error(covsToDF(df, "obsCovs", 2, 2))
+
+ cl <- list(x = matrix(rnorm(6), 2, 3), y =matrix(rnorm(6), 2, 3))
+ df_cl <- as.data.frame(lapply(cl, function(x) as.vector(t(x))))
+ expect_equal(covsToDF(cl, "obsCovs", 3, 2),
+ df_cl)
+ expect_error(covsToDF(cl, "obsCovs", 2, 3))
+})
diff --git a/vignettes/contributing_to_unmarked.Rmd b/vignettes/contributing_to_unmarked.Rmd
new file mode 100644
index 0000000..8ffab04
--- /dev/null
+++ b/vignettes/contributing_to_unmarked.Rmd
@@ -0,0 +1,318 @@
+---
+title: "Contributing to unmarked: guide to adding a new model to `unmarked`"
+author:
+ - name: Ken Kellner
+ - name: Léa Pautrel
+date: "December 08, 2023"
+output:
+ rmarkdown::html_vignette:
+ fig_width: 5
+ fig_height: 3.5
+ number_sections: true
+ toc: true
+ toc_depth: 2
+vignette: >
+ %\VignetteIndexEntry{Contributing to unmarked}
+ %\VignetteEngine{knitr::rmarkdown}
+ \usepackage[utf8]{inputenc}
+---
+
+```{r setup, include = FALSE}
+options(rmarkdown.html_vignette.check_title = FALSE)
+library(unmarked)
+```
+
+
+Follow the steps in this guide to add a new model to the `unmarked` package. Note that the order can be adjusted based on your preferences. For instance, you can start with [the likelihood function](#the-likelihood-function), as it forms the core of adding a model to unmarked, and then build the rest of the code around it. In this document, the steps are ordered as they would occur in an `unmarked` analysis workflow.
+
+This guide uses the recently developed `gdistremoval` function for examples, mainly because most of the relevant code is in a single file instead of spread around. It also uses `occu` functions to show simpler examples that may be easier to understand.
+
+# Prerequisites and advices {-}
+
+- Before you start coding, you should use git to version your code:
+ - Fork the `unmarked` [repository](https://github.com/rbchan/unmarked) on Github
+ - Make a new branch with your new function as the name
+ - Add the new code
+
+- `unmarked` uses S4 for objects and methods - if you aren't familiar with S4 you may want to consult a book or tutorial such as [this one](https://kasperdanielhansen.github.io/genbioconductor/html/R_S4.html).
+
+- If you are unfamiliar with building a package in R, here are two tutorials that may help you: [Karl Broman's guide to building packages](https://kbroman.org/pkg_primer/) and [the official R-project guide](https://cran.r-project.org/doc/manuals/R-exts.html). If you are using RStudio, their [documentation on writing package](https://docs.posit.co/ide/user/ide/guide/pkg-devel/writing-packages.html) could also be useful, especially to understand how to use the **Build** pane.
+
+- To avoid complex debugging in the end, I suggest you to regularly install and load the package as you add new code. You can easily do so in RStudio in the Build pane, by clicking on "Install > Clean and install". This will also allow you to test your functions cleanly.
+
+- Write [tests](#write-tests) and [documentation](#write-documentation) as you add new functions, classes, and methods. This eases the task, avoiding the need to write everything at the end.
+
+# Organise the input data: design the `unmarkedFrame` object
+
+Most model types in unmarked have their own `unmarkedFrame`, a specialized kind of data frame. This is an S4 object which contains, at a minimum, the response (y). It may also include site covariates, observation covariates, primary period covariates, and other info related to study design (such as distance breaks).
+
+In some cases you may be able to use an existing `unmarkedFrame` subclass. You can list all the existing `unmarkedFrame` subclasses by running the following code:
+
+```{r unmarkedFrame-subclasses}
+showClass("unmarkedFrame")
+```
+You can have more information about each `unmarkedFrame` subclass by looking at the documentation of the function that was written to create the `unmarkedFrame` object of this subclass, for example with `?unmarkedFrameGDR`, or on the [package's website](https://rbchan.github.io/unmarked/reference/unmarkedFrameGDR.html).
+
+## Define the `unmarkedFrame` subclass for this model
+
+- All `unmarkedFrame` subclasses are children of the `umarkedFrame` class, defined [here](https://github.com/rbchan/unmarked/blob/master/R/unmarkedFrame.R#L24-L30).
+- [Example with `occu`](https://github.com/rbchan/unmarked/blob/master/R/unmarkedFrame.R#L65-L66)
+- [Example with `gdistremoval`](https://github.com/rbchan/unmarked/blob/master/R/gdistremoval.R#L1-L11)
+- All `unmarkedFrame` subclasses need to pass the [validunmarkedFrame](https://github.com/rbchan/unmarked/blob/master/R/unmarkedFrame.R#L4-L19) validity check. You may want to add complementary validity check, like, for example, the [`unmarkedFrameDS subclass](https://github.com/rbchan/unmarked/blob/master/R/unmarkedFrame.R#L43-L62).
+
+## Write the function that creates the `unmarkedFrame` object
+
+- [Example with `occu`](https://github.com/rbchan/unmarked/blob/master/R/unmarkedFrame.R#L232-L239)
+- [Example with `gdistremoval`](https://github.com/rbchan/unmarked/blob/master/R/gdistremoval.R#L13-L50)
+
+## Write the S4 methods associated with the `unmarkedFrame` object {#methods-unmarkedFrame}
+
+Note that you may not have to write all of the S4 methods below. Most of them will work without having to re-write them, but you should test it to verify it. All the methods associated with `unmarkedFrame` objects are listed in the [`unmarkedFrame` class documentation](https://rbchan.github.io/unmarked/reference/unmarkedFrame-class.html) accessible with `help("unmarkedFrame-class")`.
+
+### Specific methods {-}
+
+Here are methods you probably will have to rewrite.
+
+- Subsetting the `unmarkedFrame` object: `umf[i, ]`, `umf[, j]` and `umf[i, j]`
+ - Example with `occu`: [code for `unmarkedFrame` mother class](https://github.com/rbchan/unmarked/blob/master/R/unmarkedFrame.R#L1126-L1235), as used to subset an `unmarkedFrameOccu` object.
+ - Example with `gdistremoval`: [`umf[i, ]` when `i` is numeric](https://github.com/rbchan/unmarked/blob/master/R/gdistremoval.R#L67-L120), [`umf[i, ]` when `i` is logical](https://github.com/rbchan/unmarked/blob/master/R/gdistremoval.R#L122-L126), [`umf[i, j]`](https://github.com/rbchan/unmarked/blob/master/R/gdistremoval.R#L128-L174)
+
+### Generic methods {-}
+
+Here are methods that you should test but probably will not have to rewrite. They are defined in the [`unmarkedFrame.R`](https://github.com/rbchan/unmarked/blob/master/R/unmarkedFrame.R) file, for the `unmarkedFrame` mother class.
+
+- `coordinates`
+- `getY`
+- `numSites`
+- `numY`
+- `obsCovs`
+- `obsCovs<-`
+- `obsNum`
+- `obsToY`
+- `obsToY<-`
+- `plot`
+- `projection`
+- `show`
+- `siteCovs`
+- `siteCovs<-`
+- `summary`
+
+### Methods to access new attributes {-}
+
+You may also need to add specific methods to allow users to access an attribute you added to your `unmarkedFrame` subclass.
+
+- For example, `getL` for `unmarkedFrameOccuCOP`
+
+# Fitting the model
+
+The fitting function can be declined into three main steps: reading the `unmarkedFrame` object, maximising the likelihood, and formatting the outputs.
+
+- [Example: the `occu()` function](https://github.com/rbchan/unmarked/blob/master/R/occu.R#L4-L161)
+- [Example: the `gdistremoval()` function](https://github.com/rbchan/unmarked/blob/master/R/gdistremoval.R#L257-L472)
+
+## Inputs of the fitting function
+
+- R formulas for each submodel (e.g. state, detection). We have found over time it is better to have separate arguments per formula (*e.g.* the way `gdistremoval` does it) instead of a combined formula (*e.g.* the way `occu` does it).
+- `data` for the `unmarkedFrame`
+- Parameters for `optim`: optimisation algorithm (`method`), initial parameters, and other parameters (`...`)
+- `engine` parameter to call one of the implemented likelihood functions
+- Other model-specific settings, such as key functions or parameterizations to use
+
+## Read the `unmarkedFrame` object: write the `getDesign` method
+
+Most models have their own `getDesign` function, an S4 method. The purpose of this method is to convert the information in the `unmarkedFrame` into a format usable by the likelihood function.
+
+- It generates **design matrices** from formulas and components of the `unmarkedFrame`.
+- It often also has code to handle **missing values**, such as by dropping sites that don't have measurements, or giving the user warnings if covariates are missing, etc.
+
+Writing the `getDesign` method is frequently the most tedious and difficult part of the work adding a new function.
+
+- [Example for `occu`](https://github.com/rbchan/unmarked/blob/master/R/getDesign.R#L10-L153), as used for `occu`
+- [Example for `gdistremoval`](https://github.com/rbchan/unmarked/blob/master/R/gdistremoval.R#L177-L253)
+
+## The likelihood function
+
+- **Inputs**: a vector of parameter values, the response variable, design matrices, and other settings/required data
+- **Outputs**: a numeric, the negative log-likelihood
+- Should be written so it can be used with the `optim()` function
+- Models can have three likelihood functions : coded in R, in C++ and with TMB (*which is technically in C++ too*). Users can specify which likelihood function to use in the `engine` argument of the fitting function.
+
+### The R likelihood function: easily understandable
+
+If you are mainly used to coding in R, you should probably start here. If users want to dig deeper into the likelihood of a model, it may be useful for them to be able to read the R code to calculate likelihood, as they may not be familiar with other languages. This likelihood function can be used only for **fixed-effects models**.
+
+- [Example for `occu`](https://github.com/rbchan/unmarked/blob/master/R/occu.R#L65-L74)
+- `gdistremoval` doesn't have an R version of the likelihood function
+
+### The C++ likelihood function: faster
+
+The C++ likelihood function is essentially a C++ version of the R likelihood function, also designed exclusively for **fixed-effects models**. This function uses the `RcppArmadillo` R package, [presented here](https://github.com/RcppCore/RcppArmadillo). In the C++ code, you can use functions of the `Armadillo` C++ library, [documented here](https://arma.sourceforge.net/docs.html).
+
+Your C++ function should be in a `.cpp` file in the `./src/` folder of the package. You do not need to write a header file (`.hpp`), nor do you need to compile the code by yourself as it is all handled by the `RcppArmadillo` package. To test if your C++ function runs and gives you the expected result, you can compile and load the function with ` Rcpp::sourceCpp(./src/nll_yourmodel.cpp)`, and then use it like you would use a R function: `nll_yourmodel(params=params, arg1=arg1)`.
+
+- [Example for `occu`](https://github.com/rbchan/unmarked/blob/master/src/nll_occu.cpp)
+- [Example for `gdistremoval`](https://github.com/rbchan/unmarked/blob/master/src/nll_gdistremoval.cpp)
+
+### The TMB likelihood function: for random effects
+
+> #TODO
+
+- [Example for `gdistremoval`](https://github.com/rbchan/unmarked/blob/master/src/TMB/tmb_gdistremoval.hpp)
+
+## Organise the output data
+
+### `unmarkedEstimate` objects per submodel
+
+Outputs from `optim` should be organized unto `unmarkedEstimate` (S4) objects, with one `unmarkedEstimate` per submodel (*e.g.* state, detection). These objects include the parameter estimates and other information about link functions etc.
+
+The `unmarkedEstimate` class is defined [here](https://github.com/rbchan/unmarked/blob/master/R/unmarkedEstimate.R#L5-L26) in the `unmarkedEstimate.R` file, and the `unmarkedEstimate` function is defined [here](https://github.com/rbchan/unmarked/blob/master/R/unmarkedEstimate.R#L86-L100), and is used to create new `unmarkedEstimate` objects. You normally will not need to create `unmarkedEstimate` subclass.
+
+- [Example for the state estimate for `occu`](https://github.com/rbchan/unmarked/blob/master/R/occu.R#L132-L139)
+- [Example for the lambda estimate for `gdistremoval`](https://github.com/rbchan/unmarked/blob/master/R/gdistremoval.R#L429-L431C72)
+
+
+### Design the `unmarkedFit` object
+
+You'll need to create a new `unmarkedFit` subclass for your model. The main component of `unmarkedFit` objects is a list of the `unmarkedEstimates` described above.
+
+- [Definition of the `unmarkedFit` mother class](https://github.com/rbchan/unmarked/blob/master/R/unmarkedFit.R#L1-L14)
+- [Example of the `unmarkedFitOccu` subclass definition](https://github.com/rbchan/unmarked/blob/master/R/unmarkedFit.R#L68-L70)
+- [Example of the `unmarkedFitGDR` subclass definition](https://github.com/rbchan/unmarked/blob/master/R/gdistremoval.R#L255)
+
+After you defined your `unmarkedFit` subclass, you can create the object in your fitting function.
+
+- [Example of the `unmarkedFitOccu` object creation](https://github.com/rbchan/unmarked/blob/master/R/occu.R#L153-L158)
+- [Example of the `unmarkedFitGDR` object creation](https://github.com/rbchan/unmarked/blob/master/R/gdistremoval.R#L466-L470)
+
+The fitting function return this `unmarkedFit` object.
+
+## Test the complete fitting function process
+
+- Simulate some data using your model
+- Construct the `unmarkedFrame`
+- Provide formulas, `unmarkedFrame`, other options to your draft fitting function
+- Process them with `getDesign`
+- Pass results from `getDesign` as inputs to your likelihood function
+- Optimize the likelihood function
+- Check the resulting parameter estimates for accuracy
+
+# Write the methods associated with the `unmarkedFit` object
+
+Develop methods specific to your `unmarkedFit` type for operating on the output of your model. Like for the methods associated with an `unmarkedFrame` object [above](#methods-unmarkedFrame), you probably will not have to re-write all of them, but you should test them to see if they work. All the methods associated with `unmarkedFit` objects are listed in the [`unmarkedFit` class documentation](https://rbchan.github.io/unmarked/reference/unmarkedFit-class.html) accessible with `help("unmarkedFit-class")`.
+
+### Specific methods {-}
+
+Those are methods you will want to rewrite, adjusting them for your model.
+
+#### `getP` {-}
+
+The `getP` method ([defined here](https://github.com/rbchan/unmarked/blob/master/R/unmarkedFit.R#L1475-L1492)) "back-transforms" the detection parameter ($p$ the detection probability or $\lambda$ the detection rate, depending on the model). It returns a matrix of the estimated detection parameters. It is called by several other methods that are useful to extract information from the `unmarkedFit` object.
+
+- For `occu`, the generic method for `unmarkedFit` objects is called.
+- [Example for `gdistremoval`](https://github.com/rbchan/unmarked/blob/master/R/gdistremoval.R#L476-L537)
+
+#### `simulate` {-}
+
+The generic `simulate` method ([defined here](https://github.com/rbchan/unmarked/blob/master/R/simulate.R#L62C33-L86)) calls the `simulate_fit` method that depends on the class of the `unmarkedFit` object, which depends on the model.
+
+- [Example of `simulate_fit` method for `occu`](https://github.com/rbchan/unmarked/blob/master/R/simulate.R#L158-L165)
+- [Example of `simulate_fit` method for `gdistremoval`](https://github.com/rbchan/unmarked/blob/master/R/simulate.R#L536-L558)
+
+The `simulate` method can be used in two ways:
+
+- to generate datasets from scratch ([see the "Simulating datasets" vignette](https://rbchan.github.io/unmarked/articles/simulate.html))
+- to generate datasets from a fitted model (with `simulate(object = my_unmarkedFit_object)`).
+
+You should test both ways with your model.
+
+#### `plot` {-}
+
+This method plots the results of your model. The generic `plot` method for `unmarkedFit` ([defined here](https://github.com/rbchan/unmarked/blob/master/R/unmarkedFit.R#L1346-L1352)) plot the residuals of the model.
+
+- For `occu`, the generic method for `unmarkedFit` objects is called.
+- [Example for `gdistremoval`](https://github.com/rbchan/unmarked/blob/master/R/gdistremoval.R#L837-L853)
+
+### Generic methods {-}
+
+Here are methods that you should test but probably will not have to rewrite. They are defined in the [`unmarkedFit.R`](https://github.com/rbchan/unmarked/blob/master/R/unmarkedFit.R) file, for the `unmarkedFit` mother class.
+
+- `[`
+- `backTransform`
+- `coef`
+- `confint`
+- `fitted`
+- `getData`
+- `hessian`
+- `linearComb`
+- `mle`
+- `names`
+- `nllFun`
+- `parboot`
+- `nonparboot`
+- `predict`
+- `profile`
+- `residuals`
+- `sampleSize`
+- `SE`
+- `show`
+- `summary`
+- `update`
+- `vcov`
+- `logLik`
+- `LRT`
+
+### Methods to access new attributes {-}
+
+You may also need to add specific methods to allow users to access an attribute you added to your `unmarkedFit` subclass.
+
+For example, some methods are relevant for some type of models only:
+
+- `getFP` for occupancy models that account for false positives
+- `getB` for occupancy models that account for false positives
+- `smoothed` for colonization-extinction models
+- `projected` for colonization-extinction models
+
+# Update the `NAMESPACE` file
+
+- Add your fitting function to the functions export [here](https://github.com/rbchan/unmarked/blob/master/NAMESPACE#L23-L27)
+- Add the new subclasses (`unmarkedFrame`, `unmarkedFit`) to the classes export [here](https://github.com/rbchan/unmarked/blob/master/NAMESPACE#L31-L43)
+- Add the function you wrote to create your `unmarkedFrame` object to the functions export [here](https://github.com/rbchan/unmarked/blob/master/NAMESPACE#L58-L64)
+- If you wrote new methods, for example to [access new attributes for objects of a subclass](#Methods-to-access-new-attributes), add them to the methods export [here](https://github.com/rbchan/unmarked/blob/master/NAMESPACE#L45-L54)
+- If required, export other functions you created that may be called by users of the package
+
+# Write tests
+
+Using `testthat` package, you need to write tests for your `unmarkedFrame` function, your fitting function, and methods described above. The tests should be fast, but cover all the key configurations.
+
+Write your tests in the `./tests/testthat/` folder, creating a R file for your model. If you are using RStudio, you can run the tests of your file easily by clicking on the "Run tests" button. You can run all the tests by clicking on the "Test" button in the Build pane.
+
+* [Example for `occu`](https://github.com/rbchan/unmarked/blob/master/tests/testthat/test_occu.R)
+* [Example for `gdistremoval`](https://github.com/rbchan/unmarked/blob/master/tests/testthat/test_gdistremoval.R)
+
+
+# Write documentation
+
+You need to write the documentation files for the new classes and functions you added. Documentation `.Rd` files are stored in the `man` folder. [Here](https://r-pkgs.org/man.html) is a documentation on how to format your documentation.
+
+- The most important, your fitting function!
+ - [Example for `occu`](https://github.com/rbchan/unmarked/blob/master/man/occu.Rd)
+ - [Example for `gdistremoval`](https://github.com/rbchan/unmarked/blob/master/man/gdistremoval.Rd)
+- Your `unmarkedFrame` constructor function
+ - [Example for `occu`](https://github.com/rbchan/unmarked/blob/master/man/occu.Rd)
+ - [Example for `gdistremoval`](https://github.com/rbchan/unmarked/blob/master/man/gdistremoval.Rd)
+- Add your fitting function to the reference of all functions to [_pkgdown.yml](https://github.com/rbchan/unmarked/blob/master/_pkgdown.yml)
+- Add the specific "type" for the predict methods of your `unmarkedFit` class to [predict-methods.Rd](https://github.com/rbchan/unmarked/blob/master/man/predict-methods.Rd)
+- Add your `getP` method for the signature of you `unmarkedFitList` object in [getP-methods.Rd](https://github.com/rbchan/unmarked/blob/master/man/getP-methods.Rd).
+
+Depending on how much you had to add, you may also need to update existing files:
+
+- If you added specific methods for your new `unmarkedFrame` class: add them to [unmarkedFrame-class.Rd](https://github.com/rbchan/unmarked/blob/master/man/unmarkedFrame-class.Rd)
+- If you added specific methods for your new `unmarkedFit` class: add them to [unmarkedFit-class.Rd](https://github.com/rbchan/unmarked/blob/master/man/unmarkedFit-class.Rd). The same goes for your new `unmarkedFitList` class in [unmarkedFitList-class.Rd](https://github.com/rbchan/unmarked/blob/master/man/unmarkedFitList-class.rd).
+- Add any specific function, method or class you created. For example, specific distance-sampling functions are documented in [detFuns.Rd](https://github.com/rbchan/unmarked/blob/master/man/detFuns.Rd).
+
+
+# Add to `unmarked`
+
+- Send a pull request on Github
+- Probably fix a few things
+- Merged and done!
diff --git a/vignettes/figures/COP-model.png b/vignettes/figures/COP-model.png
new file mode 100644
index 0000000..5728dc9
--- /dev/null
+++ b/vignettes/figures/COP-model.png
Binary files differ
diff --git a/vignettes/powerAnalysis.Rmd b/vignettes/powerAnalysis.Rmd
index f2cce35..6195816 100644
--- a/vignettes/powerAnalysis.Rmd
+++ b/vignettes/powerAnalysis.Rmd
@@ -820,7 +820,7 @@ It looks like only the largest tested sample size (100 sites) has power > 0.8 to
# Shiny webapp
-`unmarked` now includes a [Shiny](https://shiny.rstudio.com/) webapp that can be used to conduct power analyses.
+`unmarked` now includes a [Shiny](https://shiny.posit.co/) 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.
diff --git a/vignettes/powerAnalysis.Rmd.orig b/vignettes/powerAnalysis.Rmd.orig
index fad2fb0..4c8fda8 100644
--- a/vignettes/powerAnalysis.Rmd.orig
+++ b/vignettes/powerAnalysis.Rmd.orig
@@ -530,7 +530,7 @@ It looks like only the largest tested sample size (100 sites) has power > 0.8 to
# Shiny webapp
-`unmarked` now includes a [Shiny](https://shiny.rstudio.com/) webapp that can be used to conduct power analyses.
+`unmarked` now includes a [Shiny](https://shiny.posit.co/) 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.
diff --git a/vignettes/unmarked.bib b/vignettes/unmarked.bib
index c6091c6..82148aa 100644
--- a/vignettes/unmarked.bib
+++ b/vignettes/unmarked.bib
@@ -468,3 +468,18 @@ year = {2012}
volume = {9},
pages = {300-318}
}
+
+
+@misc{pautrel2023,
+ title = {Analysing Biodiversity Observation Data Collected in Continuous Time: Should We Use Discrete or Continuous-Time Occupancy Models?},
+ shorttitle = {Analysing Biodiversity Observation Data Collected in Continuous Time},
+ author = {Pautrel, L{\'e}a and Moulherat, Sylvain and Gimenez, Olivier and Etienne, Marie-Pierre},
+ year = {2023},
+ month = nov,
+ pages = {2023.11.17.567350},
+ publisher = {{bioRxiv}},
+ doi = {10.1101/2023.11.17.567350},
+ archiveprefix = {bioRxiv},
+ copyright = {{\textcopyright} 2023, Posted by Cold Spring Harbor Laboratory. This pre-print is available under a Creative Commons License (Attribution 4.0 International), CC BY 4.0, as described at http://creativecommons.org/licenses/by/4.0/},
+ langid = {english},
+}