From noreply at r-forge.r-project.org Mon Apr 29 19:20:10 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 29 Apr 2013 19:20:10 +0200 (CEST) Subject: [Phylobase-commits] r841 - in pkg: . R inst/nexusfiles inst/unitTests Message-ID: <20130429172010.3D977184C10@r-forge.r-project.org> Author: francois Date: 2013-04-29 19:20:09 +0200 (Mon, 29 Apr 2013) New Revision: 841 Removed: pkg/inst/unitTests/runit.readNexus.R Modified: pkg/DESCRIPTION pkg/R/setAs-Methods.R pkg/inst/nexusfiles/multiLines.Rdata pkg/inst/unitTests/runit.readNCL.R pkg/inst/unitTests/runit.setAs-Methods.R Log: reorder edge matrix to pre- or postorder if conversion from a phylo object that has is cladewise or pruningwise respectively to fix bug reported by Nick Matzke to R-sig-phylo on 2013-04-26, remove readNexus unit tests (replaced by tests in readNCL), bumped to version 0.6.5.2 Modified: pkg/DESCRIPTION =================================================================== --- pkg/DESCRIPTION 2012-11-24 20:22:08 UTC (rev 840) +++ pkg/DESCRIPTION 2013-04-29 17:20:09 UTC (rev 841) @@ -1,8 +1,8 @@ Package: phylobase Type: Package Title: Base package for phylogenetic structures and comparative data -Version: 0.6.5 -Date: 2012-11-21 +Version: 0.6.5.2 +Date: 2013-04-29 Depends: methods, grid, Modified: pkg/R/setAs-Methods.R =================================================================== --- pkg/R/setAs-Methods.R 2012-11-24 20:22:08 UTC (rev 840) +++ pkg/R/setAs-Methods.R 2013-04-29 17:20:09 UTC (rev 841) @@ -5,56 +5,66 @@ ## TODO should we also attempt to get order information? ## BMB horrible kludge to avoid requiring ape explicitly ape_is.rooted <- function(phy) { - if (!is.null(phy$root.edge)) - TRUE - else if (tabulate(phy$edge[, 1])[length(phy$tip.label) + - 1] > 2) - FALSE + if (!is.null(phy$root.edge)) + TRUE + else if (tabulate(phy$edge[, 1])[length(phy$tip.label) + 1] > 2) + FALSE else TRUE - } - if (ape_is.rooted(from)) { - tip.idx <- 1:nTips(from) - if (nTips(from) < nrow(from$edge)) { - int.idx <- (nTips(from)+1):dim(from$edge)[1] - } else { - int.idx <- NULL - } - root.node <- as.numeric(setdiff(unique(from$edge[,1]), unique(from$edge[,2]))) - - from$edge <- rbind(from$edge[tip.idx,],c(0,root.node),from$edge[int.idx,]) - if (!is.null(from$edge.length)) { - if (is.null(from$root.edge)) { - from$edge.length <- c(from$edge.length[tip.idx],as.numeric(NA),from$edge.length[int.idx]) - } - else { - from$edge.length <- c(from$edge.length[tip.idx],from$root.edge,from$edge.length[int.idx]) - } - } - if (!is.null(from$edge.label)) { - from$edge.label <- c(from$edge.label[tip.idx],NA,from$edge.label[int.idx]) - } + } + if (ape_is.rooted(from)) { + tip.idx <- 1:nTips(from) + if (nTips(from) < nrow(from$edge)) { + int.idx <- (nTips(from)+1):dim(from$edge)[1] + } else { + int.idx <- NULL } - oldorder <- attr(from,"order") - neworder <- if (is.null(oldorder)) { "unknown" } else + root.node <- as.numeric(setdiff(unique(from$edge[,1]), unique(from$edge[,2]))) + + from$edge <- rbind(from$edge[tip.idx,],c(0,root.node),from$edge[int.idx,]) + if (!is.null(from$edge.length)) { + if (is.null(from$root.edge)) { + from$edge.length <- c(from$edge.length[tip.idx],as.numeric(NA),from$edge.length[int.idx]) + } + else { + from$edge.length <- c(from$edge.length[tip.idx],from$root.edge,from$edge.length[int.idx]) + } + } + if (!is.null(from$edge.label)) { + from$edge.label <- c(from$edge.label[tip.idx],NA,from$edge.label[int.idx]) + } + } + newobj <- phylo4(from$edge, from$edge.length, unname(from$tip.label), + node.label = from$node.label, + edge.label = from$edge.label, + order = "unknown") + oldorder <- attr(from,"order") + neworder <- if (is.null(oldorder)) { "unknown" } else if (!oldorder %in% phylo4_orderings) { stop("unknown ordering '",oldorder,"' in ape object") - } else if (oldorder=="cladewise") "preorder" - else oldorder - attr(from,"order") <- NULL - newobj <- phylo4(from$edge, from$edge.length, unname(from$tip.label), - node.label = from$node.label, - edge.label = from$edge.label, - order = neworder) - attribs <- attributes(from) - attribs$names <- NULL - knownattr <- c("logLik", "origin", "para", "xi") - known <- names(attribs)[names(attribs) %in% knownattr] - unknown <- names(attribs)[!names(attribs) %in% c(knownattr, "class", "names")] - if (length(unknown) > 0) { - warning(paste("unknown attributes ignored: ", unknown, collapse = " ")) + } else if (oldorder == "cladewise" || oldorder == "preorder") "preorder" + else if (oldorder == "pruningwise" || oldorder == "postorder") "postorder" + if (isRooted(newobj)) { + if (neworder == "preorder") { + newobj <- reorder(newobj, order="preorder") } - for (i in known) attr(newobj, i) <- attr(from, i) - newobj + if (neworder == "postorder") { + newobj <- reorder(newobj, order="postorder") + } + } + newobj at order <- neworder + + attr(from,"order") <- NULL + + attribs <- attributes(from) + attribs$names <- NULL + knownattr <- c("logLik", "origin", "para", "xi") + known <- names(attribs)[names(attribs) %in% knownattr] + unknown <- names(attribs)[!names(attribs) %in% c(knownattr, "class", "names")] + if (length(unknown) > 0) { + warning(paste("unknown attributes ignored: ", unknown, collapse = " ")) + } + for (i in known) attr(newobj, i) <- attr(from, i) + newobj }) setAs("phylo", "phylo4d", function(from, to) { Modified: pkg/inst/nexusfiles/multiLines.Rdata =================================================================== (Binary files differ) Modified: pkg/inst/unitTests/runit.readNCL.R =================================================================== --- pkg/inst/unitTests/runit.readNCL.R 2012-11-24 20:22:08 UTC (rev 840) +++ pkg/inst/unitTests/runit.readNCL.R 2013-04-29 17:20:09 UTC (rev 841) @@ -123,16 +123,8 @@ ## match it load(mlFile) checkIdentical(multiLines[[1]], ml1) - ## FAILS: why? - ## BMB 9 Nov 2012 - ## for (i in slotNames(ml1)) { - ## cat(i,"\n") - ## checkIdentical(slot(ml1,i),slot(multiLines[[1]],i)) - ## fails on 'order': "preorder" (ml1) vs "unknown" (multiLines[[1]])? - ## "unknown" seems correct to me, so modifying original file - ## } - checkIdentical(multiLines[[2]], ml1) - rm(ml1) + checkIdentical(multiLines[[2]], ml2) + rm(ml1, ml2) ## ########### Tree + data -- file from Mesquite ## tree properties @@ -147,16 +139,15 @@ "Myrmecocystuscfnavajo", "Myrmecocystusnavajo", NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA) names(labTr) <- 1:35 - eTr <- c(1.699299, 0.894820, 0.836689, 4.524387, 0.506099, 0.198842, 0.689044, - 2.926053, 1.724765, 1.724765, 4.650818, 4.255993, 1.083870, 1.083870, - 0.802512, 2.027251, 2.708942, 2.708942, NA, 0.284767, 2.257581, - 2.193845, 2.193845, 4.451425, 6.044804, 10.569191, 8.635503, 2.770378, - 2.770378, 12.300701, 8.275077, 5.724923, 2.855375, 2.869547, 2.869547) - names(eTr) <- c("19-20","20-21","21-22","22-23","23-24","24-25","25-26","26-27", - "27-1", "27-2","26-3","25-28","28-4","28-5","24-29","29-30", - "30-6","30-7","0-19","29-31","31-32","32-8","32-9","31-10", - "23-11","22-12","21-33","33-13","33-14","20-15","19-34","34-16", - "34-35","35-17","35-18") + eTr <- c(NA, 1.699299, 12.300701, 0.894820, 0.836689, 10.569191, 4.524387, 6.044804, + 0.506099, 0.198842, 0.689044, 4.650818, 2.926053, 1.724765, 1.724765, 4.255993, + 1.083870, 1.083870, 0.802512, 2.027251, 2.708942, 2.708942, 0.284767, 4.451425, + 2.257581, 2.193845, 2.193845, 8.635503, 2.770378, 2.770378, 8.275077, 5.724923, + 2.855375, 2.869547, 2.869547) + names(eTr) <- c("0-19", "19-20", "20-15", "20-21", "21-22", "22-12", "22-23", "23-11", "23-24", + "24-25", "25-26", "26-3", "26-27", "27-1", "27-2", "25-28", "28-4", "28-5", + "24-29", "29-30", "30-6", "30-7", "29-31", "31-10", "31-32", "32-8", "32-9", + "21-33", "33-13", "33-14", "19-34", "34-16", "34-35", "35-17", "35-18") nTtr <- c("tip", "tip", "tip", "tip", "tip", "tip", "tip", "tip", "tip", "tip", "tip", "tip", "tip", "tip", "tip", "tip", "tip", "tip", "root", "internal", "internal", "internal", "internal", "internal", @@ -443,8 +434,8 @@ ## Tree representation labNew <- c("a", "b", "c", NA, NA) names(labNew) <- 1:5 - eLnew <- c(1, 4, 2, NA, 3) - names(eLnew) <- c("4-1", "4-5", "5-2", "0-4", "5-3") + eLnew <- c(NA, 1, 4, 2, 3) + names(eLnew) <- c("0-4", "4-1", "4-5", "5-2", "5-3") nTnew <- c("tip", "tip", "tip", "root", "internal") names(nTnew) <- 1:5 ## check.node.labels="drop" with readNCL Deleted: pkg/inst/unitTests/runit.readNexus.R =================================================================== --- pkg/inst/unitTests/runit.readNexus.R 2012-11-24 20:22:08 UTC (rev 840) +++ pkg/inst/unitTests/runit.readNexus.R 2013-04-29 17:20:09 UTC (rev 841) @@ -1,415 +0,0 @@ -# -# --- Test readNexus.R --- -# - -### Get all the test files -if (Sys.getenv("RCMDCHECK") == FALSE) { - pth <- file.path(getwd(), "..", "inst", "nexusfiles") -} else { - pth <- system.file(package="phylobase", "nexusfiles") -} -## co1.nex -- typical output from MrBayes. Contains 2 identical trees, the first -## one having posterior probabilities as node labels -co1File <- file.path(pth, "co1.nex") - -## MultiLineTrees.nex -- 2 identical trees stored on several lines -multiLinesFile <- file.path(pth, "MultiLineTrees.nex") - -## treeWithDiscreteData.nex -- Mesquite file with discrete data -treeDiscDt <- file.path(pth, "treeWithDiscreteData.nex") - -## treeWithPolyExcludedData.nex -- Mesquite file with polymorphic and excluded -## characters -treePolyDt <- file.path(pth, "treeWithPolyExcludedData.nex") - -## treeWithContinuousData.nex -- Mesquite file with continuous characters -treeContDt <- file.path(pth, "treeWithContinuousData.nex") - -## treeWithDiscAndContData.nex -- Mesquite file with both discrete and -## continuous data -treeDiscCont <- file.path(pth, "treeWithDiscAndContData.nex") - -## Contains correct (as of 2010-03-08) phylo4 representation of one of the tree -## stored in the nexus file -mlFile <- file.path(pth, "multiLines.Rdata") - -## Contains representation of data associated with continuous data -ExContDataFile <- file.path(pth, "ExContData.Rdata") - -stopifnot(file.exists(co1File)) -stopifnot(file.exists(treeDiscDt)) -stopifnot(file.exists(multiLinesFile)) -stopifnot(file.exists(mlFile)) -stopifnot(file.exists(treePolyDt)) -stopifnot(file.exists(treeContDt)) -stopifnot(file.exists(treeDiscCont)) -stopifnot(file.exists(ExContDataFile)) - -op <- phylobase.options() - -test.readNexus <- function() { - ## function (file, simplify=TRUE, type=c("all", "tree", "data"), - ## char.all=FALSE, polymorphic.convert=TRUE, levels.uniform=TRUE, - ## check.node.labels=c("keep", "drop", "asdata")) - - ## ########### CO1 -- MrBayes file -- tree only - ## Tree properties - ## Labels - labCo1 <- c("Cow", "Seal", "Carp", "Loach", "Frog", "Chicken", "Human", - "Mouse", "Rat", "Whale", NA, NA, NA, NA, NA, NA, NA, NA) - names(labCo1) <- 1:18 - ## Edge lengths - eLco1 <- c(0.143336, 0.225087, 0.047441, 0.055934, 0.124549, 0.204809, 0.073060, 0.194575, - 0.171296, 0.222039, 0.237101, 0.546258, 0.533183, 0.154442, 0.134574, 0.113163, - 0.145592) - names(eLco1) <- c("11-1", "11-2", "11-12", "12-13", "13-14", "14-15", "15-16", "16-17", "17-3", - "17-4", "16-5", "15-6", "14-7", "13-18", "18-8", "18-9", "12-10") - ## Node types - nTco1 <- c("tip", "tip", "tip", "tip", "tip", "tip", "tip", "tip", "tip", - "tip", "internal", "internal", "internal", "internal", "internal", - "internal", "internal", "internal") - names(nTco1) <- 1:18 - ## Label values - lVco1 <- c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, 0.93, 0.88, 0.99, 1.00, - 0.76, 1.00, 1.00) - ## Read trees - co1 <- readNexus(file=co1File, check.node.labels="asdata") - ## Tree 1 - co1Tree1 <- co1[[1]] - checkIdentical(labels(co1Tree1), labCo1) # check labels - checkIdentical(edgeLength(co1Tree1), eLco1) # check edge lengths - checkIdentical(nodeType(co1Tree1), nTco1) # check node types - checkIdentical(as(co1Tree1, "data.frame")$labelValues, lVco1) # check label values - ## Tree 2 - co1Tree2 <- co1[[2]] - checkIdentical(labels(co1Tree2), labCo1) # check labels - checkIdentical(edgeLength(co1Tree2), eLco1) # check edge lengths - checkIdentical(nodeType(co1Tree2), nTco1) # check node types - - ## Check option simplify - co1 <- readNexus(file=co1File, check.node.labels="asdata", simplify=TRUE) - checkIdentical(length(co1), as.integer(1)) # make sure there is only one tree - checkIdentical(labels(co1), labCo1) # check labels - checkIdentical(edgeLength(co1), eLco1) # check edge lengths - checkIdentical(nodeType(co1), nTco1) # check node type - checkIdentical(as(co1, "data.frame")$labelValues, lVco1) # check label values - - ## Check option check.node.labels - phylobase.options(allow.duplicated.labels="fail") - checkException(readNexus(file=co1File, check.node.labels="keep")) # fail because labels aren't unique - phylobase.options(op) - phylobase.options(allow.duplicated.labels="ok") - co1 <- readNexus(file=co1File, check.node.labels="keep", simplify=TRUE) - checkIdentical(nodeLabels(co1), setNames(c(NA, "0.93", "0.88", "0.99", "1.00", "0.76", "1.00", "1.00"), - 11:18)) - phylobase.options(op) - co1 <- readNexus(file=co1File, check.node.labels="drop", simplify=TRUE) - checkIdentical(labels(co1), labCo1) # check labels - checkIdentical(edgeLength(co1), eLco1) # check edge lengths - checkIdentical(nodeType(co1), nTco1) # check node type - checkIdentical(as(co1, "data.frame")$labelValues, NULL) # check label values don't exist - - ## ########### Mutli Lines -- tree only - multiLines <- readNexus(file=multiLinesFile) - ## load correct representation and make sure that the trees read - ## match it - load(mlFile) - checkIdentical(multiLines[[1]], ml1) - checkIdentical(multiLines[[2]], ml1) - rm(ml1) - - ## ########### Tree + data -- file from Mesquite - ## tree properties - labTr <- c("Myrmecocystussemirufus", "Myrmecocystusplacodops", - "Myrmecocystusmendax", "Myrmecocystuskathjuli", - "Myrmecocystuswheeleri", "Myrmecocystusmimicus", - "Myrmecocystusdepilis", "Myrmecocystusromainei", - "Myrmecocystusnequazcatl", "Myrmecocystusyuma", - "Myrmecocystuskennedyi", "Myrmecocystuscreightoni", - "Myrmecocystussnellingi", "Myrmecocystustenuinodis", - "Myrmecocystustestaceus", "Myrmecocystusmexicanus", - "Myrmecocystuscfnavajo", "Myrmecocystusnavajo", - NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA) - names(labTr) <- 1:35 - eTr <- c(1.699299, 0.894820, 0.836689, 4.524387, 0.506099, 0.198842, 0.689044, - 2.926053, 1.724765, 1.724765, 4.650818, 4.255993, 1.083870, 1.083870, - 0.802512, 2.027251, 2.708942, 2.708942, NA, 0.284767, 2.257581, - 2.193845, 2.193845, 4.451425, 6.044804, 10.569191, 8.635503, 2.770378, - 2.770378, 12.300701, 8.275077, 5.724923, 2.855375, 2.869547, 2.869547) - names(eTr) <- c("19-20","20-21","21-22","22-23","23-24","24-25","25-26","26-27", - "27-1", "27-2","26-3","25-28","28-4","28-5","24-29","29-30", - "30-6","30-7","0-19","29-31","31-32","32-8","32-9","31-10", - "23-11","22-12","21-33","33-13","33-14","20-15","19-34","34-16", - "34-35","35-17","35-18") - nTtr <- c("tip", "tip", "tip", "tip", "tip", "tip", "tip", "tip", "tip", - "tip", "tip", "tip", "tip", "tip", "tip", "tip", "tip", "tip", - "root", "internal", "internal", "internal", "internal", "internal", - "internal", "internal", "internal", "internal", "internal", - "internal", "internal", "internal", "internal", "internal", - "internal") - names(nTtr) <- 1:35 - ## data to test against - dtTest1 <- data.frame(time = factor(c(2,1,0,0,0,0,2,0,2,0,0,0,0,1,1,1,0,1)), - subgenus = factor(c(2,1,0,0,0,0,2,0,2,0,0,0,0,1,1,2,0,1))) - row.names(dtTest1) <- c("Myrmecocystuscfnavajo","Myrmecocystuscreightoni", - "Myrmecocystusdepilis","Myrmecocystuskathjuli", - "Myrmecocystuskennedyi","Myrmecocystusmendax", - "Myrmecocystusmexicanus","Myrmecocystusmimicus", - "Myrmecocystusnavajo","Myrmecocystusnequazcatl", - "Myrmecocystusplacodops","Myrmecocystusromainei", - "Myrmecocystussemirufus","Myrmecocystussnellingi", - "Myrmecocystustenuinodis","Myrmecocystustestaceus", - "Myrmecocystuswheeleri","Myrmecocystusyuma") - dtTest2 <- dtTest1 - levels(dtTest2$time) <- c("diurnal", "crepuscular", "nocturnal") - levels(dtTest2$subgenus) <- c("Endiodioctes", "Eremnocystus", "Myrmecocystus") - p4 <- "phylo4" - p4d <- "phylo4d" - attributes(p4) <- attributes(p4d) <- list(package="phylobase") - ## Tree only - tr <- readNexus(file=treeDiscDt, type="tree") - checkIdentical(labels(tr), labTr) # check labels - checkIdentical(edgeLength(tr), eTr) # check edge lengths - checkIdentical(nodeType(tr), nTtr) # check node types - checkIdentical(class(tr), p4) # check class - ## Data only - dt1 <- readNexus(file=treeDiscDt, type="data", return.labels=FALSE, - levels.uniform=FALSE) - checkIdentical(dt1, dtTest1) - dt2 <- readNexus(file=treeDiscDt, type="data", return.labels=TRUE, - levels.uniform=FALSE) - checkIdentical(dt2, dtTest2) - ## Tree + Data - trDt1 <- readNexus(file=treeDiscDt, type="all", return.labels=FALSE, - levels.uniform=FALSE) - checkIdentical(labels(trDt1), labTr) # check labels - checkIdentical(edgeLength(trDt1), eTr) # check edge lengths - checkIdentical(nodeType(trDt1), nTtr) # check node types - checkIdentical(class(trDt1), p4d) # check class - checkIdentical(tdata(trDt1, type="tip")[rownames(dtTest1), ], dtTest1) - trDt2 <- readNexus(file=treeDiscDt, type="all", return.labels=TRUE, - levels.uniform=FALSE) - checkIdentical(labels(trDt2), labTr) # check labels - checkIdentical(edgeLength(trDt2), eTr) # check edge lengths - checkIdentical(nodeType(trDt2), nTtr) # check node types - checkIdentical(class(trDt2), p4d) # check class - checkIdentical(tdata(trDt2, type="tip")[rownames(dtTest2), ], dtTest2) - - ## ########## Tree + Data -- Test for polymorphic.convert, levels.uniform and char.all - ## data to test against - ## dtTest 3 -- levels.uniform=FALSE, return.labels=FALSE, polymorphic.convert=FALSE - dtPoly1 <- data.frame(Test1=factor(c(0,0,1,1,0,NA,1,1,1,0,0,NA,1,1,NA,0,1, - NA)), - Test2=factor(c(0,0,0,0,0,NA,0,1,0,1,1, - "{0,1}",NA,0,NA,0,"{0,1}",1)), - Test3=factor(c(1,1,1,0,0,0,2, - "{0,1,2}",0,NA,0,"{0,1}",0,1,0,0,"{0,1,2}",1)), - row.names=c("Myrmecocystussemirufus","Myrmecocystusplacodops", - "Myrmecocystusmendax","Myrmecocystuskathjuli", - "Myrmecocystuswheeleri","Myrmecocystusmimicus", - "Myrmecocystusdepilis","Myrmecocystusromainei", - "Myrmecocystusnequazcatl","Myrmecocystusyuma", - "Myrmecocystuskennedyi","Myrmecocystuscreightoni", - "Myrmecocystussnellingi","Myrmecocystustenuinodis", - "Myrmecocystustestaceus","Myrmecocystusmexicanus", - "Myrmecocystuscfnavajo","Myrmecocystusnavajo")) - ## dtPoly2 -- levels.uniform=FALSE, return.labels=FALSE, polymorphic.convert=TRUE - dtPoly2 <- dtPoly1 - dtPoly2[c(12,17),2] <- NA - dtPoly2[c(8,12,17),3] <- NA - dtPoly2$Test1 <- factor(dtPoly2$Test1) - dtPoly2$Test2 <- factor(dtPoly2$Test2) - dtPoly2$Test3 <- factor(dtPoly2$Test3) - ## dtPoly3 -- levels.uniform=FALSE, return.labels=TRUE, polymorphic.convert=TRUE - dtPoly3 <- dtPoly2 - levels(dtPoly3$Test1) <- c("test1A", "test1B") - levels(dtPoly3$Test2) <- c("test2A", "test2B") - levels(dtPoly3$Test3) <- c("test3A", "test3B", "test3C") - ## dtPoly4 -- levels.uniform=FALSE, return.labels=TRUE, polymorphic.convert=FALSE - ## not yet implemented - - ## dtPoly5 -- levels.uniform=TRUE, return.labels=FALSE, polymorphic.convert=FALSE - dtPoly5 <- dtPoly1 - levels(dtPoly5$Test1) <- levels(dtPoly5$Test2) <- levels(dtPoly5$Test3) <- - union(levels(dtPoly1$Test1), c(levels(dtPoly1$Test2), levels(dtPoly1$Test3))) - ## dtPoly6 -- levels.uniform=TRUE, return.labels=FALSE, polymorphic.convert=TRUE - dtPoly6 <- dtPoly2 - levels(dtPoly6$Test1) <- levels(dtPoly6$Test2) <- levels(dtPoly6$Test3) <- - union(levels(dtPoly2$Test1), c(levels(dtPoly2$Test2), levels(dtPoly2$Test3))) - ## dtPoly7 -- levels.uniform=TRUE, return.labels=TRUE, polymorphic.convert=FALSE - ## not yet implemented - - ## dtPoly8 -- levels.uniform=TRUE, return.labels=TRUE, polymorphic.convert=TRUE - dtPoly8 <- dtPoly3 - levels(dtPoly8$Test1) <- levels(dtPoly8$Test2) <- levels(dtPoly8$Test3) <- - union(levels(dtPoly3$Test1), c(levels(dtPoly3$Test2), levels(dtPoly3$Test3))) - ## dtPoly5F -- char.all=FALSE, levels.uniform=TRUE, return.labels=FALSE, polymorphic.convert=FALSE - dtPoly5F <- dtPoly1[, 1:2] - levels(dtPoly5F$Test1) <- levels(dtPoly5F$Test2) <- - union(levels(dtPoly1$Test1), levels(dtPoly1$Test2)) - ## dtPoly6F -- char.all=FALSE, levels.uniform=TRUE, return.labels=FALSE, polymorphic.convert=TRUE - dtPoly6F <- dtPoly2[, 1:2] - levels(dtPoly6F$Test1) <- levels(dtPoly6F$Test2) <- - union(levels(dtPoly2$Test1), levels(dtPoly2$Test2)) - ## dtPoly8F -- char.all=FALSE, levels.uniform=TRUE, return.labels=TRUE, polymorphic.convert=TRUE - dtPoly8F <- dtPoly3[, 1:2] - levels(dtPoly8F$Test1) <- levels(dtPoly8F$Test2) <- - union(levels(dtPoly3$Test1), levels(dtPoly3$Test2)) - - ## char.all=TRUE, levels.uniform=FALSE, return.labels=FALSE, polymorphic.convert=FALSE - trChr1 <- readNexus(file=treePolyDt, type="all", polymorphic.convert=FALSE, - levels.uniform=FALSE, char.all=TRUE, return.labels=FALSE) - checkIdentical(labels(trChr1), labTr) # check labels - checkIdentical(edgeLength(trChr1), eTr) # check edge lengths - checkIdentical(nodeType(trChr1), nTtr) # check node types - checkIdentical(class(trChr1), p4d) # check class - checkIdentical(tdata(trChr1, "tip"), dtPoly1) - ## char.all=TRUE, levels.uniform=FALSE, return.labels=FALSE, polymorphic.convert=TRUE - trChr2 <- readNexus(file=treePolyDt, type="all", polymorphic.convert=TRUE, - levels.uniform=FALSE, return.labels=FALSE, char.all=TRUE) - checkIdentical(labels(trChr2), labTr) # check labels - checkIdentical(edgeLength(trChr2), eTr) # check edge lengths - checkIdentical(nodeType(trChr2), nTtr) # check node types - checkIdentical(class(trChr2), p4d) # check class - checkIdentical(tdata(trChr2, "tip"), dtPoly2) - ## char.all=TRUE, levels.uniform=FALSE, return.labels=TRUE, polymorphic.convert=TRUE - trChr3 <- readNexus(file=treePolyDt, type="all", polymorphic.convert=TRUE, - levels.uniform=FALSE, char.all=TRUE, return.labels=TRUE) - checkIdentical(labels(trChr3), labTr) # check labels - checkIdentical(edgeLength(trChr3), eTr) # check edge lengths - checkIdentical(nodeType(trChr3), nTtr) # check node types - checkIdentical(class(trChr3), p4d) # check class - checkIdentical(tdata(trChr3, "tip"), dtPoly3) - ## char.all=TRUE, levels.uniform=FALSE, return.labels=TRUE, polymorphic.convert=FALSE - ## not yet implemented - ## trChr4 <- - checkException(readNexus(file=treePolyDt, type="all", - levels.uniform=FALSE, - return.labels=TRUE, - polymorphic.convert=FALSE)) - ## char.all=TRUE, levels.uniform=TRUE, return.labels=FALSE, polymorphic.convert=FALSE - trChr5 <- readNexus(file=treePolyDt, type="all", polymorphic.convert=FALSE, - levels.uniform=TRUE, char.all=TRUE, return.labels=FALSE) - checkIdentical(labels(trChr5), labTr) # check labels - checkIdentical(edgeLength(trChr5), eTr) # check edge lengths - checkIdentical(nodeType(trChr5), nTtr) # check node types - checkIdentical(class(trChr5), p4d) # check class - checkIdentical(tdata(trChr5, "tip"), dtPoly5) - ## char.all=TRUE, levels.uniform=TRUE, return.labels=FALSE, polymorphic.convert=TRUE - trChr6 <- readNexus(file=treePolyDt, type="all", polymorphic.convert=TRUE, - levels.uniform=TRUE, char.all=TRUE, return.labels=FALSE) - checkIdentical(labels(trChr6), labTr) # check labels - checkIdentical(edgeLength(trChr6), eTr) # check edge lengths - checkIdentical(nodeType(trChr6), nTtr) # check node types - checkIdentical(class(trChr6), p4d) # check class - checkIdentical(tdata(trChr6, "tip"), dtPoly6) - ## char.all=TRUE, levels.uniform=TRUE, return.labels=TRUE, polymorphic.convert=FALSE - ## not yet implemented - ## trChr7 <- - checkException(readNexus(file=treePolyDt, type="all", char.all=TRUE, - levels.uniform=TRUE, - return.labels=TRUE, - polymorphic.convert=FALSE)) - ## char.all=TRUE, levels.uniform=TRUE, return.labels=TRUE, polymorphic.convert=TRUE - trChr8 <- readNexus(file=treePolyDt, type="all", char.all=TRUE, - levels.uniform=TRUE, - return.labels=TRUE, - polymorphic.convert=TRUE) - checkIdentical(labels(trChr8), labTr) # check labels - checkIdentical(edgeLength(trChr8), eTr) # check edge lengths - checkIdentical(nodeType(trChr8), nTtr) # check node types - checkIdentical(class(trChr8), p4d) # check class - checkIdentical(tdata(trChr8, "tip"), dtPoly8) - - ## -- with char.all=FALSE - ## char.all=FALSE, levels.uniform=FALSE, return.labels=FALSE, polymorphic.convert=FALSE - trChr1F <- readNexus(file=treePolyDt, type="all", polymorphic.convert=FALSE, - levels.uniform=FALSE, char.all=FALSE, return.labels=FALSE) - checkIdentical(labels(trChr1F), labTr) # check labels - checkIdentical(edgeLength(trChr1F), eTr) # check edge lengths - checkIdentical(nodeType(trChr1F), nTtr) # check node types - checkIdentical(class(trChr1F), p4d) # check class - checkIdentical(tdata(trChr1F, "tip"), dtPoly1[, 1:2]) - ## char.all=FALSE, levels.uniform=FALSE, return.labels=FALSE, polymorphic.convert=TRUE - trChr2F <- readNexus(file=treePolyDt, type="all", polymorphic.convert=TRUE, - levels.uniform=FALSE, return.labels=FALSE, char.all=FALSE) - checkIdentical(labels(trChr2F), labTr) # check labels - checkIdentical(edgeLength(trChr2F), eTr) # check edge lengths - checkIdentical(nodeType(trChr2F), nTtr) # check node types - checkIdentical(class(trChr2F), p4d) # check class - checkIdentical(tdata(trChr2F, "tip"), dtPoly2[, 1:2]) - ## char.all=FALSE, levels.uniform=FALSE, return.labels=TRUE, polymorphic.convert=TRUE - trChr3F <- readNexus(file=treePolyDt, type="all", polymorphic.convert=TRUE, - levels.uniform=FALSE, char.all=FALSE, return.labels=TRUE) - checkIdentical(labels(trChr3F), labTr) # check labels - checkIdentical(edgeLength(trChr3F), eTr) # check edge lengths - checkIdentical(nodeType(trChr3F), nTtr) # check node types - checkIdentical(class(trChr3F), p4d) # check class - checkIdentical(tdata(trChr3F, "tip"), dtPoly3[, 1:2]) - ## char.all=FALSE, levels.uniform=FALSE, return.labels=TRUE, polymorphic.convert=FALSE - ## not yet implemented - ## trChr4F <- - checkException(readNexus(file=treePolyDt, type="all", - levels.uniform=FALSE, - return.labels=TRUE, - polymorphic.convert=FALSE)) - ## char.all=FALSE, levels.uniform=TRUE, return.labels=FALSE, polymorphic.convert=FALSE - trChr5F <- readNexus(file=treePolyDt, type="all", polymorphic.convert=FALSE, - levels.uniform=TRUE, char.all=FALSE, return.labels=FALSE) - checkIdentical(labels(trChr5F), labTr) # check labels - checkIdentical(edgeLength(trChr5F), eTr) # check edge lengths - checkIdentical(nodeType(trChr5F), nTtr) # check node types - checkIdentical(class(trChr5F), p4d) # check class - checkIdentical(tdata(trChr5F, "tip"), dtPoly5F) - ## char.all=FALSE, levels.uniform=TRUE, return.labels=FALSE, polymorphic.convert=TRUE - trChr6F <- readNexus(file=treePolyDt, type="all", polymorphic.convert=TRUE, - levels.uniform=TRUE, char.all=FALSE, return.labels=FALSE) - checkIdentical(labels(trChr6F), labTr) # check labels - checkIdentical(edgeLength(trChr6F), eTr) # check edge lengths - checkIdentical(nodeType(trChr6F), nTtr) # check node types - checkIdentical(class(trChr6F), p4d) # check class - checkIdentical(tdata(trChr6F, "tip"), dtPoly6F) - ## char.all=FALSE, levels.uniform=TRUE, return.labels=TRUE, polymorphic.convert=FALSE - ## not yet implemented - ## trChr7F <- - checkException(readNexus(file=treePolyDt, type="all", char.all=FALSE, - levels.uniform=TRUE, - return.labels=TRUE, - polymorphic.convert=FALSE)) - ## char.all=FALSE, levels.uniform=TRUE, return.labels=TRUE, polymorphic.convert=TRUE - trChr8F <- readNexus(file=treePolyDt, type="all", char.all=FALSE, - levels.uniform=TRUE, - return.labels=TRUE, - polymorphic.convert=TRUE) - checkIdentical(labels(trChr8F), labTr) # check labels - checkIdentical(edgeLength(trChr8F), eTr) # check edge lengths - checkIdentical(nodeType(trChr8F), nTtr) # check node types - checkIdentical(class(trChr8F), p4d) # check class - checkIdentical(tdata(trChr8F, "tip"), dtPoly8F) - - ## ########## Tree + Data -- test with continuous Characters - DtCont <- readNexus(file=treeContDt, type="data") - trDtCont <- readNexus(file=treeContDt, type="all") - load(ExContDataFile) - checkIdentical(DtCont, ExContData[rownames(DtCont), ]) - checkIdentical(tdata(trDtCont, "tip"), ExContData) - rm(ExContData) - checkIdentical(labels(trDtCont), labTr) # check labels - checkIdentical(edgeLength(trDtCont), eTr) # check edge lengths - checkIdentical(nodeType(trDtCont), nTtr) # check node types - checkIdentical(class(trDtCont), p4d) # check class - - ## ########## Tree + Data -- both types (Discrete & Continuous) - dtDiscCont <- readNexus(file=treeDiscCont, type="data", levels.uniform=FALSE) - trDtDiscCont <- readNexus(file=treeDiscCont, type="all", levels.uniform=FALSE) - load(ExContDataFile) - dtDiscContTest <- cbind(ExContData, dtTest2[rownames(ExContData), ]) - rm(ExContDataFile) - checkIdentical(dtDiscCont, dtDiscContTest[rownames(dtDiscCont), ]) - checkIdentical(tdata(trDtDiscCont, "tip"), dtDiscContTest) - checkIdentical(labels(trDtDiscCont), labTr) # check labels - checkIdentical(edgeLength(trDtDiscCont), eTr) # check edge lengths - checkIdentical(nodeType(trDtDiscCont), nTtr) # check node types - checkIdentical(class(trDtDiscCont), p4d) # check class -} - Modified: pkg/inst/unitTests/runit.setAs-Methods.R =================================================================== --- pkg/inst/unitTests/runit.setAs-Methods.R 2012-11-24 20:22:08 UTC (rev 840) +++ pkg/inst/unitTests/runit.setAs-Methods.R 2013-04-29 17:20:09 UTC (rev 841) @@ -44,7 +44,7 @@ as.phy <- as(reorder(tr, "cladewise"), "phylo4") checkIdentical("preorder", edgeOrder(as.phy)) as.phy <- as(reorder(tr, "pruningwise"), "phylo4") - checkIdentical("pruningwise", edgeOrder(as.phy)) + checkIdentical("postorder", edgeOrder(as.phy)) # test phylo import when only 2 tips tr2 <- ape::drop.tip(tr, 3:ape::Ntip(tr)) From noreply at r-forge.r-project.org Tue Apr 30 20:43:52 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 30 Apr 2013 20:43:52 +0200 (CEST) Subject: [Phylobase-commits] r842 - pkg/tests Message-ID: <20130430184352.1888118450E@r-forge.r-project.org> Author: bbolker Date: 2013-04-30 20:43:51 +0200 (Tue, 30 Apr 2013) New Revision: 842 Modified: pkg/tests/phylotorture.Rout.save Log: updated test output Modified: pkg/tests/phylotorture.Rout.save =================================================================== --- pkg/tests/phylotorture.Rout.save 2013-04-29 17:20:09 UTC (rev 841) +++ pkg/tests/phylotorture.Rout.save 2013-04-30 18:43:51 UTC (rev 842) @@ -1,7 +1,6 @@ -R Under development (unstable) (2012-11-20 r61133) -- "Unsuffered Consequences" -Copyright (C) 2012 The R Foundation for Statistical Computing -ISBN 3-900051-07-0 +R Under development (unstable) (2013-04-25 r62670) -- "Unsuffered Consequences" +Copyright (C) 2013 The R Foundation for Statistical Computing Platform: i686-pc-linux-gnu (32-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. @@ -98,8 +97,10 @@ > broke1$edge[broke1$edge[,2] ==9, 1] <- 9 # disconnect the node, two subtrees, ((a, b), c) and (d,e) > > try(as(broke1, "phylo4") -> tree, silent=TRUE) # makes a phylo4 object with no warning -Warning message: -In checkTree(object) : tree contains singleton nodes +Warning messages: +1: In checkTree(object) : tree contains singleton nodes +2: In checkTree(object) : tree contains singleton nodes +3: In checkTree(object) : tree contains singleton nodes > try(phylo4(broke1$edge), silent=TRUE) # constructor makes a phylo4 object with no warning label node ancestor edge.length node.type 1 T1 1 7 NA tip @@ -213,4 +214,4 @@ > > proc.time() user system elapsed - 1.876 2.224 3.954 + 1.996 2.228 4.109