📖 treeNetwork doc improvements

O-mics · Jun 17, 2017 · de203db · de203db
1 parent f9c30ba
commit de203db
Show file tree

Hide file tree

Showing 8 changed files with 177 additions and 71 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -3,8 +3,8 @@ Type: Package
 Title: D3 JavaScript Network Graphs from R
 Description: Creates 'D3' 'JavaScript' network, tree, dendrogram, and Sankey
     graphs from 'R'.
-Version: 0.4
-Date: 2017-03-18
+Version: 0.5
+Date: 2017-06-17
 Authors@R: c(
     person("J.J.", "Allaire", role = "aut"),
     person("Peter", "Ellis", role = "ctb"),
@@ -26,8 +26,10 @@ Depends:
 Imports:
     htmlwidgets (>= 0.3.2),
     igraph,
-    magrittr
+    magrittr,
+    tibble
 Suggests:
+    data.tree,
     htmltools (>= 0.2.6),
     jsonlite,
 Enhances: knitr, shiny

diff --git a/NAMESPACE b/NAMESPACE
@@ -1,15 +1,15 @@
 # Generated by roxygen2: do not edit by hand
 
-S3method(as.treenetdf,Node)
-S3method(as.treenetdf,data.frame)
-S3method(as.treenetdf,hclust)
-S3method(as.treenetdf,igraph)
-S3method(as.treenetdf,list)
-S3method(as.treenetdf,phylo)
-S3method(as.treenetdf,tbl_graph)
+S3method(as_treenetdf,Node)
+S3method(as_treenetdf,data.frame)
+S3method(as_treenetdf,hclust)
+S3method(as_treenetdf,igraph)
+S3method(as_treenetdf,list)
+S3method(as_treenetdf,phylo)
+S3method(as_treenetdf,tbl_graph)
 export(JS)
 export(as.radialNetwork)
-export(as.treenetdf)
+export(as_treenetdf)
 export(chordNetwork)
 export(chordNetworkOutput)
 export(dendroNetwork)
@@ -47,5 +47,6 @@ importFrom(igraph,membership)
 importFrom(igraph,simplify)
 importFrom(magrittr,"%>%")
 importFrom(stats,as.dendrogram)
+importFrom(stats,na.exclude)
 importFrom(stats,setNames)
 importFrom(utils,modifyList)
diff --git a/R/as.treenetdf.R → R/as_treenetdf.R b/R/as.treenetdf.R → R/as_treenetdf.R
@@ -9,46 +9,50 @@
 
 
 #########################################################################
-# as.treenetdf
+#' Convert an object to a \code{treenetdf}
+#' 
+#' @param data an object to convert to \code{treenetdf}.
+#' 
 #' @export
-as.treenetdf <- function(data = NULL, ...) {
-  UseMethod("as.treenetdf")
+as_treenetdf <- function(data = NULL, ...) {
+  UseMethod("as_treenetdf")
 }
 
 #########################################################################
 # hclust_to_treenetdf
 #' @export
-as.treenetdf.hclust <- function(data, ...) {
+as_treenetdf.hclust <- function(data, ...) {
   clustparents <-
     unlist(sapply(seq_along(data$height), function(i) {
       parent <- which(i == data$merge)
-      parent <- ifelse(parent > nrow(data$merge), parent - nrow(data$merge), parent)
+      parent <- ifelse(parent > nrow(data$merge), parent - nrow(data$merge), 
+                       parent)
       as.integer(ifelse(length(parent) == 0, NA_integer_, parent))
     }))
-  
+
   leaveparents <-
     unlist(sapply(seq_along(data$labels), function(i) {
       parent <- which(i * -1 == data$merge)
       parent <- ifelse(parent > nrow(data$merge), parent - nrow(data$merge), parent)
       as.integer(ifelse(length(parent) == 0, NA, parent))
     }))
-  
-  df <- 
+
+  df <-
     data.frame(
       nodeId = 1:(length(data$height) + length(data$labels)),
       parentId = c(clustparents, leaveparents),
       name = c(rep('', length(data$height)), data$labels),
       height = c(data$height, rep(0, length(data$labels)))
     )
-  
+
   if (require('tibble')) { return(tibble::as.tibble(df)) }
   return(df)
 }
 
 #########################################################################
 # nestedlist_to_treenetdf
 #' @export
-as.treenetdf.list <- function(data=NULL, children_name = 'children', node_name = 'name', ...) {
+as_treenetdf.list <- function(data=NULL, children_name = 'children', node_name = 'name', ...) {
   makelistofdfs <- function(data) {
     children <- data[[children_name]]
     children <-
@@ -65,14 +69,14 @@ as.treenetdf.list <- function(data=NULL, children_name = 'children', node_name =
         }
         return(child)
       })
-    
+
     if (length(children) == 0)
       return(list(data[names(data)[!names(data) %in% children_name]]))
-    
+
     c(list(data[names(data)[!names(data) %in% children_name]]),
       unlist(recursive = F, lapply(children, makelistofdfs)))
   }
-  
+
   listoflists <- makelistofdfs(data)
   col_names <- unique(unlist(sapply(listoflists, names)))
   matrix <-
@@ -85,42 +89,49 @@ as.treenetdf.list <- function(data=NULL, children_name = 'children', node_name =
         })
       )
     })
