R/networkFix.R

In danielalcaide/mclean: Multilevel Clustering Exploration As Network

networkFix <- function(Links,
                                 Nodes,
                                 Source,
                                 Target,
                                 Value,
                                 NodeID,
                                 Nodesize,
                                 Group,
                                 Component,
                                 xPos = "x",
                                 yPos = "y",
                                 height = NULL,
                                 width = NULL,
                                 colourScale = JS("d3.scaleOrdinal(d3.schemeCategory20);"),
                                 fontSize = 7,
                                 fontFamily = "serif",
                                 linkDistance = 50,
                                 linkWidth = JS("function(d) { return Math.sqrt(d.value); }"),
                                 radiusCalculation = JS(" Math.sqrt(d.nodesize)+6"),
                                 charge = -120,
                                 linkColour = "#666",
                                 opacity = 0.6,
                                 zoom = FALSE,
                                 legend = FALSE,
                                 interaction = "lasso",
                                 shiny = FALSE,
                                 id = "default",
                                 bounded = FALSE,
                                 opacityNoHover = 0,
                                 clickAction = NULL)
{
  # Check if data is zero indexed
  check_zero(Links[, Source], Links[, Target])

  # Check if LASSO interaction and ZOOM
  if (interaction == "lasso" && zoom == TRUE) {
    zoom = FALSE
    warning(paste("Lasso interaction is active.",
                  "Zoom option is not compatible with lasso at the same time.",
                  "Zoom won't be used", sep=" "))
  }

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

  # 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], Nodes[, Component], Nodes[,xPos], Nodes[,yPos])
    names(NodesDF) <- c("name", "group", "nodesize", "component", "x", "y")
    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)

  # 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,
    interaction = interaction,
    shiny = shiny,
    id = id,
    nodesize = nodesize,
    radiusCalculation = radiusCalculation,
    bounded = bounded,
    opacityNoHover = opacityNoHover,
    clickAction = clickAction
  )

  # create widget
  htmlwidgets::createWidget(
    name = "networkFix",
    x = list(links = LinksDF, nodes = NodesDF, options = options),
    width = width,
    height = height,
    htmlwidgets::sizingPolicy(padding = 10, browser.fill = TRUE),
    package = "mclean"
  )
}

#' @rdname mclean-shiny
#' @export
networkFixOutput <- function(outputId, width = "100%", height = "960px") {
  shinyWidgetOutput(outputId, "network", width, height,
                    package = "mclean")
}

#' @rdname mclean-shiny
#' @export
renderNetworkFix <- function(expr, env = parent.frame(), quoted = FALSE) {
  if (!quoted) { expr <- substitute(expr) } # force quoted
  shinyRenderWidget(expr, networkFixOutput, env, quoted = TRUE)
}