From f10cc8518cf2027a2d4c0484a2d9e6dc6afc932f Mon Sep 17 00:00:00 2001 From: xiangpin Date: Fri, 20 Aug 2021 20:38:49 +0800 Subject: [PATCH 1/7] update show --- R/show.R | 17 ++++++----------- 1 file changed, 6 insertions(+), 11 deletions(-) diff --git a/R/show.R b/R/show.R index af329e4..008d981 100644 --- a/R/show.R +++ b/R/show.R @@ -60,17 +60,10 @@ print.treedata <- function(x, ..., n = NULL, width = NULL, n_extra = NULL){ print1.treedata <- function(x, ..., n = NULL, width = NULL, n_extra = NULL){ if (nrow(x@data) == 0 && nrow(x@extraInfo) == 0){ - print2.treedata(x) - return() + n = 10 } - trdf <- x@phylo %>% - as_tibble() %>% - .internal_add_isTip() - - annotda <- trdf %>% - dplyr::left_join(get_tree_data(x), by="node") - annotda <- annotda[, !colnames(annotda) %in% c("parent", "branch.length")] + annotda <- .extract_annotda.treedata(x) formatstr <- annotda %>% format(..., n = n, width = width, n_extra = n_extra) @@ -78,19 +71,21 @@ print1.treedata <- function(x, ..., n = NULL, width = NULL, n_extra = NULL){ if(length(fields)==1 && fields==""){ fields <- '' + newheader <- c("\n None available features.") }else{ ff <- paste0("\t'",paste(fields, collapse="',\t'"), "'.\n") fields <- fields_wrap(ff) + newheader <- c("\nwith the following features available:", fields) } - newheader <- c("\nwith the following features available:", fields) - msg <- .internal_print.treedata_msg(x) %>% writeLines() print.phylo(as.phylo(x)) formatstr[1] <- gsub("(A tibble:)", "The associated data tibble abstraction:", formatstr[1]) + formatstr %<>% append(pillar::style_subtle("# The 'node', 'label' and 'isTip' are from the phylo tree."), + after=1) newheader %>% append(formatstr) %>% writeLines() From 07749f1eabf4e420e879c52921d4e20c282e8fef Mon Sep 17 00:00:00 2001 From: xiangpin Date: Fri, 20 Aug 2021 20:39:57 +0800 Subject: [PATCH 2/7] add AAbin class for tip_seq and anc_seq slot --- R/AllClasses.R | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/R/AllClasses.R b/R/AllClasses.R index ba3ae55..cc60c65 100644 --- a/R/AllClasses.R +++ b/R/AllClasses.R @@ -2,6 +2,9 @@ setOldClass("phylo") ## setOldClass("multiPhylo") setOldClass("DNAbin") +setOldClass("AAbin") + +setClassUnion("DNAbin_Or_AAbin", c("DNAbin", "AAbin", "NULL")) ##' Class "treedata" ##' This class stores phylogenetic tree with associated data @@ -35,8 +38,8 @@ setClass("treedata", phylo = "phylo", data = "tbl_df", extraInfo = "tbl_df", - tip_seq = "DNAbin", - anc_seq = "DNAbin", + tip_seq = "DNAbin_Or_AAbin", + anc_seq = "DNAbin_Or_AAbin", seq_type = "character", tipseq_file = "character", ancseq_file = "character", @@ -45,8 +48,8 @@ setClass("treedata", prototype = prototype( data = tibble(), extraInfo = tibble(), - anc_seq = ape::as.DNAbin(character(0)), - tip_seq = ape::as.DNAbin(character(0)) + anc_seq = NULL,#ape::as.DNAbin(character(0)), + tip_seq = NULL#ape::as.DNAbin(character(0)) ) ) From a56153ee0453088f4aa88b48cce4d5b8e7942314 Mon Sep 17 00:00:00 2001 From: xiangpin Date: Fri, 20 Aug 2021 20:40:53 +0800 Subject: [PATCH 3/7] add filter, select, mutate for treedata object --- R/filter.R | 12 ++++++++++++ R/get-fields.R | 20 ++++++++++++++------ R/mutate.R | 16 ++++++++++++++++ R/select.R | 12 ++++++++++++ man/get.fields-methods.Rd | 3 +-- man/reexports.Rd | 3 ++- 6 files changed, 57 insertions(+), 9 deletions(-) diff --git a/R/filter.R b/R/filter.R index 90bb109..ce1f61c 100644 --- a/R/filter.R +++ b/R/filter.R @@ -7,3 +7,15 @@ filter.ggtree <- function(.data, ..., .preserve = FALSE) { dplyr::filter(.data$data, !!!dots, .preserve = .preserve) } +##' @method filter treedata +##' @export +filter.treedata <- function(.data, ..., .preserve=FALSE, keep.td=TRUE){ + dots <- rlang::quos(...) + dat <- .extract_annotda.treedata(.data) + da <- dplyr::filter(dat, !!!dots, .preserve = .preserve) + if (keep.td){ + .data <- .update.treedata(td=.data, da=da, dat=dat, type="extra") + return(.data) + } + return(da) +} diff --git a/R/get-fields.R b/R/get-fields.R index 0b4a68f..abc06ba 100644 --- a/R/get-fields.R +++ b/R/get-fields.R @@ -1,7 +1,5 @@ -##' get.fields method -##' -##' ##' @rdname get.fields-methods +##' @aliases get.fields,treedata ##' @exportMethod get.fields setMethod("get.fields", signature(object = "treedata"), function(object) { @@ -10,20 +8,30 @@ setMethod("get.fields", signature(object = "treedata"), get.fields.treedata <- function(object) { + fields1 <- get.fields.data(object) + fields2 <- get.fields.extraInfo(object) + return(c(fields1, fields2)) +} + +get.fields.data <- function(object){ if (nrow(object@data) > 0) { fields <- colnames(object@data) fields <- fields[fields != "node"] } else { fields <- "" } + return(fields) +} +get.fields.extraInfo <- function(object){ extraInfo <- object@extraInfo if (nrow(extraInfo) > 0) { cn <- colnames(extraInfo) i <- match(c("x", "y", "isTip", "node", "parent", "label", "branch", "branch.length"), cn) i <- i[!is.na(i)] - fields %<>% c(cn[-i]) + fields <- cn[-i] + return(fields) + }else{ + return(character(0)) } - return(fields) } - diff --git a/R/mutate.R b/R/mutate.R index 9440652..2b97baa 100644 --- a/R/mutate.R +++ b/R/mutate.R @@ -6,3 +6,19 @@ mutate.tbl_tree <- function(.data, ...) { class(res) <- class(.data) res } + +##' @method mutate treedata +##' @export +mutate.treedata <- function(.data, ..., keep.td=TRUE){ + dots <- rlang::quos(...) + dat <- .extract_annotda.treedata(.data) + da <- dplyr::mutate(dat, !!!dots) + if (keep.td){ + .data <- .update.treedata(td = .data, + da = da, + dat = dat, + type = "extra") + return(.data) + } + return(da) +} diff --git a/R/select.R b/R/select.R index f74a468..5f3e060 100644 --- a/R/select.R +++ b/R/select.R @@ -6,3 +6,15 @@ select.ggtree <- function(.data, ...) { dplyr::select(.data$data, !!!dots) } +##' @method select treedata +##' @export +select.treedata <- function(.data, ..., keep.td=FALSE){ + dots <- rlang::quos(...) + dat <- .extract_annotda.treedata(.data) + da <- dplyr::select(dat, !!!dots) + if (keep.td){ + .data <- .update.treedata(td=.data, da=da, dat=dat) + return(.data) + } + return(da) +} diff --git a/man/get.fields-methods.Rd b/man/get.fields-methods.Rd index 60211e5..0f6e617 100644 --- a/man/get.fields-methods.Rd +++ b/man/get.fields-methods.Rd @@ -4,6 +4,7 @@ \name{get.fields} \alias{get.fields} \alias{get.fields,treedata-method} +\alias{get.fields,treedata} \title{get.fields method} \usage{ get.fields(object, ...) @@ -19,7 +20,5 @@ get.fields(object, ...) available annotation variables } \description{ -get.fields method - get.fields method } diff --git a/man/reexports.Rd b/man/reexports.Rd index 7389b0f..dd9aecc 100644 --- a/man/reexports.Rd +++ b/man/reexports.Rd @@ -18,6 +18,7 @@ \alias{summarize} \alias{full_join} \alias{.data} +\alias{left_join} \title{Objects exported from other packages} \keyword{internal} \description{ @@ -27,7 +28,7 @@ below to see their documentation. \describe{ \item{ape}{\code{\link[ape]{as.phylo}}} - \item{dplyr}{\code{\link[dplyr]{arrange}}, \code{\link[dplyr]{filter}}, \code{\link[dplyr:mutate-joins]{full_join}}, \code{\link[dplyr]{mutate}}, \code{\link[dplyr]{rename}}, \code{\link[dplyr]{select}}, \code{\link[dplyr]{summarise}}, \code{\link[dplyr:summarise]{summarize}}, \code{\link[dplyr:mutate]{transmute}}} + \item{dplyr}{\code{\link[dplyr]{arrange}}, \code{\link[dplyr]{filter}}, \code{\link[dplyr:mutate-joins]{full_join}}, \code{\link[dplyr:mutate-joins]{left_join}}, \code{\link[dplyr]{mutate}}, \code{\link[dplyr]{rename}}, \code{\link[dplyr]{select}}, \code{\link[dplyr]{summarise}}, \code{\link[dplyr:summarise]{summarize}}, \code{\link[dplyr:mutate]{transmute}}} \item{magrittr}{\code{\link[magrittr:compound]{\%<>\%}}, \code{\link[magrittr:pipe]{\%>\%}}} From 8d5c6b61de55a01f58122a6f50318bc1f5c2dfbb Mon Sep 17 00:00:00 2001 From: xiangpin Date: Fri, 20 Aug 2021 20:41:34 +0800 Subject: [PATCH 4/7] add left_join for treedata --- DESCRIPTION | 5 +- NAMESPACE | 7 ++ R/left-join.R | 48 +++++++++++++ R/reexports.R | 4 ++ R/tidy_utilities.R | 77 ++++++++++++++++++++ tests/testthat/test-dplyr-methods.R | 108 ++++++++++++++++++++++++++++ 6 files changed, 248 insertions(+), 1 deletion(-) create mode 100644 R/left-join.R create mode 100644 R/tidy_utilities.R create mode 100644 tests/testthat/test-dplyr-methods.R diff --git a/DESCRIPTION b/DESCRIPTION index 2a5cbcc..27dce40 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -23,7 +23,10 @@ Suggests: rmarkdown, prettydoc, testthat, - treeio + treeio, + pillar, + utils, + tidyr VignetteBuilder: knitr ByteCompile: true License: Artistic-2.0 diff --git a/NAMESPACE b/NAMESPACE index 04010c4..684080d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -11,10 +11,14 @@ S3method(as_tibble,phylo) S3method(as_tibble,treedata) S3method(child,tbl_tree) S3method(filter,ggtree) +S3method(filter,treedata) S3method(groupClade,tbl_tree) S3method(groupOTU,tbl_tree) +S3method(left_join,phylo) +S3method(left_join,treedata) S3method(merge,tbl_tree) S3method(mutate,tbl_tree) +S3method(mutate,treedata) S3method(nodeid,tbl_tree) S3method(nodelab,tbl_tree) S3method(offspring,tbl_tree) @@ -22,6 +26,7 @@ S3method(parent,tbl_tree) S3method(print,treedata) S3method(rootnode,tbl_tree) S3method(select,ggtree) +S3method(select,treedata) S3method(sibling,tbl_tree) export("%<>%") export("%>%") @@ -40,6 +45,7 @@ export(get.fields) export(get_tree_data) export(groupClade) export(groupOTU) +export(left_join) export(mutate) export(nodeid) export(nodelab) @@ -67,6 +73,7 @@ importFrom(dplyr,arrange) importFrom(dplyr,filter) importFrom(dplyr,full_join) importFrom(dplyr,group_by) +importFrom(dplyr,left_join) importFrom(dplyr,mutate) importFrom(dplyr,rename) importFrom(dplyr,select) diff --git a/R/left-join.R b/R/left-join.R new file mode 100644 index 0000000..67e01b0 --- /dev/null +++ b/R/left-join.R @@ -0,0 +1,48 @@ +#' @method left_join treedata +#' @export +left_join.treedata <- function(x, y, by = NULL, copy = FALSE, ...){ + dots <- rlang::quos(...) + suffix <- c("", ".y") + if ("suffix" %in% names(dots)){ + dots <- dots[names(dots)!="suffix"] + } + + dat <- .extract_annotda.treedata(x) + ornm <- colnames(dat) + da <- dat %>% + dplyr::left_join(y, by = by, copy = copy, suffix = suffix, !!!dots) + + if (any(duplicated(da$node))){ + da %<>% .internal_nest(keepnm=ornm) + } + + tr <- .update.td.join(td=x, da=da) + return(tr) +} + +#' @method left_join phylo +#' @export +left_join.phylo <- function(x, y, by=NULL, copy=FALSE, ...){ + x %<>% treeio::as.treedata() + tr <- x %>% left_join(y, by = by, copy = copy) + return(tr) +} + + +#' @keywords internal +#' @param td treedata object +#' @param da tbl_df after left_join. +#' @noRd +.update.td.join <- function(td, da){ + data.nm <- get.fields.data(td) + if (length(data.nm)==1 && data.nm==""){ + td@data <- tibble() + }else{ + td@data <- da %>% select(c("node", data.nm)) + } + extra.nm <- colnames(da)[!colnames(da) %in% c("node", "label", "isTip", data.nm)] + if (length(extra.nm) > 0){ + td@extraInfo <- da %>% select(c("node", extra.nm)) + } + return(td) +} diff --git a/R/reexports.R b/R/reexports.R index daad44b..aa0d798 100644 --- a/R/reexports.R +++ b/R/reexports.R @@ -55,3 +55,7 @@ dplyr::full_join ##' @importFrom rlang .data ##' @export rlang::.data + +##' @importFrom dplyr left_join +##' @export +dplyr::left_join diff --git a/R/tidy_utilities.R b/R/tidy_utilities.R new file mode 100644 index 0000000..a4691fd --- /dev/null +++ b/R/tidy_utilities.R @@ -0,0 +1,77 @@ +.internal_add_isTip <- function(x){ + x %<>% mutate(isTip=ifelse(!.data$node %in% .data$parent, TRUE, FALSE)) + return(x) +} + +.extract_annotda.treedata <- function(x){ + if (inherits(x, "treedata")){ + annotda <- get_tree_data(x) + x <- x@phylo + }else{ + annotda <- NULL + } + trdf <- x %>% + as_tibble() %>% + .internal_add_isTip() %>% + drop_class(name="tbl_tree") + + if (!any(is.null(annotda) || nrow(annotda)==0)){ + annotda <- trdf %>% + dplyr::left_join(annotda, by="node") + }else{ + annotda <- trdf + } + annotda <- annotda[, !colnames(annotda) %in% c("parent", "branch.length")] + return(annotda) +} + +.update.treedata <- function(td, da, dat, type=NULL){ + data.nm <- get.fields.data(td) + extra.nm <- get.fields.extraInfo(td) + data.nm <- intersect(data.nm, colnames(da)) + if (!is.null(type) && type == "extra"){ + clnm <- colnames(da)[!colnames(da) %in% c("label", "isTip", data.nm)] + extra.nm <- union(extra.nm, clnm) + dat <- da + }else{ + extra.nm <- intersect(extra.nm, colnames(da)) + } + if (length(data.nm)>0){ + td@data <- dat %>% select(c("node", data.nm)) + }else{ + td@data <- tibble() + } + if (length(extra.nm)>0){ + td@extraInfo <- dat %>% select(c("node", extra.nm)) + }else{ + td@extraInfo <- tibble() + } + return(td) +} + +#' remove the some class names from x object +#' @noRd +drop_class <- function(x, name) { + class(x) <- class(x)[!class(x) %in% name] + x +} + +.internal_nest <- function(x, keepnm, ..., .names_sep = NULL){ + nest <- utils::getFromNamespace("nest", "tidyr") + if (missing(...)){ + idx <- x %>% vapply(is.list, logical(1)) + clnm <- colnames(x) + clnm <- clnm[!idx] + clnm <- clnm[!clnm %in% keepnm] + params <- c(list(x), lapply(clnm, function(x)x)) + names(params) <- c(".data", clnm) + }else{ + res <- nest(.data=x, ..., .names_sep=.names_sep) + return(res) + } + if (!is.null(.names_sep)){ + params <- c(params, .names_sep=.names_sep) + } + res <- do.call(nest, params) + return(res) +} diff --git a/tests/testthat/test-dplyr-methods.R b/tests/testthat/test-dplyr-methods.R new file mode 100644 index 0000000..89ccf9b --- /dev/null +++ b/tests/testthat/test-dplyr-methods.R @@ -0,0 +1,108 @@ +context("dplyr-methods") + +nwk <- '(((((((A:4,B:4):6,C:5):8,D:6):3,E:21):10,((F:4,G:12):14,H:8):13):13,((I:5,J:2):30,(K:11,L:11):2):17):4,M:56);' +dat <- tibble(node=c(1, 2, 3, 4, 5), group=c("A", "A", "A", "B", "B"), test=c(10, 20, 30, 40, 50)) + +tree <- read.tree(text=nwk) %>% treeio::as.treedata() +tree@data <- dat + +test_that("select fields from treedata and return tbl_df directly ",{ + expect_equal(tree %>% select(group) %>% nrow(), tree %>% as_tibble() %>% nrow()) + expect_equal(tree %>% select(node, group) %>% filter(!is.na(group)) %>% nrow(), dat %>% nrow()) +}) + +test_that("select fields from treedata and return treedata",{ + expect_true(inherits(tree %>% select(-group, keep.td=TRUE), "treedata")) + expect_true(inherits(tree %>% select(-c(group, test), keep.td=TRUE), "treedata")) + expect_equal(tree %>% select(-test, keep.td=TRUE) %>% get.fields, "group") +}) + +test_that("filter fields for treedata and return tbl_df directly",{ + expect_equal(tree %>% + filter(group=="A", keep.td=FALSE) %>% + nrow(), + dat %>% + filter(group=="A") %>% + nrow() + ) + expect_equal(tree %>% + filter(group=="A" & test>=20, keep.td=FALSE) %>% + nrow(), + dat %>% + filter(group=="A" & test>=20) %>% + nrow() + ) +}) + +test_that("filter fields for treedata and return treedata", { + expect_true(inherits(tree %>% filter(group=="A", keep.td=TRUE), "treedata")) + tree2 <- tree %>% filter(group=="A" & test>=20, keep.td=TRUE) + expect_equal(tree2@data %>% + filter(!is.na(group)) %>% + nrow(), + dat %>% + filter(group=="A" & test>=20) %>% + nrow() + ) +}) + +test_that("mutate fields for treedata and return tbl_df", { + expect_equal(tree %>% + mutate(type="A", keep.td=FALSE) %>% + nrow(), + tree %>% + as_tibble() %>% + nrow() + ) + + expect_equal(tree %>% + mutate(test="A", keep.td=FALSE) %>% + colnames(), + c("node", "label", "isTip", colnames(dat)[-1]) + ) + +}) + +test_that("mutate fields for treedata and return treedata", { + expect_true(inherits(tree %>% + mutate(type="A", keep.td=TRUE), + "treedata") + ) + tree2 <- tree %>% mutate(type="A", keep.td=TRUE) + p <- ggtree::ggtree(tree2) + expect_true(inherits(p, "ggtree")) + expect_equal(tree2@extraInfo %>% nrow(), + tree %>% treeio::Nnode(internal.only=FALSE) + ) +}) + +test_that("left_join for treedata",{ + set.seed(123) + df <- data.frame(label=tree@phylo$tip.label, value=abs(rnorm(length(tree@phylo$tip.label)))) + N <- tree %>% treeio::Nnode(internal.only=FALSE) + dt <- data.frame(ind=rep(seq_len(N), 2), group=rep(c("A","B"), each=N)) + + tr2 <- tree %>% left_join(df, by="label") + + tr3 <- tree %>% left_join(dt, by=c("node"="ind")) + + expect_true(inherits(tr2, "treedata")) + + expect_true(inherits(tr3, "treedata")) + + expect_equal(tree %>% + as_tibble() %>% + nrow(), + tr3 %>% + as_tibble() %>% + nrow()) + + expect_equal(tr3 %>% + select("node", "group.y") %>% + tidyr::unnest("group.y") %>% + dplyr::rename(ind="node", group="group.y"), + dt %>% + tibble::as_tibble() %>% + dplyr::arrange(ind) + ) +}) From 270a0a49faeb0adeeaa1521e0149098db0aeef30 Mon Sep 17 00:00:00 2001 From: xiangpin Date: Sat, 21 Aug 2021 19:39:31 +0800 Subject: [PATCH 5/7] add unnest for treedata --- R/methods-tidyr.R | 17 +++++++++++++++++ R/reexports.R | 13 ++++++++++++- R/tidy_utilities.R | 5 +++++ man/reexports.Rd | 6 +++++- tests/testthat/test-dplyr-methods.R | 28 ++++++++++++++++++++++++++++ 5 files changed, 67 insertions(+), 2 deletions(-) create mode 100644 R/methods-tidyr.R diff --git a/R/methods-tidyr.R b/R/methods-tidyr.R new file mode 100644 index 0000000..4d03094 --- /dev/null +++ b/R/methods-tidyr.R @@ -0,0 +1,17 @@ +#' @method unnest treedata +#' @export +unnest.treedata <- function(data, + cols, ..., + keep_empty = FALSE, + ptype = NULL, + names_sep = NULL, + names_repair = "check_unique"){ + tbl_df_returned_message %>% + pillar::style_subtle() %>% + writeLines() + cols <- rlang::enquo(cols) + data <- .extract_annotda.treedata(data) + data <- unnest(data, !!cols, ..., keep_empty=keep_empty, + ptype=ptype, names_sep=names_sep, names_repair=names_repair) + return(data) +} diff --git a/R/reexports.R b/R/reexports.R index aa0d798..5c8ce39 100644 --- a/R/reexports.R +++ b/R/reexports.R @@ -47,7 +47,6 @@ dplyr::summarise ##' @export dplyr::summarize - ##' @importFrom dplyr full_join ##' @export dplyr::full_join @@ -59,3 +58,15 @@ rlang::.data ##' @importFrom dplyr left_join ##' @export dplyr::left_join + +##' @importFrom dplyr pull +##' @export +dplyr::pull + +##' @importFrom dplyr rename +##' @export +dplyr::rename + +##' @importFrom tidyr unnest +##' @export +tidyr::unnest diff --git a/R/tidy_utilities.R b/R/tidy_utilities.R index a4691fd..125e88e 100644 --- a/R/tidy_utilities.R +++ b/R/tidy_utilities.R @@ -26,6 +26,9 @@ } .update.treedata <- function(td, da, dat, type=NULL){ + if (inherits(td, "phylo")){ + td %<>% treeio::as.treedata() + } data.nm <- get.fields.data(td) extra.nm <- get.fields.extraInfo(td) data.nm <- intersect(data.nm, colnames(da)) @@ -75,3 +78,5 @@ drop_class <- function(x, name) { res <- do.call(nest, params) return(res) } + +tbl_df_returned_message <- "# A tbl_df is returned for independent data analysis." diff --git a/man/reexports.Rd b/man/reexports.Rd index dd9aecc..8cd0426 100644 --- a/man/reexports.Rd +++ b/man/reexports.Rd @@ -19,6 +19,8 @@ \alias{full_join} \alias{.data} \alias{left_join} +\alias{pull} +\alias{unnest} \title{Objects exported from other packages} \keyword{internal} \description{ @@ -28,12 +30,14 @@ below to see their documentation. \describe{ \item{ape}{\code{\link[ape]{as.phylo}}} - \item{dplyr}{\code{\link[dplyr]{arrange}}, \code{\link[dplyr]{filter}}, \code{\link[dplyr:mutate-joins]{full_join}}, \code{\link[dplyr:mutate-joins]{left_join}}, \code{\link[dplyr]{mutate}}, \code{\link[dplyr]{rename}}, \code{\link[dplyr]{select}}, \code{\link[dplyr]{summarise}}, \code{\link[dplyr:summarise]{summarize}}, \code{\link[dplyr:mutate]{transmute}}} + \item{dplyr}{\code{\link[dplyr]{arrange}}, \code{\link[dplyr]{filter}}, \code{\link[dplyr:mutate-joins]{full_join}}, \code{\link[dplyr:mutate-joins]{left_join}}, \code{\link[dplyr]{mutate}}, \code{\link[dplyr]{pull}}, \code{\link[dplyr]{rename}}, \code{\link[dplyr]{rename}}, \code{\link[dplyr]{select}}, \code{\link[dplyr]{summarise}}, \code{\link[dplyr:summarise]{summarize}}, \code{\link[dplyr:mutate]{transmute}}} \item{magrittr}{\code{\link[magrittr:compound]{\%<>\%}}, \code{\link[magrittr:pipe]{\%>\%}}} \item{rlang}{\code{\link[rlang:tidyeval-data]{.data}}} \item{tibble}{\code{\link[tibble]{as_tibble}}, \code{\link[tibble]{tibble}}} + + \item{tidyr}{\code{\link[tidyr:nest]{unnest}}} }} diff --git a/tests/testthat/test-dplyr-methods.R b/tests/testthat/test-dplyr-methods.R index 89ccf9b..d245e49 100644 --- a/tests/testthat/test-dplyr-methods.R +++ b/tests/testthat/test-dplyr-methods.R @@ -106,3 +106,31 @@ test_that("left_join for treedata",{ dplyr::arrange(ind) ) }) + +test_that("pull for treedata",{ + expect_equal(tree %>% + pull(label, name=node), + tree %>% + as_tibble() %>% + pull(label, name=node) + ) +}) + +test_that("rename for treedata", { + expect_equal(tree %>% + rename(type=test) %>% + select(node, group, type) %>% + dplyr::slice(seq_len(5)), + tree@data %>% + rename(type=test) + ) + dat <- data.frame(node=c(1, 2, 3, 4, 5), GT="b", BMW="a") + tree %<>% left_join(dat, by="node") + + expect_equal(tree %>% + rename(Group=GT, BW=BMW) %>% + select(node, Group, BW), + tree@extraInfo %>% + rename(Group=GT, BW=BMW) + ) +}) From 4edab3d002c9edc61ee0212041c25a3255e3462c Mon Sep 17 00:00:00 2001 From: xiangpin Date: Sat, 21 Aug 2021 19:39:57 +0800 Subject: [PATCH 6/7] add pull for treedata --- R/pull.R | 12 ++++++++++++ 1 file changed, 12 insertions(+) create mode 100644 R/pull.R diff --git a/R/pull.R b/R/pull.R new file mode 100644 index 0000000..396c23f --- /dev/null +++ b/R/pull.R @@ -0,0 +1,12 @@ +##' @method pull treedata +##' @export +pull.treedata <- function(.data, var = -1, name = NULL, ...){ + var <- rlang::enquo(var) + name <- rlang::enquo(name) + dat <- .extract_annotda.treedata(.data) + dplyr::pull(dat, var = !!var, name = !!name, ...) +} + +##' @method pull phylo +##' @export +pull.phylo <- pull.treedata From 22a64e330d4778d7e59d0ca581cb944a18b7be1a Mon Sep 17 00:00:00 2001 From: xiangpin Date: Sat, 21 Aug 2021 19:40:27 +0800 Subject: [PATCH 7/7] add rename for tredata --- DESCRIPTION | 7 ++++--- NAMESPACE | 9 +++++++++ R/rename.R | 45 +++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 58 insertions(+), 3 deletions(-) create mode 100644 R/rename.R diff --git a/DESCRIPTION b/DESCRIPTION index 27dce40..040ee12 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -16,7 +16,9 @@ Imports: magrittr, methods, rlang, - tibble + tibble, + tidyr, + tidyselect Suggests: ggtree, knitr, @@ -25,8 +27,7 @@ Suggests: testthat, treeio, pillar, - utils, - tidyr + utils VignetteBuilder: knitr ByteCompile: true License: Artistic-2.0 diff --git a/NAMESPACE b/NAMESPACE index 684080d..750d270 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -24,10 +24,14 @@ S3method(nodelab,tbl_tree) S3method(offspring,tbl_tree) S3method(parent,tbl_tree) S3method(print,treedata) +S3method(pull,phylo) +S3method(pull,treedata) +S3method(rename,treedata) S3method(rootnode,tbl_tree) S3method(select,ggtree) S3method(select,treedata) S3method(sibling,tbl_tree) +S3method(unnest,treedata) export("%<>%") export("%>%") export(.data) @@ -51,6 +55,7 @@ export(nodeid) export(nodelab) export(offspring) export(parent) +export(pull) export(rename) export(rootnode) export(select) @@ -60,6 +65,7 @@ export(summarize) export(tibble) export(transmute) export(treedata) +export(unnest) exportClasses(treedata) exportMethods(get.data) exportMethods(get.fields) @@ -75,6 +81,7 @@ importFrom(dplyr,full_join) importFrom(dplyr,group_by) importFrom(dplyr,left_join) importFrom(dplyr,mutate) +importFrom(dplyr,pull) importFrom(dplyr,rename) importFrom(dplyr,select) importFrom(dplyr,summarise) @@ -92,3 +99,5 @@ importFrom(methods,show) importFrom(rlang,.data) importFrom(tibble,as_tibble) importFrom(tibble,tibble) +importFrom(tidyr,unnest) +importFrom(tidyselect,eval_select) diff --git a/R/rename.R b/R/rename.R new file mode 100644 index 0000000..734aa54 --- /dev/null +++ b/R/rename.R @@ -0,0 +1,45 @@ +##' @method rename treedata +##' @importFrom tidyselect eval_select +##' @export +rename.treedata <- function(.data, ...){ + dat <- .data %>% .extract_annotda.treedata() + + cols <- eval_select(rlang::expr(c(...)), dat) + + loc <- check_names_from_phylo(x=dat, recol=cols) + clnames <- colnames(dat) + + .data@data <- .update.td.rename(x=.data@data, loc=loc, clnames=clnames) + + .data@extraInfo <- .update.td.rename(x=.data@extraInfo, loc=loc, clnames=clnames) + + return(.data) +} + +#' @param x the data before rename +#' @param recol the column will be renamed +#' @noRd +check_names_from_phylo <- function(x, recol){ + clnm <- colnames(x) + renm <- clnm[recol] + if (any(renm %in% c("node", "label", "isTip"))){ + warning("The 'node', 'label' and 'isTip' do not be renamed !") + ind <- seq_len(length(recol)) + names(ind) <- renm + ind <- ind[!names(ind) %in% c("node", "label", "isTip")] + recol <- recol[unname(ind)] + } + return(recol) +} + +#' @noRd +.update.td.rename <- function(x, loc, clnames){ + clnmda <- colnames(x) + loc <- sort(loc) + ind.da1 <- which(clnames[loc] %in% clnmda) + ind.da2 <- which(clnmda %in% clnames[loc]) + clnmda[ind.da2] <- names(loc)[ind.da1] + + colnames(x) <- clnmda + return(x) +}