-  
+
   df <- data.frame(matrix, stringsAsFactors = F)
   df$nodeId[is.na(df$nodeId)] <- df[[node_name]][is.na(df$nodeId)]
-  
+
   if (require('tibble')) { return(tibble::as.tibble(df)) }
   return(df)
 }
 
 
 #########################################################################
 # Node_to_treenetdf
+# 
+# @importFrom data.tree ToDataFrameNetwork
+# @importFrom tibble as.tibble
+# 
 #' @export
-as.treenetdf.Node <-  function(data = NULL, ...) {
-  require(data.tree)
-  df <- do.call(data.tree::ToDataFrameNetwork, c(data, direction = 'descend', data$fieldsAll))
+as_treenetdf.Node <-  function(data = NULL, ...) {
+  df <- do.call(data.tree::ToDataFrameNetwork,
+                c(data, direction = 'descend', data$fieldsAll))
   names(df)[1:2] <- c('nodeId', 'parentId')
   rootId <- unique(df$parentId[! df$parentId %in% df$nodeId])
   df <- rbind(c(nodeId = rootId, parentId = NA, rep(NA, ncol(df) - 2)), df)
   df$name <- df$nodeId
-  
+
   if (require('tibble')) { return(tibble::as.tibble(df)) }
   return(df)
 }
 
 #########################################################################
 # phylo_to_treenetdf
+# 
+# @importFrom tibble as.tibble
 #' @export
-as.treenetdf.phylo <- function(data = NULL, ...) {
+
+as_treenetdf.phylo <- function(data = NULL, ...) {
   df <- data.frame(nodeId = data$edge[, 2],
                    parentId = data$edge[, 1],
                    name = data$tip.label[data$edge[, 2]],
                    depth = data$edge.length,
                    stringsAsFactors = F)
   rootId <- unique(df$parentId[! df$parentId %in% df$nodeId])
   df <- rbind(c(nodeId = rootId, parentId = NA, name = NA, depth = 1), df)
-  
+
   if (require('tibble')) { return(tibble::as.tibble(df)) }
   return(df)
 }
@@ -130,22 +141,26 @@ as.treenetdf.phylo <- function(data = NULL, ...) {
 #########################################################################
 # tbl_graph_to_treenetdf
 #' @export
-as.treenetdf.tbl_graph <- function(data = NULL, ...) {
-  as.treenetdf.igraph(data)
+as_treenetdf.tbl_graph <- function(data = NULL, ...) {
+  as_treenetdf.igraph(data)
 }
 
 #########################################################################
 # igraph_to_treenetdf
+# 
+# @importFrom igraph as_data_frame
+# 
 #' @export
-as.treenetdf.igraph <- function(data = NULL, root = 'root', ...) {
-  require(igraph)
+as_treenetdf.igraph <- function(data = NULL, root = 'root', ...) {
   df <- igraph::as_data_frame(data)
   names(df)[1:2] <- c('nodeId', 'parentId')
   rootId <- unique(df$parentId[! df$parentId %in% df$nodeId])
   if (length(rootId) > 1) {
     rootdf <- Reduce(function(x, y) {
-      rbind(x, c(nodeId = y, parentId = root, setNames(rep(NA, length(names(df)) - 2), names(df)[-(1:2)])))
-    }, rootId, c(nodeId = root, parentId = NA, setNames(rep(NA, length(names(df)) - 2), names(df)[-(1:2)])))
+      rbind(x, c(nodeId = y, parentId = root, 
+                 setNames(rep(NA, length(names(df)) - 2), names(df)[-(1:2)])))
+    }, rootId, c(nodeId = root, parentId = NA, 
+                 setNames(rep(NA, length(names(df)) - 2), names(df)[-(1:2)])))
     df <- rbind(rootdf, df, stringsAsFactors = F, make.row.names = F)
     df$name <- df$nodeId
     df$name[1] <- NA
@@ -154,7 +169,7 @@ as.treenetdf.igraph <- function(data = NULL, root = 'root', ...) {
     df <- rbind(rootdf, df, stringsAsFactors = F, make.row.names = F)
     df$name <- df$nodeId
   }
-  
+
   if (require('tibble')) { return(tibble::as.tibble(df)) }
   return(df)
 }
@@ -163,16 +178,19 @@ as.treenetdf.igraph <- function(data = NULL, root = 'root', ...) {
 #########################################################################
 # data.frame_to_treenetdf
 #' @export
-as.treenetdf.data.frame <- function(data = NULL, cols = setNames(names(data), names(data)), dftype = 'treenetdf', subset = names(data), root = NULL, ...) {
+as_treenetdf.data.frame <- function(data = NULL, 
+                                    cols = setNames(names(data), names(data)), 
+                                    dftype = 'treenetdf', subset = names(data), 
+                                    root = NULL, ...) {
   if (dftype == 'treenetdf') {
     # convert custom column names to native names
     cols <- cols[cols %in% names(data)]  # only use custom names that exist in data
     namestoswitch <- names(data) %in% cols
     names(data)[namestoswitch] <- names(cols)[match(names(data)[namestoswitch], cols)]
-    
+
     if (require('tibble')) { return(tibble::as.tibble(data)) }
     return(data)
-    
+
   } else if (dftype == 'leafpathdf') {
     # get root name from name of passed data.frame, even if it was subset in the
     # argument, unless explicitly set
@@ -182,27 +200,28 @@ as.treenetdf.data.frame <- function(data = NULL, cols = setNames(names(data), na
         root <- root[2]
       }
     }
-    
+
     # subset the data by cols (default, same as it is)
     data <- data[, subset]
-    
+
     # add a root col if necessary, otherwise reset root from the data
     if (length(unique(data[[1]])) != 1) {
       data <- data.frame(root, data, stringsAsFactors = F)
     } else {
       root <- unique(data[[1]])
     }
-    
+
     nodelist <-
       c(setNames(root, root),
         unlist(
           sapply(2:ncol(data), function(i) {
             subdf <- unique(data[, 1:i])
-            sapply(1:nrow(subdf), function(i) setNames(paste(subdf[i, ], collapse = '::'), rev(subdf[i, ])[1]))
+            sapply(1:nrow(subdf), function(i) 
+              setNames(paste(subdf[i, ], collapse = '::'), rev(subdf[i, ])[1]))
           })
         )
       )
-    
+
     nodeId <- seq_along(nodelist)
     name <- names(nodelist)
     parentId <-
@@ -215,41 +234,48 @@ as.treenetdf.data.frame <- function(data = NULL, cols = setNames(names(data), na
           nodelist
         )
       )
-    
+
     if (require('tibble')) {
       return(tibble::tibble(nodeId = nodeId, parentId = parentId, name = name))
     }
-    return(data.frame(nodeId = nodeId, parentId = parentId, name = name, stringsAsFactors = F))
+    return(data.frame(nodeId = nodeId, parentId = parentId, name = name, 
+                      stringsAsFactors = F))
   }
 }
 
 
 
 #########################################################################
-# treenetdf_to_nestedlist
-
-treenetdf_to_nestedlist <- function(df, id_col = 'nodeId', parent_col = 'parentId') {
-  stopifnot(anyDuplicated(df[[id_col]]) == 0)  # no duplicate nodeId's
-  stopifnot(!any(df[[id_col]] == df[[parent_col]], na.rm = T))  # no self-referential nodes
-  stopifnot(all(na.exclude(df[[parent_col]]) %in% df[[id_col]]))  # no unidentified parent nodes
+#' Convert a treenet to a nested list
+#'
+#' @param df a \code{treenetdf} to convert to a nested list
+#' @param id_col character string indicating the node ID in \code{df}
+#' @param parent_col character string indicating the parent ID in \code{df} 
+#'
+#' @importFrom stats na.exclude
 
-  if (sum(is.na(df[[parent_col]])) != 1) {  # mutliple roots or no root
-    stop('mutliple or no roots')
-    # potentially add a root to df and continue
-  }
+treenetdf_to_nestedlist <- function(df, id_col = 'nodeId',
+                                    parent_col = 'parentId') {
+    stopifnot(anyDuplicated(df[[id_col]]) == 0)  # no duplicate nodeId's
+    stopifnot(!any(df[[id_col]] == df[[parent_col]], na.rm = T))  # no self-referential nodes
+    stopifnot(all(na.exclude(df[[parent_col]]) %in% df[[id_col]]))  # no unidentified parent nodes
 
-  rootid <- df[is.na(df[[parent_col]]), id_col]
+    if (sum(is.na(df[[parent_col]])) != 1) {  # mutliple roots or no root
+        stop('mutliple or no roots')
+        # potentially add a root to df and continue
+    }
 
-  makelist <- function(nodeid) {
-    i <- which(df[[id_col]] == nodeid)
-    child_ids <- df[[id_col]][which(df[[parent_col]] == nodeid)]
+    rootid <- df[is.na(df[[parent_col]]), id_col]
 
-    if (length(child_ids) == 0)
-      return(as.list(df[i, ]))
+    makelist <- function(nodeid) {
+        i <- which(df[[id_col]] == nodeid)
+        child_ids <- df[[id_col]][which(df[[parent_col]] == nodeid)]
 
-    c(as.list(df[i, ]),
-      children = list(lapply(child_ids, makelist)))
-  }
+        if (length(child_ids) == 0)
+            return(as.list(df[i, ]))
 
-  makelist(rootid)
+        c(as.list(df[i, ]),
+        children = list(lapply(child_ids, makelist)))
+    }
+    makelist(rootid)
 }
diff --git a/R/treeNetwork.R b/R/treeNetwork.R
@@ -12,7 +12,7 @@ treeNetwork <- function(data, width = NULL, height = NULL, elementId = NULL,
                         inbrowser = FALSE, ...) {
 
   # convert to the native data format
-  data <- as.treenetdf(data, ...)
+  data <- as_treenetdf(data, ...)
 
   default <- function(defaults = NULL) {
     defaults_ <-
@@ -80,7 +80,8 @@ treeNetwork <- function(data, width = NULL, height = NULL, elementId = NULL,
 #'
 #' @export
 treeNetworkOutput <- function(outputId, width = '100%', height = '400px'){
-  htmlwidgets::shinyWidgetOutput(outputId, 'treeNetwork', width, height, package = 'networkD3')
+  htmlwidgets::shinyWidgetOutput(outputId, 'treeNetwork', width, height, 
+                                 package = 'networkD3')
 }
 
 #' @rdname treeNetwork-shiny

diff --git a/man/as_treenetdf.Rd b/man/as_treenetdf.Rd