Update getP

7 files changed, 121 insertions, 122 deletions

diff --git a/R/gdistremoval.R b/R/gdistremoval.R
index fdeab80..a90f807 100644
--- a/R/gdistremoval.R
+++ b/R/gdistremoval.R
@@ -473,7 +473,7 @@ gdistremoval <- function(lambdaformula=~1, phiformula=~1, removalformula=~1,
 
 # Methods
 
-setMethod("getP", "unmarkedFitGDR", function(object){
+setMethod("getP_internal", "unmarkedFitGDR", function(object, na.rm = TRUE){
 
   M <- numSites(object@data)
   T <- object@data@numPrimary
diff --git a/R/goccu.R b/R/goccu.R
index ca54fc6..900f563 100644
--- a/R/goccu.R
+++ b/R/goccu.R
@@ -180,12 +180,12 @@ setMethod("get_orig_data", "unmarkedFitGOccu", function(object, type, ...){
   clean_covs[[datatype]]
 })
 
-setMethod("getP", "unmarkedFitGOccu",
-  function(object, na.rm=FALSE){
+setMethod("getP_internal", "unmarkedFitGOccu",
+  function(object, na.rm=TRUE){
   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), 
+  M <- nrow(gd$y)
+  p <- matrix(p, nrow=M, ncol=ncol(gd$y), 
               byrow=TRUE)
   p
 })
@@ -193,9 +193,9 @@ setMethod("getP", "unmarkedFitGOccu",
 setMethod("fitted_internal", "unmarkedFitGOccu",
   function(object, na.rm= FALSE){
 
-  M <- numSites(object@data)
-  JT <- obsNum(object@data)  
   gd <- getDesign(object@data, object@formula, na.rm=na.rm)
+  M <- nrow(gd$y)
+  JT <- ncol(gd$y)  
 
   psi <- drop(plogis(gd$Xpsi %*% coef(object, "psi")))
   psi <- matrix(psi, nrow=M, ncol=JT)
@@ -204,7 +204,7 @@ setMethod("fitted_internal", "unmarkedFitGOccu",
   phi <- rep(phi, each = JT / object@data@numPrimary)
   phi <- matrix(phi, nrow=M, ncol=JT, byrow=TRUE)
 
-  p <- getP(object)
+  p <- getP(object, na.rm = na.rm)
 
   psi * phi * p
 })
@@ -224,7 +224,7 @@ setMethod("ranef", "unmarkedFitGOccu", function(object, ...){
   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 <- getP(object, na.rm=FALSE)
   p_array <- array(t(p), c(J, T, M))
   
   Z <- ZZ <- 0:1
@@ -270,7 +270,7 @@ setMethod("ranef", "unmarkedFitGOccu", function(object, ...){
 setMethod("simulate_internal", "unmarkedFitGOccu", 
           function(object, nsim = 1, na.rm = FALSE){
   
-  gd <- getDesign(object@data, object@formula, na.rm=FALSE)
+  gd <- getDesign(object@data, object@formula, na.rm=na.rm)
   M <- nrow(gd$y)
   T <- object@data@numPrimary
   JT <- ncol(gd$y)
@@ -280,7 +280,7 @@ setMethod("simulate_internal", "unmarkedFitGOccu",
   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 <- getP(object, na.rm=na.rm)
 
   sim_list <- list()
 
diff --git a/R/occuCOP.R b/R/occuCOP.R
index d91879e..339e077 100644
--- a/R/occuCOP.R
+++ b/R/occuCOP.R
@@ -366,7 +366,7 @@ setMethod("get_orig_data", "unmarkedFitOccuCOP", function(object, type, ...){
 
 
 ## getP ----
-setMethod("getP", "unmarkedFitOccuCOP", function(object, na.rm = TRUE) {
+setMethod("getP_internal", "unmarkedFitOccuCOP", function(object, na.rm = TRUE) {
   data <- object@data
   M = nrow(getY(data))
   J = ncol(getY(data))
diff --git a/R/unmarkedFit.R b/R/unmarkedFit.R
index 3d664ca..4d49858 100644
--- a/R/unmarkedFit.R
+++ b/R/unmarkedFit.R
@@ -1476,7 +1476,15 @@ setGeneric("getFP", function(object, ...) standardGeneric("getFP"))
 setGeneric("getB", function(object, ...) standardGeneric("getB"))
 
 
-setMethod("getP", "unmarkedFit", function(object, na.rm = TRUE)
+setMethod("getP", "unmarkedFit", function(object, na.rm = TRUE){
+  getP_internal(object = object, na.rm = na.rm)
+})
+
+setGeneric("getP_internal", function(object, na.rm = TRUE){
+  standardGeneric("getP_internal")
+})
+
+setMethod("getP_internal", "unmarkedFit", function(object, na.rm = TRUE)
 {
     formula <- object@formula
     detformula <- as.formula(formula[[2]])
@@ -1496,7 +1504,7 @@ setMethod("getP", "unmarkedFit", function(object, na.rm = TRUE)
 })
 
 
-setMethod("getP", "unmarkedFitOccuFP", function(object, na.rm = TRUE)
+setMethod("getP_internal", "unmarkedFitOccuFP", function(object, na.rm = TRUE)
 {
   formula <- object@formula
   detformula <- object@detformula
@@ -1518,7 +1526,8 @@ setMethod("getP", "unmarkedFitOccuFP", function(object, na.rm = TRUE)
   return(p)
 })
 
-setMethod("getP", "unmarkedFitOccuMulti", function(object)
+
+setMethod("getP_internal", "unmarkedFitOccuMulti", function(object, na.rm = TRUE)
 {
 
   ylist <- object@data@ylist
@@ -1544,7 +1553,8 @@ setMethod("getP", "unmarkedFitOccuMulti", function(object)
   out
 })
 
-setMethod("getP", "unmarkedFitOccuMS", function(object)
+
+setMethod("getP_internal", "unmarkedFitOccuMS", function(object, na.rm = TRUE)
 {
   J <- ncol(object@data@y)
   N <- nrow(object@data@y)
@@ -1552,7 +1562,8 @@ setMethod("getP", "unmarkedFitOccuMS", function(object)
   lapply(pred, function(x) matrix(x$Predicted, nrow=N, ncol=J, byrow=T))
 })
 
-setMethod("getP", "unmarkedFitOccuTTD", function(object)
+
+setMethod("getP_internal", "unmarkedFitOccuTTD", function(object, na.rm = TRUE)
 {
 
   N <- nrow(object@data@y)
@@ -1572,62 +1583,8 @@ setMethod("getP", "unmarkedFitOccuTTD", function(object)
   matrix(est_p, nrow=N, byrow=TRUE)
 })
 
-setMethod("getFP", "unmarkedFitOccuFP", function(object, na.rm = TRUE)
-{
-  formula <- object@formula
-  detformula <- object@detformula
-  stateformula <- object@stateformula
-  FPformula <- object@FPformula
-  Bformula <- object@Bformula
-  umf <- object@data
-  designMats <- getDesign(umf, detformula,FPformula,Bformula,stateformula, na.rm = na.rm)
-  type = object@type
-  y <- designMats$y
-  U <- designMats$U
-  U.offset <- designMats$U.offset
-  if (is.null(U.offset))
-    U.offset <- rep(0, nrow(U))
-  M <- nrow(y)
-  J <- ncol(y)
-  fpars <- coef(object, type = "fp")
-  f <- plogis(U %*% fpars + U.offset)
-  f <- matrix(f, M, J, byrow = TRUE)
-  if (type[1]!=0){
-    f[,1:type[1]] = 0
-  }
-  return(f)
-})
-
-setMethod("getB", "unmarkedFitOccuFP", function(object, na.rm = TRUE)
-{
-  formula <- object@formula
-  detformula <- object@detformula
-  stateformula <- object@stateformula
-  FPformula <- object@FPformula
-  Bformula <- object@Bformula
-  umf <- object@data
-  designMats <- getDesign(umf, detformula,FPformula,Bformula,stateformula, na.rm = na.rm)
-  y <- designMats$y
-  W <- designMats$W
-  W.offset <- designMats$W.offset
-  if (is.null(W.offset))
-    W.offset <- rep(0, nrow(W))
-  M <- nrow(y)
-  J <- ncol(y)
-  type = object@type
-  if (type[3]!=0){
-    bpars <- coef(object, type = "b")
-  b <- plogis(W %*% bpars + W.offset)
-  b <- matrix(b, M, J, byrow = TRUE)
-  }
-  if (type[3]==0){
-    b <- matrix(0, M, J)
-  }
-  return(b)
-})
 
-
-setMethod("getP", "unmarkedFitDS",
+setMethod("getP_internal", "unmarkedFitDS",
     function(object, na.rm = TRUE)
 {
     formula <- object@formula
@@ -1731,10 +1688,8 @@ setMethod("getP", "unmarkedFitDS",
 })
 
 
-
-
 # Should this return p or pi. Right now it's pi without phi.
-setMethod("getP", "unmarkedFitGDS",
+setMethod("getP_internal", "unmarkedFitGDS",
     function(object, na.rm = TRUE)
 {
 #    browser()
@@ -1855,7 +1810,7 @@ setMethod("getP", "unmarkedFitGDS",
 })
 
 
-setMethod("getP", "unmarkedFitDSO",
+setMethod("getP_internal", "unmarkedFitDSO",
     function(object, na.rm = TRUE)
 {
     umf <- getData(object)
@@ -1898,7 +1853,7 @@ setMethod("getP", "unmarkedFitDSO",
 })
 
 
-setMethod("getP", "unmarkedFitMPois", function(object, na.rm = TRUE)
+setMethod("getP_internal", "unmarkedFitMPois", function(object, na.rm = TRUE)
 {
     formula <- object@formula
     detformula <- as.formula(formula[[2]])
@@ -1920,7 +1875,7 @@ setMethod("getP", "unmarkedFitMPois", function(object, na.rm = TRUE)
 })
 
 
-setMethod("getP", "unmarkedFitMMO", function(object, na.rm = TRUE)
+setMethod("getP_internal", "unmarkedFitMMO", function(object, na.rm = TRUE)
 {
 
   umf <- object@data
@@ -1946,7 +1901,7 @@ setMethod("getP", "unmarkedFitMMO", function(object, na.rm = TRUE)
 })
 
 
-setMethod("getP", "unmarkedFitPCO", function(object, na.rm = TRUE)
+setMethod("getP_internal", "unmarkedFitPCO", function(object, na.rm = TRUE)
 {
     umf <- object@data
     D <- getDesign(umf, object@formula, na.rm = na.rm)
@@ -1965,7 +1920,7 @@ setMethod("getP", "unmarkedFitPCO", function(object, na.rm = TRUE)
 
 
 
-setMethod("getP", "unmarkedFitColExt", function(object, na.rm = TRUE)
+setMethod("getP_internal", "unmarkedFitColExt", function(object, na.rm = TRUE)
 {
     data <- object@data
     detParms <- coef(object, 'det')
@@ -1986,7 +1941,7 @@ setMethod("getP", "unmarkedFitColExt", function(object, na.rm = TRUE)
 
 
 
-setMethod("getP", "unmarkedFitGMM",
+setMethod("getP_internal", "unmarkedFitGMM",
     function(object, na.rm = TRUE)
 {
     formula <- object@formula
@@ -2020,7 +1975,7 @@ setMethod("getP", "unmarkedFitGMM",
 })
 
 
-setMethod("getP", "unmarkedFitGPC",
+setMethod("getP_internal", "unmarkedFitGPC",
     function(object, na.rm = TRUE)
 {
     formula <- object@formula
@@ -2041,6 +1996,62 @@ setMethod("getP", "unmarkedFitGPC",
     return(p)
 })
 
+
+setMethod("getFP", "unmarkedFitOccuFP", function(object, na.rm = TRUE)
+{
+  formula <- object@formula
+  detformula <- object@detformula
+  stateformula <- object@stateformula
+  FPformula <- object@FPformula
+  Bformula <- object@Bformula
+  umf <- object@data
+  designMats <- getDesign(umf, detformula,FPformula,Bformula,stateformula, na.rm = na.rm)
+  type = object@type
+  y <- designMats$y
+  U <- designMats$U
+  U.offset <- designMats$U.offset
+  if (is.null(U.offset))
+    U.offset <- rep(0, nrow(U))
+  M <- nrow(y)
+  J <- ncol(y)
+  fpars <- coef(object, type = "fp")
+  f <- plogis(U %*% fpars + U.offset)
+  f <- matrix(f, M, J, byrow = TRUE)
+  if (type[1]!=0){
+    f[,1:type[1]] = 0
+  }
+  return(f)
+})
+
+setMethod("getB", "unmarkedFitOccuFP", function(object, na.rm = TRUE)
+{
+  formula <- object@formula
+  detformula <- object@detformula
+  stateformula <- object@stateformula
+  FPformula <- object@FPformula
+  Bformula <- object@Bformula
+  umf <- object@data
+  designMats <- getDesign(umf, detformula,FPformula,Bformula,stateformula, na.rm = na.rm)
+  y <- designMats$y
+  W <- designMats$W
+  W.offset <- designMats$W.offset
+  if (is.null(W.offset))
+    W.offset <- rep(0, nrow(W))
+  M <- nrow(y)
+  J <- ncol(y)
+  type = object@type
+  if (type[3]!=0){
+    bpars <- coef(object, type = "b")
+  b <- plogis(W %*% bpars + W.offset)
+  b <- matrix(b, M, J, byrow = TRUE)
+  }
+  if (type[3]==0){
+    b <- matrix(0, M, J)
+  }
+  return(b)
+})
+
+
 #Y extractors for unmarkedFit objects
 setMethod("getY", "unmarkedFit", function(object) object@data@y)
 setMethod("getY", "unmarkedFitOccu", function(object) {
diff --git a/man/getP-methods.Rd b/man/getP-methods.Rd
deleted file mode 100644
index 7a3b87e..0000000
--- a/man/getP-methods.Rd
+++ /dev/null
@@ -1,34 +0,0 @@
-\name{getP-methods}
-\docType{methods}
-\alias{getP}
-\alias{getP-methods}
-\alias{getP,unmarkedFit-method}
-\alias{getP,unmarkedFitOccuFP-method}
-\alias{getP,unmarkedFitOccuMulti-method}
-\alias{getP,unmarkedFitOccuMS-method}
-\alias{getP,unmarkedFitOccuTTD-method}
-\alias{getP,unmarkedFitDS-method}
-\alias{getP,unmarkedFitMPois-method}
-\alias{getP,unmarkedFitColExt-method}
-\alias{getP,unmarkedFitPCO-method}
-\alias{getP,unmarkedFitGMM-method}
-\alias{getP,unmarkedFitGDS-method}
-\alias{getP,unmarkedFitGPC-method}
-\alias{getP,unmarkedFitDSO-method}
-\alias{getP,unmarkedFitMMO-method}
-\alias{getP,unmarkedFitGDR-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 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{\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/getP.Rd b/man/getP.Rd
new file mode 100644
index 0000000..821f3ea
--- /dev/null
+++ b/man/getP.Rd
@@ -0,0 +1,22 @@
+\name{getP}
+\alias{getP}
+\alias{getP-methods}
+\alias{getP,unmarkedFit-method}
+
+\title{Get detection parameter estimates from a fitted 'unmarked' model}
+
+\description{
+The \code{getP} function returns a matrix of the back-transformed detection parameter (\eqn{p} the detection probability or \eqn{\lambda} the detection rate, depending on the model).
+}
+
+\usage{
+\S4method{getP}{unmarkedFit}(object, na.rm = TRUE)
+}
+
+\arguments{
+  \item{object}{An \code{unmarkedFit} object.}
+  \item{na.rm}{Logical. Should missing values be removed?}
+}
+
+\value{A matrix 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. Some fit types with multiple detection processes or multiple species return a named list of matrices, one per detection process or species.
+} 
diff --git a/tests/testthat/test_goccu.R b/tests/testthat/test_goccu.R
index 48f6031..d4c0e16 100644
--- a/tests/testthat/test_goccu.R
+++ b/tests/testthat/test_goccu.R
@@ -124,12 +124,12 @@ test_that("goccu handles missing values", {
   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))
+  expect_warning(gp <- getP(mod_na))
+  expect_equal(dim(gp), c(M-1, 20))
+  expect_true(is.na(gp[4,1]))
+  expect_true(all(is.na(gp[5, 1:4])))
+  expect_warning(s <- simulate(mod_na))
+  expect_equal(dim(s[[1]]), c(M-1, 20))
   ft <- fitted(mod_na)
   expect_equal(dim(ft), dim(mod_na@data@y))
   r <- ranef(mod_na)