Merge pull request #244 from VEuPathDB/degree-list

Degree list

DESCRIPTION

@@ -34,7 +34,7 @@ Description: plot.data is an R package for creating client-ready data for variou
 License: Apache License (= 2.0)
 Encoding: UTF-8
 LazyData: true
-RoxygenNote: 7.2.3
+RoxygenNote: 7.3.1
 Suggests: 
     covr,
     testthat (>= 2.1.0)

NAMESPACE

@@ -16,11 +16,9 @@ export(KPartiteNetwork)
 export(Link)
 export(LinkList)
 export(Network)
-export(Node)
 export(NodeId)
 export(NodeIdList)
 export(NodeList)
-export(Partition)
 export(Partitions)
 export(TwoByTwoTable)
 export(adjustToViewport)
@@ -45,6 +43,7 @@ export(findViewport)
 export(fishersTest)
 export(getDuplicateLinks)
 export(getIsolatedNodes)
+export(getPartitionIndex)
 export(getQuadrantValues)
 export(heatmap)
 export(heatmap.dt)
@@ -76,8 +75,8 @@ export(sensitivity)
 export(smoothedMean)
 export(specificity)
 export(writeJSON)
+export(writeNetworkJSON)
 exportClasses(ContingencyTable)
-exportClasses(KPartiteNetwork)
 exportClasses(Link)
 exportClasses(LinkList)
 exportClasses(Network)
@@ -87,6 +86,12 @@ exportClasses(NodeIdList)
 exportClasses(NodeList)
 exportClasses(Partitions)
 exportClasses(TwoByTwoTable)
+exportMethods(KPartiteNetwork)
+exportMethods(Link)
+exportMethods(LinkList)
+exportMethods(Network)
+exportMethods(NodeIdList)
+exportMethods(NodeList)
 exportMethods(allStats)
 exportMethods(chiSqResults)
 exportMethods(fishersTest)
@@ -106,6 +111,7 @@ exportMethods(relativeRisk)
 exportMethods(sensitivity)
 exportMethods(specificity)
 exportMethods(toJSON)
+exportMethods(writeNetworkJSON)
 import(data.table)
 import(veupathUtils)
 importFrom(S4Vectors,SimpleList)

R/class-Link.R

@@ -17,7 +17,6 @@ check_link <- function(object) {
   return(if (length(errors) == 0) TRUE else errors) 
 }
 
-
 #' Link
 #' 
 #' Represent one singular link. A link has a source, and a target. It may be directed or undirected.
