From 7028c19ad6db2a7911854ae83415cd28226bf2ab Mon Sep 17 00:00:00 2001 From: "tuskan.net@gmail.com" Date: Mon, 9 Apr 2018 01:29:04 -0300 Subject: [PATCH 1/2] User Input Mouse Callback Function --- DESCRIPTION | 4 +- NAMESPACE | 3 + R/as_treenetdf.R | 385 +++++++++++++++++-------------- R/chordNetwork.R | 131 ++++++----- R/data-definitions.R | 2 +- R/dendroNetwork.R | 199 ++++++++-------- R/diagonalNetwork.R | 92 ++++---- R/forceNetwork.R | 253 +++++++++++++------- R/radialNetwork.R | 103 +++++---- R/sankeyNetwork.R | 136 ++++++----- R/saveNetwork.R | 2 +- R/simpleNetwork.R | 90 ++++---- R/treeNetwork.R | 53 +++-- R/utils.R | 193 +++++++++------- inst/examples/examples.R | 10 +- inst/htmlwidgets/forceNetwork.js | 83 ++----- man/as_treenetdf.Rd | 4 +- man/chordNetwork.Rd | 16 +- man/diagonalNetwork.Rd | 2 +- man/forceNetwork.Rd | 40 ++-- man/labelScaleEffect.Rd | 22 ++ man/networkD3-shiny.Rd | 2 +- man/nodeSizeEffect.Rd | 16 ++ man/radialNetwork.Rd | 2 +- man/unFocusOtherLinks.Rd | 26 +++ 25 files changed, 1046 insertions(+), 823 deletions(-) create mode 100644 man/labelScaleEffect.Rd create mode 100644 man/nodeSizeEffect.Rd create mode 100644 man/unFocusOtherLinks.Rd diff --git a/DESCRIPTION b/DESCRIPTION index f5378ca6..2b1ce252 100644 --- 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.9000 -Date: 2017-06-18 +Version: 0.5 +Date: 2018-04-08 Authors@R: c( person("J.J.", "Allaire", role = "aut"), person("Peter", "Ellis", role = "ctb"), diff --git a/NAMESPACE b/NAMESPACE index d017f025..84b621e4 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -19,6 +19,8 @@ export(diagonalNetworkOutput) export(forceNetwork) export(forceNetworkOutput) export(igraph_to_networkD3) +export(labelScaleEffect) +export(nodeSizeEffect) export(radialNetwork) export(radialNetworkOutput) export(renderDendroNetwork) @@ -36,6 +38,7 @@ export(simpleNetwork) export(simpleNetworkOutput) export(treeNetwork) export(treeNetworkOutput) +export(unFocusOtherLinks) importFrom(data.tree,ToDataFrameNetwork) importFrom(htmlwidgets,createWidget) importFrom(htmlwidgets,shinyRenderWidget) diff --git a/R/as_treenetdf.R b/R/as_treenetdf.R index 580bc782..1bcaf346 100644 --- a/R/as_treenetdf.R +++ b/R/as_treenetdf.R @@ -28,7 +28,7 @@ #' - igraph #' - ape `phylo` #' -#' @examples +#' @examples #' links <- read.csv(header = TRUE, stringsAsFactors = FALSE, text = ' #' source,target,name #' 1,,one @@ -39,10 +39,10 @@ #' 6,2,six #' 7,2,seven #' 8,6,eight') -#' +#' #' # Convert data #' as_treenetdf(links, cols = c(nodeId = 'source', parentId = 'target')) -#' +#' #' # Graph (calls as_treenetdf internally) #' treeNetwork(links, cols = c(nodeId = 'source', parentId = 'target')) #' @@ -56,7 +56,7 @@ #' as_treenetdf <- function(data = NULL, ...) { - UseMethod("as_treenetdf") + UseMethod("as_treenetdf") } ######################################################################### @@ -68,32 +68,33 @@ as_treenetdf <- function(data = NULL, ...) { #' @export 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) - 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 <- - 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))) - ) + 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 + ) + 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 <- + 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 (pkg_installed('tibble')) return(tibble::as.tibble(df)) - return(df) + if (pkg_installed("tibble")) return(tibble::as.tibble(df)) + return(df) } ######################################################################### @@ -107,51 +108,57 @@ as_treenetdf.hclust <- function(data, ...) { #' @param ... arguments to pass to methods. #' #' @export -as_treenetdf.list <- function(data, children_name = 'children', - node_name = 'name', ...) { - makelistofdfs <- function(data) { - children <- data[[children_name]] - children <- - lapply(children, function(child) { - if ('parentId' %in% names(data)) { - child$parentId <- paste0(data$parentId, ':', data[[node_name]]) - } else { - child$parentId <- data[[node_name]] - } - if ('nodeId' %in% names(data)) { - child$nodeId <- paste0(data$nodeId, ':', child[[node_name]]) - } else { - child$nodeId <- paste0(data[[node_name]], ':', - child[[node_name]]) - } - return(child) - }) - - if (length(children) == 0) - return(list(data[names(data)[!names(data) %in% children_name]])) +as_treenetdf.list <- function(data, children_name = "children", + node_name = "name", ...) { + makelistofdfs <- function(data) { + children <- data[[children_name]] + children <- + lapply(children, function(child) { + if ("parentId" %in% names(data)) { + child$parentId <- paste0(data$parentId, ":", data[[node_name]]) + } else { + child$parentId <- data[[node_name]] + } + if ("nodeId" %in% names(data)) { + child$nodeId <- paste0(data$nodeId, ":", child[[node_name]]) + } else { + child$nodeId <- paste0( + data[[node_name]], ":", + child[[node_name]] + ) + } + return(child) + }) - c(list(data[names(data)[!names(data) %in% children_name]]), - unlist(recursive = FALSE, lapply(children, makelistofdfs))) + if (length(children) == 0) { + return(list(data[names(data)[!names(data) %in% children_name]])) } - listoflists <- makelistofdfs(data) - col_names <- unique(unlist(sapply(listoflists, names))) - matrix <- - sapply(col_names, function(col_name) { - unlist( - sapply(listoflists, function(x) { - ifelse(col_name %in% names(x), - x[col_name], - list(col_name = NA)) - }) - ) + c( + list(data[names(data)[!names(data) %in% children_name]]), + unlist(recursive = FALSE, lapply(children, makelistofdfs)) + ) + } + + listoflists <- makelistofdfs(data) + col_names <- unique(unlist(sapply(listoflists, names))) + matrix <- + sapply(col_names, function(col_name) { + unlist( + sapply(listoflists, function(x) { + ifelse(col_name %in% names(x), + x[col_name], + list(col_name = NA) + ) + }) + ) }) - df <- data.frame(matrix, stringsAsFactors = F) - df$nodeId[is.na(df$nodeId)] <- df[[node_name]][is.na(df$nodeId)] + df <- data.frame(matrix, stringsAsFactors = F) + df$nodeId[is.na(df$nodeId)] <- df[[node_name]][is.na(df$nodeId)] - if (pkg_installed('tibble')) return(tibble::as.tibble(df)) - return(df) + if (pkg_installed("tibble")) return(tibble::as.tibble(df)) + return(df) } @@ -164,16 +171,18 @@ as_treenetdf.list <- function(data, children_name = 'children', # @importFrom data.tree ToDataFrameNetwork # #' @export -as_treenetdf.Node <- function(data, ...) { - 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 (pkg_installed('tibble')) return(tibble::as.tibble(df)) - return(df) +as_treenetdf.Node <- function(data, ...) { + 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 (pkg_installed("tibble")) return(tibble::as.tibble(df)) + return(df) } ######################################################################### @@ -185,34 +194,42 @@ as_treenetdf.Node <- function(data, ...) { #' @export as_treenetdf.phylo <- function(data, ...) { - df <- data.frame(nodeId = data$edge[, 2], - parentId = data$edge[, 1], - name = data$tip.label[data$edge[, 2]], - edge.length = data$edge.length, - depth = NA, - stringsAsFactors = FALSE) - - rootId <- unique(df$parentId[! df$parentId %in% df$nodeId]) - - calc_height <- function(parentId) { - childIdxs <- df$parentId == parentId - childIds <- df$nodeId[childIdxs] - - parentHeight <- df$depth[df$nodeId == parentId] - if (length(parentHeight) == 0) { parentHeight <- 0 } - df$depth[childIdxs] <<- df$edge.length[childIdxs] + parentHeight - - if (length(childIds) > 0) { lapply(childIds, calc_height) } - invisible(df) + df <- data.frame( + nodeId = data$edge[, 2], + parentId = data$edge[, 1], + name = data$tip.label[data$edge[, 2]], + edge.length = data$edge.length, + depth = NA, + stringsAsFactors = FALSE + ) + + rootId <- unique(df$parentId[!df$parentId %in% df$nodeId]) + + calc_height <- function(parentId) { + childIdxs <- df$parentId == parentId + childIds <- df$nodeId[childIdxs] + + parentHeight <- df$depth[df$nodeId == parentId] + if (length(parentHeight) == 0) { + parentHeight <- 0 } - df <- calc_height(rootId) - - df$height <- max(df$depth) - df$depth - df <- rbind(c(nodeId = rootId, parentId = NA, name = NA, edge.length = 0, - depth = 0, height = max(df$depth)), df) + df$depth[childIdxs] <<- df$edge.length[childIdxs] + parentHeight - if (pkg_installed('tibble')) return(tibble::as.tibble(df)) - return(df) + if (length(childIds) > 0) { + lapply(childIds, calc_height) + } + invisible(df) + } + df <- calc_height(rootId) + + df$height <- max(df$depth) - df$depth + df <- rbind(c( + nodeId = rootId, parentId = NA, name = NA, edge.length = 0, + depth = 0, height = max(df$depth) + ), df) + + if (pkg_installed("tibble")) return(tibble::as.tibble(df)) + return(df) } ######################################################################### @@ -224,7 +241,7 @@ as_treenetdf.phylo <- function(data, ...) { #' @export as_treenetdf.tbl_graph <- function(data, ...) { - as_treenetdf.igraph(data) + as_treenetdf.igraph(data) } ######################################################################### @@ -238,28 +255,36 @@ as_treenetdf.tbl_graph <- function(data, ...) { #' @importFrom igraph as_data_frame #' #' @export -as_treenetdf.igraph <- function(data, 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)]))) - df <- rbind(rootdf, df, stringsAsFactors = F, make.row.names = FALSE) - df$name <- df$nodeId - df$name[1] <- NA - } else { - rootdf <- c(nodeId = rootId, parentId = NA, rep(NA, ncol(df) - 2)) - df <- rbind(rootdf, df, stringsAsFactors = F, make.row.names = FALSE) - df$name <- df$nodeId - } +as_treenetdf.igraph <- function(data, 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)] + ) + )) + df <- rbind(rootdf, df, stringsAsFactors = F, make.row.names = FALSE) + df$name <- df$nodeId + df$name[1] <- NA + } else { + rootdf <- c(nodeId = rootId, parentId = NA, rep(NA, ncol(df) - 2)) + df <- rbind(rootdf, df, stringsAsFactors = F, make.row.names = FALSE) + df$name <- df$nodeId + } - if (pkg_installed('tibble')) { return(tibble::as.tibble(df)) } - return(df) + if (pkg_installed("tibble")) { + return(tibble::as.tibble(df)) + } + return(df) } @@ -283,30 +308,33 @@ as_treenetdf.igraph <- function(data, root = 'root', ...) { as_treenetdf.data.frame <- function(data, cols = setNames(names(data), names(data)), - df_type = 'treenetdf', subset = names(data), + df_type = "treenetdf", subset = names(data), root, ...) { - if (df_type == '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 (nrow(na.omit(data[-1, ])) < nrow(data[-1, ])) # assumes root is in first row - warning("Missing values found in data. May cause graph to fail.", - call. = FALSE) - - if (pkg_installed('tibble')) return(tibble::as.tibble(data)) - return(data) - - } else if (df_type == 'leafpathdf') { - # get root name from name of passed data.frame, even if it was subset in the - # argument, unless explicitly set - if (missing(root)) { - root <- all.names(substitute(data)) - if (length(root) > 1) { - root <- root[2] - } + if (df_type == "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 (nrow(na.omit(data[-1, ])) < nrow(data[-1, ])) { # assumes root is in first row + warning("Missing values found in data. May cause graph to fail.", + call. = FALSE + ) + } + + if (pkg_installed("tibble")) return(tibble::as.tibble(data)) + return(data) + } else if (df_type == "leafpathdf") { + # get root name from name of passed data.frame, even if it was subset in the + # argument, unless explicitly set + if (missing(root)) { + root <- all.names(substitute(data)) + if (length(root) > 1) { + root <- root[2] + } } # subset the data by cols (default, same as it is) @@ -314,40 +342,49 @@ as_treenetdf.data.frame <- function(data, # 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) + data <- data.frame(root, data, stringsAsFactors = F) } else { - root <- unique(data[[1]]) + 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])) - }) - ) + 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] + )) + }) ) + ) nodeId <- seq_along(nodelist) name <- names(nodelist) parentId <- - c(NA_integer_, - match( - sapply(nodelist[-1], function(x) { - elms <- strsplit(x, '::')[[1]] - paste(elms[1:max(length(elms) - 1)], collapse = '::') - }), - nodelist - ) - ) + c( + NA_integer_, + match( + sapply(nodelist[-1], function(x) { + elms <- strsplit(x, "::")[[1]] + paste(elms[1:max(length(elms) - 1)], collapse = "::") + }), + nodelist + ) + ) - if (pkg_installed('tibble')) - return(tibble::tibble(nodeId = nodeId, parentId = parentId, - name = name)) - return(data.frame(nodeId = nodeId, parentId = parentId, name = name, - stringsAsFactors = F)) + if (pkg_installed("tibble")) { + return(tibble::tibble( + nodeId = nodeId, parentId = parentId, + name = name + )) } + return(data.frame( + nodeId = nodeId, parentId = parentId, name = name, + stringsAsFactors = F + )) + } } diff --git a/R/chordNetwork.R b/R/chordNetwork.R index 971e93fc..7ba723d4 100644 --- a/R/chordNetwork.R +++ b/R/chordNetwork.R @@ -6,7 +6,7 @@ #' \code{NULL} then height is automatically determined based on context) #' @param width numeric width for the network graph's frame area in pixels (if #' \code{NULL} then width is automatically determined based on context) -#' @param initialOpacity specify the opacity before the user mouses over +#' @param initialOpacity specify the opacity before the user mouses over #' the link #' @param colourScale specify the hexadecimal colours in which to display #' the different categories. If there are fewer colours than categories, @@ -25,27 +25,27 @@ #' #' @examples #' \dontrun{ -#' #### Data about hair colour preferences, from +#' #### Data about hair colour preferences, from #' ## https://github.com/mbostock/d3/wiki/Chord-Layout -#' +#' #' hairColourData <- matrix(c(11975, 1951, 8010, 1013, #' 5871, 10048, 16145, 990, #' 8916, 2060, 8090, 940, #' 2868, 6171, 8045, 6907), #' nrow = 4) -#' -#' chordNetwork(Data = hairColourData, -#' width = 500, +#' +#' chordNetwork(Data = hairColourData, +#' width = 500, #' height = 500, -#' colourScale = c("#000000", -#' "#FFDD89", -#' "#957244", +#' colourScale = c("#000000", +#' "#FFDD89", +#' "#957244", #' "#F26223"), #' labels = c("red", "brown", "blond", "gray")) -#' +#' #' } #' -#' @source +#' @source #' #' Mike Bostock: \url{https://github.com/mbostock/d3/wiki/Chord-Layout}. #' @@ -56,33 +56,33 @@ chordNetwork <- function(Data, width = 500, initialOpacity = 0.8, useTicks = 0, - colourScale = c("#1f77b4", - "#aec7e8", - "#ff7f0e", - "#ffbb78", - "#2ca02c", - "#98df8a", - "#d62728", - "#ff9896", - "#9467bd", - "#c5b0d5", - "#8c564b", - "#c49c94", - "#e377c2", - "#f7b6d2", - "#7f7f7f", - "#c7c7c7", - "#bcbd22", - "#dbdb8d", - "#17becf", - "#9edae5"), + colourScale = c( + "#1f77b4", + "#aec7e8", + "#ff7f0e", + "#ffbb78", + "#2ca02c", + "#98df8a", + "#d62728", + "#ff9896", + "#9467bd", + "#c5b0d5", + "#8c564b", + "#c49c94", + "#e377c2", + "#f7b6d2", + "#7f7f7f", + "#c7c7c7", + "#bcbd22", + "#dbdb8d", + "#17becf", + "#9edae5" + ), padding = 0.1, fontSize = 14, fontFamily = "sans-serif", labels = c(), - labelDistance = 30) - -{ + labelDistance = 30) { options <- list( width = width, height = height, @@ -95,57 +95,60 @@ chordNetwork <- function(Data, labels = labels, label_distance = labelDistance ) - - if (!is.matrix(Data) && !is.data.frame(Data)) - { + + if (!is.matrix(Data) && !is.data.frame(Data)) { stop("Data must be of type matrix or data frame") } - - if (nrow(Data) != ncol(Data)) - { + + if (nrow(Data) != ncol(Data)) { stop(paste("Data must have the same number of rows and columns; given ", - nrow(Data), - "rows and", - ncol(Data), - "columns", - sep = " ")) + nrow(Data), + "rows and", + ncol(Data), + "columns", + sep = " " + )) } - - if(length(labels)!=0 && length(labels)!=ncol(Data)){ + + if (length(labels) != 0 && length(labels) != ncol(Data)) { stop(paste("Length of labels vector should be the same as the number of rows")) } - - if (is.data.frame(Data)) - { - Data = data.matrix(Data) + + if (is.data.frame(Data)) { + Data <- data.matrix(Data) } - + # create widget htmlwidgets::createWidget( name = "chordNetwork", x = list(matrix = Data, options = options), width = width, height = height, - htmlwidgets::sizingPolicy(viewer.suppress = TRUE, - browser.fill = TRUE, - browser.padding = 75, - knitr.figure = FALSE, - knitr.defaultWidth = 500, - knitr.defaultHeight = 500), - package = "networkD3") + htmlwidgets::sizingPolicy( + viewer.suppress = TRUE, + browser.fill = TRUE, + browser.padding = 75, + knitr.figure = FALSE, + knitr.defaultWidth = 500, + knitr.defaultHeight = 500 + ), + package = "networkD3" + ) } #' @rdname networkD3-shiny #' @export chordNetworkOutput <- function(outputId, width = "100%", height = "500px") { - shinyWidgetOutput(outputId, "chordNetwork", width, height, - package = "networkD3") + shinyWidgetOutput(outputId, "chordNetwork", width, height, + package = "networkD3" + ) } #' @rdname networkD3-shiny #' @export renderchordNetwork <- function(expr, env = parent.frame(), quoted = FALSE) { - if (!quoted) { expr <- substitute(expr) } # force quoted - shinyRenderWidget(expr, chordNetworkOutput, env, quoted = TRUE) + if (!quoted) { + expr <- substitute(expr) + } # force quoted + shinyRenderWidget(expr, chordNetworkOutput, env, quoted = TRUE) } - diff --git a/R/data-definitions.R b/R/data-definitions.R index 195c5c31..08e7c5dd 100644 --- a/R/data-definitions.R +++ b/R/data-definitions.R @@ -18,7 +18,7 @@ #' Edge list of REF (2014) journal submissions for Politics and International #' Relations -#' +#' #' @format A data set with 2732 rows and 3 variables. #' @source See REF 2014 \url{http://results.ref.ac.uk/DownloadSubmissions/ByUoa/21}. "SchoolsJournals" diff --git a/R/dendroNetwork.R b/R/dendroNetwork.R index bec82c1c..ba51b532 100644 --- a/R/dendroNetwork.R +++ b/R/dendroNetwork.R @@ -55,112 +55,127 @@ #' @export #' dendroNetwork <- function( - hc, - height = 500, - width = 800, - fontSize = 10, - linkColour = "#ccc", - nodeColour = "#fff", - nodeStroke = "steelblue", - textColour = "#111", - textOpacity = 0.9, - textRotate = NULL, - opacity = 0.9, - margins = NULL, - linkType = c("elbow", "diagonal"), - treeOrientation = c("horizontal", "vertical"), - zoom = FALSE) -{ - # validate input - if (length(textColour) == 1L) - textColour = rep(textColour, length(hc$labels)) - if (length(textOpacity) == 1L) - textOpacity = rep(textOpacity, length(hc$labels)) + hc, + height = 500, + width = 800, + fontSize = 10, + linkColour = "#ccc", + nodeColour = "#fff", + nodeStroke = "steelblue", + textColour = "#111", + textOpacity = 0.9, + textRotate = NULL, + opacity = 0.9, + margins = NULL, + linkType = c("elbow", "diagonal"), + treeOrientation = c("horizontal", "vertical"), + zoom = FALSE) { + # validate input + if (length(textColour) == 1L) { + textColour <- rep(textColour, length(hc$labels)) + } + if (length(textOpacity) == 1L) { + textOpacity <- rep(textOpacity, length(hc$labels)) + } - linkType = match.arg(linkType[1], c("elbow", "diagonal")) - treeOrientation = match.arg(treeOrientation[1], - c("horizontal", "vertical")) + linkType <- match.arg(linkType[1], c("elbow", "diagonal")) + treeOrientation <- match.arg( + treeOrientation[1], + c("horizontal", "vertical") + ) - root <- as.dendroNetwork(hc, textColour, textOpacity) + root <- as.dendroNetwork(hc, textColour, textOpacity) - if (treeOrientation == "vertical") - margins_def = list(top = 40, right = 40, bottom = 150, left = 40) - else - margins_def = list(top = 40, right = 150, bottom = 40, left = 40) + if (treeOrientation == "vertical") { + margins_def <- list(top = 40, right = 40, bottom = 150, left = 40) + } else { + margins_def <- list(top = 40, right = 150, bottom = 40, left = 40) + } - if (length(margins) == 1L && is.numeric(margins)) { - margins = as.list(setNames(rep(margins, 4), - c("top", "right", "bottom", "left"))) - } else if (is.null(margins)) { - margins = margins_def - } else { - margins = modifyList(margins_def, margins) - } + if (length(margins) == 1L && is.numeric(margins)) { + margins <- as.list(setNames( + rep(margins, 4), + c("top", "right", "bottom", "left") + )) + } else if (is.null(margins)) { + margins <- margins_def + } else { + margins <- modifyList(margins_def, margins) + } - if (is.null(textRotate)) - textRotate = ifelse(treeOrientation == "vertical", 65, 0) + if (is.null(textRotate)) { + textRotate <- ifelse(treeOrientation == "vertical", 65, 0) + } - # create options - options = list( - height = height, - width = width, - fontSize = fontSize, - linkColour = linkColour, - nodeColour = nodeColour, - nodeStroke = nodeStroke, - textRotate = textRotate, - margins = margins, - opacity = opacity, - linkType = linkType, - treeOrientation = treeOrientation, - zoom = zoom - ) + # create options + options <- list( + height = height, + width = width, + fontSize = fontSize, + linkColour = linkColour, + nodeColour = nodeColour, + nodeStroke = nodeStroke, + textRotate = textRotate, + margins = margins, + opacity = opacity, + linkType = linkType, + treeOrientation = treeOrientation, + zoom = zoom + ) - # create widget - htmlwidgets::createWidget( + # create widget + htmlwidgets::createWidget( name = "dendroNetwork", x = list(root = root, options = options), - width = width, - height = height, - htmlwidgets::sizingPolicy(padding = 10, browser.fill = TRUE), - package = "networkD3") - } + width = width, + height = height, + htmlwidgets::sizingPolicy(padding = 10, browser.fill = TRUE), + package = "networkD3" + ) +} - #' @rdname networkD3-shiny - #' @export - dendroNetworkOutput <- function(outputId, width = "100%", height = "800px") { - shinyWidgetOutput(outputId, "dendroNetwork", width, height, - package = "networkD3") - } +#' @rdname networkD3-shiny +#' @export +dendroNetworkOutput <- function(outputId, width = "100%", height = "800px") { + shinyWidgetOutput(outputId, "dendroNetwork", width, height, + package = "networkD3" + ) +} - #' @rdname networkD3-shiny - #' @export - renderDendroNetwork <- function(expr, env = parent.frame(), quoted = FALSE) { - if (!quoted) { expr <- substitute(expr) } # force quoted - shinyRenderWidget(expr, dendroNetworkOutput, env, quoted = TRUE) - } +#' @rdname networkD3-shiny +#' @export +renderDendroNetwork <- function(expr, env = parent.frame(), quoted = FALSE) { + if (!quoted) { + expr <- substitute(expr) + } # force quoted + shinyRenderWidget(expr, dendroNetworkOutput, env, quoted = TRUE) +} - as.dendroNetwork <- function(hc, textColour, textOpacity) - { - if (!("hclust" %in% class(hc))) - stop("hc must be a object of class hclust") +as.dendroNetwork <- function(hc, textColour, textOpacity) { + if (!("hclust" %in% class(hc))) { + stop("hc must be a object of class hclust") + } - if (length(textColour) != length(hc$labels)) - stop("textColour length must match label length") - if (length(textOpacity) != length(hc$labels)) - stop("textOpacity length must match label length") + if (length(textColour) != length(hc$labels)) { + stop("textColour length must match label length") + } + if (length(textOpacity) != length(hc$labels)) { + stop("textOpacity length must match label length") + } - ul <- function(lev) - { - child = lapply(1:2, function(i) { - val <- abs(hc$merge[lev, ][i]) - if (hc$merge[lev, ][i] < 0) - list(name = hc$labels[val], y = 0, textColour = textColour[val], - textOpacity = textOpacity[val]) - else - ul(val) + ul <- function(lev) { + child <- lapply(1:2, function(i) { + val <- abs(hc$merge[lev, ][i]) + if (hc$merge[lev, ][i] < 0) { + list( + name = hc$labels[val], y = 0, textColour = textColour[val], + textOpacity = textOpacity[val] + ) + } else { + ul(val) + } }) list(name = "", y = hc$height[lev], children = child) - } - ul(nrow(hc$merge)) + } + ul(nrow(hc$merge)) } diff --git a/R/diagonalNetwork.R b/R/diagonalNetwork.R index 638d1111..4e7d75a5 100644 --- a/R/diagonalNetwork.R +++ b/R/diagonalNetwork.R @@ -32,7 +32,7 @@ #' # Create URL. paste0 used purely to keep within line width. #' URL <- paste0("https://cdn.rawgit.com/christophergandrud/networkD3/", #' "master/JSONdata//flare.json") -#' +#' #' ## Convert to list format #' Flare <- jsonlite::fromJSON(URL, simplifyDataFrame = FALSE) #' @@ -88,59 +88,63 @@ #' @export #' diagonalNetwork <- function( - List, - height = NULL, - width = NULL, - fontSize = 10, - fontFamily = "serif", - linkColour = "#ccc", - nodeColour = "#fff", - nodeStroke = "steelblue", - textColour = "#111", - opacity = 0.9, - margin = NULL) -{ - # validate input - if (!is.list(List)) - stop("List must be a list object.") - root <- List - - margin <- margin_handler(margin) + List, + height = NULL, + width = NULL, + fontSize = 10, + fontFamily = "serif", + linkColour = "#ccc", + nodeColour = "#fff", + nodeStroke = "steelblue", + textColour = "#111", + opacity = 0.9, + margin = NULL) { + # validate input + if (!is.list(List)) { + stop("List must be a list object.") + } + root <- List + + margin <- margin_handler(margin) - # create options - options = list( - height = height, - width = width, - fontSize = fontSize, - fontFamily = fontFamily, - linkColour = linkColour, - nodeColour = nodeColour, - nodeStroke = nodeStroke, - textColour = textColour, - margin = margin, - opacity = opacity - ) + # create options + options <- list( + height = height, + width = width, + fontSize = fontSize, + fontFamily = fontFamily, + linkColour = linkColour, + nodeColour = nodeColour, + nodeStroke = nodeStroke, + textColour = textColour, + margin = margin, + opacity = opacity + ) - # create widget - htmlwidgets::createWidget( - name = "diagonalNetwork", - x = list(root = root, options = options), - width = width, - height = height, - htmlwidgets::sizingPolicy(padding = 10, browser.fill = TRUE), - package = "networkD3") + # create widget + htmlwidgets::createWidget( + name = "diagonalNetwork", + x = list(root = root, options = options), + width = width, + height = height, + htmlwidgets::sizingPolicy(padding = 10, browser.fill = TRUE), + package = "networkD3" + ) } #' @rdname networkD3-shiny #' @export diagonalNetworkOutput <- function(outputId, width = "100%", height = "800px") { - shinyWidgetOutput(outputId, "diagonalNetwork", width, height, - package = "networkD3") + shinyWidgetOutput(outputId, "diagonalNetwork", width, height, + package = "networkD3" + ) } #' @rdname networkD3-shiny #' @export renderDiagonalNetwork <- function(expr, env = parent.frame(), quoted = FALSE) { - if (!quoted) { expr <- substitute(expr) } # force quoted - shinyRenderWidget(expr, diagonalNetworkOutput, env, quoted = TRUE) + if (!quoted) { + expr <- substitute(expr) + } # force quoted + shinyRenderWidget(expr, diagonalNetworkOutput, env, quoted = TRUE) } diff --git a/R/forceNetwork.R b/R/forceNetwork.R index 8bf8d136..e4d824d3 100755 --- a/R/forceNetwork.R +++ b/R/forceNetwork.R @@ -50,13 +50,16 @@ #' zooming. #' @param legend logical value to enable node colour legends. #' @param arrows logical value to enable directional link arrows. +#' @param showLabel logical value to show node label #' @param bounded logical value to enable (\code{TRUE}) or disable #' (\code{FALSE}) the bounding box limiting the graph's extent. See #' \url{http://bl.ocks.org/mbostock/1129492}. -#' @param opacityNoHover numeric value of the opacity proportion for node labels -#' text when the mouse is not hovering over them. -#' @param clickAction character string with a JavaScript expression to evaluate -#' when a node is clicked. +#' @param clickCallback character string with a JavaScript expression to evaluate +#' when click a node. +#' @param hoverCallback a list of character string with a JavaScript expression to evaluate +#' when hover a node. +#' @param unhoverCallback a list of character string with a JavaScript expression to evaluate +#' when unhover a node. #' #' @examples #' # Load data @@ -107,8 +110,7 @@ #' # Create graph with node text faintly visible when no hovering #' forceNetwork(Links = MisJson$links, Nodes = MisJson$nodes, Source = "source", #' Target = "target", Value = "value", NodeID = "name", -#' Group = "group", opacity = 0.4, bounded = TRUE, -#' opacityNoHover = TRUE) +#' Group = "group", opacity = 0.4, bounded = TRUE) #' #' ## Specify colours for specific edges #' # Find links to Valjean (11) @@ -128,13 +130,13 @@ #' # Shiny.onInputChange() to allocate d.XXX to an element of input #' # for use in a Shiny app. #' -#' MyClickScript <- 'alert("You clicked " + d.name + " which is in row " + -#' (d.index + 1) + " of your original R data frame");' +#' MyClickScript <- JS('alert("You clicked " + d.name + " which is in row " + +#' (d.index + 1) + " of your original R data frame");') #' #' forceNetwork(Links = MisLinks, Nodes = MisNodes, Source = "source", #' Target = "target", Value = "value", NodeID = "name", #' Group = "group", opacity = 1, zoom = FALSE, -#' bounded = TRUE, clickAction = MyClickScript) +#' bounded = TRUE, clickCallback = MyClickScript) #' } #' @@ -153,108 +155,185 @@ forceNetwork <- function(Links, NodeID, Nodesize, Group, - height = NULL, - width = NULL, + height = "95vmin", + width = "95vmax", colourScale = JS("d3.scaleOrdinal(d3.schemeCategory20);"), - fontSize = 7, + fontSize = 8, fontFamily = "serif", linkDistance = 50, linkWidth = JS("function(d) { return Math.sqrt(d.value); }"), - radiusCalculation = JS(" Math.sqrt(d.nodesize)+6"), + radiusCalculation = JS(" Math.sqrt(d.nodesize)+8"), charge = -30, linkColour = "#666", opacity = 0.6, zoom = FALSE, legend = FALSE, arrows = FALSE, + showLabel = TRUE, bounded = FALSE, - opacityNoHover = 0, - clickAction = NULL) -{ - # Check if data is zero indexed - check_zero(Links[, Source], Links[, Target]) + clickCallback = NULL, + hoverCallback = JS( + "function mouseover(d) {", + unFocusOtherLinks(unfocusDivisor = 2, duration = 200, opacity = opacity), + unFocusOtherNodes(unfocusDivisor = 2, duration = 200, opacity = opacity), + nodeSizeEffect(plusSize = 5, duration = 300), + labelScaleEffect(fontSize = fontSize * 2.5, offset = fontSize, duration = 300, opacity = 1), + "}" + ), + unhoverCallback = JS( + "function mouseover(d) {", + unFocusOtherLinks(reset = TRUE, opacity = opacity), + unFocusOtherNodes(reset = TRUE, opacity = opacity), + nodeSizeEffect(plusSize = 0, duration = 300), + labelScaleEffect(fontSize = fontSize, offset = 0, duration = 300, opacity = showLabel * opacity), + "}" + )) { + # Check if data is zero indexed + check_zero(Links[, Source], Links[, Target]) - # If tbl_df convert to plain data.frame - Links <- tbl_df_strip(Links) - Nodes <- tbl_df_strip(Nodes) + # If tbl_df convert to plain data.frame + Links <- tbl_df_strip(Links) + Nodes <- tbl_df_strip(Nodes) - # Hack for UI consistency. Think of improving. - colourScale <- as.character(colourScale) - linkWidth <- as.character(linkWidth) - radiusCalculation <- as.character(radiusCalculation) + # Hack for UI consistency. Think of improving. + colourScale <- as.character(colourScale) + linkWidth <- as.character(linkWidth) + radiusCalculation <- as.character(radiusCalculation) - # Subset data frames for network graph - if (!is.data.frame(Links)) { - stop("Links must be a data frame class object.") - } - if (!is.data.frame(Nodes)) { - stop("Nodes must be a data frame class object.") - } - if (missing(Value)) { - LinksDF <- data.frame(Links[, Source], Links[, Target]) - names(LinksDF) <- c("source", "target") - } - else if (!missing(Value)) { - LinksDF <- data.frame(Links[, Source], Links[, Target], Links[, Value]) - names(LinksDF) <- c("source", "target", "value") - } - if (!missing(Nodesize)){ - NodesDF <- data.frame(Nodes[, NodeID], Nodes[, Group], Nodes[, Nodesize]) - names(NodesDF) <- c("name", "group", "nodesize") - nodesize = TRUE - } else { - NodesDF <- data.frame(Nodes[, NodeID], Nodes[, Group]) - names(NodesDF) <- c("name", "group") - nodesize = FALSE - } + # Subset data frames for network graph + if (!is.data.frame(Links)) { + stop("Links must be a data frame class object.") + } + if (!is.data.frame(Nodes)) { + stop("Nodes must be a data frame class object.") + } + if (missing(Value)) { + LinksDF <- data.frame(Links[, Source], Links[, Target]) + names(LinksDF) <- c("source", "target") + } + else if (!missing(Value)) { + LinksDF <- data.frame(Links[, Source], Links[, Target], Links[, Value]) + names(LinksDF) <- c("source", "target", "value") + } + if (!missing(Nodesize)) { + NodesDF <- data.frame(Nodes[, NodeID], Nodes[, Group], Nodes[, Nodesize]) + names(NodesDF) <- c("name", "group", "nodesize") + nodesize <- TRUE + } else { + NodesDF <- data.frame(Nodes[, NodeID], Nodes[, Group]) + names(NodesDF) <- c("name", "group") + nodesize <- FALSE + } - LinksDF <- data.frame(LinksDF, colour = linkColour) - LinksDF$colour = as.character(LinksDF$colour) + LinksDF <- data.frame(LinksDF, colour = linkColour) + LinksDF$colour <- as.character(LinksDF$colour) - # create options - options = list( - NodeID = NodeID, - Group = Group, - colourScale = colourScale, - fontSize = fontSize, - fontFamily = fontFamily, - clickTextSize = fontSize * 2.5, - linkDistance = linkDistance, - linkWidth = linkWidth, - charge = charge, - # linkColour = linkColour, - opacity = opacity, - zoom = zoom, - legend = legend, - arrows = arrows, - nodesize = nodesize, - radiusCalculation = radiusCalculation, - bounded = bounded, - opacityNoHover = opacityNoHover, - clickAction = clickAction - ) + # create options + options <- list( + NodeID = NodeID, + Group = Group, + colourScale = colourScale, + fontSize = fontSize, + fontFamily = fontFamily, + linkDistance = linkDistance, + linkWidth = linkWidth, + charge = charge, + linkColour = linkColour, + opacity = opacity, + zoom = zoom, + legend = legend, + arrows = arrows, + showLabel = showLabel, + nodesize = nodesize, + radiusCalculation = radiusCalculation, + bounded = bounded, + clickCallback = clickCallback, + hoverCallback = hoverCallback, + unhoverCallback = unhoverCallback + ) - # create widget - htmlwidgets::createWidget( - name = "forceNetwork", - x = list(links = LinksDF, nodes = NodesDF, options = options), - width = width, - height = height, - htmlwidgets::sizingPolicy(padding = 10, browser.fill = TRUE), - package = "networkD3" - ) + # create widget + htmlwidgets::createWidget( + name = "forceNetwork", + x = list(links = LinksDF, nodes = NodesDF, options = options), + width = width, + height = height, + htmlwidgets::sizingPolicy(padding = 10, browser.fill = TRUE), + package = "networkD3" + ) } + +#' Javascript function to unfocus other nodes +#' +#' @param unfocusDivisor a divisor factor of apacity +#' @param duration the duration of the effect +#' @param reset reset the effect +#' @param opacity numeric value of the proportion opaque you would like the +#' graph elements to be. +#' @export +unFocusOtherLinks <- function(unfocusDivisor = 2, duration = 200, opacity = 1, reset = FALSE) { + if (reset) return(paste0('d3.selectAll(".link").style("opacity", +', opacity, ');')) + paste0( + 'd3.selectAll(".link").transition().duration(', duration, ') + .style("opacity", function(l) { return d != l.source && d != l.target ? +', opacity, " / ", unfocusDivisor, " : +", opacity, ' });' + ) +} + +#' @rdname unFocusOtherLinks +unFocusOtherNodes <- function(unfocusDivisor = 2, duration = 200, opacity = 1, reset = FALSE) { + if (reset) return(paste0('d3.selectAll(".node").style("opacity", +', opacity, ');')) + paste0( + 'd3.selectAll(".node").transition().duration(', duration, ') + .style("opacity", function(o) { return d.index == o.index || d3.neighboring(d,o) ? +', opacity, " : +", opacity, " / ", unfocusDivisor, '; });' + ) +} + +#' Javascript function to increase node size +#' +#' @param plusSize value to increase size node +#' @param duration the duration of the effect +#' @export +nodeSizeEffect <- function(plusSize = 5, duration = 300) { + paste0( + 'd3.select("#node" + d.index).select("circle").transition() + .duration(', duration, ') + .attr("r", function(n){return d3.nodeSize(n)+', plusSize, ";});" + ) +} + +#' Javascript function to scale the label +#' +#' @param fontSize a scale factor of fontSize +#' @param offset a value to x-offset label +#' @param duration the duration of the effect +#' @param opacity numeric value of the proportion opaque you would like the +#' graph elements to be. +#' @export +labelScaleEffect <- function(fontSize = 14, offset = 13, duration = 300, opacity = 1) { + paste0( + 'd3.select("#node" + d.index).select("text").transition() + .duration(', duration, ') + .attr("x", ', offset, ') + .style("font-size", "', fontSize, 'px") + .style("opacity", ', opacity, ");" + ) +} + + #' @rdname networkD3-shiny #' @export -forceNetworkOutput <- function(outputId, width = "100%", height = "500px") { - shinyWidgetOutput(outputId, "forceNetwork", width, height, - package = "networkD3") +forceNetworkOutput <- function(outputId, width = "95vmmax", height = "95vmin") { + shinyWidgetOutput(outputId, "forceNetwork", width, height, + package = "networkD3" + ) } #' @rdname networkD3-shiny #' @export renderForceNetwork <- function(expr, env = parent.frame(), quoted = FALSE) { - if (!quoted) { expr <- substitute(expr) } # force quoted - shinyRenderWidget(expr, forceNetworkOutput, env, quoted = TRUE) + if (!quoted) { + expr <- substitute(expr) + } # force quoted + shinyRenderWidget(expr, forceNetworkOutput, env, quoted = TRUE) } diff --git a/R/radialNetwork.R b/R/radialNetwork.R index aeaa3245..f8bec35e 100644 --- a/R/radialNetwork.R +++ b/R/radialNetwork.R @@ -32,7 +32,7 @@ #' # Create URL. paste0 used purely to keep within line width. #' URL <- paste0("https://cdn.rawgit.com/christophergandrud/networkD3/", #' "master/JSONdata//flare.json") -#' +#' #' ## Convert to list format #' Flare <- jsonlite::fromJSON(URL, simplifyDataFrame = FALSE) #' @@ -98,51 +98,55 @@ radialNetwork <- function( nodeStroke = "steelblue", textColour = "#111", opacity = 0.9, - margin = NULL) -{ - # validate input - if (!is.list(List)) - stop("List must be a list object.") - root <- List - - margin <- margin_handler(margin) + margin = NULL) { + # validate input + if (!is.list(List)) { + stop("List must be a list object.") + } + root <- List + + margin <- margin_handler(margin) - # create options - options = list( - height = height, - width = width, - fontSize = fontSize, - fontFamily = fontFamily, - linkColour = linkColour, - nodeColour = nodeColour, - nodeStroke = nodeStroke, - textColour = textColour, - margin = margin, - opacity = opacity - ) + # create options + options <- list( + height = height, + width = width, + fontSize = fontSize, + fontFamily = fontFamily, + linkColour = linkColour, + nodeColour = nodeColour, + nodeStroke = nodeStroke, + textColour = textColour, + margin = margin, + opacity = opacity + ) - # create widget - htmlwidgets::createWidget( - name = "radialNetwork", - x = list(root = root, options = options), - width = width, - height = height, - htmlwidgets::sizingPolicy(padding = 10, browser.fill = TRUE), - package = "networkD3") + # create widget + htmlwidgets::createWidget( + name = "radialNetwork", + x = list(root = root, options = options), + width = width, + height = height, + htmlwidgets::sizingPolicy(padding = 10, browser.fill = TRUE), + package = "networkD3" + ) } #' @rdname networkD3-shiny #' @export radialNetworkOutput <- function(outputId, width = "100%", height = "800px") { - shinyWidgetOutput(outputId, "radialNetwork", width, height, - package = "networkD3") + shinyWidgetOutput(outputId, "radialNetwork", width, height, + package = "networkD3" + ) } #' @rdname networkD3-shiny #' @export renderRadialNetwork <- function(expr, env = parent.frame(), quoted = FALSE) { - if (!quoted) { expr <- substitute(expr) } # force quoted - shinyRenderWidget(expr, radialNetworkOutput, env, quoted = TRUE) + if (!quoted) { + expr <- substitute(expr) + } # force quoted + shinyRenderWidget(expr, radialNetworkOutput, env, quoted = TRUE) } #' Convert an R hclust or dendrogram object into a radialNetwork list. @@ -167,22 +171,21 @@ renderRadialNetwork <- function(expr, env = parent.frame(), quoted = FALSE) { #' #' @export -as.radialNetwork <- function(d, root) -{ - if(missing(root)) root <- as.character(match.call()[[2]]) - if("hclust" %in% class(d)) d <- as.dendrogram(d) - if(!("dendrogram" %in% class(d))) - stop("d must be a object of class hclust or dendrogram") - ul <- function(x, level = 1) { - if(is.list(x)) { - return(lapply(x, function(y) - { +as.radialNetwork <- function(d, root) { + if (missing(root)) root <- as.character(match.call()[[2]]) + if ("hclust" %in% class(d)) d <- as.dendrogram(d) + if (!("dendrogram" %in% class(d))) { + stop("d must be a object of class hclust or dendrogram") + } + ul <- function(x, level = 1) { + if (is.list(x)) { + return(lapply(x, function(y) { name <- "" - if(!is.list(y)) name <- attr(y, "label") - list(name=name, children=ul(y, level + 1)) - })) - } - list(name = attr(x,"label")) + if (!is.list(y)) name <- attr(y, "label") + list(name = name, children = ul(y, level + 1)) + })) } - list(name = root, children = ul(d)) + list(name = attr(x, "label")) + } + list(name = root, children = ul(d)) } diff --git a/R/sankeyNetwork.R b/R/sankeyNetwork.R index 31f99ded..f4fcc3b6 100644 --- a/R/sankeyNetwork.R +++ b/R/sankeyNetwork.R @@ -73,87 +73,97 @@ #' @export sankeyNetwork <- function(Links, Nodes, Source, Target, Value, - NodeID, NodeGroup = NodeID, LinkGroup = NULL, units = "", - colourScale = JS("d3.scaleOrdinal(d3.schemeCategory20);"), fontSize = 7, - fontFamily = NULL, nodeWidth = 15, nodePadding = 10, margin = NULL, - height = NULL, width = NULL, iterations = 32, sinksRight = TRUE) -{ - # Check if data is zero indexed - check_zero(Links[, Source], Links[, Target]) + NodeID, NodeGroup = NodeID, LinkGroup = NULL, units = "", + colourScale = JS("d3.scaleOrdinal(d3.schemeCategory20);"), fontSize = 7, + fontFamily = NULL, nodeWidth = 15, nodePadding = 10, margin = NULL, + height = NULL, width = NULL, iterations = 32, sinksRight = TRUE) { + # Check if data is zero indexed + check_zero(Links[, Source], Links[, Target]) - # Hack for UI consistency. Think of improving. - colourScale <- as.character(colourScale) + # Hack for UI consistency. Think of improving. + colourScale <- as.character(colourScale) - # If tbl_df convert to plain data.frame - Links <- tbl_df_strip(Links) - Nodes <- tbl_df_strip(Nodes) + # If tbl_df convert to plain data.frame + Links <- tbl_df_strip(Links) + Nodes <- tbl_df_strip(Nodes) - # Subset data frames for network graph - if (!is.data.frame(Links)) { - stop("Links must be a data frame class object.") - } - if (!is.data.frame(Nodes)) { - stop("Nodes must be a data frame class object.") - } - # if Source or Target are missing assume Source is the first - # column Target is the second column - if (missing(Source)) - Source = 1 - if (missing(Target)) - Target = 2 + # Subset data frames for network graph + if (!is.data.frame(Links)) { + stop("Links must be a data frame class object.") + } + if (!is.data.frame(Nodes)) { + stop("Nodes must be a data frame class object.") + } + # if Source or Target are missing assume Source is the first + # column Target is the second column + if (missing(Source)) { + Source <- 1 + } + if (missing(Target)) { + Target <- 2 + } - if (missing(Value)) { - LinksDF <- data.frame(Links[, Source], Links[, Target]) - names(LinksDF) <- c("source", "target") - } else if (!missing(Value)) { - LinksDF <- data.frame(Links[, Source], Links[, Target], - Links[, Value]) - names(LinksDF) <- c("source", "target", "value") - } + if (missing(Value)) { + LinksDF <- data.frame(Links[, Source], Links[, Target]) + names(LinksDF) <- c("source", "target") + } else if (!missing(Value)) { + LinksDF <- data.frame( + Links[, Source], Links[, Target], + Links[, Value] + ) + names(LinksDF) <- c("source", "target", "value") + } - # if NodeID is missing assume NodeID is the first column - if (missing(NodeID)) - NodeID = 1 - NodesDF <- data.frame(Nodes[, NodeID]) - names(NodesDF) <- c("name") + # if NodeID is missing assume NodeID is the first column + if (missing(NodeID)) { + NodeID <- 1 + } + NodesDF <- data.frame(Nodes[, NodeID]) + names(NodesDF) <- c("name") - # add node group if specified - if (is.character(NodeGroup)) { - NodesDF$group <- Nodes[, NodeGroup] - } + # add node group if specified + if (is.character(NodeGroup)) { + NodesDF$group <- Nodes[, NodeGroup] + } - if (is.character(LinkGroup)) { - LinksDF$group <- Links[, LinkGroup] - } + if (is.character(LinkGroup)) { + LinksDF$group <- Links[, LinkGroup] + } - margin <- margin_handler(margin) + margin <- margin_handler(margin) - # create options - options = list(NodeID = NodeID, NodeGroup = NodeGroup, LinkGroup = LinkGroup, - colourScale = colourScale, fontSize = fontSize, fontFamily = fontFamily, - nodeWidth = nodeWidth, nodePadding = nodePadding, units = units, - margin = margin, iterations = iterations, sinksRight = sinksRight) + # create options + options <- list( + NodeID = NodeID, NodeGroup = NodeGroup, LinkGroup = LinkGroup, + colourScale = colourScale, fontSize = fontSize, fontFamily = fontFamily, + nodeWidth = nodeWidth, nodePadding = nodePadding, units = units, + margin = margin, iterations = iterations, sinksRight = sinksRight + ) - # create widget - htmlwidgets::createWidget(name = "sankeyNetwork", x = list(links = LinksDF, - nodes = NodesDF, options = options), width = width, height = height, - htmlwidgets::sizingPolicy(padding = 10, browser.fill = TRUE), - package = "networkD3") + # create widget + htmlwidgets::createWidget( + name = "sankeyNetwork", x = list( + links = LinksDF, + nodes = NodesDF, options = options + ), width = width, height = height, + htmlwidgets::sizingPolicy(padding = 10, browser.fill = TRUE), + package = "networkD3" + ) } #' @rdname networkD3-shiny #' @export sankeyNetworkOutput <- function(outputId, width = "100%", height = "500px") { - shinyWidgetOutput(outputId, "sankeyNetwork", width, height, - package = "networkD3") + shinyWidgetOutput(outputId, "sankeyNetwork", width, height, + package = "networkD3" + ) } #' @rdname networkD3-shiny #' @export renderSankeyNetwork <- function(expr, env = parent.frame(), quoted = FALSE) { - if (!quoted) - { - expr <- substitute(expr) - } # force quoted - shinyRenderWidget(expr, sankeyNetworkOutput, env, quoted = TRUE) + if (!quoted) { + expr <- substitute(expr) + } # force quoted + shinyRenderWidget(expr, sankeyNetworkOutput, env, quoted = TRUE) } diff --git a/R/saveNetwork.R b/R/saveNetwork.R index eb3100a6..7dc81ddb 100644 --- a/R/saveNetwork.R +++ b/R/saveNetwork.R @@ -11,5 +11,5 @@ #' #' @export saveNetwork <- function(network, file, selfcontained = TRUE) { - htmlwidgets::saveWidget(network, file, selfcontained) + htmlwidgets::saveWidget(network, file, selfcontained) } diff --git a/R/simpleNetwork.R b/R/simpleNetwork.R index 6ee58aba..2a4511bd 100644 --- a/R/simpleNetwork.R +++ b/R/simpleNetwork.R @@ -58,63 +58,67 @@ simpleNetwork <- function(Data, linkColour = "#666", nodeColour = "#3182bd", opacity = 0.6, - zoom = F) -{ - # validate input - if (!is.data.frame(Data)) - stop("data must be a data frame class object.") + zoom = F) { + # validate input + if (!is.data.frame(Data)) { + stop("data must be a data frame class object.") + } - sources <- Data[[Source]] - targets <- Data[[Target]] + sources <- Data[[Source]] + targets <- Data[[Target]] - # Check if data is zero indexed - check_zero(sources, targets) + # Check if data is zero indexed + check_zero(sources, targets) - # create nodes data - node_names <- factor(sort(unique(c(as.character(sources), as.character(targets))))) - nodes <- data.frame(name = node_names, group = 1, size = 8) + # create nodes data + node_names <- factor(sort(unique(c(as.character(sources), as.character(targets))))) + nodes <- data.frame(name = node_names, group = 1, size = 8) - # create links data - links <- data.frame(source = match(sources, node_names) - 1, - target = match(targets, node_names) - 1, - value = 1) + # create links data + links <- data.frame( + source = match(sources, node_names) - 1, + target = match(targets, node_names) - 1, + value = 1 + ) - # create options - options = list( - Links = links, - Nodes = nodes, - Source = 'source', - Target = 'target', - Value = 'value', - NodeID = 'name', - Group = 'group', - linkDistance = linkDistance, - charge = charge, - fontSize = fontSize, - fontFamily = fontFamily, - linkColour = linkColour, - colourScale = JS(paste0("d3.scaleOrdinal(['", nodeColour, "'])")), - opacity = opacity, - zoom = zoom, - radiusCalculation = JS("d.nodesize"), - Nodesize = 'size', - linkWidth = "'1.5px'.toString()", - opacityNoHover = 1 - ) + # create options + options <- list( + Links = links, + Nodes = nodes, + Source = "source", + Target = "target", + Value = "value", + NodeID = "name", + Group = "group", + linkDistance = linkDistance, + charge = charge, + fontSize = fontSize, + fontFamily = fontFamily, + linkColour = linkColour, + colourScale = JS(paste0("d3.scaleOrdinal(['", nodeColour, "'])")), + opacity = opacity, + zoom = zoom, + radiusCalculation = JS("d.nodesize"), + Nodesize = "size", + linkWidth = "'1.5px'.toString()" + ) - do.call(forceNetwork, options) + do.call(forceNetwork, options) } #' @rdname networkD3-shiny #' @export simpleNetworkOutput <- function(outputId, width = "100%", height = "500px") { - shinyWidgetOutput(outputId, "forceNetwork", width, height, - package = "networkD3") + shinyWidgetOutput(outputId, "forceNetwork", width, height, + package = "networkD3" + ) } #' @rdname networkD3-shiny #' @export renderSimpleNetwork <- function(expr, env = parent.frame(), quoted = FALSE) { - if (!quoted) { expr <- substitute(expr) } # force quoted - shinyRenderWidget(expr, simpleNetworkOutput, env, quoted = TRUE) + if (!quoted) { + expr <- substitute(expr) + } # force quoted + shinyRenderWidget(expr, simpleNetworkOutput, env, quoted = TRUE) } diff --git a/R/treeNetwork.R b/R/treeNetwork.R index a2601532..133d2a8f 100644 --- a/R/treeNetwork.R +++ b/R/treeNetwork.R @@ -23,10 +23,10 @@ #' @importFrom htmlwidgets shinyRenderWidget #' #' @export -#' -treeNetwork <- function(data, width = NULL, height = NULL, treeType = 'tidy', - direction = 'right', linkType = 'diagonal', - defaults = NULL, mouseover = '', mouseout = '', +#' +treeNetwork <- function(data, width = NULL, height = NULL, treeType = "tidy", + direction = "right", linkType = "diagonal", + defaults = NULL, mouseover = "", mouseout = "", inbrowser = FALSE, ...) { # convert to the native data format @@ -36,45 +36,47 @@ treeNetwork <- function(data, width = NULL, height = NULL, treeType = 'tidy', defaults_ <- list( nodeSize = 8, - nodeStroke = 'steelblue', - nodeColour = 'steelblue', - nodeSymbol = 'circle', - nodeFont = 'sans-serif', + nodeStroke = "steelblue", + nodeColour = "steelblue", + nodeSymbol = "circle", + nodeFont = "sans-serif", nodeFontSize = 10, - textColour = 'black', + textColour = "black", textOpacity = 1, - linkColour = 'black', - linkWidth = '1.5px' + linkColour = "black", + linkWidth = "1.5px" ) if (missing(defaults)) { return(defaults_) } else { defaults <- as.list(defaults) - names(defaults) <- sub('Color$', 'Colour', names(defaults)) - return(c(defaults, defaults_[! names(defaults_) %in% names(defaults)])) + names(defaults) <- sub("Color$", "Colour", names(defaults)) + return(c(defaults, defaults_[!names(defaults_) %in% names(defaults)])) } } defaults <- default(defaults) - for(i in 1:length(defaults)) { - if (! names(defaults)[i] %in% names(data)) { + for (i in 1:length(defaults)) { + if (!names(defaults)[i] %in% names(data)) { data[names(defaults)[i]] <- defaults[i] } } - options <- list(treeType = treeType, direction = direction, - linkType = linkType, mouseover = mouseover, - mouseout = mouseout) + options <- list( + treeType = treeType, direction = direction, + linkType = linkType, mouseover = mouseover, + mouseout = mouseout + ) x <- list(data = jsonlite::toJSON(data), options = options) # create widget htmlwidgets::createWidget( - name = 'treeNetwork', + name = "treeNetwork", x = x, width = width, height = height, - package = 'networkD3', + package = "networkD3", sizingPolicy = htmlwidgets::sizingPolicy(viewer.suppress = inbrowser) ) } @@ -96,14 +98,17 @@ treeNetwork <- function(data, width = NULL, height = NULL, treeType = 'tidy', #' @name treeNetwork-shiny #' #' @export -treeNetworkOutput <- function(outputId, width = '100%', height = '400px'){ - htmlwidgets::shinyWidgetOutput(outputId, 'treeNetwork', width, height, - package = 'networkD3') +treeNetworkOutput <- function(outputId, width = "100%", height = "400px") { + htmlwidgets::shinyWidgetOutput(outputId, "treeNetwork", width, height, + package = "networkD3" + ) } #' @rdname treeNetwork-shiny #' @export renderTreeNetwork <- function(expr, env = parent.frame(), quoted = FALSE) { - if (!quoted) { expr <- substitute(expr) } # force quoted + if (!quoted) { + expr <- substitute(expr) + } # force quoted htmlwidgets::shinyRenderWidget(expr, treeNetworkOutput, env, quoted = TRUE) } diff --git a/R/utils.R b/R/utils.R index d7ecad29..2dd0128e 100644 --- a/R/utils.R +++ b/R/utils.R @@ -8,15 +8,16 @@ #' #' @export -JS <- function (...) -{ - x <- c(...) - if (is.null(x)) - return() - if (!is.character(x)) - stop("The arguments for JS() must be a chraracter vector") - x <- paste(x, collapse = "\n") - structure(x, class = unique(c("JS_EVAL", oldClass(x)))) +JS <- function(...) { + x <- c(...) + if (is.null(x)) { + return() + } + if (!is.character(x)) { + stop("The arguments for JS() must be a chraracter vector") + } + x <- paste(x, collapse = "\n") + structure(x, class = unique(c("JS_EVAL", oldClass(x)))) } @@ -28,21 +29,24 @@ JS <- function (...) #' \url{http://theweiluo.wordpress.com/2011/09/30/r-to-json-for-d3-js-and-protovis/} #' @keywords internal #' @noRd -toJSONarray <- function(dtf){ +toJSONarray <- function(dtf) { clnms <- colnames(dtf) - name.value <- function(i){ - quote <- ''; - if(class(dtf[, i])!='numeric' && class(dtf[, i])!='integer'){ - quote <- '"'; + name.value <- function(i) { + quote <- "" + if (class(dtf[, i]) != "numeric" && class(dtf[, i]) != "integer") { + quote <- '"' } - paste('"', i, '" : ', quote, dtf[,i], quote, sep='') + paste('"', i, '" : ', quote, dtf[, i], quote, sep = "") } - objs <- apply(sapply(clnms, name.value), 1, function(x){paste(x, - collapse=', ')}) - objs <- paste('{', objs, '}') + objs <- apply(sapply(clnms, name.value), 1, function(x) { + paste(x, + collapse = ", " + ) + }) + objs <- paste("{", objs, "}") - res <- paste('[', paste(objs, collapse=', '), ']') + res <- paste("[", paste(objs, collapse = ", "), "]") return(res) } @@ -56,8 +60,8 @@ toJSONarray <- function(dtf){ #' @return string with document contents #' @keywords internal #' @noRd -read_file <- function(doc, ...){ - paste(readLines(doc, ...), collapse = '\n') +read_file <- function(doc, ...) { + paste(readLines(doc, ...), collapse = "\n") } @@ -70,21 +74,21 @@ read_file <- function(doc, ...){ #' the \code{right} margin. #' @return named \code{list} with top, right, bottom, left margins #' @noRd -margin_handler <- function(margin){ +margin_handler <- function(margin) { # margin can be either a single value or a list with any of # top, right, bottom, left # if margin is a single value, then we will stick # with the original behavior of networkD3 and use it for the right margin - if(!is.null(margin) && length(margin) == 1 && is.null(names(margin))){ + if (!is.null(margin) && length(margin) == 1 && is.null(names(margin))) { margin <- list( top = NULL, right = margin, bottom = NULL, left = NULL ) - } else if(!is.null(margin)){ + } else if (!is.null(margin)) { # if margin is a named vector then convert to list - if(!is.list(margin) && !is.null(names(margin))){ + if (!is.list(margin) && !is.null(names(margin))) { margin <- as.list(margin) } # if we are here then margin should be a list and @@ -159,54 +163,63 @@ margin_handler <- function(margin){ #' @importFrom magrittr %>% #' @export -igraph_to_networkD3 <- function(g, group, what = 'both') { - # Sanity check - if (!('igraph' %in% class(g))) stop('g must be an igraph class object.', - call. = FALSE) - if (!(what %in% c('both', 'links', 'nodes'))) stop('what must be either "nodes", "links", or "both".', - call. = FALSE) - - # Extract vertices (nodes) - temp_nodes <- V(g) %>% as.matrix %>% data.frame - temp_nodes$name <- row.names(temp_nodes) - names(temp_nodes) <- c('id', 'name') - - # Convert to base 0 (for JavaScript) - temp_nodes$id <- temp_nodes$id - 1 - - # Nodes for output - nodes <- temp_nodes$name %>% data.frame %>% setNames('name') - # Include grouping variable if applicable - if (!missing(group)) { - group <- as.matrix(group) - if (nrow(nodes) != nrow(group)) stop('group must have the same number of rows as the number of nodes in g.', - call. = FALSE) - nodes <- cbind(nodes, group) - } - row.names(nodes) <- NULL - - # Convert links from names to numbers - links <- as_data_frame(g, what = 'edges') - links <- merge(links, temp_nodes, by.x = 'from', by.y = 'name') - links <- merge(links, temp_nodes, by.x = 'to', by.y = 'name') - if (ncol(links) == 5) { - links <- links[, c(4:5, 3)] %>% - setNames(c('source', 'target', 'value')) - } - else { - links <- links[, c('id.x', 'id.y')] %>% setNames(c('source', 'target')) - } +igraph_to_networkD3 <- function(g, group, what = "both") { + # Sanity check + if (!("igraph" %in% class(g))) { + stop("g must be an igraph class object.", + call. = FALSE + ) + } + if (!(what %in% c("both", "links", "nodes"))) { + stop('what must be either "nodes", "links", or "both".', + call. = FALSE + ) + } - # Output requested object - if (what == 'both') { - return(list(links = links, nodes = nodes)) - } - else if (what == 'links') { - return(links) - } - else if (what == 'nodes') { - return(nodes) + # Extract vertices (nodes) + temp_nodes <- V(g) %>% as.matrix() %>% data.frame() + temp_nodes$name <- row.names(temp_nodes) + names(temp_nodes) <- c("id", "name") + + # Convert to base 0 (for JavaScript) + temp_nodes$id <- temp_nodes$id - 1 + + # Nodes for output + nodes <- temp_nodes$name %>% data.frame() %>% setNames("name") + # Include grouping variable if applicable + if (!missing(group)) { + group <- as.matrix(group) + if (nrow(nodes) != nrow(group)) { + stop("group must have the same number of rows as the number of nodes in g.", + call. = FALSE + ) } + nodes <- cbind(nodes, group) + } + row.names(nodes) <- NULL + + # Convert links from names to numbers + links <- as_data_frame(g, what = "edges") + links <- merge(links, temp_nodes, by.x = "from", by.y = "name") + links <- merge(links, temp_nodes, by.x = "to", by.y = "name") + if (ncol(links) == 5) { + links <- links[, c(4:5, 3)] %>% + setNames(c("source", "target", "value")) + } + else { + links <- links[, c("id.x", "id.y")] %>% setNames(c("source", "target")) + } + + # Output requested object + if (what == "both") { + return(list(links = links, nodes = nodes)) + } + else if (what == "links") { + return(links) + } + else if (what == "nodes") { + return(nodes) + } } #' Check if data is 0 indexed @@ -214,36 +227,40 @@ igraph_to_networkD3 <- function(g, group, what = 'both') { #' @noRd check_zero <- function(Source, Target) { - if (!is.factor(Source) && !is.factor(Target)) { - SourceTarget <- c(Source, Target) - if (is.numeric(SourceTarget) | is.integer(SourceTarget)) { - if (!(0 %in% SourceTarget)) - warning( - 'It looks like Source/Target is not zero-indexed. This is required in JavaScript and so your plot may not render.', - call. = FALSE) - } + if (!is.factor(Source) && !is.factor(Target)) { + SourceTarget <- c(Source, Target) + if (is.numeric(SourceTarget) | is.integer(SourceTarget)) { + if (!(0 %in% SourceTarget)) { + warning( + "It looks like Source/Target is not zero-indexed. This is required in JavaScript and so your plot may not render.", + call. = FALSE + ) + } } + } } #' Convert dplyr created tbl_df to plain data.frame #' @noRd tbl_df_strip <- function(x) { - if('tbl_df' %in% class(x)) { - message(paste(deparse(substitute(x)), - 'is a tbl_df. Converting to a plain data frame.')) - x <- base::as.data.frame(x) - } - return(x) + if ("tbl_df" %in% class(x)) { + message(paste( + deparse(substitute(x)), + "is a tbl_df. Converting to a plain data frame." + )) + x <- base::as.data.frame(x) + } + return(x) } #' Check if a package is installed -#' +#' #' @param pkg_name character string name of package -#' +#' #' @importFrom utils installed.packages pkg_installed <- function(pkg_name) { - pkg_name %in% rownames(installed.packages()) + pkg_name %in% rownames(installed.packages()) } diff --git a/inst/examples/examples.R b/inst/examples/examples.R index a4e03d3a..8faf3536 100644 --- a/inst/examples/examples.R +++ b/inst/examples/examples.R @@ -31,7 +31,7 @@ MyClickScript <- forceNetwork(Links = MisLinks, Nodes = MisNodes, Source = "source", Target = "target", Value = "value", NodeID = "name", Group = "group", opacity = 1, zoom = F, bounded = T, - clickAction = MyClickScript) + clickCallback = MyClickScript) # showing how you can re-use the name of the clicked-on node (which is 'd') # You are unlikely to want to do this pop-up alert, but you might want @@ -42,12 +42,12 @@ MyClickScript <- 'alert("You clicked " + d.name + " which is in row " + (d.index forceNetwork(Links = MisLinks, Nodes = MisNodes, Source = "source", Target = "target", Value = "value", NodeID = "name", Group = "group", opacity = 1, zoom = F, bounded = T, - clickAction = MyClickScript) + clickCallback = MyClickScript) forceNetwork(Links = MisLinks, Nodes = MisNodes, Source = "source", Target = "target", Value = "value", NodeID = "name", Group = "group", opacity = 1, zoom = F, bounded = T, - clickAction = "alert('Ouch!')") + clickCallback = "alert('Ouch!')") # With a different font, and dimensions chosen to illustrate bounded box forceNetwork(Links = MisLinks, Nodes = MisNodes, Source = "source", @@ -60,7 +60,7 @@ forceNetwork(Links = MisLinks, Nodes = MisNodes, Source = "source", forceNetwork(Links = MisLinks, Nodes = MisNodes, Source = "source", Target = "target", Value = "value", NodeID = "name", Group = "group", opacity = 1, zoom = F, bounded = T, - fontFamily = "cursive", opacityNoHover = 0.3) + fontFamily = "cursive") # Create graph with legend and varying radius forceNetwork(Links = MisLinks, Nodes = MisNodes, Source = "source", @@ -149,7 +149,7 @@ hairColourData <- matrix(c(11975, 1951, 8010, 1013, 8916, 2060, 8090, 940, 2868, 6171, 8045, 6907), nrow = 4) -chordNetwork(data = hairColourData, +chordNetwork(Data = hairColourData, width = 500, height = 500, colourScale = c("#000000", "#FFDD89", "#957244", "#F26223")) diff --git a/inst/htmlwidgets/forceNetwork.js b/inst/htmlwidgets/forceNetwork.js index 54c22b5e..af39fd25 100755 --- a/inst/htmlwidgets/forceNetwork.js +++ b/inst/htmlwidgets/forceNetwork.js @@ -27,14 +27,15 @@ HTMLWidgets.widget({ // Compute the node radius using the javascript math expression specified function nodeSize(d) { - if(options.nodesize){ - return eval(options.radiusCalculation); + if(options.nodesize){ + return eval(options.radiusCalculation); - }else{ - return 6} + } else{ + return 6} } - + + d3.nodeSize = nodeSize; // alias options var options = x.options; @@ -53,6 +54,8 @@ HTMLWidgets.widget({ function neighboring(a, b) { return linkedByIndex[a.index + "," + b.index]; } + + d3.neighboring = neighboring; // get the width and height var width = el.offsetWidth; @@ -68,6 +71,8 @@ HTMLWidgets.widget({ .nodes(d3.values(nodes)) .force("link", d3.forceLink(links).distance(options.linkDistance)) .force("center", d3.forceCenter(width / 2, height / 2)) + //.force("x", d3.forceX(width / 2).strength(0.015)) + //.force("y", d3.forceY(height / 2).strength(0.015)) .force("charge", d3.forceManyBody().strength(options.charge)) .on("tick", tick); @@ -76,7 +81,7 @@ HTMLWidgets.widget({ var drag = d3.drag() .on("start", dragstart) .on("drag", dragged) - .on("end", dragended) + .on("end", dragended); function dragstart(d) { if (!d3.event.active) force.alphaTarget(0.3).restart(); d.fx = d.x; @@ -99,7 +104,7 @@ HTMLWidgets.widget({ // fine to have two g layers even if zoom = F svg = svg .append("g").attr("class","zoom-layer") - .append("g") + .append("g"); // add zooming if requested if (options.zoom) { @@ -107,7 +112,7 @@ HTMLWidgets.widget({ d3.select(el).select(".zoom-layer") .attr("transform", d3.event.transform); } - zoom.on("zoom", redraw) + zoom.on("zoom", redraw); d3.select(el).select("svg") .attr("pointer-events", "all") @@ -122,18 +127,20 @@ HTMLWidgets.widget({ .data(links) .enter().append("line") .attr("class", "link") + .attr('id', function(d){ return 'link' + d.index; }) .style("stroke", function(d) { return d.colour ; }) - //.style("stroke", options.linkColour) + .style("stroke", options.linkColour) .style("opacity", options.opacity) .style("stroke-width", eval("(" + options.linkWidth + ")")) .on("mouseover", function(d) { - d3.select(this) + d3.select("#link" + d.index) .style("opacity", 1); }) .on("mouseout", function(d) { - d3.select(this) + d3.select("#link" + d.index) .style("opacity", options.opacity); }); + if (options.arrows) { link.style("marker-end", function(d) { return "url(#arrow-" + d.colour + ")"; }); @@ -161,11 +168,12 @@ HTMLWidgets.widget({ .data(force.nodes()) .enter().append("g") .attr("class", "node") + .attr('id', function(d){ return 'node' + d.index; }) .style("fill", function(d) { return color(d.group); }) .style("opacity", options.opacity) - .on("mouseover", mouseover) - .on("mouseout", mouseout) - .on("click", click) + .on("mouseover", options.hoverCallback) + .on("mouseout", options.unhoverCallback) + .on("click", options.clickCallback) .call(drag); node.append("circle") @@ -179,8 +187,9 @@ HTMLWidgets.widget({ .attr("dx", 12) .attr("dy", ".35em") .text(function(d) { return d.name }) - .style("font", options.fontSize + "px " + options.fontFamily) - .style("opacity", options.opacityNoHover) + .style("font-family", options.fontFamily) + .style("font-size", options.fontSize + "px") + .style("opacity", options.showLabel * options.opacity) .style("pointer-events", "none"); function tick() { @@ -214,48 +223,6 @@ HTMLWidgets.widget({ .attr("x2", function(d) { return idx(d, "x2"); }) .attr("y2", function(d) { return idx(d, "y2"); }); } - - function mouseover(d) { - // unfocus non-connected links and nodes - //if (options.focusOnHover) { - var unfocusDivisor = 4; - - link.transition().duration(200) - .style("opacity", function(l) { return d != l.source && d != l.target ? +options.opacity / unfocusDivisor : +options.opacity }); - - node.transition().duration(200) - .style("opacity", function(o) { return d.index == o.index || neighboring(d, o) ? +options.opacity : +options.opacity / unfocusDivisor; }); - //} - - d3.select(this).select("circle").transition() - .duration(750) - .attr("r", function(d){return nodeSize(d)+5;}); - d3.select(this).select("text").transition() - .duration(750) - .attr("x", 13) - .style("stroke-width", ".5px") - .style("font", options.clickTextSize + "px ") - .style("opacity", 1); - } - - function mouseout() { - node.style("opacity", +options.opacity); - link.style("opacity", +options.opacity); - - d3.select(this).select("circle").transition() - .duration(750) - .attr("r", function(d){return nodeSize(d);}); - d3.select(this).select("text").transition() - .duration(1250) - .attr("x", 0) - .style("font", options.fontSize + "px ") - .style("opacity", options.opacityNoHover); - } - - function click(d) { - return eval(options.clickAction) - } - // add legend option if(options.legend){ var legendRectSize = 18; diff --git a/man/as_treenetdf.Rd b/man/as_treenetdf.Rd index c770d8fd..e3e18a3f 100644 --- a/man/as_treenetdf.Rd +++ b/man/as_treenetdf.Rd @@ -51,10 +51,10 @@ links <- read.csv(header = TRUE, stringsAsFactors = FALSE, text = ' 6,2,six 7,2,seven 8,6,eight') - + # Convert data as_treenetdf(links, cols = c(nodeId = 'source', parentId = 'target')) - + # Graph (calls as_treenetdf internally) treeNetwork(links, cols = c(nodeId = 'source', parentId = 'target')) diff --git a/man/chordNetwork.Rd b/man/chordNetwork.Rd index 6b6d71c1..21eabaa0 100644 --- a/man/chordNetwork.Rd +++ b/man/chordNetwork.Rd @@ -24,7 +24,7 @@ the strength of the link from group n to group m} \item{width}{numeric width for the network graph's frame area in pixels (if \code{NULL} then width is automatically determined based on context)} -\item{initialOpacity}{specify the opacity before the user mouses over +\item{initialOpacity}{specify the opacity before the user mouses over the link} \item{useTicks}{integer number of ticks on the radial axis. @@ -52,7 +52,7 @@ Create Reingold-Tilford Tree network diagrams. } \examples{ \dontrun{ -#### Data about hair colour preferences, from +#### Data about hair colour preferences, from ## https://github.com/mbostock/d3/wiki/Chord-Layout hairColourData <- matrix(c(11975, 1951, 8010, 1013, @@ -60,13 +60,13 @@ hairColourData <- matrix(c(11975, 1951, 8010, 1013, 8916, 2060, 8090, 940, 2868, 6171, 8045, 6907), nrow = 4) - -chordNetwork(Data = hairColourData, - width = 500, + +chordNetwork(Data = hairColourData, + width = 500, height = 500, - colourScale = c("#000000", - "#FFDD89", - "#957244", + colourScale = c("#000000", + "#FFDD89", + "#957244", "#F26223"), labels = c("red", "brown", "blond", "gray")) diff --git a/man/diagonalNetwork.Rd b/man/diagonalNetwork.Rd index 2bc47050..5d6f9769 100644 --- a/man/diagonalNetwork.Rd +++ b/man/diagonalNetwork.Rd @@ -60,7 +60,7 @@ Create Reingold-Tilford Tree network diagrams. # Create URL. paste0 used purely to keep within line width. URL <- paste0("https://cdn.rawgit.com/christophergandrud/networkD3/", "master/JSONdata//flare.json") - + ## Convert to list format Flare <- jsonlite::fromJSON(URL, simplifyDataFrame = FALSE) diff --git a/man/forceNetwork.Rd b/man/forceNetwork.Rd index 2b97ba15..c88f62ba 100644 --- a/man/forceNetwork.Rd +++ b/man/forceNetwork.Rd @@ -10,14 +10,22 @@ specifically for force directed networks } \usage{ forceNetwork(Links, Nodes, Source, Target, Value, NodeID, Nodesize, Group, - height = NULL, width = NULL, - colourScale = JS("d3.scaleOrdinal(d3.schemeCategory20);"), fontSize = 7, + height = "95vmin", width = "95vmax", + colourScale = JS("d3.scaleOrdinal(d3.schemeCategory20);"), fontSize = 8, fontFamily = "serif", linkDistance = 50, linkWidth = JS("function(d) { return Math.sqrt(d.value); }"), - radiusCalculation = JS(" Math.sqrt(d.nodesize)+6"), charge = -30, + radiusCalculation = JS(" Math.sqrt(d.nodesize)+8"), charge = -30, linkColour = "#666", opacity = 0.6, zoom = FALSE, legend = FALSE, - arrows = FALSE, bounded = FALSE, opacityNoHover = 0, - clickAction = NULL) + arrows = FALSE, showLabel = TRUE, bounded = FALSE, + clickCallback = NULL, hoverCallback = JS("function mouseover(d) {", + unFocusOtherLinks(unfocusDivisor = 2, duration = 200, opacity = opacity), + unFocusOtherNodes(unfocusDivisor = 2, duration = 200, opacity = opacity), + nodeSizeEffect(plusSize = 5, duration = 300), labelScaleEffect(fontSize = + fontSize * 2.5, offset = fontSize, duration = 300, opacity = 1), "}"), + unhoverCallback = JS("function mouseover(d) {", unFocusOtherLinks(reset = + TRUE, opacity = opacity), unFocusOtherNodes(reset = TRUE, opacity = opacity), + nodeSizeEffect(plusSize = 0, duration = 300), labelScaleEffect(fontSize = + fontSize, offset = 0, duration = 300, opacity = showLabel * opacity), "}")) } \arguments{ \item{Links}{a data frame object with the links between the nodes. It should @@ -92,15 +100,20 @@ zooming.} \item{arrows}{logical value to enable directional link arrows.} +\item{showLabel}{logical value to show node label} + \item{bounded}{logical value to enable (\code{TRUE}) or disable (\code{FALSE}) the bounding box limiting the graph's extent. See \url{http://bl.ocks.org/mbostock/1129492}.} -\item{opacityNoHover}{numeric value of the opacity proportion for node labels -text when the mouse is not hovering over them.} +\item{clickCallback}{character string with a JavaScript expression to evaluate +when click a node.} + +\item{hoverCallback}{a list of character string with a JavaScript expression to evaluate +when hover a node.} -\item{clickAction}{character string with a JavaScript expression to evaluate -when a node is clicked.} +\item{unhoverCallback}{a list of character string with a JavaScript expression to evaluate +when unhover a node.} } \description{ Create a D3 JavaScript force directed network graph. @@ -154,8 +167,7 @@ forceNetwork(Links = MisJson$links, Nodes = MisJson$nodes, Source = "source", # Create graph with node text faintly visible when no hovering forceNetwork(Links = MisJson$links, Nodes = MisJson$nodes, Source = "source", Target = "target", Value = "value", NodeID = "name", - Group = "group", opacity = 0.4, bounded = TRUE, - opacityNoHover = TRUE) + Group = "group", opacity = 0.4, bounded = TRUE) ## Specify colours for specific edges # Find links to Valjean (11) @@ -175,13 +187,13 @@ forceNetwork(Links = MisLinks, Nodes = MisNodes, Source = "source", # Shiny.onInputChange() to allocate d.XXX to an element of input # for use in a Shiny app. -MyClickScript <- 'alert("You clicked " + d.name + " which is in row " + - (d.index + 1) + " of your original R data frame");' +MyClickScript <- JS('alert("You clicked " + d.name + " which is in row " + + (d.index + 1) + " of your original R data frame");') forceNetwork(Links = MisLinks, Nodes = MisNodes, Source = "source", Target = "target", Value = "value", NodeID = "name", Group = "group", opacity = 1, zoom = FALSE, - bounded = TRUE, clickAction = MyClickScript) + bounded = TRUE, clickCallback = MyClickScript) } } diff --git a/man/labelScaleEffect.Rd b/man/labelScaleEffect.Rd new file mode 100644 index 00000000..6089889b --- /dev/null +++ b/man/labelScaleEffect.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/forceNetwork.R +\name{labelScaleEffect} +\alias{labelScaleEffect} +\title{Javascript function to scale the label} +\usage{ +labelScaleEffect(fontSize = 14, offset = 13, duration = 300, + opacity = 1) +} +\arguments{ +\item{fontSize}{a scale factor of fontSize} + +\item{offset}{a value to x-offset label} + +\item{duration}{the duration of the effect} + +\item{opacity}{numeric value of the proportion opaque you would like the +graph elements to be.} +} +\description{ +Javascript function to scale the label +} diff --git a/man/networkD3-shiny.Rd b/man/networkD3-shiny.Rd index d4d5cb35..51d1adc2 100644 --- a/man/networkD3-shiny.Rd +++ b/man/networkD3-shiny.Rd @@ -32,7 +32,7 @@ diagonalNetworkOutput(outputId, width = "100\%", height = "800px") renderDiagonalNetwork(expr, env = parent.frame(), quoted = FALSE) -forceNetworkOutput(outputId, width = "100\%", height = "500px") +forceNetworkOutput(outputId, width = "95vmmax", height = "95vmin") renderForceNetwork(expr, env = parent.frame(), quoted = FALSE) diff --git a/man/nodeSizeEffect.Rd b/man/nodeSizeEffect.Rd new file mode 100644 index 00000000..5f3d50e6 --- /dev/null +++ b/man/nodeSizeEffect.Rd @@ -0,0 +1,16 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/forceNetwork.R +\name{nodeSizeEffect} +\alias{nodeSizeEffect} +\title{Javascript function to increase node size} +\usage{ +nodeSizeEffect(plusSize = 5, duration = 300) +} +\arguments{ +\item{plusSize}{value to increase size node} + +\item{duration}{the duration of the effect} +} +\description{ +Javascript function to increase node size +} diff --git a/man/radialNetwork.Rd b/man/radialNetwork.Rd index 84313b2c..6eeefe58 100644 --- a/man/radialNetwork.Rd +++ b/man/radialNetwork.Rd @@ -60,7 +60,7 @@ Create Reingold-Tilford Tree network diagrams. # Create URL. paste0 used purely to keep within line width. URL <- paste0("https://cdn.rawgit.com/christophergandrud/networkD3/", "master/JSONdata//flare.json") - + ## Convert to list format Flare <- jsonlite::fromJSON(URL, simplifyDataFrame = FALSE) diff --git a/man/unFocusOtherLinks.Rd b/man/unFocusOtherLinks.Rd new file mode 100644 index 00000000..cbbee6d0 --- /dev/null +++ b/man/unFocusOtherLinks.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/forceNetwork.R +\name{unFocusOtherLinks} +\alias{unFocusOtherLinks} +\alias{unFocusOtherNodes} +\title{Javascript function to unfocus other nodes} +\usage{ +unFocusOtherLinks(unfocusDivisor = 2, duration = 200, opacity = 1, + reset = FALSE) + +unFocusOtherNodes(unfocusDivisor = 2, duration = 200, opacity = 1, + reset = FALSE) +} +\arguments{ +\item{unfocusDivisor}{a divisor factor of apacity} + +\item{duration}{the duration of the effect} + +\item{opacity}{numeric value of the proportion opaque you would like the +graph elements to be.} + +\item{reset}{reset the effect} +} +\description{ +Javascript function to unfocus other nodes +} From ce0fdee543e462f0a08e9aeffea6f9e0d3ff9e38 Mon Sep 17 00:00:00 2001 From: "tuskan.net@gmail.com" Date: Mon, 9 Apr 2018 01:43:21 -0300 Subject: [PATCH 2/2] User Input Mouse Callback Function Added --- NAMESPACE | 1 + R/forceNetwork.R | 16 ++++++---------- man/{unFocusOtherLinks.Rd => Callbacks.Rd} | 20 +++++++++++++++++--- man/labelScaleEffect.Rd | 22 ---------------------- man/nodeSizeEffect.Rd | 16 ---------------- 5 files changed, 24 insertions(+), 51 deletions(-) rename man/{unFocusOtherLinks.Rd => Callbacks.Rd} (58%) delete mode 100644 man/labelScaleEffect.Rd delete mode 100644 man/nodeSizeEffect.Rd diff --git a/NAMESPACE b/NAMESPACE index 84b621e4..a7d22d33 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -39,6 +39,7 @@ export(simpleNetworkOutput) export(treeNetwork) export(treeNetworkOutput) export(unFocusOtherLinks) +export(unFocusOtherNodes) importFrom(data.tree,ToDataFrameNetwork) importFrom(htmlwidgets,createWidget) importFrom(htmlwidgets,shinyRenderWidget) diff --git a/R/forceNetwork.R b/R/forceNetwork.R index e4d824d3..499d5423 100755 --- a/R/forceNetwork.R +++ b/R/forceNetwork.R @@ -264,13 +264,14 @@ forceNetwork <- function(Links, } -#' Javascript function to unfocus other nodes +#' Javascript callback mouse functions #' #' @param unfocusDivisor a divisor factor of apacity #' @param duration the duration of the effect #' @param reset reset the effect #' @param opacity numeric value of the proportion opaque you would like the #' graph elements to be. +#' @name Callbacks #' @export unFocusOtherLinks <- function(unfocusDivisor = 2, duration = 200, opacity = 1, reset = FALSE) { if (reset) return(paste0('d3.selectAll(".link").style("opacity", +', opacity, ');')) @@ -280,7 +281,8 @@ unFocusOtherLinks <- function(unfocusDivisor = 2, duration = 200, opacity = 1, r ) } -#' @rdname unFocusOtherLinks +#' @rdname Callbacks +#' @export unFocusOtherNodes <- function(unfocusDivisor = 2, duration = 200, opacity = 1, reset = FALSE) { if (reset) return(paste0('d3.selectAll(".node").style("opacity", +', opacity, ');')) paste0( @@ -289,10 +291,8 @@ unFocusOtherNodes <- function(unfocusDivisor = 2, duration = 200, opacity = 1, r ) } -#' Javascript function to increase node size -#' +#' @rdname Callbacks #' @param plusSize value to increase size node -#' @param duration the duration of the effect #' @export nodeSizeEffect <- function(plusSize = 5, duration = 300) { paste0( @@ -302,13 +302,9 @@ nodeSizeEffect <- function(plusSize = 5, duration = 300) { ) } -#' Javascript function to scale the label -#' +#' @rdname Callbacks #' @param fontSize a scale factor of fontSize #' @param offset a value to x-offset label -#' @param duration the duration of the effect -#' @param opacity numeric value of the proportion opaque you would like the -#' graph elements to be. #' @export labelScaleEffect <- function(fontSize = 14, offset = 13, duration = 300, opacity = 1) { paste0( diff --git a/man/unFocusOtherLinks.Rd b/man/Callbacks.Rd similarity index 58% rename from man/unFocusOtherLinks.Rd rename to man/Callbacks.Rd index cbbee6d0..e73013da 100644 --- a/man/unFocusOtherLinks.Rd +++ b/man/Callbacks.Rd @@ -1,15 +1,23 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/forceNetwork.R -\name{unFocusOtherLinks} +\name{Callbacks} +\alias{Callbacks} \alias{unFocusOtherLinks} \alias{unFocusOtherNodes} -\title{Javascript function to unfocus other nodes} +\alias{nodeSizeEffect} +\alias{labelScaleEffect} +\title{Javascript callback mouse functions} \usage{ unFocusOtherLinks(unfocusDivisor = 2, duration = 200, opacity = 1, reset = FALSE) unFocusOtherNodes(unfocusDivisor = 2, duration = 200, opacity = 1, reset = FALSE) + +nodeSizeEffect(plusSize = 5, duration = 300) + +labelScaleEffect(fontSize = 14, offset = 13, duration = 300, + opacity = 1) } \arguments{ \item{unfocusDivisor}{a divisor factor of apacity} @@ -20,7 +28,13 @@ unFocusOtherNodes(unfocusDivisor = 2, duration = 200, opacity = 1, graph elements to be.} \item{reset}{reset the effect} + +\item{plusSize}{value to increase size node} + +\item{fontSize}{a scale factor of fontSize} + +\item{offset}{a value to x-offset label} } \description{ -Javascript function to unfocus other nodes +Javascript callback mouse functions } diff --git a/man/labelScaleEffect.Rd b/man/labelScaleEffect.Rd deleted file mode 100644 index 6089889b..00000000 --- a/man/labelScaleEffect.Rd +++ /dev/null @@ -1,22 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/forceNetwork.R -\name{labelScaleEffect} -\alias{labelScaleEffect} -\title{Javascript function to scale the label} -\usage{ -labelScaleEffect(fontSize = 14, offset = 13, duration = 300, - opacity = 1) -} -\arguments{ -\item{fontSize}{a scale factor of fontSize} - -\item{offset}{a value to x-offset label} - -\item{duration}{the duration of the effect} - -\item{opacity}{numeric value of the proportion opaque you would like the -graph elements to be.} -} -\description{ -Javascript function to scale the label -} diff --git a/man/nodeSizeEffect.Rd b/man/nodeSizeEffect.Rd deleted file mode 100644 index 5f3d50e6..00000000 --- a/man/nodeSizeEffect.Rd +++ /dev/null @@ -1,16 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/forceNetwork.R -\name{nodeSizeEffect} -\alias{nodeSizeEffect} -\title{Javascript function to increase node size} -\usage{ -nodeSizeEffect(plusSize = 5, duration = 300) -} -\arguments{ -\item{plusSize}{value to increase size node} - -\item{duration}{the duration of the effect} -} -\description{ -Javascript function to increase node size -}