From 8de45de974edc30eb1f019719a961f482a63a140 Mon Sep 17 00:00:00 2001 From: Dominic Bennett Date: Fri, 22 Jul 2016 16:26:59 +0100 Subject: [PATCH] Created new _nds_ functions based around nd mat --- NAMESPACE | 2 +- R/calc-methods.R | 17 ++++++----- R/gen-methods.R | 10 +++++++ R/get-methods.R | 19 +++++++----- R/manip-methods.R | 3 +- R/ndlst-methods.R | 24 ++++++++++++--- R/node-declaration.R | 6 ++-- R/read-write-methods.R | 16 ++++++++-- R/set-methods.R | 8 +++++ R/treeman-declaration.R | 6 ++-- R/update-methods.R | 3 +- man/TreeMan-class.Rd | 2 ++ man/calcFrPrp.Rd | 2 +- man/getNdsKids.Rd | 2 +- src/read_tools.c | 2 +- tests/testthat/test-calc-methods.R | 1 + tests/testthat/test-ndlst-methods.R | 45 ++++++++++++++--------------- 17 files changed, 112 insertions(+), 56 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 38be04b..9b0aa65 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -73,7 +73,7 @@ importFrom(stats,runif) importFrom(utils,combn) importFrom(utils,write.table) useDynLib(treeman) +useDynLib(treeman,cFindPrids) useDynLib(treeman,cGetNdPrids) useDynLib(treeman,cGetNdPtids) useDynLib(treeman,cGetNdsMat) -useDynLib(treeman,findPrids) diff --git a/R/calc-methods.R b/R/calc-methods.R index e46df04..1bcc274 100644 --- a/R/calc-methods.R +++ b/R/calc-methods.R @@ -156,13 +156,14 @@ calcOvrlp <- function(tree, ids_1, ids_2, nrmlsd=FALSE, ...) { #' tree_1 <- randTree(10) #' tree_2 <- randTree(10) #' calcDstBLD(tree_1, tree_2) + calcDstBLD <- function(tree_1, tree_2, nrmlsd=FALSE, ...) { n1 <- tree_1@nds[!tree_1@nds == tree_1@root] n2 <- tree_2@nds[!tree_2@nds == tree_2@root] - c1 <- getNdsKids(tree_1, n1, ...) - c2 <- getNdsKids(tree_2, n2, ...) - s1 <- getNdsSlt(tree_1, slt_nm="spn", ids=n1, ...) - s2 <- getNdsSlt(tree_2, slt_nm="spn", ids=n2, ...) + c1 <- getNdsKids(tree_1, n1) + c2 <- getNdsKids(tree_2, n2) + s1 <- getNdsSlt(tree_1, slt_nm="spn", ids=n1) + s2 <- getNdsSlt(tree_2, slt_nm="spn", ids=n2) d1 <- s2[match(c1, c2)] d1[which(is.na(d1))] <- 0 d1 <- s1 - d1 @@ -261,22 +262,22 @@ calcPhyDv <- function(tree, tids, ...) { #' library(treeman) #' tree <- randTree(10) #' calcFrPrp(tree, tree['tips']) -calcFrPrp <- function(tree, tids, ...) { +calcFrPrp <- function(tree, tids, parallel=FALSE) { .calc <- function(tid) { ids <- c(tid, prids[[tid]]) sum(spns[ids]/ns[ids]) } all <- names(tree@ndlst) tids <- sapply(tree@ndlst, function(x) length(x[['ptid']]) == 0) - tids <- all[tids] nds_mat <- getNdsMat(tree, all) prids <- apply(nds_mat, 2, function(x) all[x]) - ns <- apply(nds_mat, 1, sum) + ns <- apply(nds_mat, 1, function(x) sum(tids & x)) rm(nds_mat) ns[ns == 0] <- 1 # prevent division by 0 spns <- sapply(tree@ndlst, function(x) x[['spn']]) + tids <- all[tids] l_data <- data.frame(tid=tids, stringsAsFactors=FALSE) - plyr::mdply(.data=l_data, .fun=.calc, ...)[ ,2] + res_2 <- plyr::mdply(.data=l_data, .fun=.calc, .parallel=parallel)[ ,2] } #' @name calcDstMtrx diff --git a/R/gen-methods.R b/R/gen-methods.R index 8aadff5..866c0eb 100644 --- a/R/gen-methods.R +++ b/R/gen-methods.R @@ -51,6 +51,16 @@ randTree <- function(n, update=TRUE, parallel=FALSE) { tree <- new('TreeMan', ndlst=ndlst, root='n1') if(update) { tree <- updateTree(tree) + } else { + # init basic slots + tree@updtd <- FALSE + tree@tips <- paste0('t', 1:n) + tree@ntips <- n + tree@nds <- paste0('n', 1:(n-1)) + tree@nnds <- n - 1 + tree@all <- names(tree@ndlst) + tree@nall <- nnds + tree@wspn <- TRUE } tree } diff --git a/R/get-methods.R b/R/get-methods.R index 9c80c3c..1edcc89 100644 --- a/R/get-methods.R +++ b/R/get-methods.R @@ -36,7 +36,6 @@ #' prids <- apply(res, 2, function(x) all[x]) getNdsMat <- function(tree, qry_ids) { res <- .getNdsMat(tree@ndlst, qry_ids) - res <- res > 0 rownames(res) <- names(tree@ndlst) colnames(res) <- qry_ids res @@ -244,6 +243,7 @@ getNdsPrdst <- function(tree, ids) { res <- .getNdsMat(tree@ndlst, ids) all <- sapply(tree@ndlst, function(x) x[['spn']]) res <- apply(res, 2, function(x) sum(all[x])) + res <- res + all[ids] names(res) <- ids res } @@ -328,13 +328,18 @@ getNdKids <- function(tree, id) { #' library(treeman) #' tree <- randTree(10) #' getNdsKids(tree, id=tree['nds']) -getNdsKids <- function(tree, ids, ...) { +getNdsKids <- function(tree, ids) { # TODO: make parallel - tids <- sapply(tree@ndlst, function(x) length(x[['ptid']]) == 0) - tids <- names(tids)[tids] - res <- .getNdsMat(tree@ndlst, tids) - is <- match(ids, names(tree@ndlst)) - res <- apply(res[is, ], 1, function(x) tids[x]) + if(length(ids) <= 1) { + res <- getNdKids(tree, ids) + res <- list(res) + } else { + tids <- sapply(tree@ndlst, function(x) length(x[['ptid']]) == 0) + tids <- names(tids)[tids] + res <- .getNdsMat(tree@ndlst, tids) + is <- match(ids, names(tree@ndlst)) + res <- apply(res[is, ], 1, function(x) tids[x]) + } names(res) <- ids res } diff --git a/R/manip-methods.R b/R/manip-methods.R index f50fd86..f5447a0 100644 --- a/R/manip-methods.R +++ b/R/manip-methods.R @@ -22,7 +22,7 @@ rmTips <- function(tree, tid, drp_intrnl=TRUE) { # internal .rmTip <- function(tid) { # get sister IDs - sids <- .getSstr(ndlst, tid) + sids <- .getNdSstr(ndlst, tid) # get prid prid <- ndlst[[tid]][['prid']][[1]] # remove tid @@ -54,6 +54,7 @@ rmTips <- function(tree, tid, drp_intrnl=TRUE) { sapply(tid, .rmTip) tree@ndlst <- ndlst tree@root <- rid + tree@updtd <- FALSE tree } diff --git a/R/ndlst-methods.R b/R/ndlst-methods.R index 2c7ad1d..219f820 100644 --- a/R/ndlst-methods.R +++ b/R/ndlst-methods.R @@ -1,3 +1,18 @@ +# Attemp for making getNdsMat run in parallel +# ... actually made it slower +# ntids <- length(tids) +# n <- foreach::getDoParWorkers() +# nparts <- ntids %/% n +# parts <- c(seq(1, ntids - 1, nparts), ntids + 1) +# res <- foreach (i=2:length(parts), .combine="cbind") %dopar% { +# tids <- tids[parts[i-1]:(parts[i] - 1)] +# res <- .Call("cGetNdsMat", PACKAGE="treeman", +# as.integer(length(nids)), +# as.integer(tids), +# as.integer(prids)) +# res +# } + # MULTIPLE NDS #' @useDynLib treeman cGetNdsMat .getNdsMat <- function(ndlst, qry_ids) { @@ -11,6 +26,7 @@ as.integer(tids), as.integer(prids)) res <- res > 0 + res } # SINGLE ND @@ -35,7 +51,7 @@ } .getNdPrdst <- function(ndlst, id) { - prids <- .getPrids(ndlst, id) + prids <- .getNdPrids(ndlst, id) sum(sapply(ndlst[prids], function(x) x[['spn']])) + ndlst[[id]][['spn']] } @@ -53,13 +69,13 @@ } .getNdKids <- function(ndlst, id) { - ptids <- .getPtids(ndlst, id) + ptids <- .getNdPtids(ndlst, id) kids <- sapply(ndlst[ptids], function(x) length(x[['ptid']]) == 0) ptids[as.logical(kids)] } .getNdPD <- function(ndlst, id) { - ptids <- .getPtids(ndlst, id) + ptids <- .getNdPtids(ndlst, id) if(length(ptids) > 0) { res <- sum(sapply(ndlst[ptids], function(x) x[['spn']])) } else { @@ -73,6 +89,6 @@ .getTreeAge <- function(ndlst) { tids <- sapply(ndlst, function(x) length(x[['ptid']]) == 0) tids <- as.integer(which(tids)) - tip_prdsts <- sapply(tids, .getPrdst, ndlst=ndlst) + tip_prdsts <- sapply(tids, .getNdPrdst, ndlst=ndlst) max(tip_prdsts) } \ No newline at end of file diff --git a/R/node-declaration.R b/R/node-declaration.R index 8eaa2d9..a7426c7 100644 --- a/R/node-declaration.R +++ b/R/node-declaration.R @@ -4,8 +4,8 @@ spn <- pd <- prdst <- numeric() } else { spn <- nd[['spn']] - pd <- .getPD(tree@ndlst, id) - prdst <- .getPrdst(tree@ndlst, id) + pd <- .getNdPD(tree@ndlst, id) + prdst <- .getNdPrdst(tree@ndlst, id) } if(length(tree@age) > 0) { age <- tree@age - prdst @@ -17,7 +17,7 @@ } else { txnym <- nd[['txnym']] } - kids <- names(tree@ndlst)[.getKids(tree@ndlst, id)] + kids <- names(tree@ndlst)[.getNdKids(tree@ndlst, id)] new('Node', id=nd[['id']], spn=spn, prid=as.character(nd[['prid']][1]), ptid=as.character(nd[['ptid']]), kids=as.character(kids), nkids=length(kids), pd=pd, txnym=txnym, prdst=prdst, diff --git a/R/read-write-methods.R b/R/read-write-methods.R index decdb84..37824ce 100644 --- a/R/read-write-methods.R +++ b/R/read-write-methods.R @@ -82,8 +82,6 @@ writeTree <- function(tree, file, ndLabels=function(nd){ #' @param ... \code{plyr} arguments #' @seealso #' \code{\link{writeTree}}, \code{\link{randTree}}, \url{https://en.wikipedia.org/wiki/Newick_format} -#' @useDynLib treeman -#' @useDynLib treeman findPrids #' @export #' @examples #' library(treeman) @@ -104,6 +102,8 @@ readTree <- function(file=NULL, text=NULL, update=TRUE, ...) { tree } +#' @useDynLib treeman +#' @useDynLib treeman cFindPrids .readTree <- function(trstr, update) { # Internals .idspn <- function(i) { @@ -151,7 +151,7 @@ readTree <- function(file=NULL, text=NULL, update=TRUE, ...) { # gen prids opns <- gregexpr("\\(", trstr)[[1]] clss <- gregexpr("\\)", trstr)[[1]] - prids <- .Call("findPrids", PACKAGE="treeman", + prids <- .Call("cFindPrids", PACKAGE="treeman", as.integer(nds), as.integer(clss), as.integer(opns)) @@ -170,6 +170,16 @@ readTree <- function(file=NULL, text=NULL, update=TRUE, ...) { tree <- new('TreeMan', ndlst=ndlst, root=ids[root]) if(update) { tree <- updateTree(tree) + } else { + # init basic slots + tree@updtd <- FALSE + tree@tips <- sort(ids[tids]) + tree@ntips <- length(tids) + tree@nds <- sort(ids[ids != tree@tips]) + tree@nnds <- length(tree@nds) + tree@all <- names(tree@ndlst) + tree@nall <- length(tree@all) + tree@wspn <- any(spns > 0) } tree } diff --git a/R/set-methods.R b/R/set-methods.R index a23863f..b6f0274 100644 --- a/R/set-methods.R +++ b/R/set-methods.R @@ -33,6 +33,7 @@ setPD <- function(tree, val) { spns <- getNdsSlt(tree, ids=tree@all, slt_nm="spn") spns <- spns/(tree@pd/val) tree <- setNdsSpn(tree, ids=tree@all, vals=spns) + tree@updtd <- FALSE tree } @@ -58,6 +59,7 @@ setAge <- function(tree, val) { spns <- getNdsSlt(tree, ids=tree@all, slt_nm="spn") spns <- spns/(tree@age/val) tree <- setNdsSpn(tree, ids=tree@all, vals=spns) + tree@updtd <- FALSE tree } @@ -83,6 +85,7 @@ setAge <- function(tree, val) { #' viz(tree) setNdSpn <- function(tree, id, val) { tree@ndlst[[id]][['spn']] <- val + tree@updtd <- FALSE tree } @@ -119,6 +122,7 @@ setNdsSpn <- function(tree, ids, vals, ...) { ndlst <- plyr::mlply(l_data, .fun=.reset, ...) ndlst <- ndlst[1:length(ndlst)] tree@ndlst[ids] <- ndlst + tree@updtd <- FALSE tree } @@ -142,6 +146,7 @@ setNdsSpn <- function(tree, ids, vals, ...) { #' summary(tree) setTol <- function(tree, tol) { tree@tol <- tol + tree@updtd <- FALSE tree } @@ -221,6 +226,7 @@ setNdsID <- function(tree, ids, vals, ...) { tree@ext <- .rplcS4('ext') tree@exc <- .rplcS4('exc') tree@root <- .rplcS4('root') + tree@updtd <- FALSE tree } @@ -246,6 +252,7 @@ setNdsID <- function(tree, ids, vals, ...) { #' (getNdSlt(tree, id='t1', slt_nm='binary_val')) setNdOther <- function(tree, id, val, slt_nm) { tree@ndlst[[id]][slt_nm] <- val + tree@updtd <- FALSE tree } @@ -275,5 +282,6 @@ setNdsOther <- function(tree, ids, vals, slt_nm, ...) { l_data <- data.frame(id=ids, val=vals, stringsAsFactors=FALSE) plyr::m_ply(.data=l_data, .fun=.set) + tree@updtd <- FALSE tree } diff --git a/R/treeman-declaration.R b/R/treeman-declaration.R index ce69956..85a419c 100644 --- a/R/treeman-declaration.R +++ b/R/treeman-declaration.R @@ -28,6 +28,7 @@ #' @slot ply logical, is tree bifurcating #' @slot tol numeric of tolerance for determining extant #' @slot root character of node id of root, if no root then empty character +#' @slot updtd logical, if tree slots have been updated since initiation or change #' @details #' A \code{TreeMan} object holds a list of nodes. The idea of the \code{TreeMan} #' class is to make adding and removing nodes as similar as possible to adding @@ -89,6 +90,7 @@ setClass('TreeMan', representation=representation( ultr='logical', # logical, do all tips end at 0 ply='logical', # logical, is tree bifurcating tol='numeric', # numeric of tolerance for determining extant + updtd='logical', # logical, if tree has been updated since a change root='character'), # character of node id of root, if no root then empty character prototype=prototype(tol=1e-8), validity=fastCheckTreeMan) @@ -169,8 +171,8 @@ setMethod('str', c('object'='TreeMan'), #' @exportMethod summary setMethod('summary', c('object'='TreeMan'), function(object){ - if(length(object@ply) == 0) { - stop("Tree is not updated. Use `updateTree()`") + if(!object@updtd) { + stop("Tree is not updated since change or initiation. Use `updateTree()`") } msg <- 'Tree (TreeMan Object):\n' msg <- paste0(msg, ' + ', object@ntips, ' tips\n') diff --git a/R/update-methods.R b/R/update-methods.R index 7789462..66f0352 100644 --- a/R/update-methods.R +++ b/R/update-methods.R @@ -27,7 +27,7 @@ updateTree <- function(tree) { tree@nnds <- length(tree@nds) tree@all <- names(tree@ndlst) tree@nall <- length(tree@all) - tree@wspn <- any(sapply(tree@ndlst, function(n) n[['spn']] != 0)) + tree@wspn <- any(sapply(tree@ndlst, function(n) n[['spn']] > 0)) if(tree@wspn) { if(length(tree@root) > 0) { tip_prdsts <- getNdsPrdst(tree, tree@tips) @@ -48,5 +48,6 @@ updateTree <- function(tree) { tree@ultr <- logical() } tree@ply <- any(sapply(tree@ndlst, function(n) length(n[['ptid']]) > 2)) + tree@updtd <- TRUE initialize(tree) } \ No newline at end of file diff --git a/man/TreeMan-class.Rd b/man/TreeMan-class.Rd index 69a789c..e5411ab 100644 --- a/man/TreeMan-class.Rd +++ b/man/TreeMan-class.Rd @@ -96,6 +96,8 @@ See below in 'Examples' for these methods in use. \item{\code{tol}}{numeric of tolerance for determining extant} \item{\code{root}}{character of node id of root, if no root then empty character} + +\item{\code{updtd}}{logical, if tree slots have been updated since initiation or change} }} \examples{ library(treeman) diff --git a/man/calcFrPrp.Rd b/man/calcFrPrp.Rd index c30badc..4017dfe 100644 --- a/man/calcFrPrp.Rd +++ b/man/calcFrPrp.Rd @@ -4,7 +4,7 @@ \alias{calcFrPrp} \title{Calculate evolutionary distinctness} \usage{ -calcFrPrp(tree, tids, ...) +calcFrPrp(tree, tids, parallel = FALSE) } \arguments{ \item{tree}{\code{TreeMan} object} diff --git a/man/getNdsKids.Rd b/man/getNdsKids.Rd index cd33856..58324e6 100644 --- a/man/getNdsKids.Rd +++ b/man/getNdsKids.Rd @@ -4,7 +4,7 @@ \alias{getNdsKids} \title{Get children IDs for multiple nodes} \usage{ -getNdsKids(tree, ids, ...) +getNdsKids(tree, ids) } \arguments{ \item{tree}{\code{TreeMan} object} diff --git a/src/read_tools.c b/src/read_tools.c index 464d335..0d04feb 100644 --- a/src/read_tools.c +++ b/src/read_tools.c @@ -2,7 +2,7 @@ #include // Return vector of position of prid in Newick string -SEXP findPrids(SEXP nds_, SEXP clss_, SEXP opns_) +SEXP cFindPrids(SEXP nds_, SEXP clss_, SEXP opns_) { SEXP res; int n = length(nds_); diff --git a/tests/testthat/test-calc-methods.R b/tests/testthat/test-calc-methods.R index b8b1538..956b12e 100644 --- a/tests/testthat/test-calc-methods.R +++ b/tests/testthat/test-calc-methods.R @@ -57,6 +57,7 @@ test_that('calcDstRF() works', { # }) test_that('calcFrPrp() works', { tree <- randTree(10) + sum(sapply(tree@ndlst, function(x) x[['spn']])) ed_values <- calcFrPrp(tree, tree['tips']) expect_that(sum(ed_values), equals(tree['pd'])) }) diff --git a/tests/testthat/test-ndlst-methods.R b/tests/testthat/test-ndlst-methods.R index ece0cc5..cdb7f44 100644 --- a/tests/testthat/test-ndlst-methods.R +++ b/tests/testthat/test-ndlst-methods.R @@ -4,84 +4,83 @@ library(testthat) # RUNNING context('Testing \'ndlst-methods\'') -test_that('.getPrids([basic]) works', { +test_that('.getNdPrids([basic]) works', { # init tree <- randTree(100) ndlst <- tree@ndlst ids <- names(ndlst) # tests rnd_tip <- sample(tree@tips, 1) - res <- treeman:::.getPrids(ndlst, rnd_tip) + res <- treeman:::.getNdPrids(ndlst, rnd_tip) expect_true(ndlst[[rnd_tip]]['prid'] %in% ids[res]) expect_true(tree@root %in% ids[res]) rnd_nd <- sample(tree@nds, 1) - res <- treeman:::.getPrids(ndlst, rnd_nd) + res <- treeman:::.getNdPrids(ndlst, rnd_nd) expect_true(ndlst[[rnd_nd]]['prid'] %in% ids[res]) expect_true(tree@root %in% ids[res]) - res <- treeman:::.getPrids(ndlst, tree@root) + res <- treeman:::.getNdPrids(ndlst, tree@root) expect_true(tree@root == ids[res]) }) -test_that('.getPrdst([basic]) works', { +test_that('.getNdPrdst([basic]) works', { # init tree <- randTree(100) ndlst <- tree@ndlst ids <- names(ndlst) # tests - res <- treeman:::.getPrdst(ndlst, tree@root) + res <- treeman:::.getNdPrdst(ndlst, tree@root) expect_that(res, equals(0)) rnd_nd <- sample(tree@nds[tree@nds != tree@root], 1) - res <- treeman:::.getPrdst(ndlst, rnd_nd) + res <- treeman:::.getNdPrdst(ndlst, rnd_nd) expect_that(res, is_less_than(tree@age)) }) -test_that('.getPtids([basic]) works', { +test_that('.getNdPtids([basic]) works', { # init tree <- randTree(100) ndlst <- tree@ndlst ids <- names(ndlst) # tests rnd_tip <- sample(tree@tips, 1) - res <- treeman:::.getPtids(ndlst, rnd_tip) + res <- treeman:::.getNdPtids(ndlst, rnd_tip) expect_that(length(res), equals(0)) intrnls <- tree@nds[tree@nds != tree@root] - res <- treeman:::.getPtids(ndlst, id=tree@root) + res <- treeman:::.getNdPtids(ndlst, id=tree@root) expect_true(all(intrnls %in% ids[res])) rnd_nd <- sample(intrnls, 1) - res <- treeman:::.getPtids(ndlst, id=rnd_nd) + res <- treeman:::.getNdPtids(ndlst, id=rnd_nd) expect_false(all(intrnls %in% ids[res])) }) -test_that('.getKids([basic]) works', { +test_that('.getNdKids([basic]) works', { # init tree <- randTree(100) ndlst <- tree@ndlst ids <- names(ndlst) # tests - res <- treeman:::.getKids(ndlst, id=tree@root) + res <- treeman:::.getNdKids(ndlst, id=tree@root) expect_true(all(tree@tips %in% ids[res])) rnd_nd <- sample(tree@nds[tree@nds != tree@root], 1) - res <- treeman:::.getKids(ndlst, id=rnd_nd) + res <- treeman:::.getNdKids(ndlst, id=rnd_nd) expect_false(all(tree@tips %in% ids[res])) rnd_tip <- sample(tree@tips, 1) - res <- treeman:::.getKids(ndlst, id=rnd_tip) + res <- treeman:::.getNdKids(ndlst, id=rnd_tip) expect_that(length(res), equals(0)) }) -test_that('.getPD([basic]) works', { +test_that('.getNdPD([basic]) works', { # init tree <- randTree(100) ndlst <- tree@ndlst ids <- names(ndlst) # tests - res <- treeman:::.getPD(ndlst, id=tree@root) + res <- treeman:::.getNdPD(ndlst, id=tree@root) expect_that(res, equals(tree@pd)) rnd_nd <- sample(tree@nds[tree@nds != tree@root], 1) - res <- treeman:::.getPD(ndlst, id=rnd_nd) + res <- treeman:::.getNdPD(ndlst, id=rnd_nd) expect_that(res, is_less_than(tree@pd)) }) -test_that('.getAge([basic]) works', { +test_that('.getTreeAge([basic]) works', { # init tree <- randTree(100) ndlst <- tree@ndlst - ids <- names(ndlst) # tests - res <- treeman:::.getAge(ndlst) - expect_true(res == tree@age) -}) \ No newline at end of file + res <- treeman:::.getTreeAge(ndlst) + expect_that(res, equals(tree@age)) +})