diff --git a/DESCRIPTION b/DESCRIPTION index a920bd2d..26123e9e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -30,7 +30,9 @@ Imports: tidyr, htmltools, jsonlite, - igraph + igraph, + ggdendro, + ape Suggests: knitr, rmarkdown diff --git a/NAMESPACE b/NAMESPACE index 5e4b45b7..1e0adabe 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -3,6 +3,7 @@ S3method(hchart,acf) S3method(hchart,character) S3method(hchart,default) +S3method(hchart,dendrogram) S3method(hchart,dist) S3method(hchart,factor) S3method(hchart,forecast) @@ -10,6 +11,7 @@ S3method(hchart,histogram) S3method(hchart,igraph) S3method(hchart,mts) S3method(hchart,numeric) +S3method(hchart,phylo) S3method(hchart,stl) S3method(hchart,ts) S3method(hchart,xts) @@ -108,6 +110,7 @@ importFrom(dplyr,rename_) importFrom(dplyr,select) importFrom(dplyr,select_) importFrom(dplyr,tbl_df) +importFrom(ggdendro,dendro_data) importFrom(grDevices,col2rgb) importFrom(grDevices,colorRampPalette) importFrom(graphics,hist) @@ -118,12 +121,16 @@ importFrom(htmlwidgets,createWidget) importFrom(htmlwidgets,shinyRenderWidget) importFrom(htmlwidgets,shinyWidgetOutput) importFrom(htmlwidgets,sizingPolicy) +importFrom(igraph,"V<-") +importFrom(igraph,V) importFrom(igraph,get.edge.attribute) importFrom(igraph,get.edgelist) importFrom(igraph,get.vertex.attribute) +importFrom(igraph,graph.edgelist) importFrom(igraph,layout_nicely) importFrom(jsonlite,toJSON) importFrom(magrittr,"%>%") +importFrom(purrr,by_row) importFrom(purrr,map) importFrom(purrr,map2) importFrom(purrr,map_df) diff --git a/R/hchart.R b/R/hchart.R index 4128a6ed..05fd4beb 100644 --- a/R/hchart.R +++ b/R/hchart.R @@ -369,6 +369,60 @@ hchart.igraph <- function(object, ..., layout = layout_nicely, digits = 2) { } +# @importFrom ape as.igraph.phylo +#' @importFrom igraph graph.edgelist V V<- +#' @export +hchart.phylo <- function(object, ...) { + + x <- object + if (is.null(x$node.label)) + x <- makeNodeLabel(x) + x$edge <- matrix(c(x$tip.label, x$node.label)[x$edge], ncol = 2) + + object <- graph.edgelist(x$edge) + # object <- as.igraph.phylo(object) + + V(object)$size <- ifelse(str_detect(V(object)$name, "Node\\d+"), 0, 1) + + hchart(object, minSize = 0, ...) + +} + +#' @importFrom ggdendro dendro_data +#' @importFrom purrr by_row +#' @export +hchart.dendrogram <- function(object, ...) { + + dddata <- dendro_data(object) + + dsseg <- dddata$segments %>% + mutate(x = x - 1, xend = xend - 1) %>% + by_row(function(x){ + list(list(x = x$x, y = x$y), list(x = x$xend, y = x$yend)) + }, .to = "out") %>% + .[["out"]] + + hc <- highchart() %>% + hc_plotOptions( + series = list( + lineWidth = 2, + showInLegend = FALSE, + marker = list(radius = 0), + enableMouseTracking = FALSE + ) + ) %>% + hc_xAxis(categories = dddata$labels$label, + tickmarkPlacement = "on") %>% + hc_colors(list(hex_to_rgba("#606060"))) + + for (i in seq_along(dsseg)) { + hc <- hc %>% hc_add_series(data = dsseg[[i]], type = "scatter") + } + + hc +} + + # # @export # hchart.seas <- function(object, ..., outliers = TRUE, trend = FALSE) { # diff --git a/devscripts/test-dendro.R b/devscripts/test-dendro.R index d2888119..81f07a64 100644 --- a/devscripts/test-dendro.R +++ b/devscripts/test-dendro.R @@ -3,42 +3,52 @@ library("highcharter") library("ggdendro") library("dplyr") -dd <- iris[, -5] %>% dist %>% hclust %>% as.dendrogram() -dd <- mtcars %>% dist %>% hclust %>% as.dendrogram() -plot(dd) -dddata <- dendro_data(dd) +x <- iris[, -5] %>% dist %>% hclust %>% as.dendrogram() +x <- mtcars %>% dist %>% hclust %>% as.dendrogram() -by_row2 <- function(.d, .f, ...) { - purrr::by_row(.d, .f, ..., .to = "out")[["out"]] -} +hchart(as.dendrogram(hclust(dist(mtcars)))) -dsseg <- dddata$segments %>% - mutate(x = x - 1, xend = xend - 1) %>% - by_row2(function(x){ - list(list(x = x$x, y = x$y), list(x = x$xend, y = x$yend)) - }) - - -hc <- highchart() %>% - hc_plotOptions( - series = list( - lineWidth = 2, - showInLegend = FALSE, - marker = list(radius = 0), - enableMouseTracking = FALSE - ) - ) %>% - hc_xAxis(categories = dddata$labels$label, - tickmarkPlacement = "on") %>% - hc_colors(list(hex_to_rgba("#606060"))) - -for (i in seq_along(dsseg)) { - hc <- hc %>% hc_add_series(data = dsseg[[i]], type = "scatter") +attr(x, "class") <- "dendrogram" +class(x) +plot(x) +hchart(x) +highcharter:::hchart.dendrogram(x) +hc <- hchart(x) +#' @importFrom ggdendro dendro_data +hchart.dendrogram <- function(x, ...) { + dddata <- dendro_data(x) + + by_row2 <- function(.d, .f, ...) { + purrr::by_row(.d, .f, ..., .to = "out")[["out"]] + } + + dsseg <- dddata$segments %>% + mutate(x = x - 1, xend = xend - 1) %>% + by_row2(function(x){ + list(list(x = x$x, y = x$y), list(x = x$xend, y = x$yend)) + }) + + hc <- highchart() %>% + hc_plotOptions( + series = list( + lineWidth = 2, + showInLegend = FALSE, + marker = list(radius = 0), + enableMouseTracking = FALSE + ) + ) %>% + hc_xAxis(categories = dddata$labels$label, + tickmarkPlacement = "on") %>% + hc_colors(list(hex_to_rgba("#606060"))) + + for (i in seq_along(dsseg)) { + hc <- hc %>% hc_add_series(data = dsseg[[i]], type = "scatter") + } + + hc } -hc - hc %>% hc_chart(type = "column") @@ -50,8 +60,7 @@ hc %>% hc_chart(type = "bar") %>% hc_yAxis(reversed = TRUE) %>% hc_xAxis(opposite = TRUE, tickLength = 0) -hc %>% hc_chart(polar = TRUE) %>% - hc_yAxis(reversed = TRUE, visible = FALSE) %>% - hc_xAxis(gridLineWidth = 0, - lineWidth = 0) +Shc %>% hc_chart(polar = TRUE) %>% + hc_yAxis(reversed = TRUE, visible = TRUE) %>% + hc_xAxis(gridLineWidth = 0, lineWidth = 0) diff --git a/devscripts/test-igraph.R b/devscripts/test-igraph.R index fe17d3b6..33451a4a 100644 --- a/devscripts/test-igraph.R +++ b/devscripts/test-igraph.R @@ -50,6 +50,7 @@ V(net)$degree <- degree(net, mode = "all")*3 V(net)$betweenness <- betweenness(net) V(net)$color <- colorize_vector(V(net)$betweenness) V(net)$size <- sqrt(V(net)$degree) +V(net)$label <- seq_along(V(net)$size) hchart(net, minSize = 5, maxSize = 20) set.seed(10) @@ -61,8 +62,8 @@ library("stringr") library("purrr") library("resolution") -net <- #"http://media.moviegalaxies.com/gexf/316.gexf" %>% - "http://media.moviegalaxies.com/gexf/92.gexf" %>% +net <- "http://media.moviegalaxies.com/gexf/316.gexf" %>% + # "http://media.moviegalaxies.com/gexf/92.gexf" %>% read_lines() %>% read.gexf() %>% gexf.to.igraph() diff --git a/devscripts/test-phylo.R b/devscripts/test-phylo.R new file mode 100644 index 00000000..d6f21ba9 --- /dev/null +++ b/devscripts/test-phylo.R @@ -0,0 +1,24 @@ +library("ape") +library("igraph") +library("highcharter") + + +object <- as.phylo(hclust(dist(mtcars))) +class(object) +plot(object) +hchart(object) + + +hchart.phylo <- function(object, ...) { + + object <- as.igraph(object) + + V(object)$size <- ifelse(str_detect(V(object)$name, "Node\\d+"), 0, 1) + + hchart(object, minSize = 0) + +} + +tr <- rcoal(5) +(x <- evonet(tr, 6:7, 8:9)) +plot(x)