diff --git a/DESCRIPTION b/DESCRIPTION index c78f80e0..baf2b1d8 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: unmarked -Version: 1.5.0.9004 -Date: 2025-07-21 +Version: 1.5.0.9005 +Date: 2025-07-27 Type: Package Title: Models for Data from Unmarked Animals Authors@R: c( @@ -65,6 +65,7 @@ Collate: 'classes.R' 'unmarkedEstimate.R' 'unmarkedFrame.R' 'occuCOP.R' 'occuComm.R' 'removed_functions.R' + 'square_brackets.R' 'RcppExports.R' 'zzz.R' LinkingTo: diff --git a/R/gdistremoval.R b/R/gdistremoval.R index bbc8a27e..ba6a6926 100644 --- a/R/gdistremoval.R +++ b/R/gdistremoval.R @@ -54,118 +54,6 @@ setAs("unmarkedFrameGDR", "data.frame", function(from){ data.frame(yDistance, yRemoval, out) }) -setMethod("[", c("unmarkedFrameGDR", "numeric", "missing", "missing"), - function(x, i) { - M <- numSites(x) - T <- x@numPrimary - - if(length(i) == 0) return(x) - if(any(i < 0) && any(i > 0)) - stop("i must be all positive or all negative indices.") - if(all(i < 0)) { # if i is negative, then convert to positive - i <- (1:M)[i] - } - - yDist <- x@yDistance - Rdist <- ncol(yDist) - Jdist <- Rdist / T - yRem <- x@yRemoval - Rrem <- ncol(yRem) - Jrem <- Rrem / T - sc <- siteCovs(x) - oc <- obsCovs(x) - ysc <- NULL - if(T > 1){ - ysc <- yearlySiteCovs(x) - } - - yDist <- yDist[i,,drop=FALSE] - yRem <- yRem[i,,drop=FALSE] - - if(!is.null(sc)){ - sc <- sc[i,,drop=FALSE] - } - - if(!is.null(oc)){ - site_idx <- rep(1:M, each=Rrem) - oc <- do.call("rbind", lapply(i, function(ind){ - obsCovs(x)[site_idx == ind,,drop=FALSE] - })) - } - - if(!is.null(ysc)){ - site_idx <- rep(1:M, each=T) - ysc <- do.call("rbind", lapply(i, function(ind){ - yearlySiteCovs(x)[site_idx == ind,,drop=FALSE] - })) - } - - umf <- x - umf@y <- yRem - umf@yDistance <- yDist - umf@yRemoval <- yRem - umf@siteCovs <- sc - umf@obsCovs <- oc - umf@yearlySiteCovs <- ysc - - umf -}) - -setMethod("[", c("unmarkedFrameGDR", "logical", "missing", "missing"), - function(x, i) { - i <- which(i) - x[i, ] -}) - -setMethod("[", c("unmarkedFrameGDR", "missing", "numeric", "missing"), - function(x, i, j){ - - M <- numSites(x) - T <- x@numPrimary - if(T == 1){ - stop("Only possible to subset by primary period", call.=FALSE) - } - yDist <- x@yDistance - Rdist <- ncol(yDist) - Jdist <- Rdist / T - yRem <- x@yRemoval - Rrem <- ncol(yRem) - Jrem <- Rrem / T - oc <- obsCovs(x) - ysc <- yearlySiteCovs(x) - - rem_idx <- rep(1:T, each=Jrem) %in% j - yRem <- yRem[,rem_idx,drop=FALSE] - obsToY <- x@obsToY[rem_idx, rem_idx] - - dist_idx <- rep(1:T, each=Jdist) %in% j - yDist <- yDist[,dist_idx,drop=FALSE] - - if(!is.null(oc)){ - T_idx <- rep(rep(1:T, each=Jrem),M) - keep <- T_idx %in% j - oc <- oc[keep,,drop=FALSE] - } - - if(!is.null(ysc)){ - site_idx <- rep(1:T, M) - keep <- site_idx %in% j - ysc <- ysc[keep,,drop=FALSE] - } - - umf <- x - umf@y <- yRem - umf@yDistance <- yDist - umf@yRemoval <- yRem - umf@obsCovs <- oc - umf@yearlySiteCovs <- ysc - umf@obsToY <- obsToY - umf@numPrimary <- length(j) - - umf -}) - - setClass("unmarkedFitGDR", contains = "unmarkedFitGDS") gdistremoval <- function(lambdaformula=~1, phiformula=~1, removalformula=~1, diff --git a/R/occuCOP.R b/R/occuCOP.R index 6237f8e6..c57d0d42 100644 --- a/R/occuCOP.R +++ b/R/occuCOP.R @@ -90,87 +90,6 @@ setMethod("summary", "unmarkedFrameOccuCOP", function(object,...) { }) -## 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)) - ) - }) - - -## 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, ...){ fl <- fit@formlist diff --git a/R/occuComm.R b/R/occuComm.R index f631bd4f..f170ed2c 100644 --- a/R/occuComm.R +++ b/R/occuComm.R @@ -100,67 +100,6 @@ setMethod("plot", c(x="unmarkedFrameOccuComm", y="missing"), labels=names(x@ylist), ...) }) -#[ Methods for community occupancy frames -setMethod("[", c("unmarkedFrameOccuComm", "numeric", "missing", "missing"), - function(x, i){ - if(length(i) == 0) return(x) - M <- numSites(x) - J <- obsNum(x) - S <- length(x@ylist) - - ylist <- lapply(x@ylist,function(x) x[i,,drop=F]) - - siteCovs <- siteCovs(x) - if (!is.null(siteCovs)) { - siteCovs <- siteCovs(x)[i, , drop = FALSE] - } - - obsCovs <- obsCovs(x) - if (!is.null(obsCovs)) { - .site <- rep(1:M, each = J) - oc <- lapply(i, function(ind){ - obsCovs[.site==ind,,drop=FALSE] - }) - obsCovs <- do.call(rbind, oc) - } - - # Species covs - spc <- x@speciesCovs - if(!is.null(spc)){ - # length S covs are unchanged - spc_sp <- sapply(spc, function(x) identical(length(x), S)) - spc_sp <- spc[spc_sp] - - # M x S covs - spc_site <- sapply(spc, function(x) identical(dim(x), c(M, S))) - spc_site <- spc[spc_site] - if(length(spc_site) > 0){ - spc_site <- lapply(spc_site, function(x){ - x[i,,drop=FALSE] - }) - } - # M x J x S covs - spc_obs <- sapply(spc, function(x) identical(dim(x), c(M, J, S))) - spc_obs <- spc[spc_obs] - if(length(spc_obs) > 0){ - spc_obs <- lapply(spc_obs, function(x){ - x[i,,,drop=FALSE] - }) - } - new_spc <- c(spc_site, spc_obs, spc_sp) - } else { - new_spc <- NULL - } - - umf <- x - umf@y <- ylist[[1]] - umf@ylist <- ylist - umf@siteCovs <- siteCovs - umf@obsCovs <- obsCovs - umf@speciesCovs <- new_spc - umf -}) - process_multispecies_umf <- function(umf, interact_covs){ ylist <- umf@ylist M <- nrow(ylist[[1]]) diff --git a/R/square_brackets.R b/R/square_brackets.R new file mode 100644 index 00000000..98935da8 --- /dev/null +++ b/R/square_brackets.R @@ -0,0 +1,405 @@ +setClassUnion("numericOrLogical", c("numeric", "logical")) + +# Square bracket selector methods (exported)----------------------------------- +setMethod("[", c("unmarkedFrame", "numericOrLogical", "missing", "missing"), + function(x, i){ + subset_sites(x, i) +}) + +setMethod("[", c("unmarkedFrame", "missing", "numericOrLogical", "missing"), + function(x, i, j){ + subset_obs(x, j) +}) + +setMethod("[", c("unmarkedFrame", "numericOrLogical", "numericOrLogical", "missing"), + function(x, i, j){ + x <- x[i,] + x[,j] +}) + + +# Internal site-selector methods----------------------------------------------- + +setGeneric("subset_sites", function(umf, i) standardGeneric("subset_sites")) + +setMethod("subset_sites", c("unmarkedFrame", "numericOrLogical"), + function(umf, i){ + + M <- numSites(umf) + J <- obsNum(umf) + + # Process selection + keep <- process_site_index(umf, i) + + # Subset y + y <- getY(umf)[keep,,drop=FALSE] + umf@y <- y + + # Subset site covs + sc <- siteCovs(umf) + if(!is.null(sc)){ + siteCovs(umf) <- sc[keep,,drop=FALSE] + } + + # Subset obs covs + oc <- obsCovs(umf) + if(!is.null(oc)){ + keep_obs <- rep(1:M, each = J) + oc_new <- lapply(keep, function(x){ + oc[keep_obs == x,,drop=FALSE] + }) + obsCovs(umf) <- do.call(rbind, oc_new) + } + + # Subset yearly site covs if they exist + if(methods::.hasSlot(umf, "yearlySiteCovs")){ + ysc <- yearlySiteCovs(umf) + keep_per <- rep(1:M, each = umf@numPrimary) + if(!is.null(ysc)){ + ysc_new <- lapply(keep, function(x){ + ysc[keep_per == x,,drop=FALSE] + }) + yearlySiteCovs(umf) <- do.call(rbind, ysc_new) + } + } + + umf +}) + +setMethod("subset_sites", c("unmarkedFrameDailMadsen", "numericOrLogical"), + function(umf, i){ + idx <- process_site_index(umf, i) + umf <- methods::callNextMethod(umf, i) + umf@primaryPeriod <- umf@primaryPeriod[idx,,drop=FALSE] + umf +}) + +setMethod("subset_sites", c("unmarkedFrameDS", "numericOrLogical"), + function(umf, i){ + idx <- process_site_index(umf, i) + umf <- methods::callNextMethod(umf, i) + if(umf@survey == "line"){ + umf@tlength <- umf@tlength[idx] + } + umf +}) + +setMethod("subset_sites", c("unmarkedFrameDSO", "numericOrLogical"), + function(umf, i){ + idx <- process_site_index(umf, i) + umf <- methods::callNextMethod(umf, i) + if(umf@survey == "line"){ + umf@tlength <- umf@tlength[idx] + } + umf +}) + +setMethod("subset_sites", c("unmarkedFrameGDR", "numericOrLogical"), + function(umf, i){ + keep <- process_site_index(umf, i) + umf <- methods::callNextMethod(umf, i) + umf@yDistance <- umf@yDistance[keep,,drop=FALSE] + umf@yRemoval <- umf@yRemoval[keep,,drop=FALSE] + umf +}) + +setMethod("subset_sites", c("unmarkedFrameGDS", "numericOrLogical"), + function(umf, i){ + idx <- process_site_index(umf, i) + umf <- methods::callNextMethod(umf, i) + if(umf@survey == "line"){ + umf@tlength <- umf@tlength[idx] + } + umf +}) + +# This one is more complicated due to species covs and repeated site/obs covs +setMethod("subset_sites", c("unmarkedFrameOccuComm", "numericOrLogical"), + function(umf, i){ + if(length(i) == 0) return(umf) + i <- process_site_index(umf, i) + M <- numSites(umf) + J <- obsNum(umf) + S <- length(umf@ylist) + + ylist <- lapply(umf@ylist,function(x) x[i,,drop=F]) + + siteCovs <- siteCovs(umf) + if (!is.null(siteCovs)) { + siteCovs <- siteCovs(umf)[i, , drop = FALSE] + } + + obsCovs <- obsCovs(umf) + if (!is.null(obsCovs)) { + .site <- rep(1:M, each = J) + oc <- lapply(i, function(ind){ + obsCovs[.site==ind,,drop=FALSE] + }) + obsCovs <- do.call(rbind, oc) + } + + # Species covs + spc <- umf@speciesCovs + if(!is.null(spc)){ + # length S covs are unchanged + spc_sp <- sapply(spc, function(x) identical(length(x), S)) + spc_sp <- spc[spc_sp] + + # M x S covs + spc_site <- sapply(spc, function(x) identical(dim(x), c(M, S))) + spc_site <- spc[spc_site] + if(length(spc_site) > 0){ + spc_site <- lapply(spc_site, function(x){ + x[i,,drop=FALSE] + }) + } + # M x J x S covs + spc_obs <- sapply(spc, function(x) identical(dim(x), c(M, J, S))) + spc_obs <- spc[spc_obs] + if(length(spc_obs) > 0){ + spc_obs <- lapply(spc_obs, function(x){ + x[i,,,drop=FALSE] + }) + } + new_spc <- c(spc_site, spc_obs, spc_sp) + } else { + new_spc <- NULL + } + + umf@y <- ylist[[1]] + umf@ylist <- ylist + umf@siteCovs <- siteCovs + umf@obsCovs <- obsCovs + umf@speciesCovs <- new_spc + umf +}) + +setMethod("subset_sites", c("unmarkedFrameOccuCOP", "numericOrLogical"), + function(umf, i){ + keep <- process_site_index(umf, i) + umf <- methods::callNextMethod(umf, i) + umf@L <- umf@L[keep,,drop=FALSE] + umf +}) + +setMethod("subset_sites", c("unmarkedFrameOccuMulti", "numericOrLogical"), + function(umf, i){ + keep <- process_site_index(umf, i) + umf <- methods::callNextMethod(umf, i) + umf@ylist <- lapply(umf@ylist, function(s) s[keep,,drop=FALSE]) + umf +}) + +setMethod("subset_sites", c("unmarkedFrameOccuTTD", "numericOrLogical"), + function(umf, i){ + idx <- process_site_index(umf, i) + umf <- methods::callNextMethod(umf, i) + umf@surveyLength <- umf@surveyLength[idx,,drop=FALSE] + umf +}) + +# Utility function to clean up indices +process_site_index <- function(umf, i){ + if(is.logical(i)){ + stopifnot(length(i) == numSites(umf)) + keep <- 1:numSites(umf) + keep <- keep[i] + } else if(is.numeric(i)){ + stopifnot(all(abs(i) %in% 1:numSites(umf))) + stopifnot(all(i>0) | all(i<0)) + if(all(i<0)){ + keep <- 1:numSites(umf) + keep <- keep[!keep %in% abs(i)] + } else { + keep <- i + } + } + keep +} + + +# Internal obs/period-selector methods----------------------------------------- + +setGeneric("subset_obs", function(umf, j) standardGeneric("subset_obs")) + +setMethod("subset_obs", c("unmarkedFrame", "numericOrLogical"), + function(umf, j){ + if(obsNum(umf) != numY(umf)){ + stop("Can't subset multinomial observations", call.=FALSE) + } + M <- numSites(umf) + J <- obsNum(umf) + + # Process selection + keep <- process_obs_index(umf, j) + + # Subset y + y <- getY(umf)[,keep,drop=FALSE] + umf@y <- y + + # Subset obs covs + oc <- obsCovs(umf) + if(!is.null(oc)){ + keep_site <- rep(1:M, each = J) + oc_new <- lapply(1:M, function(m){ + oc_sub <- oc[keep_site == m,,drop=FALSE] + oc_sub <- oc_sub[keep,,drop=FALSE] + }) + obsCovs(umf) <- do.call(rbind, oc_new) + } + + # Subset obsToY + # This only works with non-multinomial + obsToY(umf) <- diag(length(keep)) + + umf +}) + +setMethod("subset_obs", c("unmarkedFrameOccuCOP", "numericOrLogical"), + function(umf, j){ + keep <- process_obs_index(umf, j) + umf <- methods::callNextMethod(umf, j) + umf@L <- umf@L[,keep,drop=FALSE] + umf +}) + +setMethod("subset_obs", c("unmarkedFrameOccuMulti", "numericOrLogical"), + function(umf, j){ + keep <- process_obs_index(umf, j) + umf <- methods::callNextMethod(umf, j) + umf@ylist <- lapply(umf@ylist, function(s) s[,keep,drop=FALSE]) + umf +}) + +process_obs_index <- function(umf, j){ + if(methods::.hasSlot(umf, "numPrimary")){ + if(umf@numPrimary > 1){ + stop("Can't subset observations in multi-period umf", call.=FALSE) + } + } + if(is.logical(j)){ + stopifnot(length(j) == obsNum(umf)) + keep <- 1:obsNum(umf) + keep <- keep[j] + } else if(is.numeric(j)){ + stopifnot(all(abs(j) %in% 1:obsNum(umf))) + stopifnot(all(j>0) | all(j<0)) + if(all(j<0)){ + keep <- 1:obsNum(umf) + keep <- keep[!keep %in% abs(j)] + } else { + keep <- j + } + } + keep +} + + +# The following select by period instead of individual occasion---------------- + +setMethod("subset_obs", c("unmarkedMultFrame", "numericOrLogical"), + function(umf, j){ + if(obsNum(umf) != numY(umf)){ + stop("Can't subset multinomial observations", call.=FALSE) + } + M <- numSites(umf) + T_old <- umf@numPrimary + J <- numY(umf) / T_old + R <- obsNum(umf) / T_old + + # Process selection + keep <- process_period_index(umf, j) + + umf@numPrimary <- length(keep) + + # Subset y + keep_per <- rep(1:T_old, each = J) + y <- lapply(keep, function(x){ + getY(umf)[,keep_per == x,drop=FALSE] + }) + umf@y <- do.call(cbind, y) + + # Subset yearly site covs + ysc <- yearlySiteCovs(umf) + if(!is.null(ysc)){ + keep_site <- rep(1:M, each = T_old) + ysc_new <- lapply(1:M, function(m){ + ysc_sub <- ysc[keep_site == m,,drop=FALSE] + ysc_sub <- ysc_sub[keep,,drop=FALSE] + }) + yearlySiteCovs(umf) <- do.call(rbind, ysc_new) + } + + # Subset obs covs + oc <- obsCovs(umf) + if(!is.null(oc)){ + keep_site <- rep(1:M, each = obsNum(umf)) + keep_per <- rep(1:T_old, each = R) + + oc_new <- lapply(1:M, function(m){ + oc_sub <- oc[keep_site == m,,drop=FALSE] + oc_sub <- lapply(keep, function(x){ + oc_sub[keep_per == x,,drop=FALSE] + }) + do.call(rbind, oc_sub) + }) + obsCovs(umf) <- do.call(rbind, oc_new) + } + + # Subset obsToY + # Only works with non-multinomial + obsToY(umf) <- diag(numY(umf)) + + umf +}) + +setMethod("subset_obs", c("unmarkedFrameGDR", "numericOrLogical"), + function(umf, j){ + keep <- process_period_index(umf, j) + T <- umf@numPrimary + Jdist <- ncol(umf@yDistance) / T + Jrem <- ncol(umf@yRemoval) / T + umf <- methods::callNextMethod(umf, j) + + # Subset y matrices + keep_per <- rep(1:T, each = Jdist) + yDistance <- lapply(keep, function(k){ + umf@yDistance[,keep_per == k,drop=FALSE] + }) + umf@yDistance <- do.call(cbind, yDistance) + + keep_per <- rep(1:T, each = Jrem) + yRemoval <- lapply(keep, function(k){ + umf@yRemoval[,keep_per == k,drop=FALSE] + }) + umf@yRemoval <- do.call(cbind, yRemoval) + umf +}) + +process_period_index <- function(umf, j){ + stopifnot(methods::.hasSlot(umf, "numPrimary")) + T <- umf@numPrimary + stopifnot(T > 1) + if(is.logical(j)){ + stopifnot(length(j) == T) + keep <- 1:T + keep <- keep[j] + } else if(is.numeric(j)){ + stopifnot(all(abs(j) %in% 1:T)) + stopifnot(all(j>0) | all(j<0)) + if(all(j < 0)){ + keep <- 1:T + keep <- keep[!keep %in% abs(j)] + } else { + keep <- j + } + } + keep +} + +# head method------------------------------------------------------------------ + +setMethod("head", "unmarkedFrame", function(x, n) { + if(missing(n)) n <- 6 + x[1:n,] +}) diff --git a/R/unmarkedFrame.R b/R/unmarkedFrame.R index 2702f9ca..25034bfc 100644 --- a/R/unmarkedFrame.R +++ b/R/unmarkedFrame.R @@ -1146,443 +1146,6 @@ setMethod("hist", "unmarkedFrameDS", function(x, ...) hist(distances, breaks=dbreaks, ...) }) - - -################################# SELECTORS ############################## - -# i is the vector of sites to extract - -setMethod("[", c("unmarkedFrame", "numeric", "missing", "missing"), - function(x, i) -{ - M <- numSites(x) - if(length(i) == 0) return(x) - if(any(i < 0) && any(i > 0)) - stop("i must be all positive or all negative indices.") - if(all(i < 0)) { # if i is negative, then convert to positive - i <- (1:M)[i] - } - y <- getY(x)[i,,drop=FALSE] - siteCovs <- siteCovs(x) - obsCovs <- obsCovs(x) - if (!is.null(siteCovs)) { - siteCovs <- siteCovs(x)[i, , drop = FALSE] - } - if (!is.null(obsCovs)) { - R <- obsNum(x) - .site <- rep(1:M, each = R) - oc <- lapply(i, function(ind){ - obsCovs[.site==ind,,drop=FALSE] - }) - obsCovs <- do.call(rbind, oc) - } - umf <- x - umf@y <- y - umf@siteCovs <- siteCovs - umf@obsCovs <- obsCovs - umf -}) - - -## remove obs only -### RBC: Why??? this doesn't allow umf[,c(1,1)] -setMethod("[", c("unmarkedFrame", "missing", "numeric", "missing"), - function(x, i, j) -{ - y <- getY(x) - obsCovs <- obsCovs(x) - obsToY <- obsToY(x) - obs.remove <- rep(TRUE, obsNum(x)) - obs.remove[j] <- FALSE - y.remove <- t(obs.remove) %*% obsToY > 0 - y <- y[,!y.remove, drop=FALSE] - obsCovs <- obsCovs[!rep(obs.remove, numSites(x)),, drop=FALSE] - x@obsCovs <- obsCovs - x@y <- y - x@obsToY <- obsToY[!obs.remove,!y.remove, drop=FALSE] - x -}) - - -# i is as before and j is the obsNum to remove and corresponding y's -setMethod("[", c("unmarkedFrame","numeric", "numeric", "missing"), - function(x, i, j) -{ - ## first remove sites - umf <- x[i,] - umf <- umf[,j] - umf -}) - - - -### list is a ragged array of indices (y's) to include for each site. -### Typically useful for multilevel boostrapping. -setMethod("[", c("unmarkedFrame","list", "missing", "missing"), - function(x, i, j) -{ - m <- numSites(x) - J <- R <- obsNum(x) - o2y <- obsToY(x) - if (!identical(o2y, diag(R))) - stop("Ragged subsetting of unmarkedFrames is only valid for diagonal obsToY.") - J <- ncol(o2y) - if (m != length(i)) stop("list length must be same as number of sites.") - siteCovs <- siteCovs(x) - y <- cbind(.site=1:m, getY(x)) - obsCovs <- obsCovs(x) - site_idx <- rep(1:m, each=R) - stopifnot(length(site_idx) == nrow(obsCovs)) - - oc <- lapply(1:m, function(ind){ - df <- obsCovs[site_idx==ind,,drop=FALSE] - obs <- i[[ind]] - if (length(obs) > R) - stop("All elements of list must be less than or equal to R.") - obs <- c(obs, rep(NA, R-length(obs))) - df[obs,,drop=FALSE] - }) - obsCovs <- do.call(rbind, oc) - rownames(obsCovs) <- NULL - - y <- apply(y, 1, function(row) { - site <- row[1] - row <- row[-1] - obs <- i[[site]] - obs <- c(obs, rep(NA, R-length(obs))) - row[obs] - }) - - if(!is.null(obsCovs(x))){ - obsCovs(x) <- obsCovs - } - x@y <- t(y) - x -}) - - -#[ Methods for multispecies occupancy frames -setMethod("[", c("unmarkedFrameOccuMulti", "numeric", "missing", "missing"), - function(x, i) -{ - if(length(i) == 0) return(x) - M <- numSites(x) - - ylist <- lapply(x@ylist,function(x) x[i,,drop=F]) - siteCovs <- siteCovs(x) - obsCovs <- obsCovs(x) - if (!is.null(siteCovs)) { - siteCovs <- siteCovs(x)[i, , drop = FALSE] - } - if (!is.null(obsCovs)) { - R <- obsNum(x) - .site <- rep(1:M, each = R) - oc <- lapply(i, function(ind){ - obsCovs[.site==ind,,drop=FALSE] - }) - obsCovs <- do.call(rbind, oc) - } - umf <- x - umf@y <- ylist[[1]] - umf@ylist <- ylist - umf@siteCovs <- siteCovs - umf@obsCovs <- obsCovs - umf -}) - -setMethod("[", c("unmarkedFrameOccuMulti", "missing", "numeric", "missing"), - function(x, i, j) -{ - y <- getY(x) - obsCovs <- obsCovs(x) - obsToY <- obsToY(x) - obs.remove <- rep(TRUE, obsNum(x)) - obs.remove[j] <- FALSE - y.remove <- t(obs.remove) %*% obsToY > 0 - ylist <- lapply(x@ylist, function(z) z[,!y.remove, drop=F]) - obsCovs <- obsCovs[!rep(obs.remove, numSites(x)),, drop=FALSE] - - x@obsCovs <- obsCovs - x@y <- ylist[[1]] - x@ylist <- ylist - x@obsToY <- obsToY[!obs.remove,!y.remove, drop=FALSE] - x -}) - - -## for multframes, must remove years at a time -setMethod("[", c("unmarkedMultFrame", "missing", "numeric", "missing"), - function(x, i, j) -{ - J <- obsNum(x)/x@numPrimary - obs <- rep(1:x@numPrimary, each = J) - years <- 1:x@numPrimary - numPrimary <- length(j) - obsj <- match(obs, j) - j2 <- which(!is.na(obsj)) - u <- callNextMethod(x, i, j2) - ysc <- yearlySiteCovs(x) - if(!is.null(ysc)) { - ysc <- ysc[rep(!is.na(match(years, j)), nrow(getY(x))),, drop=FALSE] - u@yearlySiteCovs <- ysc - } - u@numPrimary <- numPrimary - return(u) -}) - - - -## for multframes, must remove years at a time -setMethod("[", c("unmarkedMultFrame", "numeric", "missing", "missing"), - function(x, i, j) -{ - M <- numSites(x) - if(length(i) == 0) return(x) - if(any(i < 0) && any(i > 0)) - stop("i must be all positive or all negative indices.") - if(all(i < 0)) { # if i is negative, then convert to positive - i <- (1:M)[i] - } - oldy <- getY(x) - y <- oldy[i,] - siteCovs <- siteCovs(x) - obsCovs <- obsCovs(x) - if (!is.null(siteCovs)) { - siteCovs <- siteCovs(x)[i, , drop = FALSE] - } - if (!is.null(obsCovs)) { - R <- obsNum(x) - .site <- rep(1:M, each = obsNum(x)) #NULL ## testing - oc <- lapply(i, function(ind){ - obsCovs[.site==ind,,drop=FALSE] - }) - obsCovs <- do.call(rbind, oc) - } - u <- unmarkedMultFrame(y=matrix(y, ncol=ncol(oldy)), - siteCovs=siteCovs, - obsCovs=obsCovs, - numPrimary=x@numPrimary) - ysc <- x@yearlySiteCovs - if(!is.null(ysc)) { - T <- x@numPrimary - sites <- rep(1:M, each=T) - keep <- as.vector(sapply(i, function(x) which(sites %in% x))) - ysc <- ysc[keep,, drop=FALSE] - u@yearlySiteCovs <- ysc - } - u - -}) - - -setMethod("[", c("unmarkedFrameOccuMS", "numeric", "missing", "missing"), - function(x, i, j) -{ - multf <- callNextMethod(x, i, j) - unmarkedFrameOccuMS(y=getY(multf), siteCovs=siteCovs(multf), - yearlySiteCovs=yearlySiteCovs(multf), - obsCovs=obsCovs(multf), - numPrimary=x@numPrimary) -}) - -setMethod("[", c("unmarkedFrameGMM", "numeric", "missing", "missing"), - function(x, i, j) -{ - M <- nrow(x@y) - y <- x@y[i,,drop=FALSE] - R <- obsNum(x) - T <- x@numPrimary - - sc <- siteCovs(x)[i,,drop=FALSE] - - ysc_ind <- rep(1:M, each=T) - ysc <- do.call("rbind", lapply(i, function(ind){ - yearlySiteCovs(x)[ysc_ind == ind,,drop=FALSE] - })) - - oc_ind <- rep(1:M, each=R) - oc <- do.call("rbind", lapply(i, function(ind){ - obsCovs(x)[oc_ind == ind,,drop=FALSE] - })) - - unmarkedFrameGMM(y=y, siteCovs=sc, - yearlySiteCovs=ysc, - obsCovs=oc, - piFun=x@piFun, type=x@samplingMethod, - obsToY=x@obsToY, numPrimary=x@numPrimary) -}) - -setMethod("[", c("unmarkedFrameMMO", "numeric", "missing", "missing"), - function(x, i, j) -{ - M <- nrow(x@y) - y <- x@y[i,,drop=FALSE] - R <- obsNum(x) - T <- x@numPrimary - - sc <- siteCovs(x)[i,,drop=FALSE] - - ysc_ind <- rep(1:M, each=T) - ysc <- do.call("rbind", lapply(i, function(ind){ - yearlySiteCovs(x)[ysc_ind == ind,,drop=FALSE] - })) - - oc_ind <- rep(1:M, each=R) - oc <- do.call("rbind", lapply(i, function(ind){ - obsCovs(x)[oc_ind == ind,,drop=FALSE] - })) - - unmarkedFrameMMO(y=y, siteCovs=sc, - yearlySiteCovs=ysc, - obsCovs=oc, - type=x@samplingMethod, - numPrimary=x@numPrimary, - primaryPeriod=x@primaryPeriod[i,,drop=FALSE]) -}) - - -setMethod("[", c("unmarkedFrameGPC", "numeric", "missing", "missing"), - function(x, i, j) -{ - multf <- callNextMethod(x, i, j) # unmarkedMultFrame - class(multf) <- "unmarkedFrameGPC" - multf -}) - - -setMethod("[", c("unmarkedFrameGPC", "missing", "numeric", "missing"), - function(x, i, j) -{ - multf <- as(x, "unmarkedMultFrame") - out <- callNextMethod(multf, i, j) # unmarkedMultFrame - as(out, "unmarkedFrameGPC") -}) - - - - - -setMethod("[", c("unmarkedFrameGDS", "numeric", "missing", "missing"), - function(x, i, j) -{ - multf <- callNextMethod(x, i, j) # unmarkedMultFrame - sur <- x@survey - if(sur=="line") - unmarkedFrameGDS(y=getY(multf), siteCovs=siteCovs(multf), - yearlySiteCovs=yearlySiteCovs(multf), - numPrimary=x@numPrimary, - dist.breaks=x@dist.breaks, - tlength=x@tlength[i], - survey=sur, - unitsIn=x@unitsIn) - else if(sur=="point") - unmarkedFrameGDS(y=getY(multf), siteCovs=siteCovs(multf), - yearlySiteCovs=yearlySiteCovs(multf), - numPrimary=x@numPrimary, - dist.breaks=x@dist.breaks, - survey=sur, - unitsIn=x@unitsIn) -}) - - - -setMethod("[", c("unmarkedFramePCO", "numeric", "missing", "missing"), - function(x, i, j) -{ - multf <- callNextMethod(x, i, j) # unmarkedMultFrame - unmarkedFramePCO(y=getY(multf), siteCovs=siteCovs(multf), - yearlySiteCovs=yearlySiteCovs(multf), - obsCovs=obsCovs(multf), - numPrimary=x@numPrimary, - primaryPeriod=x@primaryPeriod[i,,drop=FALSE]) -}) - - -setMethod("[", c("unmarkedFramePCO", "missing", "numeric", "missing"), - function(x, i, j) -{ - multf <- callNextMethod(x, i, j) # unmarkedMultFrame - unmarkedFramePCO(y=getY(multf), siteCovs=siteCovs(multf), - yearlySiteCovs=yearlySiteCovs(multf), - obsCovs=obsCovs(multf), - numPrimary=length(j), - primaryPeriod=x@primaryPeriod[,j,drop=FALSE]) -}) - - -setMethod("[", c("unmarkedFrameOccuTTD", "numeric", "missing", "missing"), - function(x, i, j) -{ - multf <- callNextMethod(x, i, j) # unmarkedMultFrame - unmarkedFrameOccuTTD(y=getY(multf), siteCovs=siteCovs(multf), - yearlySiteCovs=yearlySiteCovs(multf), - obsCovs=obsCovs(multf), - numPrimary=x@numPrimary, - surveyLength=x@surveyLength[i,,drop=FALSE]) -}) - - -setMethod("[", c("unmarkedFrameDSO", "numeric", "missing", "missing"), - function(x, i, j) -{ - multf <- callNextMethod(x, i, j) # unmarkedMultFrame - sur <- x@survey - pp <- x@primaryPeriod[i,,drop=FALSE] - if(sur=="line") - unmarkedFrameDSO(y=getY(multf), siteCovs=siteCovs(multf), - yearlySiteCovs=yearlySiteCovs(multf), - numPrimary=x@numPrimary, - dist.breaks=x@dist.breaks, - tlength=x@tlength[i], - survey=sur, - unitsIn=x@unitsIn, - primaryPeriod=pp) - else if(sur=="point") - unmarkedFrameDSO(y=getY(multf), siteCovs=siteCovs(multf), - yearlySiteCovs=yearlySiteCovs(multf), - numPrimary=x@numPrimary, - dist.breaks=x@dist.breaks, - survey=sur, - unitsIn=x@unitsIn, - primaryPeriod=pp) -}) - - -setMethod("[", c("unmarkedFrameOccuTTD", "missing", "numeric", "missing"), - function(x, i, j) -{ - - 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) - - 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] - 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)) -}) - - - - -setMethod("head", "unmarkedFrame", function(x, n) { - if(missing(n)) n <- 10 - umf <- x[1:n,] - umf -}) - ############################### COERCION ################################# setAs("data.frame", "unmarkedFrame", function(from) diff --git a/man/extract-methods.Rd b/man/extract-methods.Rd index b6bc1d6d..b9f1fb1a 100644 --- a/man/extract-methods.Rd +++ b/man/extract-methods.Rd @@ -3,19 +3,9 @@ \alias{[-methods} \alias{[,unmarkedEstimateList,ANY,ANY,ANY-method} \alias{[,unmarkedFit,ANY,ANY,ANY-method} -\alias{[,unmarkedFrame,missing,numeric,missing-method} -\alias{[,unmarkedFrame,numeric,missing,missing-method} -\alias{[,unmarkedFrame,numeric,numeric,missing-method} -\alias{[,unmarkedMultFrame,missing,numeric,missing-method} -\alias{[,unmarkedMultFrame,numeric,missing,missing-method} -\alias{[,unmarkedFrameGMM,numeric,missing,missing-method} -\alias{[,unmarkedFrameGDS,numeric,missing,missing-method} -\alias{[,unmarkedFramePCO,numeric,missing,missing-method} -\alias{[,unmarkedFramePCO,missing,numeric,missing-method} -\alias{[,unmarkedFrameGPC,numeric,missing,missing-method} -\alias{[,unmarkedFrameGPC,missing,numeric,missing-method} -\alias{[,unmarkedFrameOccuComm,missing,numeric,missing-method} -\alias{[,unmarkedFrame,list,missing,missing-method} +\alias{[,unmarkedFrame,numericOrLogical,missing,missing-method} +\alias{[,unmarkedFrame,missing,numericOrLogical,missing-method} +\alias{[,unmarkedFrame,numericOrLogical,numericOrLogical,missing-method} \title{Methods for bracket extraction [ in Package `unmarked'} \description{ Methods for bracket extraction \code{[} in Package `unmarked' @@ -23,20 +13,14 @@ Methods for bracket extraction \code{[} in Package `unmarked' \usage{ \S4method{[}{unmarkedEstimateList,ANY,ANY,ANY}(x, i, j, drop) \S4method{[}{unmarkedFit,ANY,ANY,ANY}(x, i, j, drop) -\S4method{[}{unmarkedFrame,numeric,numeric,missing}(x, i, j) -\S4method{[}{unmarkedFrame,list,missing,missing}(x, i, j) -\S4method{[}{unmarkedMultFrame,missing,numeric,missing}(x, i, j) -\S4method{[}{unmarkedMultFrame,numeric,missing,missing}(x, i, j) -\S4method{[}{unmarkedFrameGMM,numeric,missing,missing}(x, i, j) -\S4method{[}{unmarkedFrameGDS,numeric,missing,missing}(x, i, j) -\S4method{[}{unmarkedFramePCO,numeric,missing,missing}(x, i, j) +\S4method{[}{unmarkedFrame,numericOrLogical,numericOrLogical,missing}(x, i, j) } \arguments{ \item{x}{Object of appropriate S4 class} - \item{i}{Row numbers} - \item{j}{Observation numbers (eg occasions, distance classes, etc...)} + \item{i}{Site numbers or a vector of TRUE/FALSE} + \item{j}{Observation numbers (occasions or primary periods) or a vector of TRUE/FALSE} \item{drop}{Not currently used} - } +} \section{Methods}{ \describe{ @@ -48,33 +32,8 @@ Methods for bracket extraction \code{[} in Package `unmarked' unmarkedEstimate object from an unmarkedFit by name (either 'det' or 'state')} -\item{x = "unmarkedFrame", i = "missing", j = "numeric", drop = "missing"}{ - Extract observations from an unmarkedFrame.} - -\item{x = "unmarkedFrame", i = "numeric", j = "missing", drop = "missing"}{ - Extract rows from an unmarkedFrame } - -\item{x = "unmarkedFrame", i = "numeric", j = "numeric", drop = "missing"}{ - Extract rows and observations from an unmarkedFrame } - -\item{x = "unmarkedMultFrame", i = "missing", j = "numeric", drop = "missing"}{ - Extract primary sampling periods from an unmarkedMultFrame} - -\item{x = "unmarkedFrame", i = "list", j = "missing", drop = "missing"}{ - List is the index of observations to subset for each site. } - -\item{x = "unmarkedMultFrame", i = "numeric", j = "missing", drop = "missing"}{ - Extract rows (sites) from an unmarkedMultFrame} - -\item{x = "unmarkedGMM", i = "numeric", j = "missing", drop = "missing"}{ - Extract rows (sites) from an unmarkedFrameGMM object} - -\item{x = "unmarkedGDS", i = "numeric", j = "missing", drop = "missing"}{ - Extract rows (sites) from an unmarkedFrameGDS object} - -\item{x = "unmarkedPCO", i = "numeric", j = "missing", drop = "missing"}{ - Extract rows (sites) from an unmarkedFramePCO object} - +\item{x = "unmarkedFrame", i = "numericOrLogical", j = "numericOrLogical", drop = "missing"}{ + Extract sites and/or observations from an unmarkedFrame } }} diff --git a/man/unmarkedFrame-class.Rd b/man/unmarkedFrame-class.Rd index ce4a9f09..42caf075 100644 --- a/man/unmarkedFrame-class.Rd +++ b/man/unmarkedFrame-class.Rd @@ -41,20 +41,6 @@ \alias{summary,unmarkedFrameOccuTTD-method} \alias{summary,unmarkedFrameOccuCOP-method} \alias{summary,unmarkedFrameOccuComm-method} -\alias{[,unmarkedFrameOccuMulti,missing,numeric,missing-method} -\alias{[,unmarkedFrameOccuTTD,missing,numeric,missing-method} -\alias{[,unmarkedFrameGDR,missing,numeric,missing-method} -\alias{[,unmarkedFrameOccuMS,numeric,missing,missing-method} -\alias{[,unmarkedFrameOccuTTD,numeric,missing,missing-method} -\alias{[,unmarkedFrameOccuMulti,numeric,missing,missing-method} -\alias{[,unmarkedFrameDSO,numeric,missing,missing-method} -\alias{[,unmarkedFrameMMO,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} -\alias{[,unmarkedFrameOccuComm,numeric,missing,missing-method} \title{Class "unmarkedFrame" } \description{Methods for manipulating, summarizing and viewing diff --git a/tests/testthat/test_gdistremoval.R b/tests/testthat/test_gdistremoval.R index 8f0f2cba..2bd76043 100644 --- a/tests/testthat/test_gdistremoval.R +++ b/tests/testthat/test_gdistremoval.R @@ -481,6 +481,10 @@ test_that("multi-period data works with gdistremoval",{ umf <- unmarkedFrameGDR(dat$y, dat$yRem, siteCovs=sc, obsCovs=oc, yearlySiteCovs=ysc, dist.breaks=c(0,25,50,75,100), unitsIn='m', numPrimary=5) + # Check subsetting + umf_sub <- umf[1:2,c(1,2,2)] + expect_equal(umf_sub@numPrimary, 3) + fit <- gdistremoval(~sc1,phiformula=~ysc1, removalformula=~oc1,distanceformula=~1, data=umf) expect_equivalent(coef(fit), diff --git a/tests/testthat/test_multmixOpen.R b/tests/testthat/test_multmixOpen.R index 76b4a152..9f983a64 100644 --- a/tests/testthat/test_multmixOpen.R +++ b/tests/testthat/test_multmixOpen.R @@ -69,9 +69,10 @@ test_that("subsetting unmarkedFrameMMO works", { expect_equivalent(umf_sub[1,], umf[2,]) expect_equivalent(umf_sub[2,], umf[2,]) expect_equivalent(umf_sub[3,], umf[4,]) - set.seed(123) - keep <- runif(numSites(umf), 0, 1) > 0.5 - expect_error(umf_sub <- umf[keep,]) # this should work + + keep <- c(TRUE, FALSE, TRUE, rep(FALSE, 97)) + umf_sub <- umf[keep,] # this should work + expect_equal(umf_sub, umf[c(1,3),]) }) test_that("multmixOpen can fit removal models",{ diff --git a/tests/testthat/test_occu.R b/tests/testthat/test_occu.R index eacc8b2f..d43fc111 100644 --- a/tests/testthat/test_occu.R +++ b/tests/testthat/test_occu.R @@ -20,7 +20,8 @@ test_that("unmarkedFrameOccu subset works", { expect_equivalent(umf_sub[3,], umf[4,]) keep <- c(FALSE, FALSE, TRUE, FALSE, TRUE) - expect_error(umf_sub <- umf[keep,]) # this should work + umf_sub <- umf[keep,] + expect_equal(umf_sub, umf[c(3,5),]) }) test_that("occu can fit simple models",{ diff --git a/tests/testthat/test_occuCOP.R b/tests/testthat/test_occuCOP.R index 85213c87..8ab386a8 100644 --- a/tests/testthat/test_occuCOP.R +++ b/tests/testthat/test_occuCOP.R @@ -423,7 +423,8 @@ test_that("occuCOP can fit and predict models with covariates", { ) # Check subsetting with covariates - expect_error(umf_sub <- umf[c(8,8,9),]) # this should work + umf_sub <- umf[c(8,8,9),] + expect_equal(numSites(umf_sub), 3) # Fit ---- expect_no_error(umfit <- occuCOP( diff --git a/tests/testthat/test_occuMulti.R b/tests/testthat/test_occuMulti.R index 2dd1bd26..d2897394 100644 --- a/tests/testthat/test_occuMulti.R +++ b/tests/testthat/test_occuMulti.R @@ -37,7 +37,8 @@ test_that("unmarkedFrameOccuMulti construction and methods work",{ expect_equivalent(umf_sub[3,], umf[4,]) keep <- c(FALSE, FALSE, TRUE, FALSE, TRUE) - expect_error(umf_sub <- umf[keep,]) # this should work + umf_sub <- umf[keep,] + expect_equal(umf_sub, umf[c(3,5),]) umf_sub <- umf[,1:2] expect_equal(umf_sub@ylist[[1]], umf@ylist[[1]][,1:2]) diff --git a/tests/testthat/test_occuTTD.R b/tests/testthat/test_occuTTD.R index c1135486..f855893a 100644 --- a/tests/testthat/test_occuTTD.R +++ b/tests/testthat/test_occuTTD.R @@ -33,7 +33,7 @@ test_that("unmarkedFrameOccuTTD can be constructed",{ expect_equal(s[3], "100 sites") hd <- head(umf) - expect_equivalent(as(hd, 'data.frame'), as(umf, 'data.frame')[1:10,]) + expect_equivalent(as(hd, 'data.frame'), as(umf, 'data.frame')[1:6,]) umf_sub <- umf[c(1,3),] expect_equivalent(as(umf_sub, 'data.frame'), as(umf, 'data.frame')[c(1,3),]) diff --git a/tests/testthat/test_pcount.R b/tests/testthat/test_pcount.R index 52b98a19..a3c0bbba 100644 --- a/tests/testthat/test_pcount.R +++ b/tests/testthat/test_pcount.R @@ -24,7 +24,8 @@ test_that("unmarkedFramePCount subset works", { expect_equivalent(umf_sub[3,], umf[4,]) keep <- c(FALSE, FALSE, TRUE, FALSE, TRUE) - expect_error(umf_sub <- umf[keep,]) # this should work + umf_sub <- umf[keep,] + expect_equal(umf_sub, umf[c(3,5),]) }) test_that("pcount can fit simple models",{ diff --git a/tests/testthat/test_unmarkedFrame.R b/tests/testthat/test_unmarkedFrame.R index 66bc9027..11fd4809 100644 --- a/tests/testthat/test_unmarkedFrame.R +++ b/tests/testthat/test_unmarkedFrame.R @@ -5,7 +5,7 @@ test_that("unmarkedFrame can be constructed",{ J <- 3 y <- matrix(rbinom(J * M, 1, 0.5), M, J) siteCovs <- data.frame(a = rnorm(M), b = factor(gl(2,5))) - umf <- unmarkedFrame(y = y, siteCovs = siteCovs) + umf <- unmarkedFrameOccu(y = y, siteCovs = siteCovs) expect_is(umf, "unmarkedFrame") out <- capture.output(umf) @@ -16,6 +16,22 @@ test_that("unmarkedFrame can be constructed",{ # convert to data frame df <- as(umf, "data.frame") expect_is(df, "data.frame") + + # Subset sites + expect_equal(numSites(umf[1:3,]), 3) + umf1 <- umf[1,] + umf112 <- umf[c(1,1,2),] + expect_equivalent(umf112[1,], umf1) + expect_equivalent(umf112[2,], umf1) + expect_equivalent(umf112[3,], umf[2,]) + expect_equal(umf[c(TRUE, TRUE, rep(FALSE, 8)),], umf[1:2]) + + # Subset obs + expect_equal(obsNum(umf[,1:2]), 2) + umf112 <- umf[,c(1,1,2,2)] + expect_equal(umf112@y[,1], umf112@y[,2]) + expect_equal(obsNum(umf112), 4) + expect_equal(umf[,c(TRUE, FALSE, TRUE)], umf[,c(1,3)]) }) test_that("obsToY works", { @@ -145,6 +161,7 @@ test_that("unmarkedMultFrame subset works",{ expect_equal(umf1.obs1@numPrimary, 1) umf1.obs1and3 <- umf1[,c(1,3)] + expect_equal(umf1[,c(TRUE, FALSE, TRUE)], umf1.obs1and3) umf1.site1 <- umf1[1,] expect_equal(umf1.site1@y, y[1,, drop=FALSE]) @@ -155,6 +172,8 @@ test_that("unmarkedMultFrame subset works",{ expect_equal(umf1.site1@numPrimary, 3) umf1.sites1and3 <- umf1[c(1,3),] + + expect_equal(umf1[c(TRUE, FALSE, TRUE)], umf1.sites1and3) }) test_that("unmmarkedMultFrame handles unequal secondary periods",{