@@ -30,16 +29,16 @@ check_link <- function(object) {
 #' @export
 setClass("Link", 
   representation(
-    source = "Node",
-    target = "Node",
+    source = "NodeId",
+    target = "NodeId",
     weight = "numeric",
     color = 'ANY',
     isDirected = "logical"
     # label = "character" # coming soon
   ),
   prototype = prototype(
-    source = Node(),
-    target = Node(),
+    source = NodeId(),
+    target = NodeId(),
     weight = 1,
     color = NULL,
     isDirected = FALSE
@@ -49,8 +48,8 @@ setClass("Link",
 
 #' Link constructor
 #' 
-#' @param source The source node
-#' @param target The target node
+#' @param source The source node identifier
+#' @param target The target node identifier
 #' @param weight The weight of the link
 #' @param color The color of the link
 #' @param isDirected Whether the link is directed
@@ -59,22 +58,22 @@ setGeneric("Link", function(source, target, weight = 1, color = NULL, isDirected
 
 #' @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)
+  new("Link", source = NodeId(id(source)), target = NodeId(id(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)
+  Link(source = NodeId(source), target = NodeId(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)
+  Link(source = NodeId(source), target = NodeId(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)
+  new("Link", source = source, target = target, weight = weight, color = color, isDirected = isDirected)
 })
 
 #' @export

R/class-Network.R

@@ -4,7 +4,7 @@ check_network <- function(object) {
   errors <- character()
 
   # Check that all nodes in links are in nodes
-  nodesInLinks <- NodeList(union(getSourceNodes(object@links), getTargetNodes(object@links))) # may become a method later if i find i use it elsewhere
+  nodesInLinks <- NodeIdList(union(getSourceNodes(object@links), getTargetNodes(object@links))) # may become a method later if i find i use it elsewhere
   if (!all(getNodeIds(nodesInLinks) %in% getNodeIds(object@nodes))) {
     errors <- c(errors, 'Found a node in a link that is not in the node list. All nodes in links must also be in nodes.')
   }

R/class-Node.R

@@ -103,6 +103,7 @@ generate_node_id <- function(n = 5000) {
 #' @slot y numeric value indicating the y coordinate of the node. Optional.
 #' @slot color string or numeric that determines the color of the node. Optional.
 #' @slot weight numeric value associated with the node, such as timestamp or other node-associated data. Optional.
+#' @slot degree numeric value indicating the degree of the node
 #' 
 #' @name Node-class
 #' @rdname Node-class
@@ -113,7 +114,8 @@ setClass("Node",
     x = "numeric",
     y = "numeric",
     color = "ANY",
-    weight = "ANY"
+    weight = "ANY",
+    degree = "numeric"
   ),
   validity = check_node
 )

R/constructors-Node.R

@@ -6,8 +6,11 @@
 #' 
 #' @param value string a unique identifier for the node
 #' @export 
-NodeId <- function(value) {
-  new("NodeId", value = value)
+NodeId <- function(value = character()) {
+  if (length(value) == 0) {
+    value <- generate_node_id(1)
+  }
+  new("NodeId", value = as.character(value))
 }
 
 
@@ -97,27 +100,28 @@ setMethod("NodeIdList", "Node", function(object, uniquifyIds = c(TRUE, FALSE)) {
 #' @param y numeric value indicating the y coordinate of the node. Optional.
 #' @param color string or numeric that determines the color of the node. Optional.
 #' @param weight numeric value associated with the node, such as timestamp or other node-associated data. Optional.
-#' @export
-setGeneric("Node", function(id, x = numeric(), y = numeric(), color = NULL, weight = NULL) standardGeneric("Node"), signature = c("id"))
+#' @param degree numeric value indicating the degree of the node. This only makes sense in the context of a network,
+#'    and should not be provided in other contexts like when working w an individual node.
+setGeneric("Node", function(id, x = numeric(), y = numeric(), color = NULL, weight = NULL, degree = NULL) standardGeneric("Node"), signature = c("id"))
 
-#' @export
-setMethod("Node", "numeric", function(id, x = numeric(), y = numeric(), color = NULL, weight = NULL) {
-  new("Node", id = NodeId(as.character(id)), x = x, y = y, color = color, weight = weight)
+setMethod("Node", "numeric", function(id, x = numeric(), y = numeric(), color = NULL, weight = NULL, degree = NULL) {
+  degree <- ifelse(is.null(degree), NA_real_, degree)
+  new("Node", id = NodeId(as.character(id)), x = x, y = y, color = color, weight = weight, degree = degree)
 })
 
-#' @export
-setMethod("Node", "character", function(id, x = numeric(), y = numeric(), color = NULL, weight = NULL) {
-  new("Node", id = NodeId(id), x = x, y = y, color = color, weight = weight)
+setMethod("Node", "character", function(id, x = numeric(), y = numeric(), color = NULL, weight = NULL, degree = NULL) {
+  degree <- ifelse(is.null(degree), NA_real_, degree)
+  new("Node", id = NodeId(id), x = x, y = y, color = color, weight = weight, degree = degree)
 })
 
-#' @export
-setMethod("Node", "NodeId", function(id, x = numeric(), y = numeric(), color = NULL, weight = NULL) {
-  new("Node", id = id, x = x, y = y, color = color, weight = weight)
+setMethod("Node", "NodeId", function(id, x = numeric(), y = numeric(), color = NULL, weight = NULL, degree = NULL) {
+  degree <- ifelse(is.null(degree), NA_real_, degree)
+  new("Node", id = id, x = x, y = y, color = color, weight = weight, degree = degree)
 })
 
-#' @export 
-setMethod("Node", "missing", function(id, x = numeric(), y = numeric(), color = NULL, weight = NULL) {
-  new("Node", id = NodeId(generate_node_id(1)), x = x, y = y, color = color, weight = weight)
+setMethod("Node", "missing", function(id, x = numeric(), y = numeric(), color = NULL, weight = NULL, degree = NULL) {
+  degree <- ifelse(is.null(degree), NA_real_, degree)
+  new("Node", id = NodeId(generate_node_id(1)), x = x, y = y, color = color, weight = weight, degree = degree)
 })
 
 
@@ -138,8 +142,13 @@ setMethod("NodeList", "data.frame", function(object = data.frame(source=characte
     stop(paste("Invalid edgeList:", isValidEdgeList(object), collapse = '\n'))
   }
 
-  allNodeIds <- unique(c(object$source, object$target))
-  nodesList <- lapply(allNodeIds, Node)
+  allNodeIds <- c(object$source, object$target)
+
+  makeNodeWithDegree <- function(nodeId, allNodeIds) {
+    new("Node", id = NodeId(nodeId), degree = length(which(allNodeIds == nodeId)))
+  }
+
+  nodesList <- lapply(unique(allNodeIds), makeNodeWithDegree, allNodeIds)
   new("NodeList", nodesList)
 })
 

R/methods-KPartiteNetwork.R

@@ -41,8 +41,6 @@ setMethod(toJSONGeneric, "KPartiteNetwork", function(object, named = c(TRUE, FAL
     links_json <- veupathUtils::toJSON(object@links, named = FALSE)
     partitions_json <- veupathUtils::toJSON(object@partitions, named = FALSE)
 
-    # TODO this doesnt conform to the api in the data service, bc there we explicitly have a bipartite network and not a kpartite
-    # we have `columns1NodeIds` and `columns2NodeIds` instead of `partitions`. i think this is better though.
     tmp <- paste0('"nodes":', nodes_json, ',"links":', links_json, ',"partitions":', partitions_json)
     tmp <- paste0('"data":{', tmp, '}')
     tmp <- paste0('{', tmp, ',"config":{"variables":{', veupathUtils::toJSON(object@variableMapping, named = FALSE), '}}}')

R/methods-Network.R

@@ -11,6 +11,7 @@ setGeneric("getLinkColorScheme", function(object) standardGeneric("getLinkColorS
 setMethod("getLinkColorScheme", "Network", function(object) object@linkColorScheme)
 # No setters! Once created, a network should only be updated via network methods
 
+setMethod("getDegrees", "Network", function(object) getDegrees(getNodes(object)))
 
 ## General network methods
 
@@ -26,8 +27,8 @@ setMethod("getIsolatedNodes", "Network", function(net) {
   nodes <- getNodes(net)
   links <- getLinks(net)
 
-  nodesWithLinks <- NodeList(union(getSourceNodes(links), getTargetNodes(links)))
-  isolatedNodeIds <- setdiff(getNodeIds(nodes), getNodeIds(nodesWithLinks))
+  nodeIdsWithLinks <- NodeIdList(union(getSourceNodes(links), getTargetNodes(links)))
+  isolatedNodeIds <- setdiff(getNodeIds(nodes), getNodeIds(nodeIdsWithLinks))
   isolatedNodes <- NodeList(nodes[which(getNodeIds(nodes) %in% isolatedNodeIds)])
 
   return(isolatedNodes)
@@ -192,17 +193,17 @@ setMethod(toJSONGeneric, "Network", function(object, named = c(TRUE, FALSE)) {
   return(tmp)
 })
 
-#' Write json to tmp file
+#' Write network json to tmp file
 #' 
 #' This function returns the name of a json file which it has
 #' written an object out to.
 #' @param x an object to convert to json and write to a tmp file
 #' @param verbose boolean that declares if logging is desired
 #' @return character name of a tmp file w ext *.json
 #' @export
-setGeneric("writeJSON", function(x, pattern = NULL, verbose = c(TRUE, FALSE)) standardGeneric("writeJSON"))
+setGeneric("writeNetworkJSON", function(x, pattern = NULL, verbose = c(TRUE, FALSE)) standardGeneric("writeNetworkJSON"))
 
-#' Write json to local tmp file
+#' Write network json to local tmp file
 #'
 #' This function returns the name of a json file which it has
 #' written a Network object out to.
@@ -212,7 +213,7 @@ setGeneric("writeJSON", function(x, pattern = NULL, verbose = c(TRUE, FALSE)) st
 #' @return character name of a tmp file w ext *.json
 #' @importFrom jsonlite toJSON
 #' @export
-setMethod("writeJSON", "Network", function(x, pattern=NULL, verbose = c(TRUE, FALSE)) {
+setMethod("writeNetworkJSON", "Network", function(x, pattern=NULL, verbose = c(TRUE, FALSE)) {
   net <- x
   verbose <- veupathUtils::matchArg(verbose)
 

R/methods-Nodes.R

@@ -8,6 +8,8 @@ setGeneric("x", function(object) standardGeneric("x"))
 setGeneric("x<-", function(object, value) standardGeneric("x<-"))
 setGeneric("y", function(object) standardGeneric("y"))
 setGeneric("y<-", function(object, value) standardGeneric("y<-"))
+setGeneric("degree", function(object) standardGeneric("degree"))
+setGeneric("degree<-", function(object, value) standardGeneric("degree<-"))
 
 #' @include methods-Links.R
 ## Methods for Nodes
@@ -21,6 +23,8 @@ setMethod("x<-", "Node", function(object, value) {object@x <- value; validObject
 setMethod("y<-", "Node", function(object, value) {object@y <- value; validObject(object); object})
 setMethod("color<-", "Node", function(object, value) {object@color <- value; validObject(object); object})
 setMethod("weight<-", "Node", function(object, value) {object@weight <- value; validObject(object); object})
+setMethod("degree", "Node", function(object) object@degree)
+setMethod("degree<-", "Node", function(object, value) {object@degree <- value; validObject(object); object})
 
 ## Methods for NodeId
 setMethod("id", "NodeId", function(object) object@value)
@@ -36,6 +40,8 @@ setGeneric("getNodeIds", function(object) standardGeneric("getNodeIds"))
 setMethod("getNodeIds", "NodeList", function(object) unlist(lapply(as.list(object), id)))
 setMethod("getWeights", "NodeList", function(object) unlist(lapply(as.list(object), weight)))
 setMethod("getColors", "NodeList", function(object) unlist(lapply(as.list(object), color)))
+setGeneric("getDegrees", function(object) standardGeneric("getDegrees"))
+setMethod("getDegrees", "NodeList", function(object) unlist(lapply(as.list(object), degree)))
 
 ## Methods for NodeIdList
 setMethod("getNodeIds", "NodeIdList", function(object) unlist(lapply(as.list(object), id)))
@@ -58,6 +64,7 @@ setMethod(toJSONGeneric, "Node", function(object, named = c(FALSE, TRUE)) {
     if (!!length(y(object))) tmp <- paste0(tmp, ',"y":', jsonlite::toJSON(jsonlite::unbox(y(object))))
     if (!!length(color(object))) tmp <- paste0(tmp, ',"color":', jsonlite::toJSON(jsonlite::unbox(color(object))))
     if (!!length(weight(object))) tmp <- paste0(tmp, ',"weight":', jsonlite::toJSON(jsonlite::unbox(weight(object))))
+    if (!!length(degree(object)) && !is.na(degree(object))) tmp <- paste0(tmp, ',"degree":', jsonlite::toJSON(jsonlite::unbox(degree(object))))
 
     tmp <- paste0('{', tmp, '}')
     if (named) {