### This modified version of "check.states" is needed to work with diversitree ### 0.9-7 or 0.9-10. It allows models to run when not all states are present. ### ### Changes are "multicheck" and "tmp". ### See also mod below to initial.tip.xxsse.R patched.check.states <- function(tree, states, allow.unnamed=FALSE, strict=FALSE, strict.vals=NULL, as.integer=TRUE) { multicheck <- TRUE # for multistate strict checking if ( is.matrix(states) ) { if ( inherits(tree, "clade.tree") ) stop("Clade trees won't work with multistate tips yet") n <- rowSums(states > 0) if ( any(n == 0) ) stop(sprintf("No state found for taxa: %s", paste(names(n)[n == 0], collapse=", "))) if (any(rowSums(states) == 0)) multicheck <- FALSE i.mono <- which(n == 1) i.mult <- which(n > 1) tmp <- diversitree:::matrix.to.list(states) names(tmp) <- rownames(states) states.mult <- lapply(tmp[i.mult], as.numeric) states <- rep(NA, length(tmp)) names(states) <- names(tmp) states[i.mono] <- sapply(tmp[i.mono], function(x) which(x != 0)) attr(states, "multistate") <- list(i=i.mult, states=states.mult) } if ( is.null(names(states)) ) { if ( allow.unnamed ) { if ( length(states) == length(tree$tip.label) ) { names(states) <- tree$tip.label warning("Assuming states are in tree$tip.label order") } else { stop(sprintf("Invalid states length (expected %d)", length(tree$tip.label))) } } else { stop("The states vector must contain names") } } if ( !all(tree$tip.label %in% names(states)) ) stop("Not all species have state information") if ( !is.null(strict.vals) ) { if ( isTRUE(all.equal(strict.vals, 0:1)) ) if ( is.logical(states) ) states[] <- as.integer(states) if ( strict ) { if ( !isTRUE(all.equal(sort(strict.vals), sort(unique(na.omit(states))))) & !multicheck) stop("Because strict state checking requested, all (and only) ", sprintf("states in %s are allowed", paste(strict.vals, collapse=", "))) } else { tmp <- unique(na.omit(states)) if (!is.na(tmp[[1]])) { extra <- setdiff(sort(tmp), strict.vals) if ( length(extra) > 0 ) stop(sprintf("Unknown states %s not allowed in states vector", paste(extra, collapse=", "))) } } if ( as.integer && any(!is.na(states)) ) states <- diversitree:::check.integer(states) } if ( inherits(tree, "clade.tree") ) { spp.clades <- unlist(tree$clades) if ( !all(spp.clades %in% names(states)) ) stop("Species in 'clades' do not have states information") states[union(tree$tip.label, spp.clades)] } else { ret <- states[tree$tip.label] attr(ret, "multistate") <- attr(states, "multistate") ret } } assignInNamespace("check.states", patched.check.states, "diversitree") rm(patched.check.states) ### This modified version of "check.states" is needed to work with diversitree ### 0.9-7. It allows all tips to be uncertain/multiple-value. ### ### Even more importantly, it fixes a bug with the interaction of multistate ### characters and sampling incompleteness. patched.initial.tip.xxsse <- function(cache, base.zero = FALSE) { k <- cache$info$k f <- cache$sampling.f y <- matrix(rep(c(1 - f, rep(0, k)), k + 1), k + 1, 2 * k, TRUE) y[k + 1, (k + 1):(2 * k)] <- diag(y[1:k, (k + 1):(2 * k)]) <- f y <- diversitree:::matrix.to.list(y) y.i <- cache$states if (base.zero) y.i <- y.i + 1L y.i[is.na(y.i)] <- k + 1 if (!is.null(multistate <- attr(cache$states, "multistate"))) { y.multi <- unique(multistate$states) y.i.multi <- match(multistate$states, y.multi) y <- c(y, lapply(y.multi, function(x) c(1-f, x*f))) y.i[multistate$i] <- y.i.multi + k + 1 } diversitree:::dt.tips.grouped(y, as.numeric(y.i), cache) } assignInNamespace("initial.tip.xxsse", patched.initial.tip.xxsse, "diversitree") rm(patched.initial.tip.xxsse)