Add network methods

DESCRIPTION

@@ -43,12 +43,13 @@ Depends:
 Collate: 
     'bin.R'
     'class-ContingencyTable.R'
+    'utils.R'
     'class-Node.R'
+    'constructors-Node.R'
     'class-Link.R'
     'class-Network.R'
     'methods-Links.R'
     'methods-Nodes.R'
-    'methods-KPartiteNetwork.R'
     'class-KPartiteNetwork.R'
     'class-plotdata-bar.R'
     'class-plotdata-beeswarm.R'
@@ -62,11 +63,11 @@ Collate:
     'class-plotdata.R'
     'group.R'
     'methods-ContingencyTable.R'
-    'methods-network.R'
+    'methods-KPartiteNetwork.R'
+    'methods-Network.R'
     'panel.R'
     'plot.data-package.R'
     'utils-bin.R'
     'utils-json.R'
     'utils-pipe.R'
     'utils-stats.R'
-    'utils.R'

NAMESPACE

@@ -43,6 +43,8 @@ export(findBinSliderValues)
 export(findBinWidth)
 export(findViewport)
 export(fishersTest)
+export(getDuplicateLinks)
+export(getIsolatedNodes)
 export(getQuadrantValues)
 export(heatmap)
 export(heatmap.dt)
@@ -62,6 +64,11 @@ export(orderByReferenceValues)
 export(outliers)
 export(posPredictiveValue)
 export(prevalence)
+export(pruneDuplicateLinks)
+export(pruneIsolatedNodes)
+export(pruneLinksAboveWeight)
+export(pruneLinksBelowWeight)
+export(pruneLinksByPredicate)
 export(relativeRisk)
 export(scattergl)
 export(scattergl.dt)
@@ -83,16 +90,22 @@ exportClasses(TwoByTwoTable)
 exportMethods(allStats)
 exportMethods(chiSqResults)
 exportMethods(fishersTest)
+exportMethods(getDuplicateLinks)
+exportMethods(getIsolatedNodes)
 exportMethods(getQuadrantValues)
 exportMethods(makeVariableDetails)
 exportMethods(negPredictiveValue)
 exportMethods(oddsRatio)
 exportMethods(orderByReferenceValues)
 exportMethods(posPredictiveValue)
 exportMethods(prevalence)
+exportMethods(pruneDuplicateLinks)
+exportMethods(pruneIsolatedNodes)
+exportMethods(pruneLinksByPredicate)
 exportMethods(relativeRisk)
 exportMethods(sensitivity)
 exportMethods(specificity)
+exportMethods(toJSON)
 import(data.table)
 import(veupathUtils)
 importFrom(S4Vectors,SimpleList)

R/class-KPartiteNetwork.R

