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)

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))
 }
 
 
@@ -98,26 +101,30 @@ setMethod("NodeIdList", "Node", function(object, uniquifyIds = c(TRUE, FALSE)) {
 #' @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"))
+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), 0, 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), 0, 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), 0, 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), 0, degree)
+  new("Node", id = NodeId(generate_node_id(1)), x = x, y = y, color = color, weight = weight, degree = degree)
 })
 
 
@@ -138,8 +145,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)

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))) tmp <- paste0(tmp, ',"degree":', jsonlite::toJSON(jsonlite::unbox(degree(object))))
 
     tmp <- paste0('{', tmp, '}')
     if (named) {

tests/testthat/test-kpartite-network.R

@@ -166,7 +166,7 @@ test_that("we can build a KPartiteNetwork from an edgeList data.frame", {
     ))
   )
 
-  expect_equal(getNodes(net), NodeList(c(Node('a'), Node('b'), Node('c'), Node('d'))))
+  expect_equal(getNodes(net), NodeList(c(Node('a', degree=2), Node('b', degree=2), Node('c', degree=1), Node('d', degree=1))))
   expect_equal(getLinks(net), LinkList(c(Link(source = Node('a'), target = Node('b')), Link(source = Node('b'), target = Node('a')), Link(source = Node('c'), target = Node('d')))))
   expect_equal(partitions(net), Partitions(list(Partition(list(Node('a'), Node('c'))), Partition(list(Node('b'), Node('d'))))))
   expect_equal(getLinkColorScheme(net), 'none')

tests/testthat/test-links.R

@@ -1,56 +1,49 @@
 test_that("Links work", {
   # Make a link
-  nodeA <- Node(
-    id = NodeId('A')
-  )
-  nodeB <- Node(
-    id = NodeId('B')
-  )
-
-  link <- Link(source = nodeA, target = nodeB)
+  link <- Link(source = NodeId('A'), target = NodeId('B'))
   expect_equal(class(link)[1], 'Link')
-  expect_equal(source(link), nodeA)
-  expect_equal(target(link), nodeB)
+  expect_equal(source(link), NodeId('A'))
+  expect_equal(target(link), NodeId('B'))
   expect_equal(weight(link), 1)
   expect_true(is.null(color(link)))
 
   # Make another link w colors and weights
-  link <- Link(source = nodeA, target = nodeB, color = 'red', weight = 10)
+  link <- Link(source = NodeId('A'), target = NodeId('B'), color = 'red', weight = 10)
   expect_equal(class(link)[1], 'Link')
-  expect_equal(source(link), nodeA)
-  expect_equal(target(link), nodeB)
+  expect_equal(source(link), NodeId('A'))
+  expect_equal(target(link), NodeId('B'))
   expect_equal(color(link), 'red')
   expect_equal(weight(link), 10)
 
   # pass characters for node ids
   link <- Link(source = 'A', target = 'B')
   expect_equal(class(link)[1], 'Link')
-  expect_equal(source(link), nodeA)
-  expect_equal(target(link), nodeB)
+  expect_equal(source(link), NodeId('A'))
+  expect_equal(target(link), NodeId('B'))
   expect_equal(weight(link), 1)
   expect_true(is.null(color(link)))
 
   # pass numbers for node ids
   link <- Link(source = 1, target = 2)
   expect_equal(class(link)[1], 'Link')
-  expect_equal(source(link), Node(1))
-  expect_equal(target(link), Node(2))
+  expect_equal(source(link), NodeId(1))
+  expect_equal(target(link), NodeId(2))
   expect_equal(weight(link), 1)
   expect_true(is.null(color(link)))
 
   # pass NodeId objects for node ids
   link <- Link(source = NodeId('A'), target = NodeId('B'))
   expect_equal(class(link)[1], 'Link')
-  expect_equal(source(link), nodeA)
-  expect_equal(target(link), nodeB)
+  expect_equal(source(link), NodeId('A'))
+  expect_equal(target(link), NodeId('B'))
   expect_equal(weight(link), 1)
   expect_true(is.null(color(link)))
 
   # an empty one
   link <- Link()
   expect_equal(class(link)[1], 'Link')
-  expect_equal(class(source(link))[1], 'Node')
-  expect_equal(class(target(link))[1], 'Node')
+  expect_equal(class(source(link))[1], 'NodeId')
+  expect_equal(class(target(link))[1], 'NodeId')
   expect_equal(weight(link), 1)
   expect_true(is.null(color(link)))
 })
@@ -65,15 +58,15 @@ test_that("Link methods work", {
   )
 
   link <- Link(source = nodeA, target = nodeB)
-  expect_equal(source(link), nodeA)
-  expect_equal(target(link), nodeB)
+  expect_equal(source(link), NodeId('A'))
+  expect_equal(target(link), NodeId('B'))
   expect_equal(weight(link), 1)
   expect_true(is.null(color(link)))
   expect_equal(isDirected(link), FALSE)
 
   link <- Link(source = nodeA, target = nodeB, color = 'red', weight = 10)
-  expect_equal(source(link), nodeA)
-  expect_equal(target(link), nodeB)
+  expect_equal(source(link), NodeId('A'))
+  expect_equal(target(link), NodeId('B'))
   expect_equal(color(link), 'red')
   expect_equal(weight(link), 10)
   expect_equal(isDirected(link), FALSE)
@@ -100,8 +93,8 @@ test_that("LinkList methods work", {
 
   linkList <- LinkList(S4Vectors::SimpleList(c(link1, link2, link3)))
   expect_equal(length(linkList), 3)
-  expect_equal(getSourceNodes(linkList), list(nodeA, nodeB, nodeC))
-  expect_equal(getTargetNodes(linkList), list(nodeB, nodeC, nodeA))
+  expect_equal(getSourceNodes(linkList), list(NodeId('A'), NodeId('B'), NodeId('C')))
+  expect_equal(getTargetNodes(linkList), list(NodeId('B'), NodeId('C'), NodeId('A')))
   expect_equal(getWeights(linkList), c(1, 1, 1))
   expect_equal(getColors(linkList), c(NULL, NULL, NULL))
 
@@ -113,16 +106,16 @@ test_that("LinkList methods work", {
 
   linkList <- LinkList(S4Vectors::SimpleList(c(link1, link2, link3)))
   expect_equal(length(linkList), 3)
-  expect_equal(getSourceNodes(linkList), list(nodeA, nodeB, nodeC))
-  expect_equal(getTargetNodes(linkList), list(nodeB, nodeC, nodeA))
+  expect_equal(getSourceNodes(linkList), list(NodeId('A'), NodeId('B'), NodeId('C')))
+  expect_equal(getTargetNodes(linkList), list(NodeId('B'), NodeId('C'), NodeId('A')))
   expect_equal(getWeights(linkList), c(2, 0.1, 3))
   expect_equal(getColors(linkList), c('red', 'blue', 'green'))
 
   # use a list to make LinkList
   linkList <- LinkList(list(link1, link2, link3))
   expect_equal(length(linkList), 3)
-  expect_equal(getSourceNodes(linkList), list(nodeA, nodeB, nodeC))
-  expect_equal(getTargetNodes(linkList), list(nodeB, nodeC, nodeA))
+  expect_equal(getSourceNodes(linkList), list(NodeId('A'), NodeId('B'), NodeId('C')))
+  expect_equal(getTargetNodes(linkList), list(NodeId('B'), NodeId('C'), NodeId('A')))
   expect_equal(getWeights(linkList), c(2, 0.1, 3))
   expect_equal(getColors(linkList), c('red', 'blue', 'green'))