#' Plot epicontacts objects using visNetwork
#'
#' This function plots \code{\link{epicontacts}} objects using the
#' \code{visNetwork} package. The produced object is an \code{htmlwidget} which
#' will need rendering within a web browser.
#'
#' @export
#'
#'
#' @author
#' Thibaut Jombart (\email{thibautjombart@@gmail.com})
#' VP Nagraj (\email{vpnagraj@@virginia.edu})
#' Zhian N. Kamvar (\email{zkamvar@@gmail.com})
#'
#' @param x An \code{\link{epicontacts}} object.
#'
#' @param thin A logical indicating if the data should be thinned with \code{\link{thin}} so that only cases with contacts should be plotted.
#'
#' @param node_color An index or character string indicating which field of the
#' linelist should be used to color the nodes.
#'
#' @param annot An index, logical, or character string indicating which fields
#' of the linelist should be used for annotating the nodes. Logical will be
#' recycled if necessary, so that the default \code{TRUE} effectively uses all
#' columns of the linelist.
#'
#' @param node_shape An index or character string indicating which field of the
#' linelist should be used to determine the shapes of the nodes.
#'
#' @param shapes A named vector of characters indicating which icon code should
#' be used for each value \code{node_shape}, e.g. \code{c(m = "male", f =
#' "female")} if 'm' amd 'f' are values from \code{node_shape}. See
#' \code{\link{codeawesome}} for all available codes.
#'
#' @param label An index, logical, or character string indicating which fields
#' of the linelist should be used for labelling the nodes. Logical will be
#' recycled if necessary, so that the default \code{TRUE} effectively uses all
#' columns of the linelist.
#'
#' @param edge_label An index or character string indicating which field of the
#' contacts data should be used to label the edges of the graph.
#'
#' @param edge_color An index or character string indicating which field of the
#' contacts data should be used to color the edges of the graph.
#'
#' @param edge_width An integer indicating the width of the edges. Defaults to
#' 3.
#'
#' @param legend A logical indicating whether a legend should be added to the
#' plot.
#'
#' @param x_axis Feature currently only available in development "timeline" branch.
#'
#' @param legend_max The maximum number of groups for a legend to be displayed.
#'
#' @param col_pal A color palette for the nodes.
#'
#' @param edge_col_pal A color palette for the edges.
#'
#' @param NA_col The color used for unknown group.
#'
#' @param width The width of the output, in html compatible format (e.g. '90\%'
#' or '800px').
#'
#' @param height The height of the output, in html compatible format
#' (e.g. '800px').
#'
#' @param selector A logical indicating if the selector tool should be used;
#' defaults to TRUE.
#'
#' @param editor A logical indicating if the editor tool should be used;
#' defaults to FALSE.
#'
#' @param ... Further arguments to be passed to \code{visNetwork}.
#'
#' @return The same output as \code{visNetwork}.
#'
#' @seealso \code{\link[visNetwork]{visNetwork}} in the package \code{visNetwork}.
#' \code{\link{edges_pal}} and \code{\link{cases_pal}} for color palettes used
#'
#' @examples
#' if (require(outbreaks)) {
#'
#' ## example using MERS outbreak in Korea, 2014
#' head(mers_korea_2015[[1]])
#' head(mers_korea_2015[[2]])
#'
#' x <- make_epicontacts(linelist=mers_korea_2015[[1]],
#' contacts = mers_korea_2015[[2]],
#' directed=TRUE)
#'
#' \dontrun{
#' plot(x)
#' plot(x, node_color = "place_infect")
#' # show transmission tree with time as the horizontal axis, showing all nodes
#' #' plot(x, node_color = "loc_hosp", legend_max=20, annot=TRUE)
#' #' plot(x, "place_infect", node_shape = "sex",
#' shapes = c(M = "male", F = "female"))
#'
#' plot(x, "sex", node_shape = "sex", shapes = c(F = "female", M = "male"),
#' edge_label = "exposure", edge_color = "exposure")
#' }
#' }
vis_epicontacts <- function(x, thin = TRUE, node_color = "id", label = "id",
annot = TRUE, node_shape = NULL, shapes = NULL,
edge_label = NULL, edge_color = NULL, legend = TRUE,
legend_max = 10, x_axis = NULL, col_pal = cases_pal,
NA_col = "lightgrey", edge_col_pal = edges_pal,
width = "90%", height = "700px", selector = TRUE,
editor = FALSE, edge_width = 3, ...){
## In the following, we pull the list of all plotted nodes (those from the
## linelist, and from the contacts data.frame, and then derive node attributes
## for the whole lot. These attributes are in turn used for plotting: as color
## ('group' in visNetwork terminology) or as annotations (converted to html
## code).
## handling
if (thin) {
x <- thin(x)
}
## throw error if x_axis argument specified
if(!is.null(x_axis))
stop(paste(
"x_axis feature only available in development 'timeline' branch, which can be installed",
"via remotes::install_github('reconhub/epicontacts@timeline')."
))
## check node_color (node attribute used for color)
node_color <- assert_node_color(x, node_color)
## check node_shape (node attribute used for color)
node_shape <- assert_node_shape(x, node_shape)
## check annot (txt displayed when clicking on node)
annot <- assert_annot(x, annot)
## check node_color (node attribute used for color)
edge_label <- assert_edge_label(x, edge_label)
## check node_color (node attribute used for color)
edge_color <- assert_edge_color(x, edge_color)
## make a list of all nodes, and generate a data.frame of node attributes
all_nodes <- get_id(x, which = "all")
## find out which nodes are unconnected to any other nodes
## This is only relevant when `thin = TRUE`
nodes <- data.frame(id = all_nodes,
stringsAsFactors = FALSE)
nodes <- merge(nodes, x$linelist, by = "id", all = TRUE)
## generate annotations ('title' in visNetwork terms)
if (!is.null(label)) {
labels <- apply(nodes[, label, drop = FALSE], 1,
paste, collapse = "\n")
nodes$label <- labels
}
## generate annotations ('title' in visNetwork terms)
if (!is.null(annot)) {
temp <- nodes[, annot, drop = FALSE]
temp <- vapply(names(temp),
function(e) paste(e, temp[, e], sep = ": "),
character(nrow(nodes)))
nodes$title <- paste("<p>",
apply(temp, 1, paste0, collapse = "<br>"), "</p>")
}
## add node color ('group')
if (!is.null(node_color)) {
node_col_info <- fac2col(factor(nodes[, node_color]),
col_pal,
NA_col,
legend = TRUE)
K <- length(node_col_info$leg_lab)
nodes$color <- node_col_info$color
}
## add shape info
if (!is.null(node_shape)) {
if (is.null(shapes)) {
msg <- paste("'shapes' needed if 'node_shape' provided;",
"to see codes, node_shape: codeawesome")
stop(msg)
}
vec_node_shapes <- as.character(unlist(nodes[node_shape]))
shapes["NA"] <- "question-circle"
unknown_codes <- !shapes %in% names(codeawesome)
if (any(unknown_codes)) {
culprits <- paste(shapes[unknown_codes],
collapse = ", ")
msg <- sprintf("unknown icon codes: %s \nto see 'codeawesome'",
culprits)
stop(msg)
}
vec_node_shapes <- paste(vec_node_shapes)
node_code <- codeawesome[shapes[vec_node_shapes]]
nodes$shape <- "icon"
nodes$icon.code <- node_code
nodes$icon.color <- nodes$color
} else {
nodes$borderWidth <- 2
}
## add edge info
edges <- x$contacts
edges$width <- edge_width
if (x$directed) {
edges$arrows <- "to"
}
if (!is.null(edge_label)) {
edges$label <- edges[, edge_label]
}
if (!is.null(edge_color)) {
edge_col_info <- fac2col(factor(edges[, edge_color]),
edge_col_pal,
NA_col,
legend = TRUE)
L <- length(edge_col_info$leg_lab)
edges$color <- edge_col_info$color
}
## build visNetwork output
out <- visNetwork::visNetwork(nodes, edges,
width = width,
height = height, ...)
## specify group colors, add legend
if (legend) {
if (!is.null(node_color) && (K < legend_max)) {
leg_nodes <- data.frame(label = node_col_info$leg_lab,
color = node_col_info$leg_col,
shape = "box",
shadow = TRUE,
font.size = 20)
} else {
leg_nodes <- NULL
}
if (!is.null(edge_color) && (L < legend_max)) {
leg_edges <- data.frame(label = edge_col_info$leg_lab,
color = edge_col_info$leg_col,
font.size = 15)
} else {
leg_edges <- NULL
}
out <- visNetwork::visLegend(out,
addNodes = leg_nodes,
addEdges = leg_edges,
useGroups = FALSE)
}
## set nodes borders, edge width, and plotting options
enabled <- list(enabled = TRUE)
arg_selec <- if (selector) node_color else NULL
out <- visNetwork::visOptions(out, highlightNearest = TRUE)
out <- visNetwork::visOptions(out,
selectedBy = arg_selec,
manipulation = editor,
highlightNearest = enabled)
out <- visNetwork::visPhysics(out, stabilization = FALSE)
# add fontAwesome
out <- visNetwork::addFontAwesome(out)
return(out)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.