@@ -1,10 +1,10 @@
-#' @include methods-KPartiteNetwork.R
+#' @include methods-Nodes.R
 check_partitions <- function(object) {
   errors <- character()
 
-  if (!!length(getAllNodeIds(object))) {
+  if (!!length(unlist(lapply(as.list(object), getNodeIds)))) {
     # Ensure that no node is in multiple partitions
-    if (length(getAllNodeIds(object)) > data.table::uniqueN(getAllNodeIds(object))) {
+    if (length(unlist(lapply(as.list(object), getNodeIds))) > data.table::uniqueN(getAllNodeIds(object))) {
       errors <- c(errors, 'Found a node in multiple partitions. Nodes can only exist in one partition.')
     }
   }
@@ -116,4 +116,75 @@ KPartiteNetwork <- setClass("KPartiteNetwork",
     partitions = Partitions()
   ),
   validity = check_kpartite_network
-)
+)
+
+#' @include utils.R
+#' Generate a K-Partite Network 
+#' 
+#' Generate a K-Partite Network from a LinkList and NodeList, or from a data.frame
+#' @param links LinkList
+#' @param nodes NodeList
+#' @param object Object containing data to be converted to a Network
+#' @return KPartiteNetwork
+#' @export
+#' @examples
+#' KPartiteNetwork(data.frame(source='a',target='b'))
+setGeneric("KPartiteNetwork", 
+  function(
+    links,
+    nodes,
+    object, 
+    partitions = Partitions(),
+    linkColorScheme = 'none', 
+    variables = VariableMetadataList(), 
+    ...
+  ) standardGeneric("KPartiteNetwork"),
+  signature = c("links", "nodes", "object")
+)
+
+#' @export
+setMethod("KPartiteNetwork", signature("LinkList", "NodeList", "missing"), function(
+  links, 
+  nodes,
+  object,
+  partitions = Partitions(),
+  linkColorScheme = 'none', 
+  variables = VariableMetadataList(), 
+  ...
+) {
+  # default to a single partition if none provided
+  if (length(partitions) == 0) {
+    partitions <- Partitions(list(NodeIdList(nodes)))
+  }
+  new("KPartiteNetwork", links=links, nodes=nodes, partitions=partitions, linkColorScheme=linkColorScheme, variableMapping=variables)
+})
+
+#' @export  
+setMethod("KPartiteNetwork", signature("missing", "missing", "data.frame"), function(
+  links, 
+  nodes,
+  object = data.frame(source=character(),target=character()), 
+  partitions = Partitions(),
+  linkColorScheme = 'none', 
+  variables = VariableMetadataList(), 
+  ...
+) {
+  # default to a single partition if none provided
+  if (length(partitions) == 0) {
+    partitions <- Partitions(list(NodeIdList(object)))
+  }
+  new("KPartiteNetwork", links=LinkList(object), nodes=NodeList(object), partitions=partitions, linkColorScheme=linkColorScheme, variableMapping=variables)
+})
+
+#' @export 
+setMethod("KPartiteNetwork", signature("missing", "missing", "missing"), function(
+  links, 
+  nodes,
+  object,
+  partitions = Partitions(),
+  linkColorScheme = 'none', 
+  variables = VariableMetadataList(), 
+  ...
+) {
+  new("KPartiteNetwork")
+})

R/class-Link.R

@@ -26,8 +26,9 @@ check_link <- function(object) {
 #' @name Link-class
 #' @rdname Link-class
 #' @include class-Node.R
+#' @include constructors-Node.R
 #' @export
-Link <- setClass("Link", 
+setClass("Link", 
   representation(
     source = "Node",
     target = "Node",
@@ -37,14 +38,49 @@ Link <- setClass("Link",
     # label = "character" # coming soon
   ),
   prototype = prototype(
-    source = new("Node"),
-    target = new("Node"),
+    source = Node(),
+    target = Node(),
     weight = 1,
+    color = NULL,
     isDirected = FALSE
   ),
   validity = check_link
 )
 
+#' Link constructor
+#' 
+#' @param source The source node
+#' @param target The target node
+#' @param weight The weight of the link
+#' @param color The color of the link
+#' @param isDirected Whether the link is directed
+#' @export
+setGeneric("Link", function(source, target, weight = 1, color = NULL, isDirected = FALSE) standardGeneric("Link"), signature = c("source", "target"))
+
+#' @export
+setMethod("Link", c("Node", "Node"), function(source, target, weight = 1, color = NULL, isDirected = FALSE) {
+  new("Link", source = source, target = target, weight = weight, color = color, isDirected = isDirected)
+})
+
+#' @export
+setMethod("Link", c("character", "character"), function(source, target, weight = 1, color = NULL, isDirected = FALSE) {
+  Link(source = Node(source), target = Node(target), weight = weight, color = color, isDirected = isDirected)
+})
+
+#' @export
+setMethod("Link", c("numeric", "numeric"), function(source, target, weight = 1, color = NULL, isDirected = FALSE) {
+  Link(source = Node(source), target = Node(target), weight = weight, color = color, isDirected = isDirected)
+})
+
+#' @export
+setMethod("Link", c("NodeId", "NodeId"), function(source, target, weight = 1, color = NULL, isDirected = FALSE) {
+  Link(source = Node(source), target = Node(target), weight = weight, color = color, isDirected = isDirected)
+})
+
+#' @export
+setMethod("Link", c("missing", "missing"), function(source, target, weight = 1, color = NULL, isDirected = FALSE) {
+  new("Link")
+})
 
 check_link_list <- function(object) {
 
@@ -83,10 +119,80 @@ check_link_list <- function(object) {
 #' @rdname LinkList-class
 #' @importFrom S4Vectors SimpleList
 #' @export
-LinkList <- setClass("LinkList", 
+setClass("LinkList", 
   contains = "SimpleList",
   prototype = prototype(
     elementType = "Link"
   ),
   validity = check_link_list
-)
+)
+
+#' Generate a LinkList
+#' 
+#' Generate a LinkList from an edgeList
+#' @param object Object containing data to be converted to a LinkList
+#' @param linkColorScheme Either 'none' or 'posneg'. If 'posneg', the link color will be based on the sign of the weight.
+#' @return LinkList
+#' @export
+#' @examples
+#' LinkList(data.frame(source='a',target='b'))
+setGeneric("LinkList", function(object, linkColorScheme = c('none', 'posneg')) standardGeneric("LinkList"), signature = c("object"))
+
+#' @export
+setMethod("LinkList", "data.frame", function(object = data.frame(source=character(),target=character()), linkColorScheme = c('none', 'posneg')) {
+  if (!isValidEdgeList(object)) {
+    stop(paste(errors, collapse = '\n'))
+  }
+
+  if (nrow(object) == 0) {
+    new("LinkList")
+  }
+
+  # TODO this is probably not the right place for defaults...
+  makeLink <- function(x, linkColorScheme) {
+    source <- unname(x['source'])
+    target <- unname(x['target'])
+    weight <- as.numeric(unname(x['weight']))
+    weight <- ifelse(is.na(weight), 1, weight)
+    isDirected <- unname(x['isDirected'])
+    isDirected <- ifelse(is.na(isDirected), FALSE, isDirected)
+    color <- unname(x['color'])
+
+    # dont override color if present, but if not present look to linkColorScheme
+    if (is.na(color) && linkColorScheme == 'posneg') {
+      if (weight < 0) {
+        color <- -1
+      } else if (weight > 0) {
+        color <- 1
+      } else {
+        color <- 0
+      }
+    }
+
+    if (is.na(color)) {
+      link <- Link(source, target, weight, NULL, isDirected)
+    } else {
+      link <- Link(source, target, weight, color, isDirected)
+    }
+
+    return(link)
+  }
+
+  linkList <- apply(object, 1, makeLink, linkColorScheme)
+  new("LinkList", linkList)
+})
+
+#' @export
+setMethod("LinkList", "missing", function(object) {
+  new("LinkList")
+})
+
+#' @export 
+setMethod("LinkList", "SimpleList", function(object) {
+  new("LinkList", object)
+})
+
+#' @export 
+setMethod("LinkList", "list", function(object) {
+  new("LinkList", object)
+})