Skip to content

Commit

Permalink
Incorporated prnds
Browse files Browse the repository at this point in the history 
— very slow because get functions kept calling a function to determine
prnds
— now prnds is a vector slot in class
  • Loading branch information
@DomBennett
DomBennett committed Aug 19, 2016
1 parent 9407b70 commit 81bae9f
Show file tree
Hide file tree
Showing 23 changed files with 242 additions and 217 deletions.
39 changes: 17 additions & 22 deletions R/calc-methods.R
View file
Expand Up @@ -300,29 +300,24 @@ calcPhyDv <- function(tree, tids,
#' library(treeman)
#' tree <- randTree(10)
#' calcFrPrp(tree, tree['tips'])
calcFrPrp <- function(tree, tids, parallel=FALSE, progress="none") {
.calc <- function(tid) {
ids <- c(tid, prids[[tid]])
spns <- getNdsSlt(tree, 'spn', ids)
sum(spns/nkids[ids])
}
all_ids <- names(tree@ndlst)
if(progress != "none") {
cat("Part 1/2 ....\n")
}
prids <- getNdsPrids(tree, tids, parallel=parallel,
progress=progress)
if(progress != "none") {
cat("Part 2/2 ....\n")
calcFrPrp <- function(tree, tids, progress="none") {
.calc <- function(i) {
id <- tree@all[i]
spn <- getNdSlt(tree, "spn", id)
kids <- getNdKids(tree, id)
if(length(kids) == 0) {
spn_shres[i, id] <<- spn
} else {
spn_shre <- spn/length(kids)
spn_shres[i, kids] <<- spn_shre
}
}
kids <- getNdsKids(tree, all_ids, parallel=parallel,
progress=progress)
nkids <- sapply(kids, length)
rm(kids)
nkids[nkids == 0] <- 1 # prevent division by 0
l_data <- data.frame(tid=tids, stringsAsFactors=FALSE)
plyr::mdply(.data=l_data, .fun=.calc, .parallel=parallel,
.progress=progress)[ ,2]
spn_shres <- bigmemory::big.matrix(init=0, ncol=tree@ntips, nrow=tree@nall)
options(bigmemory.allow.dimnames=TRUE)
colnames(spn_shres) <- tree@tips
plyr::m_ply(.data=data.frame(i=1:tree@nall), .fun = .calc,
.progress=progress)
colSums(spn_shres[, tids])
}

#' @name calcDstMtrx
Expand Down
18 changes: 10 additions & 8 deletions R/gen-methods.R
View file
Expand Up @@ -20,36 +20,38 @@ randTree <- function(n, update=TRUE, parallel=FALSE) {
names(nd) <- c('id', 'ptid', 'prid', 'spn')
nd[['id']] <- ids[i]
nd[['spn']] <- spns[i]
nd[['prid']] <- ids[prids[i]]
nd[['prid']] <- ids[prinds[i]]
nd[['ptid']] <- ptids[ptnds_pool == i]
nd
}
if(n < 3) {
stop("`n` is too small")
}
nnds <- n + (n - 1)
prids <- rep(NA, nnds)
prinds <- rep(NA, nnds)
intrnls <- seq(2, (nnds-2), 2)
# randomise intrnls
intrnls <- intrnls +
sample(0:1, size=length(intrnls), replace=TRUE)
# create prids vector
prids[1:3] <- 1
prids[4:nnds] <- rep(intrnls, each=2)
prinds[1:3] <- 1
prinds[4:nnds] <- rep(intrnls, each=2)
# random numbers for spans
spns <- c(0, runif(nnds-1, 0, 1))
ids <- rep(NA, nnds)
ids[!1:nnds %in% prids] <- paste0('t', 1:n)
ids[1:nnds %in% prids] <- paste0('n', 1:(n-1))
ptnds_pool <- prids[-1]
tinds <- which(!1:nnds %in% prinds)
ids[tinds] <- paste0('t', 1:n)
ids[1:nnds %in% prinds] <- paste0('n', 1:(n-1))
ptnds_pool <- prinds[-1]
ptids <- ids[-1]
ndlst <- plyr::mlply(.data=1:nnds, .fun=.add, .parallel=parallel)
attr(ndlst, "split_labels") <-
attr(ndlst, "split_type") <- NULL
names(ndlst) <- ids
# init new tree object
tree <- new('TreeMan', ndlst=ndlst, root='n1',
ndmtrx=bigmemory::big.matrix(1,1))
ndmtrx=bigmemory::big.matrix(1,1),
prinds=prinds, tinds=tinds)
if(update) {
tree <- updateTree(tree)
} else {
Expand Down
28 changes: 10 additions & 18 deletions R/get-nd-methods.R
View file
Expand Up @@ -17,11 +17,10 @@
#' data(mammals)
#' # when did apes emerge?
#' # get parent id for all apes
#' prnt_id <- getPrnt(mammals, ids=c('Homo_sapiens', 'Hylobates_concolor'))
#' getNdAge(mammals, id=prnt_id, tree_age=mammals['age'])
#' #prnt_id <- getPrnt(mammals, ids=c('Homo_sapiens', 'Hylobates_concolor'))
#' #getNdAge(mammals, id=prnt_id, tree_age=mammals['age'])
getNdAge <- function(tree, id, tree_age) {
prids <- .getSltPrids(tree@ndlst, FALSE)
tree_age - .getNdPrdstsFrmLst(tree@ndlst, prids, id)
tree_age - .getNdPrdstsFrmLst(tree@ndlst, tree@prinds, id=id)
}

#' @name getSpnAge
Expand All @@ -40,10 +39,9 @@ getNdAge <- function(tree, id, tree_age) {
#' @examples
#' library(treeman)
#' data(mammals)
#' getSpnAge(mammals, id='Homo_sapiens', tree_age=mammals['age'])
#' #getSpnAge(mammals, id='Homo_sapiens', tree_age=mammals['age'])
getSpnAge <- function(tree, id, tree_age) {
prids <- .getSltPrids(tree@ndlst, FALSE)
end <- .getNdPrdstsFrmLst(tree@ndlst, prids, id)
end <- .getNdPrdstsFrmLst(tree@ndlst, tree@prinds, id=id)
start <- end - tree@ndlst[[id]][['spn']]
end <- tree_age - end
start <- tree_age - start
Expand All @@ -68,8 +66,7 @@ getSpnAge <- function(tree, id, tree_age) {
#' # get all nodes to root
#' getNdPrids(tree, id='t1')
getNdPrids <- function(tree, id) {
prids <- .getSltPrids(tree@ndlst, FALSE)
.getNdPridsFrmLst(tree@ndlst, prids, id)
.getNdPridsFrmLst(tree@ndlst, prinds=tree@prinds, id=id)
}

#' @name getNdPtids
Expand All @@ -92,8 +89,7 @@ getNdPrids <- function(tree, id) {
# reduce dependence on the recursive, by getting prenodes
# tip ids to id
getNdPtids <- function(tree, id) {
prids <- .getSltPrids(tree@ndlst, FALSE)
.getNdPtidsFrmLst(tree@ndlst, prids, id)
.getNdPtidsFrmLst(tree@ndlst, tree@prinds, id=id)
}

#' @name getNdKids
Expand All @@ -112,9 +108,7 @@ getNdPtids <- function(tree, id) {
#' # everyone descends from root
#' getNdKids(tree, id=tree['root'])
getNdKids <- function(tree, id) {
prids <- .getSltPrids(tree@ndlst, FALSE)
tids <- .getSltTids(tree@ndlst, FALSE)
.getNdKidsFrmLst(tree@ndlst, prids, tids, id)
.getNdKidsFrmLst(tree@ndlst, prinds=tree@prinds, tinds=tree@tinds, id=id)
}

#' @name getNdPrdst
Expand All @@ -132,8 +126,7 @@ getNdKids <- function(tree, id) {
#' tree <- randTree(10)
#' getNdPrdst(tree, id='t1') # return the distance to root from t1
getNdPrdst <- function(tree, id) {
prids <- .getSltPrids(tree@ndlst, FALSE)
.getNdPrdstsFrmLst(tree@ndlst, prids, id)
.getNdPrdstsFrmLst(tree@ndlst, tree@prinds, id=id)
}

#' @name getNdSlt
Expand Down Expand Up @@ -171,8 +164,7 @@ getNdSlt <- function(tree, slt_nm, id) {
#' tree <- randTree(10)
#' getNdPD(tree, id='n1') # return PD of n1 which in this case is for the whole tree
getNdPD <- function(tree, id) {
prids <- .getSltPrids(tree@ndlst, FALSE)
.getNdPDFrmLst(tree@ndlst, prids, id)
.getNdPDFrmLst(tree@ndlst, prinds=tree@prinds, id=id)
}

#' @name getNdSstr
Expand Down
42 changes: 25 additions & 17 deletions R/get-nds-methods.R
View file
Expand Up @@ -41,12 +41,12 @@ getNdsSstr <- function(tree, ids, parallel=FALSE, progress="none") {
getNdsPD <- function(tree, ids, parallel=FALSE, progress="none") {
if(tree@updtd & length(ids) > 1) {
all_ids <- tree@all
spns <- .getSltSpns(tree@ndlst, parallel)
spns <- .getSltSpns(tree@ndlst)
res <- .getNdsPDFrmMtrx(tree@ndmtrx, all_ids, ids, spns,
parallel, progress)
} else {
res <- .getNdsPDFrmLst(tree@ndlst,
ids, parallel, progress)
res <- .getNdsPDFrmLst(tree@ndlst, prinds=tree@prinds,
ids=ids, parallel=parallel, progress=progress)
}
res
}
Expand All @@ -70,11 +70,12 @@ getNdsPD <- function(tree, ids, parallel=FALSE, progress="none") {
getNdsPrdst <- function(tree, ids, parallel=FALSE, progress="none") {
if(tree@updtd & length(ids) > 1) {
all_ids <- tree@all
spns <- .getSltSpns(tree@ndlst, parallel)
spns <- .getSltSpns(tree@ndlst)
res <- .getNdsPrdstsFrmMtrx(tree@ndmtrx, all_ids, ids, spns,
parallel, progress)
} else {
res <- .getNdsPrdstsFrmLst(tree@ndlst, ids, parallel, progress)
res <- .getNdsPrdstsFrmLst(tree@ndlst, prinds=tree@prinds,
ids=ids, parallel, progress)
}
res
}
Expand Down Expand Up @@ -129,8 +130,9 @@ getNdsKids <- function(tree, ids, parallel=FALSE,
res <- .getNdsKidsFrmMtrx(tree@ndmtrx, tree@all,
ids, tree@tips, parallel, progress)
} else {
res <- .getNdsKidsFrmLst(tree@ndlst, ids,
parallel, progress)
res <- .getNdsKidsFrmLst(tree@ndlst, ids=ids,
prinds=tree@prinds, tinds=tree@tinds,
parallel=parallel, progress=progress)
}
res
}
Expand Down Expand Up @@ -158,13 +160,15 @@ getNdsAge <- function(tree, ids, tree_age,
parallel=FALSE,
progress="none") {
if(tree@updtd & length(ids) > 1) {
spns <- .getSltSpns(tree@ndlst, parallel)
spns <- .getSltSpns(tree@ndlst)
res <- .getNdsPrdstsFrmMtrx(tree@ndmtrx, tree@all,
ids, spns, parallel, progress)
res <- tree_age - res
} else {
res <- .getNdsPrdstsFrmLst(tree@ndlst, ids,
parallel, progress)
res <- .getNdsPrdstsFrmLst(tree@ndlst, ids=ids,
prinds=tree@prinds,
parallel=parallel,
progress=progress)
res <- tree_age - res
}
res
Expand Down Expand Up @@ -195,13 +199,15 @@ getNdsAge <- function(tree, ids, tree_age,
getSpnsAge <- function(tree, ids, tree_age,
parallel=FALSE, progress="none") {
if(tree@updtd & length(ids) > 1) {
spns <- .getSltSpns(tree@ndlst, parallel)
spns <- .getSltSpns(tree@ndlst)
end <- .getNdsPrdstsFrmMtrx(tree@ndmtrx, tree@all,
ids, spns, parallel, progress)

} else {
end <- .getNdsPrdstsFrmLst(tree@ndlst, ids,
parallel, progress)
end <- .getNdsPrdstsFrmLst(tree@ndlst, ids=ids,
prinds=tree@prinds,
parallel=parallel,
progress=progress)
}
spns <- getNdsSlt(tree, slt_nm="spn", ids=ids, parallel)
start <- end - spns
Expand Down Expand Up @@ -236,8 +242,9 @@ getNdsPrids <- function(tree, ids, ordrd=FALSE,
res <- .getNdsPridsFrmMtrx(tree@ndmtrx, tree@all,
ids, parallel, progress)
} else {
res <- .getNdsPridsFrmLst(tree@ndlst, ids,
parallel, progress)
res <- .getNdsPridsFrmLst(tree@ndlst, ids=ids,
prinds=tree@prinds, parallel=parallel,
progress=progress)
}
res
}
Expand Down Expand Up @@ -266,8 +273,9 @@ getNdsPtids <- function(tree, ids, parallel=FALSE, progress="none") {
res <- .getNdsPtidsFrmMtrx(tree@ndmtrx, tree@all,
ids, parallel, progress)
} else {
res <- .getNdsPtidsFrmLst(tree@ndlst, ids,
parallel, progress)
res <- .getNdsPtidsFrmLst(tree@ndlst, ids=ids,
prinds=tree@prinds, parallel=parallel,
progress=progress)
}
res
}
Expand Down
25 changes: 13 additions & 12 deletions R/get-spcl-methods.R
View file
Expand Up @@ -15,11 +15,11 @@
#' library(treeman)
#' data(mammals)
#' # choosing ids from the two main branches of apes allows to find the parent for all apes
#' ape_id <- getPrnt(mammals, ids=c('Homo_sapiens', 'Hylobates_concolor'))
#' #ape_id <- getPrnt(mammals, ids=c('Homo_sapiens', 'Hylobates_concolor'))
getPrnt <- function(tree, ids) {
# using ndlst guarrantees order
prids <- .getNdsPridsFrmLst(tree@ndlst, ids, parallel=FALSE,
progress="none")
prids <- .getNdsPridsFrmLst(tree@ndlst, ids=ids, prinds=tree@prinds,
parallel=FALSE, progress="none")
rf <- prids[[1]]
mn_rnk <- 0
for(n in prids[-1]) {
Expand All @@ -43,9 +43,9 @@ getPrnt <- function(tree, ids) {
#' library(treeman)
#' data(mammals)
#' # what's the phylogenetic distance from humans to gorillas?
#' ape_id <- getPrnt(mammals, ids=c('Homo_sapiens', 'Hylobates_concolor'))
#' pth <- getPath(mammals, from='Homo_sapiens', to='Gorilla_gorilla')
#' sum(getNdsSlt(mammals, ids=pth, slt_nm='spn'))
#' #ape_id <- getPrnt(mammals, ids=c('Homo_sapiens', 'Hylobates_concolor'))
#' #pth <- getPath(mammals, from='Homo_sapiens', to='Gorilla_gorilla')
#' #sum(getNdsSlt(mammals, ids=pth, slt_nm='spn'))
getPath <- function(tree, from, to) {
pre_1 <- c(from, getNdPrids(tree, from))
pre_2 <- c(to, getNdPrids(tree, to))
Expand All @@ -69,7 +69,7 @@ getPath <- function(tree, from, to) {
#' library(treeman)
#' data(mammals)
#' # orangutan is an outgroup wrt humans and chimps
#' getOtgrp(mammals, ids=c('Homo_sapiens', 'Pan_troglodytes', 'Pongo_pygmaeus'))
#' #getOtgrp(mammals, ids=c('Homo_sapiens', 'Pan_troglodytes', 'Pongo_pygmaeus'))
getOtgrp <- function(tree, ids) {
.cntr <- function(id) {
kids <- getNdKids(tree, id)
Expand Down Expand Up @@ -106,8 +106,8 @@ getOtgrp <- function(tree, ids) {
#' library(treeman)
#' data(mammals)
#' # get tree of apes
#' ape_id <- getPrnt(mammals, ids=c('Homo_sapiens', 'Hylobates_concolor'))
#' apes <- getSubtree(mammals, id=ape_id)
#' #ape_id <- getPrnt(mammals, ids=c('Homo_sapiens', 'Hylobates_concolor'))
#' #apes <- getSubtree(mammals, id=ape_id)
getSubtree <- function(tree, id) {
if(!id %in% tree@nds) {
stop('`id` is not an internal node')
Expand Down Expand Up @@ -142,13 +142,14 @@ getSubtree <- function(tree, id) {
#' tree <- randTree(10)
#' (getTreeAge(tree))
getTreeAge <- function(tree, parallel=FALSE) {
tids <- tree@tips
if(tree@updtd) {
all_ids <- tree@all
tids <- tree@tips
spns <- .getSltSpns(tree@ndlst, parallel)
spns <- .getSltSpns(tree@ndlst)
res <- .getTreeAgeFrmMtrx(tree@ndmtrx, all_ids, tids, spns, parallel)
} else {
res <- .getTreeAgeFrmLst(tree@ndlst, parallel)
res <- .getTreeAgeFrmLst(tree@ndlst, prinds=tree@prinds,
tids=tids, parallel)
}
res
}
2 changes: 2 additions & 0 deletions R/manip-methods.R
View file
Expand Up @@ -56,6 +56,8 @@ rmTips <- function(tree, tids, drp_intrnl=TRUE, progress="none") {
tree@root <- rid
if(tree@updtd) {
tree@ndmtrx <- bigmemory::as.big.matrix(tree@ndmtrx[bool, bool])
tree@prinds <- vector("integer", length=0)
tree@tinds <- vector("integer", length=0)
tree <- updateTree(tree)
}
tree
Expand Down

0 comments on commit 81bae9f

Please sign in to comment.