add select,filter,mutate,left_join for treedata

DESCRIPTION

@@ -16,14 +16,18 @@ Imports:
     magrittr,
     methods,
     rlang,
-    tibble
+    tibble,
+    tidyr,
+    tidyselect
 Suggests:
     ggtree,
     knitr,
     rmarkdown,
     prettydoc,
     testthat,
-    treeio
+    treeio,
+    pillar,
+    utils
 VignetteBuilder: knitr
 ByteCompile: true
 License: Artistic-2.0

NAMESPACE

@@ -11,18 +11,27 @@ 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)
 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)
@@ -40,11 +49,13 @@ export(get.fields)
 export(get_tree_data)
 export(groupClade)
 export(groupOTU)
+export(left_join)
 export(mutate)
 export(nodeid)
 export(nodelab)
 export(offspring)
 export(parent)
+export(pull)
 export(rename)
 export(rootnode)
 export(select)
@@ -54,6 +65,7 @@ export(summarize)
 export(tibble)
 export(transmute)
 export(treedata)
+export(unnest)
 exportClasses(treedata)
 exportMethods(get.data)
 exportMethods(get.fields)
@@ -67,7 +79,9 @@ importFrom(dplyr,arrange)
 importFrom(dplyr,filter)
 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)
@@ -85,3 +99,5 @@ importFrom(methods,show)
 importFrom(rlang,.data)
 importFrom(tibble,as_tibble)
 importFrom(tibble,tibble)
+importFrom(tidyr,unnest)
+importFrom(tidyselect,eval_select)

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))
          )
          )
 

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)
+}

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)
 }
-

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)
+}

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)
+}

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)
+}

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

R/reexports.R

@@ -47,11 +47,26 @@ dplyr::summarise
 ##' @export
 dplyr::summarize
 
-
 ##' @importFrom dplyr full_join
 ##' @export
 dplyr::full_join
 
 ##' @importFrom rlang .data
 ##' @export
 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

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)
+}

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)
+}