#' Closest to tip 1 in each split
#'
#' @param tips Vector of length four specifying index of tips to consider.
#' @param splits Splits object.
#' @param nTip Integer specifying number of splits in `splits`.
#' @return Raw vector specifying the closest relative of `tips[1]` in each
#' split
#' @importFrom TreeTools NTip
#' @keywords internal
.Subsplit4 <- function (tips, splits, nTip = NTip(splits)[1]) {
blankMask <- raw((nTip - 1L) %/% 8L + 1L)
masks <- as.raw(c(1, 2, 4, 8, 16, 32, 64, 128))
tipMask <- vapply(tips, function (tip) {
mask <- blankMask
element <- (tip - 1L) %/% 8L + 1L
mask[element] <- masks[(tip - 1L) %% 8L + 1L]
mask
}, blankMask)
if (is.null(dim(tipMask))) tipMask <- matrix(tipMask, 1L)
mask12 <- tipMask[, 1] | tipMask[, 2]
mask13 <- tipMask[, 1] | tipMask[, 3]
mask14 <- tipMask[, 1] | tipMask[, 4]
mask23 <- tipMask[, 2] | tipMask[, 3]
mask24 <- tipMask[, 2] | tipMask[, 4]
mask34 <- tipMask[, 3] | tipMask[, 4]
mask <- mask12 | mask34
subSplits <- t(splits) & mask
ret <- as.raw(0L)
for (i in seq_len(ncol(subSplits))) {
# Up to twice as fast if we don't remove duplicates
split <- subSplits[, i]
if (identical(split, mask12) || identical(split, mask34)) {
ret <- as.raw(3L)
break
} else if (identical(split, mask13) || identical(split, mask24)) {
ret <- as.raw(2L)
break
} else if (identical(split, mask14) || identical(split, mask23)) {
ret <- as.raw(1L)
break
}
}
# Return:
ret
}
QuartetStatesTest <- function (splits, asRaw = FALSE) {
splits <- as.Splits(splits)
nTip <- NTip(splits)[1]
allQuartets <- AllQuartets(nTip)
if (is.list(splits)) {
nQuartets <- ncol(allQuartets)
return(t(vapply(splits, QuartetStates,
if (asRaw) raw(nQuartets) else integer(nQuartets),
asRaw = asRaw)))
}
ret <- apply(allQuartets, 2, .Subsplit4, unname(splits), nTip)
# Return:
if (asRaw) {
ret
} else {
as.integer(ret)
}
}
test_that("QuartetStates() works", {
expect_equal(QuartetStatesTest(TreeTools::BalancedTree(9)),
QuartetStates(TreeTools::BalancedTree(9)))
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.