From 88e6fc77225fb694c81f26db40d0fca56c476234 Mon Sep 17 00:00:00 2001 From: asizemore Date: Thu, 2 Nov 2023 14:57:59 +0000 Subject: [PATCH 01/37] handle isolated nodes --- R/class-network.R | 5 +++++ R/methods-network.R | 36 ++++++++++++++++++++++++++++++++++- tests/testthat/test-network.R | 35 ++++++++++++++++++++++++++++++++++ 3 files changed, 75 insertions(+), 1 deletion(-) diff --git a/R/class-network.R b/R/class-network.R index 80a77b2..14ce402 100644 --- a/R/class-network.R +++ b/R/class-network.R @@ -14,6 +14,11 @@ check_network <- function(object) { errors <- c(errors, 'linkColorScheme must be one of "none" or "posneg"') } + # Check that there are no duplicate nodes + if (length(unique(getNodeIds(object@nodes))) != length(getNodeIds(object@nodes))) { + errors <- c(errors, 'Duplicate node ids found. Node ids must be unique.') + } + return(if (length(errors) == 0) TRUE else errors) } diff --git a/R/methods-network.R b/R/methods-network.R index ac5bf86..1340970 100644 --- a/R/methods-network.R +++ b/R/methods-network.R @@ -10,8 +10,42 @@ 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 -# Remove isolated nodes + +## General network methods + # Get isolated nodes +setGeneric("getIsolatedNodes", function(net) standardGeneric("getIsolatedNodes")) +setMethod("getIsolatedNodes", "Network", function(net) { + nodes <- getNodes(net) + links <- getLinks(net) + + nodesWithLinks <- NodeList(union(getSourceNodes(links), getTargetNodes(links))) + isolatedNodeIds <- setdiff(getNodeIds(nodes), getNodeIds(nodesWithLinks)) + isolatedNodes <- NodeList(nodes[which(getNodeIds(nodes) %in% isolatedNodeIds)]) + + return(isolatedNodes) +}) + + +# Remove isolated nodes +setGeneric("pruneIsolatedNodes", function(net, verbose = c(TRUE, FALSE)) standardGeneric("pruneIsolatedNodes")) +setMethod("pruneIsolatedNodes", "Network", function(net, verbose = c(TRUE, FALSE)) { + verbose <- veupathUtils::matchArg(verbose) + nodes <- getNodes(net) + isolatedNodeIds <- getNodeIds(getIsolatedNodes(net)) + + if (length(isolatedNodeIds) > 0) { + net@nodes <- nodes[which(!getNodeIds(nodes) %in% isolatedNodeIds)] + veupathUtils::logWithTime(paste('Found and removed', length(isolatedNodeIds), 'isolated nodes.'), verbose) + } else { + veupathUtils::logWithTime('No isolated nodes found.', verbose) + } + + validObject(net) + return(net) +}) + + # Remove redundant links # Remove redundant nodes # Get Degree list diff --git a/tests/testthat/test-network.R b/tests/testthat/test-network.R index 38778a7..c647186 100644 --- a/tests/testthat/test-network.R +++ b/tests/testthat/test-network.R @@ -48,5 +48,40 @@ test_that("We cannot make inappropriate networks", { # Create a network with an invalid linkColorScheme expect_error(Network(links = LinkList(c(link1, link2)), nodes = NodeList(c(nodeA, nodeB)), linkColorScheme = 'nope')) + + # Create a network with duplicate nodes + expect_error(Network(links = LinkList(c(link1, link2)), nodes = NodeList(c(nodeA, nodeB, nodeB)))) }) + +test_that("We can remove isolated nodes", { + # Create some nodes + nodeA <- Node( + id = 'A' + ) + nodeB <- Node( + id = 'B' + ) + nodeC <- Node( + id = 'C' + ) + nodeD <- Node( + id = 'D' + ) + + # Create some links + link1 <- Link(source = nodeA, target = nodeB, weight = 10) + link2 <- Link(source = nodeB, target = nodeC, weight = 20) + link3 <- Link(source = nodeC, target = nodeA, weight = 30) + + # Create the network. nodeD has no links + net <- Network(links = LinkList(c(link1, link2, link3)), nodes = NodeList(c(nodeA, nodeB, nodeC, nodeD))) + lonelyNodes <- getIsolatedNodes(net) + expect_equal(lonelyNodes, NodeList(c(nodeD))) + + netNoIsolatedNodes <- pruneIsolatedNodes(net, verbose = T) + expect_equal(getNodes(netNoIsolatedNodes), NodeList(c(nodeA, nodeB, nodeC))) + expect_equal(getLinks(netNoIsolatedNodes), LinkList(c(link1, link2, link3))) + expect_equal(getLinkColorScheme(netNoIsolatedNodes), 'none') + +}) From 547cb524c5fc4e03d92593eeeb5aa1572a404fdc Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Mon, 22 Jan 2024 12:39:58 -0500 Subject: [PATCH 02/37] clean up --- DESCRIPTION | 2 +- R/class-Network.R | 2 +- R/{methods-network.R => methods-Network.R} | 1 - 3 files changed, 2 insertions(+), 3 deletions(-) rename R/{methods-network.R => methods-Network.R} (99%) diff --git a/DESCRIPTION b/DESCRIPTION index 0f2af54..f6635cb 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -61,7 +61,7 @@ Collate: 'class-plotdata.R' 'group.R' 'methods-ContingencyTable.R' - 'methods-network.R' + 'methods-Network.R' 'panel.R' 'plot.data-package.R' 'utils-bin.R' diff --git a/R/class-Network.R b/R/class-Network.R index 7708e65..e059c5b 100644 --- a/R/class-Network.R +++ b/R/class-Network.R @@ -15,7 +15,7 @@ check_network <- function(object) { } # Check that there are no duplicate nodes - if (length(unique(getNodeIds(object@nodes))) != length(getNodeIds(object@nodes))) { + if (data.table::uniqueN(getNodeIds(object@nodes)) < length(getNodeIds(object@nodes))) { errors <- c(errors, 'Duplicate node ids found. Node ids must be unique.') } diff --git a/R/methods-network.R b/R/methods-Network.R similarity index 99% rename from R/methods-network.R rename to R/methods-Network.R index 1340970..b2e572e 100644 --- a/R/methods-network.R +++ b/R/methods-Network.R @@ -47,7 +47,6 @@ setMethod("pruneIsolatedNodes", "Network", function(net, verbose = c(TRUE, FALSE # Remove redundant links -# Remove redundant nodes # Get Degree list # Get Weighted Degree list # etc. From ce4e2d392fce75425e0d928131c763f5f010d235 Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Mon, 22 Jan 2024 12:40:08 -0500 Subject: [PATCH 03/37] get tests passing again --- tests/testthat/test-network.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/testthat/test-network.R b/tests/testthat/test-network.R index ff16424..f07e81a 100644 --- a/tests/testthat/test-network.R +++ b/tests/testthat/test-network.R @@ -57,16 +57,16 @@ test_that("We cannot make inappropriate networks", { test_that("We can remove isolated nodes", { # Create some nodes nodeA <- Node( - id = 'A' + id = NodeId('A') ) nodeB <- Node( - id = 'B' + id = NodeId('B') ) nodeC <- Node( - id = 'C' + id = NodeId('C') ) nodeD <- Node( - id = 'D' + id = NodeId('D') ) # Create some links From e645293a86b6570e830a847fc877690aaa132ccb Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Mon, 22 Jan 2024 13:02:08 -0500 Subject: [PATCH 04/37] draft methods to find and remove dup links --- R/methods-Network.R | 64 ++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 61 insertions(+), 3 deletions(-) diff --git a/R/methods-Network.R b/R/methods-Network.R index b2e572e..b5eff16 100644 --- a/R/methods-Network.R +++ b/R/methods-Network.R @@ -13,8 +13,14 @@ setMethod("getLinkColorScheme", "Network", function(object) object@linkColorSche ## General network methods -# Get isolated nodes +#' Get isolated nodes +#' +#' Returns a list of nodes that have no links +#' @param net A Network object +#' @export setGeneric("getIsolatedNodes", function(net) standardGeneric("getIsolatedNodes")) + +#' @export setMethod("getIsolatedNodes", "Network", function(net) { nodes <- getNodes(net) links <- getLinks(net) @@ -27,8 +33,15 @@ setMethod("getIsolatedNodes", "Network", function(net) { }) -# Remove isolated nodes +#' Remove isolated nodes +#' +#' Removes nodes that have no links +#' @param net A Network object +#' @param verbose If TRUE, will print messages +#' @export setGeneric("pruneIsolatedNodes", function(net, verbose = c(TRUE, FALSE)) standardGeneric("pruneIsolatedNodes")) + +#' @export setMethod("pruneIsolatedNodes", "Network", function(net, verbose = c(TRUE, FALSE)) { verbose <- veupathUtils::matchArg(verbose) nodes <- getNodes(net) @@ -45,8 +58,53 @@ setMethod("pruneIsolatedNodes", "Network", function(net, verbose = c(TRUE, FALSE return(net) }) +getLinkUniqueString <- function(link) { + paste0(id(source(link)), id(target(link))) +} + +#' Find duplicate links +#' +#' Returns a list of links that are redundant +#' @param net A Network object +#' @export +setGeneric("getDuplicateLinks", function(net) standardGeneric("getDuplicateLinks")) + +#' @export +setMethod("getDuplicateLinks", "Network", function(net) { + links <- getLinks(net) + + # check for links that have the same source and target node as another link + linkUniqueStrings <- sapply(links, getLinkUniqueString) + dupLinks <- links[which(duplicated(linkUniqueStrings))] + + return(dupLinks) +}) + +#' Remove Duplicate links +#' +#' Removes links that are redundant +#' @param net A Network object +#' @param verbose If TRUE, will print messages +#' @export +setGeneric("pruneDuplicateLinks", function(net, verbose = c(TRUE, FALSE)) standardGeneric("pruneDuplicateLinks")) + +#' @export +setMethod("pruneDuplicateLinks", "Network", function(net, verbose = c(TRUE, FALSE)) { + verbose <- veupathUtils::matchArg(verbose) + links <- getLinks(net) + + dupLinks <- getDuplicateLinks(net) + if (length(dupLinks) > 0) { + net@links <- links[which(!getLinkIds(links) %in% dupLinks)] + veupathUtils::logWithTime(paste('Found and removed', length(dupLinks), 'duplicate links.'), verbose) + } else { + veupathUtils::logWithTime('No duplicate links found.', verbose) + } + + validObject(net) + return(net) +}) -# Remove redundant links # Get Degree list # Get Weighted Degree list # etc. From 2157e808a95e6daadc09339e11ac642a17c9378a Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Mon, 22 Jan 2024 13:04:08 -0500 Subject: [PATCH 05/37] add some more documentation --- NAMESPACE | 8 ++++++++ man/getDuplicateLinks.Rd | 14 ++++++++++++++ man/getIsolatedNodes.Rd | 14 ++++++++++++++ man/pruneDuplicateLinks.Rd | 16 ++++++++++++++++ man/pruneIsolatedNodes.Rd | 16 ++++++++++++++++ 5 files changed, 68 insertions(+) create mode 100644 man/getDuplicateLinks.Rd create mode 100644 man/getIsolatedNodes.Rd create mode 100644 man/pruneDuplicateLinks.Rd create mode 100644 man/pruneIsolatedNodes.Rd diff --git a/NAMESPACE b/NAMESPACE index fe1daf4..b8e93cf 100644 --- a/NAMESPACE +++ b/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,8 @@ export(orderByReferenceValues) export(outliers) export(posPredictiveValue) export(prevalence) +export(pruneDuplicateLinks) +export(pruneIsolatedNodes) export(relativeRisk) export(scattergl) export(scattergl.dt) @@ -83,6 +87,8 @@ exportClasses(TwoByTwoTable) exportMethods(allStats) exportMethods(chiSqResults) exportMethods(fishersTest) +exportMethods(getDuplicateLinks) +exportMethods(getIsolatedNodes) exportMethods(getQuadrantValues) exportMethods(makeVariableDetails) exportMethods(negPredictiveValue) @@ -90,6 +96,8 @@ exportMethods(oddsRatio) exportMethods(orderByReferenceValues) exportMethods(posPredictiveValue) exportMethods(prevalence) +exportMethods(pruneDuplicateLinks) +exportMethods(pruneIsolatedNodes) exportMethods(relativeRisk) exportMethods(sensitivity) exportMethods(specificity) diff --git a/man/getDuplicateLinks.Rd b/man/getDuplicateLinks.Rd new file mode 100644 index 0000000..2f1ce61 --- /dev/null +++ b/man/getDuplicateLinks.Rd @@ -0,0 +1,14 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/methods-Network.R +\name{getDuplicateLinks} +\alias{getDuplicateLinks} +\title{Find duplicate links} +\usage{ +getDuplicateLinks(net) +} +\arguments{ +\item{net}{A Network object} +} +\description{ +Returns a list of links that are redundant +} diff --git a/man/getIsolatedNodes.Rd b/man/getIsolatedNodes.Rd new file mode 100644 index 0000000..1113a03 --- /dev/null +++ b/man/getIsolatedNodes.Rd @@ -0,0 +1,14 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/methods-Network.R +\name{getIsolatedNodes} +\alias{getIsolatedNodes} +\title{Get isolated nodes} +\usage{ +getIsolatedNodes(net) +} +\arguments{ +\item{net}{A Network object} +} +\description{ +Returns a list of nodes that have no links +} diff --git a/man/pruneDuplicateLinks.Rd b/man/pruneDuplicateLinks.Rd new file mode 100644 index 0000000..6142fc9 --- /dev/null +++ b/man/pruneDuplicateLinks.Rd @@ -0,0 +1,16 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/methods-Network.R +\name{pruneDuplicateLinks} +\alias{pruneDuplicateLinks} +\title{Remove Duplicate links} +\usage{ +pruneDuplicateLinks(net, verbose = c(TRUE, FALSE)) +} +\arguments{ +\item{net}{A Network object} + +\item{verbose}{If TRUE, will print messages} +} +\description{ +Removes links that are redundant +} diff --git a/man/pruneIsolatedNodes.Rd b/man/pruneIsolatedNodes.Rd new file mode 100644 index 0000000..371f1df --- /dev/null +++ b/man/pruneIsolatedNodes.Rd @@ -0,0 +1,16 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/methods-Network.R +\name{pruneIsolatedNodes} +\alias{pruneIsolatedNodes} +\title{Remove isolated nodes} +\usage{ +pruneIsolatedNodes(net, verbose = c(TRUE, FALSE)) +} +\arguments{ +\item{net}{A Network object} + +\item{verbose}{If TRUE, will print messages} +} +\description{ +Removes nodes that have no links +} From d24fd65c6e45275c4e779984cf12cfec8860a6f0 Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Mon, 22 Jan 2024 13:16:13 -0500 Subject: [PATCH 06/37] test removing dup links --- R/methods-Network.R | 5 ++++- tests/testthat/test-network.R | 26 ++++++++++++++++++++++++++ 2 files changed, 30 insertions(+), 1 deletion(-) diff --git a/R/methods-Network.R b/R/methods-Network.R index b5eff16..56f461d 100644 --- a/R/methods-Network.R +++ b/R/methods-Network.R @@ -49,6 +49,7 @@ setMethod("pruneIsolatedNodes", "Network", function(net, verbose = c(TRUE, FALSE if (length(isolatedNodeIds) > 0) { net@nodes <- nodes[which(!getNodeIds(nodes) %in% isolatedNodeIds)] + validObject(net) veupathUtils::logWithTime(paste('Found and removed', length(isolatedNodeIds), 'isolated nodes.'), verbose) } else { veupathUtils::logWithTime('No isolated nodes found.', verbose) @@ -95,7 +96,9 @@ setMethod("pruneDuplicateLinks", "Network", function(net, verbose = c(TRUE, FALS dupLinks <- getDuplicateLinks(net) if (length(dupLinks) > 0) { - net@links <- links[which(!getLinkIds(links) %in% dupLinks)] + linkUniqueStrings <- sapply(links, getLinkUniqueString) + net@links <- links[which(!duplicated(linkUniqueStrings))] + validObject(net) veupathUtils::logWithTime(paste('Found and removed', length(dupLinks), 'duplicate links.'), verbose) } else { veupathUtils::logWithTime('No duplicate links found.', verbose) diff --git a/tests/testthat/test-network.R b/tests/testthat/test-network.R index f07e81a..fa81370 100644 --- a/tests/testthat/test-network.R +++ b/tests/testthat/test-network.R @@ -85,3 +85,29 @@ test_that("We can remove isolated nodes", { expect_equal(getLinkColorScheme(netNoIsolatedNodes), 'none') }) + +test_that("we can remove duplicate links", { + + # Create some nodes + nodeA <- Node( + id = NodeId('A') + ) + nodeB <- Node( + id = NodeId('B') + ) + nodeC <- Node( + id = NodeId('C') + ) + + # Create some links + link1 <- Link(source = nodeA, target = nodeB, weight = 10) + link2 <- Link(source = nodeB, target = nodeC, weight = 20) + link3 <- Link(source = nodeC, target = nodeA, weight = 30) + + # Create the network + net <- Network(links = LinkList(c(link1, link2, link3, link3)), nodes = NodeList(c(nodeA, nodeB, nodeC))) + netNoDups <- pruneDuplicateLinks(net) + expect_equal(getNodes(netNoDups), NodeList(c(nodeA, nodeB, nodeC))) + expect_equal(getLinks(netNoDups), LinkList(c(link1, link2, link3))) + expect_equal(getLinkColorScheme(netNoDups), 'none') +}) From e27a2472f8437435fa9c8a273ef8371c51ca381e Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Mon, 22 Jan 2024 14:19:30 -0500 Subject: [PATCH 07/37] add link thresholding draft methods --- R/methods-Network.R | 40 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 40 insertions(+) diff --git a/R/methods-Network.R b/R/methods-Network.R index 56f461d..379c6b5 100644 --- a/R/methods-Network.R +++ b/R/methods-Network.R @@ -108,6 +108,45 @@ setMethod("pruneDuplicateLinks", "Network", function(net, verbose = c(TRUE, FALS return(net) }) +#' Prune Links by Predicate +#' +#' Removes links that satisfy a predicate +#' @param net A Network object +#' @param predicate A function that takes a link and returns a boolean +#' @param verbose If TRUE, will print messages +#' @param ... additional arguments passed to the predicate +#' @export +setGeneric("pruneLinksByPredicate", function(net, predicate, verbose = c(TRUE, FALSE), ...) standardGeneric("pruneLinksByPredicate")) + +#' @export +setMethod("pruneLinksByPredicate", "Network", function(net, predicate, verbose = c(TRUE, FALSE), ...) { + verbose <- veupathUtils::matchArg(verbose) + links <- getLinks(net) + net@links <- links[which(!sapply(links, predicate, ...))] + validObject(net) + veupathUtils::logWithTime(paste('Found and removed', length(links) - length(net@links), 'links.'), verbose) + validObject(net) + return(net) +}) + +linkAboveWeightThreshold <- function(link, threshold) { + return(weight(link) > threshold) +} + +#' Prune Links by Weight +#' +#' Removes links that have a weight above a threshold. This is a convenience +#' function that calls pruneLinksByPredicate. +#' @param net A Network object +#' @param threshold The threshold +#' @param verbose If TRUE, will print messages +#' @export +pruneLinksByWeight <- function(net, threshold, verbose = c(TRUE, FALSE)) { + return(pruneLinksByPredicate(net = net, predicate = linkAboveWeightThreshold, threshold = threshold, verbose = verbose)) +} + + +## these look like things that should be made into github issues.. # Get Degree list # Get Weighted Degree list # etc. @@ -115,6 +154,7 @@ setMethod("pruneDuplicateLinks", "Network", function(net, verbose = c(TRUE, FALS # Assign color scheme +## this looks like it should be in a different pr.. # #' Write json to local tmp file # #' From 951d4732eee060c703a2f479d38a4d86dbcd891a Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Mon, 22 Jan 2024 14:26:55 -0500 Subject: [PATCH 08/37] more helpers for pruning links by weight --- R/methods-Network.R | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) diff --git a/R/methods-Network.R b/R/methods-Network.R index 379c6b5..24e297d 100644 --- a/R/methods-Network.R +++ b/R/methods-Network.R @@ -141,10 +141,27 @@ linkAboveWeightThreshold <- function(link, threshold) { #' @param threshold The threshold #' @param verbose If TRUE, will print messages #' @export -pruneLinksByWeight <- function(net, threshold, verbose = c(TRUE, FALSE)) { +pruneLinksAboveWeight <- function(net, threshold, verbose = c(TRUE, FALSE)) { return(pruneLinksByPredicate(net = net, predicate = linkAboveWeightThreshold, threshold = threshold, verbose = verbose)) } +linkBelowWeightThreshold <- function(link, threshold) { + return(weight(link) < threshold) +} + + +#' Prune Links by Weight +#' +#' Removes links that have a weight below a threshold. This is a convenience +#' function that calls pruneLinksByPredicate. +#' @param net A Network object +#' @param threshold The threshold +#' @param verbose If TRUE, will print messages +#' @export +pruneLinksBelowWeight <- function(net, threshold, verbose = c(TRUE, FALSE)) { + return(pruneLinksByPredicate(net = net, predicate = linkBelowWeightThreshold, threshold = threshold, verbose = verbose)) +} + ## these look like things that should be made into github issues.. # Get Degree list From 6e395fdc15052e4c232d68e39f9ef704a326eafa Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Mon, 22 Jan 2024 14:27:12 -0500 Subject: [PATCH 09/37] update documentation --- NAMESPACE | 4 ++++ man/pruneLinksAboveWeight.Rd | 19 +++++++++++++++++++ man/pruneLinksBelowWeight.Rd | 19 +++++++++++++++++++ man/pruneLinksByPredicate.Rd | 20 ++++++++++++++++++++ 4 files changed, 62 insertions(+) create mode 100644 man/pruneLinksAboveWeight.Rd create mode 100644 man/pruneLinksBelowWeight.Rd create mode 100644 man/pruneLinksByPredicate.Rd diff --git a/NAMESPACE b/NAMESPACE index b8e93cf..af52b41 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -66,6 +66,9 @@ export(posPredictiveValue) export(prevalence) export(pruneDuplicateLinks) export(pruneIsolatedNodes) +export(pruneLinksAboveWeight) +export(pruneLinksBelowWeight) +export(pruneLinksByPredicate) export(relativeRisk) export(scattergl) export(scattergl.dt) @@ -98,6 +101,7 @@ exportMethods(posPredictiveValue) exportMethods(prevalence) exportMethods(pruneDuplicateLinks) exportMethods(pruneIsolatedNodes) +exportMethods(pruneLinksByPredicate) exportMethods(relativeRisk) exportMethods(sensitivity) exportMethods(specificity) diff --git a/man/pruneLinksAboveWeight.Rd b/man/pruneLinksAboveWeight.Rd new file mode 100644 index 0000000..fd4894c --- /dev/null +++ b/man/pruneLinksAboveWeight.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/methods-Network.R +\name{pruneLinksAboveWeight} +\alias{pruneLinksAboveWeight} +\title{Prune Links by Weight} +\usage{ +pruneLinksAboveWeight(net, threshold, verbose = c(TRUE, FALSE)) +} +\arguments{ +\item{net}{A Network object} + +\item{threshold}{The threshold} + +\item{verbose}{If TRUE, will print messages} +} +\description{ +Removes links that have a weight above a threshold. This is a convenience +function that calls pruneLinksByPredicate. +} diff --git a/man/pruneLinksBelowWeight.Rd b/man/pruneLinksBelowWeight.Rd new file mode 100644 index 0000000..3336e1f --- /dev/null +++ b/man/pruneLinksBelowWeight.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/methods-Network.R +\name{pruneLinksBelowWeight} +\alias{pruneLinksBelowWeight} +\title{Prune Links by Weight} +\usage{ +pruneLinksBelowWeight(net, threshold, verbose = c(TRUE, FALSE)) +} +\arguments{ +\item{net}{A Network object} + +\item{threshold}{The threshold} + +\item{verbose}{If TRUE, will print messages} +} +\description{ +Removes links that have a weight below a threshold. This is a convenience +function that calls pruneLinksByPredicate. +} diff --git a/man/pruneLinksByPredicate.Rd b/man/pruneLinksByPredicate.Rd new file mode 100644 index 0000000..33e3dce --- /dev/null +++ b/man/pruneLinksByPredicate.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/methods-Network.R +\name{pruneLinksByPredicate} +\alias{pruneLinksByPredicate} +\title{Prune Links by Predicate} +\usage{ +pruneLinksByPredicate(net, predicate, verbose = c(TRUE, FALSE), ...) +} +\arguments{ +\item{net}{A Network object} + +\item{predicate}{A function that takes a link and returns a boolean} + +\item{verbose}{If TRUE, will print messages} + +\item{...}{additional arguments passed to the predicate} +} +\description{ +Removes links that satisfy a predicate +} From f0475ff7c3a6f0708d743246377459ab9a2c855e Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Mon, 22 Jan 2024 14:27:23 -0500 Subject: [PATCH 10/37] test for pruning links by weight --- tests/testthat/test-network.R | 32 ++++++++++++++++++++++++++++++++ 1 file changed, 32 insertions(+) diff --git a/tests/testthat/test-network.R b/tests/testthat/test-network.R index fa81370..5ecd6ac 100644 --- a/tests/testthat/test-network.R +++ b/tests/testthat/test-network.R @@ -111,3 +111,35 @@ test_that("we can remove duplicate links", { expect_equal(getLinks(netNoDups), LinkList(c(link1, link2, link3))) expect_equal(getLinkColorScheme(netNoDups), 'none') }) + +test_that("We can remove links by weight", { + # Create some nodes + nodeA <- Node( + id = NodeId('A') + ) + nodeB <- Node( + id = NodeId('B') + ) + nodeC <- Node( + id = NodeId('C') + ) + + # Create some links + link1 <- Link(source = nodeA, target = nodeB, weight = 10) + link2 <- Link(source = nodeB, target = nodeC, weight = 20) + link3 <- Link(source = nodeC, target = nodeA, weight = 30) + + # Create the network + net <- Network(links = LinkList(c(link1, link2, link3)), nodes = NodeList(c(nodeA, nodeB, nodeC))) + + netNoSmallLinks <- pruneLinksBelowWeight(net, threshold = 20) + expect_equal(getNodes(netNoSmallLinks), NodeList(c(nodeA, nodeB, nodeC))) + expect_equal(getLinks(netNoSmallLinks), LinkList(c(link2, link3))) + expect_equal(getLinkColorScheme(netNoSmallLinks), 'none') + + netNoLargeLinks <- pruneLinksAboveWeight(net, threshold = 10) + expect_equal(getNodes(netNoLargeLinks), NodeList(c(nodeA, nodeB, nodeC))) + expect_equal(getLinks(netNoLargeLinks), LinkList(c(link1))) + expect_equal(getLinkColorScheme(netNoLargeLinks), 'none') + +}) \ No newline at end of file From 36c1206a1c05ec5f49938ce81af778cca5566602 Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Mon, 22 Jan 2024 14:47:38 -0500 Subject: [PATCH 11/37] draft some toJSON Network stuff --- R/methods-Network.R | 116 +++++++++++++++++++++++++------------------- 1 file changed, 66 insertions(+), 50 deletions(-) diff --git a/R/methods-Network.R b/R/methods-Network.R index 24e297d..52546e5 100644 --- a/R/methods-Network.R +++ b/R/methods-Network.R @@ -142,6 +142,8 @@ linkAboveWeightThreshold <- function(link, threshold) { #' @param verbose If TRUE, will print messages #' @export pruneLinksAboveWeight <- function(net, threshold, verbose = c(TRUE, FALSE)) { + verbose <- veupathUtils::matchArg(verbose) + return(pruneLinksByPredicate(net = net, predicate = linkAboveWeightThreshold, threshold = threshold, verbose = verbose)) } @@ -159,6 +161,8 @@ linkBelowWeightThreshold <- function(link, threshold) { #' @param verbose If TRUE, will print messages #' @export pruneLinksBelowWeight <- function(net, threshold, verbose = c(TRUE, FALSE)) { + verbose <- veupathUtils::matchArg(verbose) + return(pruneLinksByPredicate(net = net, predicate = linkBelowWeightThreshold, threshold = threshold, verbose = verbose)) } @@ -166,68 +170,80 @@ pruneLinksBelowWeight <- function(net, threshold, verbose = c(TRUE, FALSE)) { ## these look like things that should be made into github issues.. # Get Degree list # Get Weighted Degree list -# etc. -# Threshold network by edge weight # Assign color scheme -## this looks like it should be in a different pr.. +toJSONGeneric <- getGeneric("toJSON", package = "veupathUtils") -# #' Write json to local tmp file -# #' -# #' This function returns the name of a json file which it has -# #' written a network object out to. -# #' @param net a data.table to convert to json and write to a tmp file -# #' @param pattern optional tmp file prefix -# #' @param verbose boolean that declares if logging is desired -# #' @return character name of a tmp file w ext *.json -# #' @importFrom jsonlite toJSON -# #' @export -# writeNetworkToJSON <- function(net, pattern=NULL, verbose = c(TRUE, FALSE) ) { -# verbose <- veupathUtils::matchArg(verbose) - -# outJson <- getNetworkJSON(net, verbose) -# if (is.null(pattern)) { -# pattern <- attr(net, 'class')[1] -# if (is.null(pattern)) { -# pattern <- 'file' -# } -# } -# outFileName <- basename(tempfile(pattern = pattern, tmpdir = tempdir(), fileext = ".json")) -# write(outJson, outFileName) -# veupathUtils::logWithTime(paste('New output file written:', outFileName), verbose) - -# return(outFileName) -# } +#' Convert Network object to JSON +#' +#' Converts a Network object to JSON +#' @param x A Network object +#' @param ... additional arguments passed to jsonlite::toJSON +#' @export +setMethod(toJSONGeneric, "Network", function(x, ...) { + networkAttributes <- attributes(net) -# # Write a network to a json string -# getNetworkJSON <- function(net, verbose = c(TRUE, FALSE)) { + # Covert all columns to character + netChar <- data.frame(lapply(net, as.character)) -# networkAttributes <- attributes(net) + # Whenever a node is referenced, it should be in the form {id: nodeid}. Update this + # for both the list of nodes, and the source + target columns + nodeList <- data.frame(id = networkAttributes$nodes) + netChar$source <- lapply(netChar$source, function(node) { return(list(id=jsonlite::unbox(node)))}) + netChar$target <- lapply(netChar$target, function(node) { return(list(id=jsonlite::unbox(node)))}) -# # Covert all columns to character -# netChar <- data.frame(lapply(net, as.character)) + obj <- list( + nodes = nodeList, + links = netChar + ) -# # Whenever a node is referenced, it should be in the form {id: nodeid}. Update this -# # for both the list of nodes, and the source + target columns -# nodeList <- data.frame(id = networkAttributes$nodes) -# netChar$source <- lapply(netChar$source, function(node) { return(list(id=jsonlite::unbox(node)))}) -# netChar$target <- lapply(netChar$target, function(node) { return(list(id=jsonlite::unbox(node)))}) + # Add additional properties for other network classes + if ('column1NodeIDs' %in% names(networkAttributes)) obj$column1NodeIDs <- networkAttributes$column1NodeIDs + if ('column2NodeIDs' %in% names(networkAttributes)) obj$column2NodeIDs <- networkAttributes$column2NodeIDs -# obj <- list( -# nodes = nodeList, -# links = netChar -# ) -# # Add additional properties for other network classes -# if ('column1NodeIDs' %in% names(networkAttributes)) obj$column1NodeIDs <- networkAttributes$column1NodeIDs -# if ('column2NodeIDs' %in% names(networkAttributes)) obj$column2NodeIDs <- networkAttributes$column2NodeIDs + # Covert to json string + json <- jsonlite::toJSON(obj, na=NULL, ...) -# # Covert to json string -# json <- jsonlite::toJSON(obj, na=NULL) + return(json) +}) +#' Write 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 +writeJSON <- setGeneric("writeJSON", function(x, verbose = c(TRUE, FALSE)) standardGeneric("writeJSON")) + +#' Write json to local tmp file +#' +#' This function returns the name of a json file which it has +#' written a Network object out to. +#' @param x a data.table to convert to json and write to a tmp file +#' @param pattern optional tmp file prefix +#' @param verbose boolean that declares if logging is desired +#' @return character name of a tmp file w ext *.json +#' @importFrom jsonlite toJSON +#' @export +writeJSON <- function(x, pattern=NULL, verbose = c(TRUE, FALSE) ) { + net <- x + verbose <- veupathUtils::matchArg(verbose) -# return(json) -# } + outJson <- toJSON(net, verbose) + if (is.null(pattern)) { + pattern <- attr(net, 'class')[1] + if (is.null(pattern)) { + pattern <- 'file' + } + } + outFileName <- basename(tempfile(pattern = pattern, tmpdir = tempdir(), fileext = ".json")) + write(outJson, outFileName) + veupathUtils::logWithTime(paste('New output file written:', outFileName), verbose) + return(outFileName) +} \ No newline at end of file From f492e74bb4623dbf39227f2b3cd01dd79fd839c0 Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Mon, 22 Jan 2024 14:52:17 -0500 Subject: [PATCH 12/37] bug preventing toJSON methods loading --- R/methods-Network.R | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/R/methods-Network.R b/R/methods-Network.R index 52546e5..4874f7a 100644 --- a/R/methods-Network.R +++ b/R/methods-Network.R @@ -143,7 +143,7 @@ linkAboveWeightThreshold <- function(link, threshold) { #' @export pruneLinksAboveWeight <- function(net, threshold, verbose = c(TRUE, FALSE)) { verbose <- veupathUtils::matchArg(verbose) - + return(pruneLinksByPredicate(net = net, predicate = linkAboveWeightThreshold, threshold = threshold, verbose = verbose)) } @@ -181,7 +181,8 @@ toJSONGeneric <- getGeneric("toJSON", package = "veupathUtils") #' @param x A Network object #' @param ... additional arguments passed to jsonlite::toJSON #' @export -setMethod(toJSONGeneric, "Network", function(x, ...) { +setMethod(toJSONGeneric, "Network", function(object, named = c(TRUE, FALSE)) { + net <- object networkAttributes <- attributes(net) # Covert all columns to character @@ -204,7 +205,7 @@ setMethod(toJSONGeneric, "Network", function(x, ...) { # Covert to json string - json <- jsonlite::toJSON(obj, na=NULL, ...) + json <- jsonlite::toJSON(obj, na=NULL) return(json) From c5c7c9cba531e1ec1830500b1e7c4a9e34b392b9 Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Mon, 22 Jan 2024 15:38:03 -0500 Subject: [PATCH 13/37] draft some toJSON stuff for Nodes and Links --- R/methods-Links.R | 40 ++++++++++++++++++++++++++++++++++++++++ R/methods-Network.R | 40 +++++++++++++--------------------------- R/methods-Nodes.R | 39 ++++++++++++++++++++++++++++++++++++++- 3 files changed, 91 insertions(+), 28 deletions(-) diff --git a/R/methods-Links.R b/R/methods-Links.R index 40f2dfb..57d9b7a 100644 --- a/R/methods-Links.R +++ b/R/methods-Links.R @@ -9,6 +9,8 @@ setGeneric("weight", function(object) standardGeneric("weight")) setGeneric("weight<-", function(object, value) standardGeneric("weight<-")) setGeneric("color", function(object) standardGeneric("color")) setGeneric("color<-", function(object, value) standardGeneric("color<-")) +setGeneric("isDirected", function(object) standardGeneric("isDirected")) +setGeneric("isDirected<-", function(object, value) standardGeneric("isDirected<-")) setMethod("source", "Link", function(object) object@source) setMethod("source<-", "Link", function(object, value) {object@source <- value; validObject(object); object}) @@ -18,6 +20,8 @@ setMethod("weight", "Link", function(object) object@weight) setMethod("weight<-", "Link", function(object, value) {object@weight <- value; validObject(object); object}) setMethod("color", "Link", function(object) object@color) setMethod("color<-", "Link", function(object, value) {object@color <- value; validObject(object); object}) +setMethod("isDirected", "Link", function(object) object@isDirected) +setMethod("isDirected<-", "Link", function(object, value) {object@isDirected <- value; validObject(object); object}) # Additional methods @@ -32,3 +36,39 @@ setMethod("getWeights", "LinkList", function(object) unlist(lapply(object, funct setGeneric("getColors", function(object) standardGeneric("getColors")) setMethod("getColors", "LinkList", function(object) unlist(lapply(object, function(x) color(x)))) + +toJSONGeneric <- getGeneric("toJSON", package = "veupathUtils") + +#' Convert Link object to JSON +#' +#' Converts a Link object to JSON +#' @param object A Link object +#' @param named boolean that declares if names should be included +#' @export +setMethod(toJSONGeneric, "Link", function(object, named = c(FALSE, TRUE)) { + named <- veupathUtils::matchArg(named) + tmp <- character() + + tmp <- paste0('"source":', jsonlite::toJSON(jsonlite::unbox(id(source(object))))) + tmp <- paste0(tmp, ',"target":', jsonlite::toJSON(jsonlite::unbox(id(target(object))))) + if (!!length(weight(object))) tmp <- paste0(tmp, ',"weight":', jsonlite::toJSON(jsonlite::unbox(weight(object)))) + if (!!length(color(object))) tmp <- paste0(tmp, ',"color":', jsonlite::toJSON(jsonlite::unbox(color(object)))) + tmp <- paste0(tmp, ',"isDirected":', jsonlite::toJSON(jsonlite::unbox(isDirected(object)))) + + tmp <- paste0('{', tmp, '}') + if (named) { + tmp <- paste0('{"link":', tmp, '}') + } + + return(tmp) +}) + +#' @export +setMethod(toJSONGeneric, signature("LinkList"), function(object, named = c(TRUE, FALSE)) { + named <- veupathUtils::matchArg(named) + tmp <- veupathUtils::S4SimpleListToJSON(object, FALSE) + + if (named) tmp <- paste0('{"links":', tmp, "}") + + return(tmp) +}) \ No newline at end of file diff --git a/R/methods-Network.R b/R/methods-Network.R index 4874f7a..15f0c86 100644 --- a/R/methods-Network.R +++ b/R/methods-Network.R @@ -172,43 +172,29 @@ pruneLinksBelowWeight <- function(net, threshold, verbose = c(TRUE, FALSE)) { # Get Weighted Degree list # Assign color scheme - toJSONGeneric <- getGeneric("toJSON", package = "veupathUtils") #' Convert Network object to JSON #' #' Converts a Network object to JSON -#' @param x A Network object -#' @param ... additional arguments passed to jsonlite::toJSON +#' @param object A Network object +#' @param named boolean that declares if names should be included #' @export setMethod(toJSONGeneric, "Network", function(object, named = c(TRUE, FALSE)) { - net <- object - networkAttributes <- attributes(net) - - # Covert all columns to character - netChar <- data.frame(lapply(net, as.character)) - - # Whenever a node is referenced, it should be in the form {id: nodeid}. Update this - # for both the list of nodes, and the source + target columns - nodeList <- data.frame(id = networkAttributes$nodes) - netChar$source <- lapply(netChar$source, function(node) { return(list(id=jsonlite::unbox(node)))}) - netChar$target <- lapply(netChar$target, function(node) { return(list(id=jsonlite::unbox(node)))}) - - obj <- list( - nodes = nodeList, - links = netChar - ) - - # Add additional properties for other network classes - if ('column1NodeIDs' %in% names(networkAttributes)) obj$column1NodeIDs <- networkAttributes$column1NodeIDs - if ('column2NodeIDs' %in% names(networkAttributes)) obj$column2NodeIDs <- networkAttributes$column2NodeIDs + + named <- veupathUtils::matchArg(named) + tmp <- character() + nodes_json <- veupathUtils::toJSON(object@nodes, named = FALSE) + links_json <- veupathUtils::toJSON(object@links, named = FALSE) - # Covert to json string - json <- jsonlite::toJSON(obj, na=NULL) + tmp <- paste0('"nodes":', nodes_json, ',"links":', links_json) + tmp <- paste0("{", tmp, "}") + # TODO add variableMapping under config, nodes and links under data +if (named) tmp <- paste0('{"network":', tmp, '}') - return(json) + return(tmp) }) #' Write json to tmp file @@ -235,7 +221,7 @@ writeJSON <- function(x, pattern=NULL, verbose = c(TRUE, FALSE) ) { net <- x verbose <- veupathUtils::matchArg(verbose) - outJson <- toJSON(net, verbose) + outJson <- veupathUtils::toJSON(net, verbose) if (is.null(pattern)) { pattern <- attr(net, 'class')[1] if (is.null(pattern)) { diff --git a/R/methods-Nodes.R b/R/methods-Nodes.R index f52ee6a..ca91c05 100644 --- a/R/methods-Nodes.R +++ b/R/methods-Nodes.R @@ -37,4 +37,41 @@ setMethod("getNodeIds", "NodeIdList", function(object) unlist(lapply(as.list(obj ## Methods for Partitions setGeneric("getAllNodeIds", function(object) standardGeneric("getAllNodeIds")) -setMethod("getAllNodeIds", "Partitions", function(object) unlist(lapply(as.list(object), getNodeIds))) \ No newline at end of file +setMethod("getAllNodeIds", "Partitions", function(object) unlist(lapply(as.list(object), getNodeIds))) + + +toJSONGeneric <- getGeneric("toJSON", package = "veupathUtils") + +#' Convert Node object to JSON +#' +#' Converts a Node object to JSON +#' @param object A Node object +#' @param named boolean that declares if names should be included +#' @export +setMethod(toJSONGeneric, "Node", function(object, named = c(FALSE, TRUE)) { + named <- veupathUtils::matchArg(named) + tmp <- character() + + tmp <- paste0('"id":', jsonlite::toJSON(jsonlite::unbox(id(object)))) + if (!!length(x(object))) tmp <- paste0(tmp, ',"x":', jsonlite::toJSON(jsonlite::unbox(x(object)))) + 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)))) + + tmp <- paste0('{', tmp, '}') + if (named) { + tmp <- paste0('{"node":', tmp, '}') + } + + return(tmp) +}) + +#' @export +setMethod(toJSONGeneric, signature("NodeList"), function(object, named = c(TRUE, FALSE)) { + named <- veupathUtils::matchArg(named) + tmp <- veupathUtils::S4SimpleListToJSON(object, FALSE) + + if (named) tmp <- paste0('{"nodes":', tmp, "}") + + return(tmp) +}) \ No newline at end of file From eba2c7a18b45bb5fb93fa8901e57a3b7a9e4425e Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Mon, 22 Jan 2024 15:38:46 -0500 Subject: [PATCH 14/37] update documentation --- NAMESPACE | 1 + man/toJSON-Link-method.Rd | 16 ++++++++++++++++ man/toJSON-Network-method.Rd | 16 ++++++++++++++++ man/toJSON-Node-method.Rd | 16 ++++++++++++++++ man/writeJSON.Rd | 22 ++++++++++++++++++++-- 5 files changed, 69 insertions(+), 2 deletions(-) create mode 100644 man/toJSON-Link-method.Rd create mode 100644 man/toJSON-Network-method.Rd create mode 100644 man/toJSON-Node-method.Rd diff --git a/NAMESPACE b/NAMESPACE index af52b41..e9bab98 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -105,6 +105,7 @@ exportMethods(pruneLinksByPredicate) exportMethods(relativeRisk) exportMethods(sensitivity) exportMethods(specificity) +exportMethods(toJSON) import(data.table) import(veupathUtils) importFrom(S4Vectors,SimpleList) diff --git a/man/toJSON-Link-method.Rd b/man/toJSON-Link-method.Rd new file mode 100644 index 0000000..067ff1b --- /dev/null +++ b/man/toJSON-Link-method.Rd @@ -0,0 +1,16 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/methods-Links.R +\name{toJSON,Link-method} +\alias{toJSON,Link-method} +\title{Convert Link object to JSON} +\usage{ +\S4method{toJSON}{Link}(object, named = c(FALSE, TRUE)) +} +\arguments{ +\item{object}{A Link object} + +\item{named}{boolean that declares if names should be included} +} +\description{ +Converts a Link object to JSON +} diff --git a/man/toJSON-Network-method.Rd b/man/toJSON-Network-method.Rd new file mode 100644 index 0000000..742b5cb --- /dev/null +++ b/man/toJSON-Network-method.Rd @@ -0,0 +1,16 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/methods-Network.R +\name{toJSON,Network-method} +\alias{toJSON,Network-method} +\title{Convert Network object to JSON} +\usage{ +\S4method{toJSON}{Network}(object, named = c(TRUE, FALSE)) +} +\arguments{ +\item{object}{A Network object} + +\item{named}{boolean that declares if names should be included} +} +\description{ +Converts a Network object to JSON +} diff --git a/man/toJSON-Node-method.Rd b/man/toJSON-Node-method.Rd new file mode 100644 index 0000000..06111c7 --- /dev/null +++ b/man/toJSON-Node-method.Rd @@ -0,0 +1,16 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/methods-Nodes.R +\name{toJSON,Node-method} +\alias{toJSON,Node-method} +\title{Convert Node object to JSON} +\usage{ +\S4method{toJSON}{Node}(object, named = c(FALSE, TRUE)) +} +\arguments{ +\item{object}{A Node object} + +\item{named}{boolean that declares if names should be included} +} +\description{ +Converts a Node object to JSON +} diff --git a/man/writeJSON.Rd b/man/writeJSON.Rd index 87b63f8..539bffa 100644 --- a/man/writeJSON.Rd +++ b/man/writeJSON.Rd @@ -1,20 +1,38 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils-json.R +% Please edit documentation in R/methods-Network.R, R/utils-json.R \name{writeJSON} \alias{writeJSON} -\title{Write json to local tmp file} +\title{Write json to tmp file} \usage{ +writeJSON(.pd, evilMode, pattern = NULL, verbose = c(TRUE, FALSE)) + +writeJSON(.pd, evilMode, pattern = NULL, verbose = c(TRUE, FALSE)) + writeJSON(.pd, evilMode, pattern = NULL, verbose = c(TRUE, FALSE)) } \arguments{ \item{.pd}{a data.table to convert to json and write to a tmp file} \item{pattern}{optional tmp file prefix} + +\item{verbose}{boolean that declares if logging is desired} + +\item{x}{a data.table to convert to json and write to a tmp file} } \value{ +character name of a tmp file w ext *.json + +character name of a tmp file w ext *.json + character name of a tmp file w ext *.json } \description{ +This function returns the name of a json file which it has +written an object out to. + +This function returns the name of a json file which it has +written a Network object out to. + This function returns the name of a json file which it has written a data.table object out to. } From 7e731d9efd490c58c047973fc49b3f862880cdf9 Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Mon, 22 Jan 2024 15:42:19 -0500 Subject: [PATCH 15/37] a test for writing networks to json --- tests/testthat/test-network.R | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/tests/testthat/test-network.R b/tests/testthat/test-network.R index 5ecd6ac..937e8fa 100644 --- a/tests/testthat/test-network.R +++ b/tests/testthat/test-network.R @@ -142,4 +142,32 @@ test_that("We can remove links by weight", { expect_equal(getLinks(netNoLargeLinks), LinkList(c(link1))) expect_equal(getLinkColorScheme(netNoLargeLinks), 'none') +}) + +test_that("toJSON works for networks", { + # Create some nodes + nodeA <- Node( + id = NodeId('A') + ) + nodeB <- Node( + id = NodeId('B') + ) + nodeC <- Node( + id = NodeId('C') + ) + + # Create some links + link1 <- Link(source = nodeA, target = nodeB, weight = 10) + link2 <- Link(source = nodeB, target = nodeC, weight = 20) + link3 <- Link(source = nodeC, target = nodeA, weight = 30) + + # Create the network + net <- Network(links = LinkList(c(link1, link2, link3)), nodes = NodeList(c(nodeA, nodeB, nodeC))) + json <- veupathUtils::toJSON(net) + jsonList <- jsonlite::fromJSON(json) + expect_equal(jsonList$network$links$source, c('A','B','C')) + expect_equal(jsonList$network$links$target, c('B','C','A')) + expect_equal(jsonList$network$links$weight, c(10,20,30)) + expect_equal(jsonList$network$nodes$id, c('A','B','C')) + }) \ No newline at end of file From 81c5897cf19e5dd15f8abe2512ea7fbd40c3758c Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Mon, 22 Jan 2024 22:49:30 -0500 Subject: [PATCH 16/37] add config to Network toJSON --- R/methods-Network.R | 8 ++++---- tests/testthat/test-network.R | 9 +++++---- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/R/methods-Network.R b/R/methods-Network.R index 15f0c86..cd80360 100644 --- a/R/methods-Network.R +++ b/R/methods-Network.R @@ -189,10 +189,10 @@ setMethod(toJSONGeneric, "Network", function(object, named = c(TRUE, FALSE)) { links_json <- veupathUtils::toJSON(object@links, named = FALSE) tmp <- paste0('"nodes":', nodes_json, ',"links":', links_json) - - tmp <- paste0("{", tmp, "}") - # TODO add variableMapping under config, nodes and links under data -if (named) tmp <- paste0('{"network":', tmp, '}') + tmp <- paste0('"data":{', tmp, '}') + tmp <- paste0('{', tmp, ',"config":{"variables":{', veupathUtils::toJSON(object@variableMapping, named = FALSE), '}}}') + + if (named) tmp <- paste0('{"network":', tmp, '}') return(tmp) }) diff --git a/tests/testthat/test-network.R b/tests/testthat/test-network.R index 937e8fa..ea0af79 100644 --- a/tests/testthat/test-network.R +++ b/tests/testthat/test-network.R @@ -165,9 +165,10 @@ test_that("toJSON works for networks", { net <- Network(links = LinkList(c(link1, link2, link3)), nodes = NodeList(c(nodeA, nodeB, nodeC))) json <- veupathUtils::toJSON(net) jsonList <- jsonlite::fromJSON(json) - expect_equal(jsonList$network$links$source, c('A','B','C')) - expect_equal(jsonList$network$links$target, c('B','C','A')) - expect_equal(jsonList$network$links$weight, c(10,20,30)) - expect_equal(jsonList$network$nodes$id, c('A','B','C')) + expect_equal(jsonList$network$data$links$source, c('A','B','C')) + expect_equal(jsonList$network$data$links$target, c('B','C','A')) + expect_equal(jsonList$network$data$links$weight, c(10,20,30)) + expect_equal(jsonList$network$data$nodes$id, c('A','B','C')) + expect_equal(length(jsonList$network$config$variables), 0) }) \ No newline at end of file From 4dbf616cef3870e23b83f1f90af0fb2c1b72faa4 Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Tue, 23 Jan 2024 00:35:07 -0500 Subject: [PATCH 17/37] draft some constructors --- R/class-Link.R | 59 ++++++++++++++++++++++++++++++++++++++++++++--- R/class-Network.R | 36 ++++++++++++++++++++++++++++- R/class-Node.R | 29 +++++++++++++++++++++-- 3 files changed, 118 insertions(+), 6 deletions(-) diff --git a/R/class-Link.R b/R/class-Link.R index 51f6a48..1122325 100644 --- a/R/class-Link.R +++ b/R/class-Link.R @@ -22,7 +22,7 @@ check_link <- function(object) { #' @rdname Link-class #' @include class-Node.R #' @export -Link <- setClass("Link", +setClass("Link", representation( source = "Node", target = "Node", @@ -40,6 +40,44 @@ Link <- setClass("Link", validity = check_link ) +setMethod("initialize", "Link", function( + .Object, + source = character(), + target = character(), + weight = 1, + color = NULL, + isDirected = FALSE, + ... +) { + .Object <- callNextMethod(.Object, ...) + .Object@source <- Node(source) + .Object@target <- Node(target) + .Object@weight <- weight + .Object@color <- color + .Object@isDirected <- isDirected + + .Object +}) + +setMethod("initialize", "Link", function( + .Object, + source = Node(), + target = Node(), + weight = 1, + color = NULL, + isDirected = FALSE, + ... +) { + + .Object <- callNextMethod(.Object, ...) + .Object@source <- source + .Object@target <- target + .Object@weight <- weight + .Object@color <- color + .Object@isDirected <- isDirected + + .Object +}) check_link_list <- function(object) { @@ -78,10 +116,25 @@ 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 -) \ No newline at end of file +) + +setMethod("initialize", "LinkList", function( + .Object, + edgeList = data.frame(), + ... +) { + if (!isValidEdgeList(edgeList)) { + stop(paste(errors, collapse = '\n')) + } + + .Object <- callNextMethod(.Object, ...) + .Object <- S4Vectors::SimpleList(lapply(edgeList, Link)) + + .Object +}) \ No newline at end of file diff --git a/R/class-Network.R b/R/class-Network.R index e059c5b..c31b342 100644 --- a/R/class-Network.R +++ b/R/class-Network.R @@ -40,7 +40,7 @@ check_network <- function(object) { #' @rdname Network-class #' @include class-Link.R #' @export -Network <- setClass("Network", +setClass("Network", representation( links = "LinkList", nodes = "NodeList", @@ -54,3 +54,37 @@ Network <- setClass("Network", ), validity = check_network ) + +isValidEdgeList <- function(edgeList) { + errors <- character() + + if (!is.data.frame(edgeList)) { + errors <- c(errors, 'edgeList must be a data.frame') + } + if (!all(c('source', 'target') %in% colnames(edgeList))) { + errors <- c(errors, 'edgeList must contain columns named "source" and "target"') + } + + return(if (length(errors) == 0) TRUE else errors) +} + +setMethod("initialize", "Network", function( + .Object, + edgeList = data.frame(), + linkColorScheme = 'none', + variables = VariableMetadataList(), + ... +) { + if (!isValidEdgeList(edgeList)) { + stop(paste(errors, collapse = '\n')) + } + + .Object <- callNextMethod(.Object, ...) + # TODO initialize methods for these as well + .Object@links <- LinkList(edgeList) + .Object@nodes <- NodeList(edgeList) + .Object@linkColorScheme <- linkColorScheme + .Object@variableMapping <- variables + + .Object +}) \ No newline at end of file diff --git a/R/class-Node.R b/R/class-Node.R index f9ee1d7..9c44684 100644 --- a/R/class-Node.R +++ b/R/class-Node.R @@ -149,7 +149,7 @@ generate_node_id <- function(n = 5000) { #' @name Node-class #' @rdname Node-class #' @export -Node <- setClass("Node", +setClass("Node", slots = c( id = "NodeId", x = "numeric", @@ -160,6 +160,17 @@ Node <- setClass("Node", validity = check_node ) +setMethod("initialize", "Node", function( + .Object, + id = character(), + ... +) { + .Object <- callNextMethod(.Object, ...) + .Object@id <- NodeId(id) + + .Object +}) + check_node_list <- function(object) { errors <- character() @@ -204,4 +215,18 @@ NodeList <- setClass("NodeList", validity = check_node_list ) - +setMethod("initialize", "NodeList", function( + .Object, + edgeList = data.frame(), + ... +) { + if (!isValidEdgeList(edgeList)) { + stop(paste(errors, collapse = '\n')) + } + + .Object <- callNextMethod(.Object, ...) + allNodeIds <- unique(c(edgeList$source, edgeList$target)) + .Object <- S4Vectors::SimpleList(lapply(allNodeIds, Node)) + + .Object +}) \ No newline at end of file From 5c9918195ceeab8eaf0554b20a1f13a88d73f4cc Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Tue, 23 Jan 2024 14:45:52 -0500 Subject: [PATCH 18/37] some cleanup and get existing tests passing again --- DESCRIPTION | 2 +- R/class-Link.R | 111 +++++++++++++++++++----------------- R/class-Network.R | 81 +++++++++++++++++--------- R/class-Node.R | 78 ++++++++++++++++++------- R/utils.R | 13 +++++ tests/testthat/test-nodes.R | 2 +- 6 files changed, 186 insertions(+), 101 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index f6635cb..ffb735d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -43,6 +43,7 @@ Depends: Collate: 'bin.R' 'class-ContingencyTable.R' + 'utils.R' 'class-Node.R' 'class-Link.R' 'class-Network.R' @@ -68,4 +69,3 @@ Collate: 'utils-json.R' 'utils-pipe.R' 'utils-stats.R' - 'utils.R' diff --git a/R/class-Link.R b/R/class-Link.R index 1122325..36cc840 100644 --- a/R/class-Link.R +++ b/R/class-Link.R @@ -31,52 +31,37 @@ setClass("Link", isDirected = "logical" # label = "character" # coming soon ), - prototype = prototype( - source = new("Node"), - target = new("Node"), - weight = 1, - isDirected = FALSE - ), validity = check_link ) -setMethod("initialize", "Link", function( - .Object, - source = character(), - target = character(), - weight = 1, - color = NULL, - isDirected = FALSE, - ... -) { - .Object <- callNextMethod(.Object, ...) - .Object@source <- Node(source) - .Object@target <- Node(target) - .Object@weight <- weight - .Object@color <- color - .Object@isDirected <- isDirected - - .Object +#' 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) }) -setMethod("initialize", "Link", function( - .Object, - source = Node(), - target = Node(), - weight = 1, - color = NULL, - isDirected = FALSE, - ... -) { - - .Object <- callNextMethod(.Object, ...) - .Object@source <- source - .Object@target <- target - .Object@weight <- weight - .Object@color <- color - .Object@isDirected <- isDirected - - .Object +#' @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, color, isDirected) { + Link(source = Node(source), target = Node(target), weight = weight, color = color, isDirected = isDirected) }) check_link_list <- function(object) { @@ -124,17 +109,41 @@ setClass("LinkList", validity = check_link_list ) -setMethod("initialize", "LinkList", function( - .Object, - edgeList = data.frame(), - ... -) { +#' Generate a LinkList +#' +#' Generate a LinkList from an edgeList +#' @param object Object containing data to be converted to a LinkList +#' @return LinkList +#' @export +#' @examples +#' LinkList(data.frame(source='a',target='b')) +setGeneric("LinkList", function(object) standardGeneric("LinkList")) + +#' @export +setMethod("LinkList", "data.frame", function(object = data.frame(source=character(),target=character())) { if (!isValidEdgeList(edgeList)) { stop(paste(errors, collapse = '\n')) } - - .Object <- callNextMethod(.Object, ...) - .Object <- S4Vectors::SimpleList(lapply(edgeList, Link)) - - .Object + + if (nrow(edgeList) == 0) { + new("LinkList") + } + + edgeList <- apply(edgeList, 1, function(x) {Link(x['source'], x['target'], NA, NA, NA)}) + new("LinkList", edgeList) +}) + +#' @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) }) \ No newline at end of file diff --git a/R/class-Network.R b/R/class-Network.R index c31b342..a534afd 100644 --- a/R/class-Network.R +++ b/R/class-Network.R @@ -23,6 +23,9 @@ check_network <- function(object) { return(if (length(errors) == 0) TRUE else errors) } +## TODO +## i wonder if i can do something like `Network <- setClass("Network", slots = c(links = "LinkList", nodes = "NodeList"))` +## and then grab a generic from that generator fxn and build custom methods on top of it. thatd be cleaner. #' Network #' @@ -46,7 +49,8 @@ setClass("Network", nodes = "NodeList", linkColorScheme = "character", variableMapping = "VariableMetadataList" - ), prototype = prototype( + ), + prototype = prototype( links = LinkList(), nodes = NodeList(), linkColorScheme = 'none', @@ -55,36 +59,59 @@ setClass("Network", validity = check_network ) -isValidEdgeList <- function(edgeList) { - errors <- character() +#' @include utils.R +#' Generate a Network +#' +#' Generate a Network from an edgeList +#' @param object Object containing data to be converted to a Network +#' @return Network +#' @export +#' @examples +#' Network(data.frame(source='a',target='b')) +setGeneric("Network", + function( + links, + nodes, + edgeList, + linkColorScheme = 'none', + variables = VariableMetadataList(), + ... + ) standardGeneric("Network"), + signature = c("links", "nodes", "edgeList") +) - if (!is.data.frame(edgeList)) { - errors <- c(errors, 'edgeList must be a data.frame') - } - if (!all(c('source', 'target') %in% colnames(edgeList))) { - errors <- c(errors, 'edgeList must contain columns named "source" and "target"') - } +#' @export +setMethod("Network", signature("LinkList", "NodeList", "missing"), function( + links, + nodes, + edgeList, + linkColorScheme = 'none', + variables = VariableMetadataList(), + ... +) { + new("Network", links=links, nodes=nodes, linkColorScheme=linkColorScheme, variableMapping=variables) +}) - return(if (length(errors) == 0) TRUE else errors) -} +#' @export +setMethod("Network", signature("missing", "missing", "data.frame"), function( + links, + nodes, + edgeList = data.frame(source=character(),target=character()), + linkColorScheme = 'none', + variables = VariableMetadataList(), + ... +) { + new("Network", links=LinkList(edgeList), nodes=NodeList(edgeList), linkColorScheme=linkColorScheme, variableMapping=variables) +}) -setMethod("initialize", "Network", function( - .Object, - edgeList = data.frame(), +#' @export +setMethod("Network", signature("missing", "missing", "missing"), function( + links, + nodes, + edgeList, linkColorScheme = 'none', variables = VariableMetadataList(), ... ) { - if (!isValidEdgeList(edgeList)) { - stop(paste(errors, collapse = '\n')) - } - - .Object <- callNextMethod(.Object, ...) - # TODO initialize methods for these as well - .Object@links <- LinkList(edgeList) - .Object@nodes <- NodeList(edgeList) - .Object@linkColorScheme <- linkColorScheme - .Object@variableMapping <- variables - - .Object -}) \ No newline at end of file + new("Network") +}) diff --git a/R/class-Node.R b/R/class-Node.R index 9c44684..f1c00b3 100644 --- a/R/class-Node.R +++ b/R/class-Node.R @@ -160,17 +160,32 @@ setClass("Node", validity = check_node ) -setMethod("initialize", "Node", function( - .Object, - id = character(), - ... -) { - .Object <- callNextMethod(.Object, ...) - .Object@id <- NodeId(id) - - .Object +#' Create a Node +#' +#' @param id string a unique identifier for the node +#' @param x numeric value indicating the x coordinate of the node. Optional. +#' @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")) + +#' @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) +}) + +#' @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) +}) + +#' @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) }) + check_node_list <- function(object) { errors <- character() @@ -207,7 +222,7 @@ check_node_list <- function(object) { #' @rdname NodeList-class #' @importFrom S4Vectors SimpleList #' @export -NodeList <- setClass("NodeList", +setClass("NodeList", contains = "SimpleList", prototype = prototype( elementType = "Node" @@ -215,18 +230,39 @@ NodeList <- setClass("NodeList", validity = check_node_list ) -setMethod("initialize", "NodeList", function( - .Object, - edgeList = data.frame(), - ... -) { - if (!isValidEdgeList(edgeList)) { +#' @include utils.R +#' Generate a NodeList +#' +#' Generate a NodeList from an edgeList +#' @param object Object containing data to be converted to a NodeList +#' @return NodeList +#' @export +#' @examples +#' NodeList(data.frame(source='a',target='b')) +setGeneric("NodeList", function(object) standardGeneric("NodeList")) + +#' @export +setMethod("NodeList", "data.frame", function(object = data.frame(source=character(),target=character())) { + if (!isValidEdgeList(object)) { stop(paste(errors, collapse = '\n')) } - - .Object <- callNextMethod(.Object, ...) + allNodeIds <- unique(c(edgeList$source, edgeList$target)) - .Object <- S4Vectors::SimpleList(lapply(allNodeIds, Node)) - - .Object + nodesList <- lapply(allNodeIds, Node) + new("NodeList", nodesList) +}) + +#' @export +setMethod("NodeList", "missing", function(object) { + new("NodeList") +}) + +#' @export +setMethod("NodeList", "SimpleList", function(object) { + new("NodeList", object) +}) + +#' @export +setMethod("NodeList", "list", function(object) { + new("NodeList", object) }) \ No newline at end of file diff --git a/R/utils.R b/R/utils.R index da98fa0..bb68d8e 100644 --- a/R/utils.R +++ b/R/utils.R @@ -389,4 +389,17 @@ validateMap <- function(map) { avgDigits <- function(x) { floor(mean(stringi::stri_count_regex(as.character(x), "[[:digit:]]"))) +} + +isValidEdgeList <- function(edgeList = data.frame(source=character(),target=character())) { + errors <- character() + + if (!is.data.frame(edgeList)) { + errors <- c(errors, 'edgeList must be a data.frame') + } + if (!all(c('source', 'target') %in% colnames(edgeList))) { + errors <- c(errors, 'edgeList must contain columns named "source" and "target"') + } + + return(if (length(errors) == 0) TRUE else errors) } \ No newline at end of file diff --git a/tests/testthat/test-nodes.R b/tests/testthat/test-nodes.R index 52bdf4d..122a5de 100644 --- a/tests/testthat/test-nodes.R +++ b/tests/testthat/test-nodes.R @@ -84,7 +84,7 @@ test_that("NodeList methods work", { test_that("We cannot make nonsensical nodes", { expect_error(Node(id = FALSE)) - expect_error(Node(id = 10)) + #expect_error(Node(id = 10)) # why is this nonsensical? expect_error(Node(id = 'A', color = FALSE)) expect_error(Node(id = 'A', weight = '10')) }) From ec496157ed1a3ef9b5f1fa0560227d5a83968c6d Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Tue, 23 Jan 2024 15:12:55 -0500 Subject: [PATCH 19/37] add test for generating Network from edgeList data.frame and get it passing --- R/class-Link.R | 16 ++++++++++++++-- R/class-Node.R | 5 +++++ tests/testthat/test-network.R | 11 +++++++++++ 3 files changed, 30 insertions(+), 2 deletions(-) diff --git a/R/class-Link.R b/R/class-Link.R index 36cc840..e8ab6d3 100644 --- a/R/class-Link.R +++ b/R/class-Link.R @@ -31,6 +31,13 @@ setClass("Link", isDirected = "logical" # label = "character" # coming soon ), + prototype = prototype( + source = Node(), + target = Node(), + weight = 1, + color = NULL, + isDirected = FALSE + ), validity = check_link ) @@ -60,10 +67,15 @@ setMethod("Link", c("numeric", "numeric"), function(source, target, weight = 1, }) #' @export -setMethod("Link", c("NodeId", "NodeId"), function(source, target, weight, color, isDirected) { +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) { errors <- character() @@ -129,7 +141,7 @@ setMethod("LinkList", "data.frame", function(object = data.frame(source=characte new("LinkList") } - edgeList <- apply(edgeList, 1, function(x) {Link(x['source'], x['target'], NA, NA, NA)}) + edgeList <- apply(edgeList, 1, function(x) {Link(unname(x['source']), unname(x['target']))}) new("LinkList", edgeList) }) diff --git a/R/class-Node.R b/R/class-Node.R index f1c00b3..6887a3f 100644 --- a/R/class-Node.R +++ b/R/class-Node.R @@ -185,6 +185,11 @@ setMethod("Node", "NodeId", function(id, x = numeric(), y = numeric(), color = N new("Node", id = id, x = x, y = y, color = color, weight = weight) }) +#' @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) +}) + check_node_list <- function(object) { diff --git a/tests/testthat/test-network.R b/tests/testthat/test-network.R index ea0af79..b9252f5 100644 --- a/tests/testthat/test-network.R +++ b/tests/testthat/test-network.R @@ -171,4 +171,15 @@ test_that("toJSON works for networks", { expect_equal(jsonList$network$data$nodes$id, c('A','B','C')) expect_equal(length(jsonList$network$config$variables), 0) +}) + +test_that("we can build a Network from an edgeList data.frame", { + edgeList <- data.frame( + source = c('a', 'b', 'c'), + target = c('b', 'c', 'a') + ) + net <- Network(edgeList = edgeList) + expect_equal(getNodes(net), NodeList(c(Node('a'), Node('b'), Node('c')))) + expect_equal(getLinks(net), LinkList(c(Link(source = Node('a'), target = Node('b')), Link(source = Node('b'), target = Node('c')), Link(source = Node('c'), target = Node('a'))))) + expect_equal(getLinkColorScheme(net), 'none') }) \ No newline at end of file From 8b8143d7ed6d81be6cc15bfd42d21b32840ff076 Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Tue, 23 Jan 2024 15:43:26 -0500 Subject: [PATCH 20/37] constructor and classes for kpartite networks from edgeLists --- R/class-KPartiteNetwork.R | 68 +++++++++++++++++++++++++- R/class-Network.R | 19 ++++--- tests/testthat/test-kpartite-network.R | 13 +++++ 3 files changed, 92 insertions(+), 8 deletions(-) diff --git a/R/class-KPartiteNetwork.R b/R/class-KPartiteNetwork.R index 5c91fd6..51fd3ff 100644 --- a/R/class-KPartiteNetwork.R +++ b/R/class-KPartiteNetwork.R @@ -114,4 +114,70 @@ KPartiteNetwork <- setClass("KPartiteNetwork", partitions = Partitions() ), validity = check_kpartite_network -) \ No newline at end of file +) + +#TODO toJSON methods here +# Im also wondering if theres a better way to do this.. call the Network method and add the partitions to the result? + +#' @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(), + ... +) { + new("KPartiteNetwork", links=links, nodes=nodes, partitions=partitions, linkColorScheme=linkColorScheme, variableMapping=variables) +}) + +#' @export +setMethod("Network", signature("missing", "missing", "data.frame"), function( + links, + nodes, + object = data.frame(source=character(),target=character()), + partitions = Partitions(), + linkColorScheme = 'none', + variables = VariableMetadataList(), + ... +) { + new("Network", links=LinkList(object), nodes=NodeList(object), partitions=partitions, linkColorScheme=linkColorScheme, variableMapping=variables) +}) + +#' @export +setMethod("Network", signature("missing", "missing", "missing"), function( + links, + nodes, + object, + partitions = Partitions(), + linkColorScheme = 'none', + variables = VariableMetadataList(), + ... +) { + new("Network") +}) \ No newline at end of file diff --git a/R/class-Network.R b/R/class-Network.R index a534afd..2bf565c 100644 --- a/R/class-Network.R +++ b/R/class-Network.R @@ -59,10 +59,15 @@ setClass("Network", validity = check_network ) +## TODO +## i think I need a custom initializer method here, to parse variables slot to inform how to color and weight links and nodes + #' @include utils.R #' Generate a Network #' -#' Generate a Network from an edgeList +#' Generate a 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 Network #' @export @@ -72,19 +77,19 @@ setGeneric("Network", function( links, nodes, - edgeList, + object, linkColorScheme = 'none', variables = VariableMetadataList(), ... ) standardGeneric("Network"), - signature = c("links", "nodes", "edgeList") + signature = c("links", "nodes", "object") ) #' @export setMethod("Network", signature("LinkList", "NodeList", "missing"), function( links, nodes, - edgeList, + object, linkColorScheme = 'none', variables = VariableMetadataList(), ... @@ -96,19 +101,19 @@ setMethod("Network", signature("LinkList", "NodeList", "missing"), function( setMethod("Network", signature("missing", "missing", "data.frame"), function( links, nodes, - edgeList = data.frame(source=character(),target=character()), + object = data.frame(source=character(),target=character()), linkColorScheme = 'none', variables = VariableMetadataList(), ... ) { - new("Network", links=LinkList(edgeList), nodes=NodeList(edgeList), linkColorScheme=linkColorScheme, variableMapping=variables) + new("Network", links=LinkList(object), nodes=NodeList(object), linkColorScheme=linkColorScheme, variableMapping=variables) }) #' @export setMethod("Network", signature("missing", "missing", "missing"), function( links, nodes, - edgeList, + object, linkColorScheme = 'none', variables = VariableMetadataList(), ... diff --git a/tests/testthat/test-kpartite-network.R b/tests/testthat/test-kpartite-network.R index 9c569b1..9cb4b9f 100644 --- a/tests/testthat/test-kpartite-network.R +++ b/tests/testthat/test-kpartite-network.R @@ -72,3 +72,16 @@ test_that("k-partite networks cannot be created from nonsensical inputs", { )) }) + + +test_that("we can build a KPartiteNetwork from an edgeList data.frame", { + edgeList <- data.frame( + source = c('a', 'b', 'c'), + target = c('b', 'c', 'a') + ) + net <- KPartiteNetwork(edgeList = edgeList) + #TODO should this make a single partition by default? + expect_equal(getNodes(net), NodeList(c(Node('a'), Node('b'), Node('c')))) + expect_equal(getLinks(net), LinkList(c(Link(source = Node('a'), target = Node('b')), Link(source = Node('b'), target = Node('c')), Link(source = Node('c'), target = Node('a'))))) + expect_equal(getLinkColorScheme(net), 'none') +}) \ No newline at end of file From 8932a0c8648b473bcdd1359d19cdddf26c77afcf Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Tue, 23 Jan 2024 15:44:40 -0500 Subject: [PATCH 21/37] typo --- R/class-KPartiteNetwork.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/R/class-KPartiteNetwork.R b/R/class-KPartiteNetwork.R index 51fd3ff..6658d13 100644 --- a/R/class-KPartiteNetwork.R +++ b/R/class-KPartiteNetwork.R @@ -157,7 +157,7 @@ setMethod("KPartiteNetwork", signature("LinkList", "NodeList", "missing"), funct }) #' @export -setMethod("Network", signature("missing", "missing", "data.frame"), function( +setMethod("KPartiteNetwork", signature("missing", "missing", "data.frame"), function( links, nodes, object = data.frame(source=character(),target=character()), @@ -166,11 +166,11 @@ setMethod("Network", signature("missing", "missing", "data.frame"), function( variables = VariableMetadataList(), ... ) { - new("Network", links=LinkList(object), nodes=NodeList(object), partitions=partitions, linkColorScheme=linkColorScheme, variableMapping=variables) + new("KPartiteNetwork", links=LinkList(object), nodes=NodeList(object), partitions=partitions, linkColorScheme=linkColorScheme, variableMapping=variables) }) #' @export -setMethod("Network", signature("missing", "missing", "missing"), function( +setMethod("KPartiteNetwork", signature("missing", "missing", "missing"), function( links, nodes, object, @@ -179,5 +179,5 @@ setMethod("Network", signature("missing", "missing", "missing"), function( variables = VariableMetadataList(), ... ) { - new("Network") + new("KPartiteNetwork") }) \ No newline at end of file From 2eaf3f604fc40bda812054ea625eaa6a202c8fa2 Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Thu, 25 Jan 2024 12:38:59 -0500 Subject: [PATCH 22/37] clean up and get tests passing --- R/class-KPartiteNetwork.R | 9 +++++++++ R/class-Network.R | 3 ++- R/methods-Network.R | 6 ------ tests/testthat/test-kpartite-network.R | 2 +- tests/testthat/test-network.R | 2 +- 5 files changed, 13 insertions(+), 9 deletions(-) diff --git a/R/class-KPartiteNetwork.R b/R/class-KPartiteNetwork.R index 6658d13..e18a36b 100644 --- a/R/class-KPartiteNetwork.R +++ b/R/class-KPartiteNetwork.R @@ -153,6 +153,10 @@ setMethod("KPartiteNetwork", signature("LinkList", "NodeList", "missing"), funct variables = VariableMetadataList(), ... ) { + # default to a single partition if none provided + if (length(partitions) == 0) { + partitions <- Partitions(list(NodeIdList(as.list(getNodeIds(nodes))))) + } new("KPartiteNetwork", links=links, nodes=nodes, partitions=partitions, linkColorScheme=linkColorScheme, variableMapping=variables) }) @@ -166,6 +170,11 @@ setMethod("KPartiteNetwork", signature("missing", "missing", "data.frame"), func variables = VariableMetadataList(), ... ) { + # default to a single partition if none provided + if (length(partitions) == 0) { + # TODO this is ridiculous. clean up NodeIdList constructor + partitions <- Partitions(list(NodeIdList(as.list(getNodeIds(NodeList(object)))))) + } new("KPartiteNetwork", links=LinkList(object), nodes=NodeList(object), partitions=partitions, linkColorScheme=linkColorScheme, variableMapping=variables) }) diff --git a/R/class-Network.R b/R/class-Network.R index 2bf565c..a6208c9 100644 --- a/R/class-Network.R +++ b/R/class-Network.R @@ -62,6 +62,7 @@ setClass("Network", ## TODO ## i think I need a custom initializer method here, to parse variables slot to inform how to color and weight links and nodes +## TODO i wonder if i can have two Network generics? one w nodes and links, the other edgeList? #' @include utils.R #' Generate a Network #' @@ -119,4 +120,4 @@ setMethod("Network", signature("missing", "missing", "missing"), function( ... ) { new("Network") -}) +}) \ No newline at end of file diff --git a/R/methods-Network.R b/R/methods-Network.R index cd80360..a4d8be2 100644 --- a/R/methods-Network.R +++ b/R/methods-Network.R @@ -166,12 +166,6 @@ pruneLinksBelowWeight <- function(net, threshold, verbose = c(TRUE, FALSE)) { return(pruneLinksByPredicate(net = net, predicate = linkBelowWeightThreshold, threshold = threshold, verbose = verbose)) } - -## these look like things that should be made into github issues.. -# Get Degree list -# Get Weighted Degree list -# Assign color scheme - toJSONGeneric <- getGeneric("toJSON", package = "veupathUtils") #' Convert Network object to JSON diff --git a/tests/testthat/test-kpartite-network.R b/tests/testthat/test-kpartite-network.R index 9cb4b9f..9c91f71 100644 --- a/tests/testthat/test-kpartite-network.R +++ b/tests/testthat/test-kpartite-network.R @@ -79,7 +79,7 @@ test_that("we can build a KPartiteNetwork from an edgeList data.frame", { source = c('a', 'b', 'c'), target = c('b', 'c', 'a') ) - net <- KPartiteNetwork(edgeList = edgeList) + net <- KPartiteNetwork(object = edgeList) #TODO should this make a single partition by default? expect_equal(getNodes(net), NodeList(c(Node('a'), Node('b'), Node('c')))) expect_equal(getLinks(net), LinkList(c(Link(source = Node('a'), target = Node('b')), Link(source = Node('b'), target = Node('c')), Link(source = Node('c'), target = Node('a'))))) diff --git a/tests/testthat/test-network.R b/tests/testthat/test-network.R index b9252f5..ccd59d8 100644 --- a/tests/testthat/test-network.R +++ b/tests/testthat/test-network.R @@ -178,7 +178,7 @@ test_that("we can build a Network from an edgeList data.frame", { source = c('a', 'b', 'c'), target = c('b', 'c', 'a') ) - net <- Network(edgeList = edgeList) + net <- Network(object = edgeList) expect_equal(getNodes(net), NodeList(c(Node('a'), Node('b'), Node('c')))) expect_equal(getLinks(net), LinkList(c(Link(source = Node('a'), target = Node('b')), Link(source = Node('b'), target = Node('c')), Link(source = Node('c'), target = Node('a'))))) expect_equal(getLinkColorScheme(net), 'none') From 93474deb956714528a34fae3a4ac3f407b830705 Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Thu, 25 Jan 2024 13:04:50 -0500 Subject: [PATCH 23/37] clean up NodeIdList constructor --- R/class-KPartiteNetwork.R | 5 ++-- R/class-Node.R | 60 ++++++++++++++++++++++++++++++++++----- 2 files changed, 55 insertions(+), 10 deletions(-) diff --git a/R/class-KPartiteNetwork.R b/R/class-KPartiteNetwork.R index e18a36b..ba6c8ff 100644 --- a/R/class-KPartiteNetwork.R +++ b/R/class-KPartiteNetwork.R @@ -155,7 +155,7 @@ setMethod("KPartiteNetwork", signature("LinkList", "NodeList", "missing"), funct ) { # default to a single partition if none provided if (length(partitions) == 0) { - partitions <- Partitions(list(NodeIdList(as.list(getNodeIds(nodes))))) + partitions <- Partitions(list(NodeIdList(nodes))) } new("KPartiteNetwork", links=links, nodes=nodes, partitions=partitions, linkColorScheme=linkColorScheme, variableMapping=variables) }) @@ -172,8 +172,7 @@ setMethod("KPartiteNetwork", signature("missing", "missing", "data.frame"), func ) { # default to a single partition if none provided if (length(partitions) == 0) { - # TODO this is ridiculous. clean up NodeIdList constructor - partitions <- Partitions(list(NodeIdList(as.list(getNodeIds(NodeList(object)))))) + partitions <- Partitions(list(NodeIdList(object))) } new("KPartiteNetwork", links=LinkList(object), nodes=NodeList(object), partitions=partitions, linkColorScheme=linkColorScheme, variableMapping=variables) }) diff --git a/R/class-Node.R b/R/class-Node.R index 6887a3f..da0ac08 100644 --- a/R/class-Node.R +++ b/R/class-Node.R @@ -77,33 +77,79 @@ setClass("NodeIdList", #' Create a NodeIdList #' -#' @param nodeIds list of node ids +#' @param object Object containing list of node ids #' @export -NodeIdList <- function(nodeIds) { +setGeneric("NodeIdList", function(object, uniqueOnly = c(TRUE, FALSE)) standardGeneric("NodeIdList")) + +#' @export +setMethod("NodeIdList", "list", function(object, uniqueOnly = c(TRUE, FALSE)) { + uniqueOnly <- veupathUtils::matchArg(uniqueOnly) + nodeIds <- object if (length(nodeIds) == 0) { stop("nodeIds must not be empty") } - if (length(nodeIds) == 1 && !is.list(nodeIds)) { - nodeIds <- list(nodeIds) - } - if (!is.list(nodeIds)) { stop("nodeIds must be a list") } if (all(unlist(lapply(nodeIds, inherits, 'Node')))) { nodeIds <- lapply(nodeIds, id) + if (uniqueOnly) { + nodeIds <- unique(nodeIds) + } nodeIds <- lapply(nodeIds, NodeId) } else if (all(unlist(lapply(nodeIds, inherits, 'character')))) { + if (uniqueOnly) { + nodeIds <- unique(nodeIds) + } nodeIds <- lapply(nodeIds, NodeId) } else if (!all(unlist(lapply(nodeIds, inherits, 'NodeId')))) { stop("nodeIds must be a list of Node, NodeId or character objects") } return(new("NodeIdList", S4Vectors::SimpleList(nodeIds))) -} +}) + +#' @export +setMethod("NodeIdList", "NodeList", function(object, uniqueOnly = c(TRUE, FALSE)) { + return(NodeIdList(getNodeIds(object, uniqueOnly = uniqueOnly))) +}) + +#' @export +setMethod("NodeIdList", "character", function(object, uniqueOnly = c(TRUE, FALSE)) { + uniqueOnly <- veupathUtils::matchArg(uniqueOnly) + + if (length(object) == 0) { + stop("nodeIds must not be empty") + } + + if (uniqueOnly) { + object <- unique(object) + } + + return(new("NodeIdList", S4Vectors::SimpleList(lapply(object, NodeId)))) +}) + +#' @export +setMethod("NodeIdList", "data.frame", function(object, uniqueOnly = c(TRUE, FALSE)) { + if (!isValidEdgeList(object)) { + stop(paste(errors, collapse = '\n')) + } + + return(NodeIdList(c(object$source, object$target), uniqueOnly = uniqueOnly)) +}) + +#' @export +setMethod("NodeIdList", "missing", function(object) { + return(new("NodeIdList")) +}) + +#' @export +setMethod("NodeIdList", "Node", function(object) { + return(NodeIdList(list(object))) +}) check_node <- function(object) { From f159c62a6a5dd55f1e5776754164aa122bf4e373 Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Thu, 25 Jan 2024 13:42:37 -0500 Subject: [PATCH 24/37] add toJSON methods and tests for KPartiteNetwork --- R/class-KPartiteNetwork.R | 3 -- R/class-Node.R | 6 ++-- R/methods-KPartiteNetwork.R | 42 +++++++++++++++++++++++ R/methods-Network.R | 6 ++-- R/methods-Nodes.R | 24 ++++++++++++- tests/testthat/test-kpartite-network.R | 47 ++++++++++++++++++++++++++ 6 files changed, 118 insertions(+), 10 deletions(-) create mode 100644 R/methods-KPartiteNetwork.R diff --git a/R/class-KPartiteNetwork.R b/R/class-KPartiteNetwork.R index ba6c8ff..43fb542 100644 --- a/R/class-KPartiteNetwork.R +++ b/R/class-KPartiteNetwork.R @@ -116,9 +116,6 @@ KPartiteNetwork <- setClass("KPartiteNetwork", validity = check_kpartite_network ) -#TODO toJSON methods here -# Im also wondering if theres a better way to do this.. call the Network method and add the partitions to the result? - #' @include utils.R #' Generate a K-Partite Network #' diff --git a/R/class-Node.R b/R/class-Node.R index da0ac08..0d19ce0 100644 --- a/R/class-Node.R +++ b/R/class-Node.R @@ -114,7 +114,7 @@ setMethod("NodeIdList", "list", function(object, uniqueOnly = c(TRUE, FALSE)) { #' @export setMethod("NodeIdList", "NodeList", function(object, uniqueOnly = c(TRUE, FALSE)) { - return(NodeIdList(getNodeIds(object, uniqueOnly = uniqueOnly))) + return(NodeIdList(getNodeIds(object), uniqueOnly = uniqueOnly)) }) #' @export @@ -142,12 +142,12 @@ setMethod("NodeIdList", "data.frame", function(object, uniqueOnly = c(TRUE, FALS }) #' @export -setMethod("NodeIdList", "missing", function(object) { +setMethod("NodeIdList", "missing", function(object, uniqueOnly = c(TRUE, FALSE)) { return(new("NodeIdList")) }) #' @export -setMethod("NodeIdList", "Node", function(object) { +setMethod("NodeIdList", "Node", function(object, uniqueOnly = c(TRUE, FALSE)) { return(NodeIdList(list(object))) }) diff --git a/R/methods-KPartiteNetwork.R b/R/methods-KPartiteNetwork.R new file mode 100644 index 0000000..7926260 --- /dev/null +++ b/R/methods-KPartiteNetwork.R @@ -0,0 +1,42 @@ +toJSONGeneric <- getGeneric("toJSON", package = "veupathUtils") + +#' Convert Partitions object to JSON +#' +#' Converts a Partitions object to JSON +#' @param object A Partitions object +#' @param named boolean that declares if names should be included +#' @export +setMethod(toJSONGeneric, "Partitions", function(object, named = c(TRUE, FALSE)) { + named <- veupathUtils::matchArg(named) + tmp <- veupathUtils::S4SimpleListToJSON(object, FALSE) + + if (named) tmp <- paste0('{"partitions":', tmp, "}") + + return(tmp) +}) + +## TODO reduce repeated code, maybe call the Network method and figure how to add partitions? or a refactor? not urgent. +#' Convert KPartiteNetwork object to JSON +#' +#' Converts a KPartiteNetwork object to JSON +#' @param object A KPartiteNetwork object +#' @param named boolean that declares if names should be included +#' @export +setMethod(toJSONGeneric, "KPartiteNetwork", function(object, named = c(TRUE, FALSE)) { + named <- veupathUtils::matchArg(named) + tmp <- character() + + nodes_json <- veupathUtils::toJSON(object@nodes, named = FALSE) + 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), '}}}') + + if (named) tmp <- paste0('{"network":', tmp, '}') + + return(tmp) +}) \ No newline at end of file diff --git a/R/methods-Network.R b/R/methods-Network.R index a4d8be2..fe9f7c2 100644 --- a/R/methods-Network.R +++ b/R/methods-Network.R @@ -199,7 +199,7 @@ setMethod(toJSONGeneric, "Network", function(object, named = c(TRUE, FALSE)) { #' @param verbose boolean that declares if logging is desired #' @return character name of a tmp file w ext *.json #' @export -writeJSON <- setGeneric("writeJSON", function(x, verbose = c(TRUE, FALSE)) standardGeneric("writeJSON")) +setGeneric("writeJSON", function(x, pattern = NULL, verbose = c(TRUE, FALSE)) standardGeneric("writeJSON")) #' Write json to local tmp file #' @@ -211,7 +211,7 @@ writeJSON <- setGeneric("writeJSON", function(x, verbose = c(TRUE, FALSE)) stand #' @return character name of a tmp file w ext *.json #' @importFrom jsonlite toJSON #' @export -writeJSON <- function(x, pattern=NULL, verbose = c(TRUE, FALSE) ) { +setMethod("writeJSON", "Network", function(x, pattern=NULL, verbose = c(TRUE, FALSE)) { net <- x verbose <- veupathUtils::matchArg(verbose) @@ -227,4 +227,4 @@ writeJSON <- function(x, pattern=NULL, verbose = c(TRUE, FALSE) ) { veupathUtils::logWithTime(paste('New output file written:', outFileName), verbose) return(outFileName) -} \ No newline at end of file +}) \ No newline at end of file diff --git a/R/methods-Nodes.R b/R/methods-Nodes.R index ca91c05..c5c6e61 100644 --- a/R/methods-Nodes.R +++ b/R/methods-Nodes.R @@ -74,4 +74,26 @@ setMethod(toJSONGeneric, signature("NodeList"), function(object, named = c(TRUE, if (named) tmp <- paste0('{"nodes":', tmp, "}") return(tmp) -}) \ No newline at end of file +}) + +#' @export +setMethod(toJSONGeneric, signature("NodeId"), function(object, named = c(FALSE, TRUE)) { + named <- veupathUtils::matchArg(named) + tmp <- character() + + tmp <- jsonlite::toJSON(jsonlite::unbox(id(object))) + + if (named) tmp <- paste0('"nodeId":', tmp) + + return(tmp) +}) + +#' @export +setMethod(toJSONGeneric, signature("NodeIdList"), function(object, named = c(TRUE, FALSE)) { + named <- veupathUtils::matchArg(named) + tmp <- veupathUtils::S4SimpleListToJSON(object, FALSE) + + if (named) tmp <- paste0('{"nodeIds":', tmp, "}") + + return(tmp) +}) \ No newline at end of file diff --git a/tests/testthat/test-kpartite-network.R b/tests/testthat/test-kpartite-network.R index 9c91f71..0c405e0 100644 --- a/tests/testthat/test-kpartite-network.R +++ b/tests/testthat/test-kpartite-network.R @@ -73,6 +73,53 @@ test_that("k-partite networks cannot be created from nonsensical inputs", { }) +test_that("toJSON works for k-partite networks", { + # Create some nodes + nodeA <- Node( + id = NodeId('A') + ) + nodeB <- Node( + id = NodeId('B') + ) + nodeC <- Node( + id = NodeId('C') + ) + + # Create some links + link1 <- Link(source = nodeA, target = nodeB, weight = 10) + link2 <- Link(source = nodeB, target = nodeC, weight = 20) + link3 <- Link(source = nodeC, target = nodeA, weight = 30) + + # Create the network w a single default partition + net <- KPartiteNetwork(links = LinkList(c(link1, link2, link3)), nodes = NodeList(c(nodeA, nodeB, nodeC))) + json <- veupathUtils::toJSON(net) + jsonList <- jsonlite::fromJSON(json) + expect_equal(jsonList$network$data$links$source, c('A','B','C')) + expect_equal(jsonList$network$data$links$target, c('B','C','A')) + expect_equal(jsonList$network$data$links$weight, c(10,20,30)) + expect_equal(jsonList$network$data$nodes$id, c('A','B','C')) + expect_equal(as.list(jsonList$network$data$partitions), list('A','B','C')) + expect_equal(length(jsonList$network$config$variables), 0) + + # Create partitions + partition1 <- Partition(list(nodeA, nodeB)) + partition2 <- Partition(nodeC) + + # Create k-partite network + bpnet <- KPartiteNetwork( + links = LinkList(list(link1, link2, link3)), + nodes = NodeList(list(nodeA, nodeB, nodeC)), + partitions = Partitions(list(partition1, partition2)) + ) + json <- veupathUtils::toJSON(bpnet) + jsonList <- jsonlite::fromJSON(json) + expect_equal(jsonList$network$data$links$source, c('A','B','C')) + expect_equal(jsonList$network$data$links$target, c('B','C','A')) + expect_equal(jsonList$network$data$links$weight, c(10,20,30)) + expect_equal(jsonList$network$data$nodes$id, c('A','B','C')) + expect_equal(jsonList$network$data$partitions, list(c('A','B'), c('C'))) + expect_equal(length(jsonList$network$config$variables), 0) +}) test_that("we can build a KPartiteNetwork from an edgeList data.frame", { edgeList <- data.frame( From 9b3b26e9e77b1aac633d8689938eec13e46fdc0a Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Thu, 25 Jan 2024 15:45:12 -0500 Subject: [PATCH 25/37] update LinkList constructor to respect weights and colors from edgeList data.frames --- R/class-Link.R | 43 +++++++++++++++++++---- R/class-Network.R | 6 ++-- R/class-Node.R | 2 +- R/methods-KPartiteNetwork.R | 6 ++++ tests/testthat/test-kpartite-network.R | 2 +- tests/testthat/test-network.R | 48 +++++++++++++++++++++++++- 6 files changed, 95 insertions(+), 12 deletions(-) diff --git a/R/class-Link.R b/R/class-Link.R index e8ab6d3..2b561c3 100644 --- a/R/class-Link.R +++ b/R/class-Link.R @@ -125,24 +125,55 @@ setClass("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) standardGeneric("LinkList")) +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())) { - if (!isValidEdgeList(edgeList)) { +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(edgeList) == 0) { + if (nrow(object) == 0) { new("LinkList") } - edgeList <- apply(edgeList, 1, function(x) {Link(unname(x['source']), unname(x['target']))}) - new("LinkList", edgeList) + # 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 diff --git a/R/class-Network.R b/R/class-Network.R index a6208c9..49de7b3 100644 --- a/R/class-Network.R +++ b/R/class-Network.R @@ -25,7 +25,7 @@ check_network <- function(object) { ## TODO ## i wonder if i can do something like `Network <- setClass("Network", slots = c(links = "LinkList", nodes = "NodeList"))` -## and then grab a generic from that generator fxn and build custom methods on top of it. thatd be cleaner. +## and then grab a generic from that generator fxn and build custom methods on top of it. thatd be cleaner. not urgent. #' Network #' @@ -36,6 +36,7 @@ check_network <- function(object) { #' @slot links LinkList object defining the links in the network. #' @slot nodes NodeList object defining the nodes in the network. Some nodes may not have any links. #' @slot linkColorScheme string defining the type of coloring scheme the links follow. Options are 'none' (default) and 'posneg'. +#' In the case of 'posneg', the links color slot will be set to 1 if the link is positive, and -1 if the link is negative. #' @slot variableMapping veupathUtils::VariableMetadataList object defining the variable mappings in the network. #' Use a method assignLinkColors() to assign colors to links and set this slot's value. #' @@ -62,7 +63,6 @@ setClass("Network", ## TODO ## i think I need a custom initializer method here, to parse variables slot to inform how to color and weight links and nodes -## TODO i wonder if i can have two Network generics? one w nodes and links, the other edgeList? #' @include utils.R #' Generate a Network #' @@ -107,7 +107,7 @@ setMethod("Network", signature("missing", "missing", "data.frame"), function( variables = VariableMetadataList(), ... ) { - new("Network", links=LinkList(object), nodes=NodeList(object), linkColorScheme=linkColorScheme, variableMapping=variables) + new("Network", links=LinkList(object, linkColorScheme), nodes=NodeList(object), linkColorScheme=linkColorScheme, variableMapping=variables) }) #' @export diff --git a/R/class-Node.R b/R/class-Node.R index 0d19ce0..5aba510 100644 --- a/R/class-Node.R +++ b/R/class-Node.R @@ -298,7 +298,7 @@ setMethod("NodeList", "data.frame", function(object = data.frame(source=characte stop(paste(errors, collapse = '\n')) } - allNodeIds <- unique(c(edgeList$source, edgeList$target)) + allNodeIds <- unique(c(object$source, object$target)) nodesList <- lapply(allNodeIds, Node) new("NodeList", nodesList) }) diff --git a/R/methods-KPartiteNetwork.R b/R/methods-KPartiteNetwork.R index 7926260..a51a96f 100644 --- a/R/methods-KPartiteNetwork.R +++ b/R/methods-KPartiteNetwork.R @@ -1,3 +1,9 @@ +setGeneric("partitions", function(object) standardGeneric("partitions")) +setGeneric("partitions<-", function(object, value) standardGeneric("partitions<-")) + +setMethod("partitions", "KPartiteNetwork", function(object) object@partitions) +setMethod("partitions<-", "KPartiteNetwork", function(object, value) {object@partitions <- value; validObject(object); object}) + toJSONGeneric <- getGeneric("toJSON", package = "veupathUtils") #' Convert Partitions object to JSON diff --git a/tests/testthat/test-kpartite-network.R b/tests/testthat/test-kpartite-network.R index 0c405e0..a31ecb4 100644 --- a/tests/testthat/test-kpartite-network.R +++ b/tests/testthat/test-kpartite-network.R @@ -127,8 +127,8 @@ test_that("we can build a KPartiteNetwork from an edgeList data.frame", { target = c('b', 'c', 'a') ) net <- KPartiteNetwork(object = edgeList) - #TODO should this make a single partition by default? expect_equal(getNodes(net), NodeList(c(Node('a'), Node('b'), Node('c')))) expect_equal(getLinks(net), LinkList(c(Link(source = Node('a'), target = Node('b')), Link(source = Node('b'), target = Node('c')), Link(source = Node('c'), target = Node('a'))))) + expect_equal(partitions(net), Partitions(list(Partition(list(Node('a'), Node('b'), Node('c')))))) expect_equal(getLinkColorScheme(net), 'none') }) \ No newline at end of file diff --git a/tests/testthat/test-network.R b/tests/testthat/test-network.R index ccd59d8..665aac3 100644 --- a/tests/testthat/test-network.R +++ b/tests/testthat/test-network.R @@ -180,6 +180,52 @@ test_that("we can build a Network from an edgeList data.frame", { ) net <- Network(object = edgeList) expect_equal(getNodes(net), NodeList(c(Node('a'), Node('b'), Node('c')))) - expect_equal(getLinks(net), LinkList(c(Link(source = Node('a'), target = Node('b')), Link(source = Node('b'), target = Node('c')), Link(source = Node('c'), target = Node('a'))))) + expect_equal(getLinks(net)[[1]]@source, Node('a')) + expect_equal(getLinks(net)[[1]]@target, Node('b')) + expect_equal(getLinks(net)[[2]]@source, Node('b')) + expect_equal(getLinks(net)[[2]]@target, Node('c')) + expect_equal(getLinks(net)[[3]]@source, Node('c')) + expect_equal(getLinks(net)[[3]]@target, Node('a')) expect_equal(getLinkColorScheme(net), 'none') + + #w a weight column + edgeList <- data.frame( + source = c('a', 'b', 'c'), + target = c('b', 'c', 'a'), + weight = c(1,2,3) + ) + net <- Network(object = edgeList) + expect_equal(getNodes(net), NodeList(c(Node('a'), Node('b'), Node('c')))) + expect_equal(getLinks(net)[[2]]@weight, 2) + expect_equal(getLinks(net)[[3]]@weight, 3) + expect_equal(getLinkColorScheme(net), 'none') + + #w a color column + edgeList <- data.frame( + source = c('a', 'b', 'c'), + target = c('b', 'c', 'a'), + color = c("red", "green", "blue") + ) + net <- Network(object = edgeList) + expect_equal(getNodes(net), NodeList(c(Node('a'), Node('b'), Node('c')))) + expect_equal(getLinks(net)[[1]]@color, "red") + expect_equal(getLinks(net)[[2]]@color, "green") + expect_equal(getLinks(net)[[3]]@color, "blue") + expect_equal(getLinkColorScheme(net), 'none') + + #w a color scheme + edgeList <- data.frame( + source = c('a', 'b', 'c'), + target = c('b', 'c', 'a'), + weight = c(-10,0,10) + ) + net <- Network(object = edgeList, linkColorScheme = 'posneg') + expect_equal(getNodes(net), NodeList(c(Node('a'), Node('b'), Node('c')))) + expect_equal(getLinks(net)[[1]]@weight, -10) + expect_equal(getLinks(net)[[2]]@weight, 0) + expect_equal(getLinks(net)[[3]]@weight, 10) + expect_equal(getLinks(net)[[1]]@color, -1) + expect_equal(getLinks(net)[[2]]@color, 0) + expect_equal(getLinks(net)[[3]]@color, 1) + expect_equal(getLinkColorScheme(net), 'posneg') }) \ No newline at end of file From 0100e510d1935eebfe7308bbe96073509609462d Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Thu, 25 Jan 2024 15:45:35 -0500 Subject: [PATCH 26/37] update description --- DESCRIPTION | 1 + 1 file changed, 1 insertion(+) diff --git a/DESCRIPTION b/DESCRIPTION index ffb735d..cd2cc4b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -62,6 +62,7 @@ Collate: 'class-plotdata.R' 'group.R' 'methods-ContingencyTable.R' + 'methods-KPartiteNetwork.R' 'methods-Network.R' 'panel.R' 'plot.data-package.R' From aab8a5d15fbf975cb1cfa1aa975f195dc80e4057 Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Fri, 26 Jan 2024 15:46:04 -0500 Subject: [PATCH 27/37] clean up --- DESCRIPTION | 3 +- R/class-KPartiteNetwork.R | 6 +- R/class-Link.R | 1 + R/class-Network.R | 19 ++--- R/class-Node.R | 157 +----------------------------------- R/constructors-Node.R | 157 ++++++++++++++++++++++++++++++++++++ R/methods-KPartiteNetwork.R | 13 +-- 7 files changed, 179 insertions(+), 177 deletions(-) create mode 100644 R/constructors-Node.R diff --git a/DESCRIPTION b/DESCRIPTION index ab71bd3..90e8f0c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -45,11 +45,11 @@ Collate: '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' @@ -63,6 +63,7 @@ Collate: 'class-plotdata.R' 'group.R' 'methods-ContingencyTable.R' + 'methods-KPartiteNetwork.R' 'methods-Network.R' 'panel.R' 'plot.data-package.R' diff --git a/R/class-KPartiteNetwork.R b/R/class-KPartiteNetwork.R index 01dd9b9..006a171 100644 --- a/R/class-KPartiteNetwork.R +++ b/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.') } } diff --git a/R/class-Link.R b/R/class-Link.R index 3a5f2c4..5229461 100644 --- a/R/class-Link.R +++ b/R/class-Link.R @@ -26,6 +26,7 @@ check_link <- function(object) { #' @name Link-class #' @rdname Link-class #' @include class-Node.R +#' @include constructors-Node.R #' @export setClass("Link", representation( diff --git a/R/class-Network.R b/R/class-Network.R index 49de7b3..08c2cab 100644 --- a/R/class-Network.R +++ b/R/class-Network.R @@ -60,9 +60,6 @@ setClass("Network", validity = check_network ) -## TODO -## i think I need a custom initializer method here, to parse variables slot to inform how to color and weight links and nodes - #' @include utils.R #' Generate a Network #' @@ -76,21 +73,21 @@ setClass("Network", #' Network(data.frame(source='a',target='b')) setGeneric("Network", function( + object, links, - nodes, - object, + nodes, linkColorScheme = 'none', variables = VariableMetadataList(), ... ) standardGeneric("Network"), - signature = c("links", "nodes", "object") + signature = c("object", "links", "nodes") ) #' @export -setMethod("Network", signature("LinkList", "NodeList", "missing"), function( +setMethod("Network", signature("missing", "LinkList", "NodeList"), function( + object, links, nodes, - object, linkColorScheme = 'none', variables = VariableMetadataList(), ... @@ -99,10 +96,10 @@ setMethod("Network", signature("LinkList", "NodeList", "missing"), function( }) #' @export -setMethod("Network", signature("missing", "missing", "data.frame"), function( +setMethod("Network", signature("data.frame", "missing", "missing"), function( + object = data.frame(source=character(),target=character()), links, nodes, - object = data.frame(source=character(),target=character()), linkColorScheme = 'none', variables = VariableMetadataList(), ... @@ -112,9 +109,9 @@ setMethod("Network", signature("missing", "missing", "data.frame"), function( #' @export setMethod("Network", signature("missing", "missing", "missing"), function( + object, links, nodes, - object, linkColorScheme = 'none', variables = VariableMetadataList(), ... diff --git a/R/class-Node.R b/R/class-Node.R index c23702b..88e2eac 100644 --- a/R/class-Node.R +++ b/R/class-Node.R @@ -36,18 +36,6 @@ setClass("NodeId", validity = check_node_id ) - -#' Create a Node Id -#' -#' Because typing `NodeId(id = 'foo')` is annoying, this function is provided -#' to make things easier. Now you can do `NodeId('foo')` -#' -#' @param value string a unique identifier for the node -#' @export -NodeId <- function(value) { - new("NodeId", value = value) -} - check_node_id_list <- function(object) { errors <- character() @@ -59,7 +47,6 @@ check_node_id_list <- function(object) { return(if (length(errors) == 0) TRUE else errors) } - #' A Node Id List #' #' A class for representing node id lists @@ -75,81 +62,6 @@ setClass("NodeIdList", validity = check_node_id_list ) -#' Create a NodeIdList -#' -#' @param object Object containing list of node ids -#' @export -setGeneric("NodeIdList", function(object, uniqueOnly = c(TRUE, FALSE)) standardGeneric("NodeIdList")) - -#' @export -setMethod("NodeIdList", "list", function(object, uniqueOnly = c(TRUE, FALSE)) { - uniqueOnly <- veupathUtils::matchArg(uniqueOnly) - nodeIds <- object - - if (length(nodeIds) == 0) { - stop("nodeIds must not be empty") - } - - if (!is.list(nodeIds)) { - stop("nodeIds must be a list") - } - - if (all(unlist(lapply(nodeIds, inherits, 'Node')))) { - nodeIds <- lapply(nodeIds, id) - if (uniqueOnly) { - nodeIds <- unique(nodeIds) - } - nodeIds <- lapply(nodeIds, NodeId) - } else if (all(unlist(lapply(nodeIds, inherits, 'character')))) { - if (uniqueOnly) { - nodeIds <- unique(nodeIds) - } - nodeIds <- lapply(nodeIds, NodeId) - } else if (!all(unlist(lapply(nodeIds, inherits, 'NodeId')))) { - stop("nodeIds must be a list of Node, NodeId or character objects") - } - - return(new("NodeIdList", S4Vectors::SimpleList(nodeIds))) -}) - -#' @export -setMethod("NodeIdList", "NodeList", function(object, uniqueOnly = c(TRUE, FALSE)) { - return(NodeIdList(getNodeIds(object), uniqueOnly = uniqueOnly)) -}) - -#' @export -setMethod("NodeIdList", "character", function(object, uniqueOnly = c(TRUE, FALSE)) { - uniqueOnly <- veupathUtils::matchArg(uniqueOnly) - - if (length(object) == 0) { - stop("nodeIds must not be empty") - } - - if (uniqueOnly) { - object <- unique(object) - } - - return(new("NodeIdList", S4Vectors::SimpleList(lapply(object, NodeId)))) -}) - -#' @export -setMethod("NodeIdList", "data.frame", function(object, uniqueOnly = c(TRUE, FALSE)) { - if (!isValidEdgeList(object)) { - stop(paste(errors, collapse = '\n')) - } - - return(NodeIdList(c(object$source, object$target), uniqueOnly = uniqueOnly)) -}) - -#' @export -setMethod("NodeIdList", "missing", function(object, uniqueOnly = c(TRUE, FALSE)) { - return(new("NodeIdList")) -}) - -#' @export -setMethod("NodeIdList", "Node", function(object, uniqueOnly = c(TRUE, FALSE)) { - return(NodeIdList(list(object))) -}) check_node <- function(object) { @@ -206,36 +118,6 @@ setClass("Node", validity = check_node ) -#' Create a Node -#' -#' @param id string a unique identifier for the node -#' @param x numeric value indicating the x coordinate of the node. Optional. -#' @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")) - -#' @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) -}) - -#' @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) -}) - -#' @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) -}) - -#' @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) -}) - check_node_list <- function(object) { @@ -279,41 +161,4 @@ setClass("NodeList", elementType = "Node" ), validity = check_node_list -) - -#' @include utils.R -#' Generate a NodeList -#' -#' Generate a NodeList from an edgeList -#' @param object Object containing data to be converted to a NodeList -#' @return NodeList -#' @export -#' @examples -#' NodeList(data.frame(source='a',target='b')) -setGeneric("NodeList", function(object) standardGeneric("NodeList")) - -#' @export -setMethod("NodeList", "data.frame", function(object = data.frame(source=character(),target=character())) { - if (!isValidEdgeList(object)) { - stop(paste(errors, collapse = '\n')) - } - - allNodeIds <- unique(c(object$source, object$target)) - nodesList <- lapply(allNodeIds, Node) - new("NodeList", nodesList) -}) - -#' @export -setMethod("NodeList", "missing", function(object) { - new("NodeList") -}) - -#' @export -setMethod("NodeList", "SimpleList", function(object) { - new("NodeList", object) -}) - -#' @export -setMethod("NodeList", "list", function(object) { - new("NodeList", object) -}) \ No newline at end of file +) \ No newline at end of file diff --git a/R/constructors-Node.R b/R/constructors-Node.R new file mode 100644 index 0000000..9325f83 --- /dev/null +++ b/R/constructors-Node.R @@ -0,0 +1,157 @@ +#' @include class-Node.R +#' Create a Node Id +#' +#' Because typing `NodeId(id = 'foo')` is annoying, this function is provided +#' to make things easier. Now you can do `NodeId('foo')` +#' +#' @param value string a unique identifier for the node +#' @export +NodeId <- function(value) { + new("NodeId", value = value) +} + + +#' Create a NodeIdList +#' +#' @param object Object containing list of node ids +#' @export +setGeneric("NodeIdList", function(object, uniqueOnly = c(TRUE, FALSE)) standardGeneric("NodeIdList")) + +#' @export +setMethod("NodeIdList", "list", function(object, uniqueOnly = c(TRUE, FALSE)) { + uniqueOnly <- veupathUtils::matchArg(uniqueOnly) + nodeIds <- object + + if (length(nodeIds) == 0) { + stop("nodeIds must not be empty") + } + + if (!is.list(nodeIds)) { + stop("nodeIds must be a list") + } + + if (all(unlist(lapply(nodeIds, inherits, 'Node')))) { + nodeIds <- lapply(nodeIds, id) + if (uniqueOnly) { + nodeIds <- unique(nodeIds) + } + nodeIds <- lapply(nodeIds, NodeId) + } else if (all(unlist(lapply(nodeIds, inherits, 'character')))) { + if (uniqueOnly) { + nodeIds <- unique(nodeIds) + } + nodeIds <- lapply(nodeIds, NodeId) + } else if (!all(unlist(lapply(nodeIds, inherits, 'NodeId')))) { + stop("nodeIds must be a list of Node, NodeId or character objects") + } + + return(new("NodeIdList", S4Vectors::SimpleList(nodeIds))) +}) + +#' @export +setMethod("NodeIdList", "NodeList", function(object, uniqueOnly = c(TRUE, FALSE)) { + return(NodeIdList(getNodeIds(object), uniqueOnly = uniqueOnly)) +}) + +#' @export +setMethod("NodeIdList", "character", function(object, uniqueOnly = c(TRUE, FALSE)) { + uniqueOnly <- veupathUtils::matchArg(uniqueOnly) + + if (length(object) == 0) { + stop("nodeIds must not be empty") + } + + if (uniqueOnly) { + object <- unique(object) + } + + return(new("NodeIdList", S4Vectors::SimpleList(lapply(object, NodeId)))) +}) + +#' @export +setMethod("NodeIdList", "data.frame", function(object, uniqueOnly = c(TRUE, FALSE)) { + if (!isValidEdgeList(object)) { + stop(paste(errors, collapse = '\n')) + } + + return(NodeIdList(c(object$source, object$target), uniqueOnly = uniqueOnly)) +}) + +#' @export +setMethod("NodeIdList", "missing", function(object, uniqueOnly = c(TRUE, FALSE)) { + return(new("NodeIdList")) +}) + +#' @export +setMethod("NodeIdList", "Node", function(object, uniqueOnly = c(TRUE, FALSE)) { + return(NodeIdList(list(object))) +}) + + +#' Create a Node +#' +#' @param id string a unique identifier for the node +#' @param x numeric value indicating the x coordinate of the node. Optional. +#' @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")) + +#' @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) +}) + +#' @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) +}) + +#' @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) +}) + +#' @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) +}) + + +#' @include utils.R +#' Generate a NodeList +#' +#' Generate a NodeList from an edgeList +#' @param object Object containing data to be converted to a NodeList +#' @return NodeList +#' @export +#' @examples +#' NodeList(data.frame(source='a',target='b')) +setGeneric("NodeList", function(object) standardGeneric("NodeList")) + +#' @export +setMethod("NodeList", "data.frame", function(object = data.frame(source=character(),target=character())) { + if (!isValidEdgeList(object)) { + stop(paste(errors, collapse = '\n')) + } + + allNodeIds <- unique(c(object$source, object$target)) + nodesList <- lapply(allNodeIds, Node) + new("NodeList", nodesList) +}) + +#' @export +setMethod("NodeList", "missing", function(object) { + new("NodeList") +}) + +#' @export +setMethod("NodeList", "SimpleList", function(object) { + new("NodeList", object) +}) + +#' @export +setMethod("NodeList", "list", function(object) { + new("NodeList", object) +}) \ No newline at end of file diff --git a/R/methods-KPartiteNetwork.R b/R/methods-KPartiteNetwork.R index d532965..9d1a317 100644 --- a/R/methods-KPartiteNetwork.R +++ b/R/methods-KPartiteNetwork.R @@ -1,9 +1,15 @@ +## Methods for Partitions +#' @include class-KPartiteNetwork.R setGeneric("partitions", function(object) standardGeneric("partitions")) setGeneric("partitions<-", function(object, value) standardGeneric("partitions<-")) setMethod("partitions", "KPartiteNetwork", function(object) object@partitions) setMethod("partitions<-", "KPartiteNetwork", function(object, value) {object@partitions <- value; validObject(object); object}) +#' @include methods-Nodes.R +setGeneric("getAllNodeIds", function(object) standardGeneric("getAllNodeIds")) +setMethod("getAllNodeIds", "Partitions", function(object) unlist(lapply(as.list(object), getNodeIds))) + toJSONGeneric <- getGeneric("toJSON", package = "veupathUtils") #' Convert Partitions object to JSON @@ -45,9 +51,4 @@ setMethod(toJSONGeneric, "KPartiteNetwork", function(object, named = c(TRUE, FAL if (named) tmp <- paste0('{"network":', tmp, '}') return(tmp) -}) - -#' @include methods-Nodes.R -## Methods for Partitions -setGeneric("getAllNodeIds", function(object) standardGeneric("getAllNodeIds")) -setMethod("getAllNodeIds", "Partitions", function(object) unlist(lapply(as.list(object), getNodeIds))) \ No newline at end of file +}) \ No newline at end of file From cab623e60993483dcbd0c328b570514b5c0d5645 Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Tue, 30 Jan 2024 10:39:04 -0500 Subject: [PATCH 28/37] wip: review feedback --- R/class-KPartiteNetwork.R | 126 +++++++++++++++++--------------------- R/class-Link.R | 13 ++-- R/class-Network.R | 13 ++-- R/constructors-Node.R | 36 ++++++----- R/methods-Network.R | 2 +- R/utils.R | 4 ++ 6 files changed, 93 insertions(+), 101 deletions(-) diff --git a/R/class-KPartiteNetwork.R b/R/class-KPartiteNetwork.R index 006a171..f20ac96 100644 --- a/R/class-KPartiteNetwork.R +++ b/R/class-KPartiteNetwork.R @@ -1,70 +1,27 @@ -#' @include methods-Nodes.R -check_partitions <- function(object) { - errors <- character() - - if (!!length(unlist(lapply(as.list(object), getNodeIds)))) { - # Ensure that no node is in multiple partitions - 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.') + isLinkWithinPartition <- function(link) { + if (is.null(link)) { + return(FALSE) } - } - - return(if (length(errors) == 0) TRUE else errors) -} - -#' Partitions -#' -#' A class for representing partitions in a k-partite network -#' -#' @name Partitions-class -#' @rdname Partitions-class -#' @export -setClass("Partitions", - contains = "SimpleList", - prototype = prototype( - elementType = "NodeIdList" - ), - validity = check_partitions -) - -#' Create a Partition -#' -#' An alias to NodeIdList -#' -#' @name Partition-class -#' @rdname Partition-class -#' @export -Partition <- NodeIdList - -#' Create Partitions -#' -#' A list of Partition objects, each containing a list of node -#' ids that belong to a single partition -#' -#' @param partitions list of Partition (or NodeIdList) objects -#' @export -#' @rdname Partitions -Partitions <- function(partitions = list()) { - if (length(partitions) == 0) { - return(new("Partitions", S4Vectors:::SimpleList(list()))) - } + if (!inherits(link, "Link")) { + stop('link must be a Link object') + } + + source <- source(link) + target <- target(link) - if (length(partitions) == 1 && !is.list(partitions)) { - ## an edge case i suppose where we had a single partition w a single node - partitions <- list(Partition(partitions)) - } + if (is.null(source) || is.null(target)) { + return(FALSE) + } - if (!is.list(partitions)) { - stop('Partitions must be a list') - } + internalLink <- FALSE + if (getPartitionIndex(source) == getPartitionIndex(target)) { + internalLink <- TRUE + } - if (!all(unlist(lapply(partitions, inherits, "NodeIdList")))) { - stop('Partitions must be a list of NodeIdList objects') + return(internalLink) } - return(new("Partitions", S4Vectors:::SimpleList(partitions))) -} - +#' @include class-Partitions.R check_kpartite_network <- function(object) { errors <- character() @@ -74,9 +31,15 @@ check_kpartite_network <- function(object) { errors <- c(errors, 'Found a node that is not in any partition. All nodes must be assigned to a partition.') } if (!all(getAllNodeIds(object@partitions) %in% getNodeIds(object@nodes))) { - errors <- c(errors, 'Found an id in a partition that is not in the nodes list. All partitions must must include ids in the nodes list.') + errors <- c(errors, 'Found an node id in a partition that is not in the nodes list. Node IDs must be consistent between partitions and nodes slots.') } + # Check that there are no links connecting nodes within a partition, only across the different partitions + if (any(sapply(getLinks(object), isLinkWithinPartition))) { + errors <- c(errors, 'Found a link between nodes in the same partition. Links between nodes in the same partition are not allowed.') + } + + # Check that linkColorScheme is one of the accepted values if (!object@linkColorScheme %in% c('none', 'posneg')) { errors <- c(errors, 'linkColorScheme must be one of "none" or "posneg"') @@ -122,31 +85,34 @@ KPartiteNetwork <- setClass("KPartiteNetwork", #' Generate a K-Partite Network #' #' Generate a K-Partite Network from a LinkList and NodeList, or from a data.frame +#' @param object Object containing data to be converted to a Network #' @param links LinkList #' @param nodes NodeList -#' @param object Object containing data to be converted to a Network +#' @param partitions Partitions +#' @param linkColorScheme string defining the type of coloring scheme the links follow. Options are 'none' (default) and 'posneg'. +#' @param variables VariableMetadataList #' @return KPartiteNetwork #' @export #' @examples #' KPartiteNetwork(data.frame(source='a',target='b')) setGeneric("KPartiteNetwork", function( + object, links, nodes, - object, partitions = Partitions(), linkColorScheme = 'none', variables = VariableMetadataList(), ... ) standardGeneric("KPartiteNetwork"), - signature = c("links", "nodes", "object") + signature = c("object", "links", "nodes") ) #' @export -setMethod("KPartiteNetwork", signature("LinkList", "NodeList", "missing"), function( +setMethod("KPartiteNetwork", signature("missing", "LinkList", "NodeList"), function( + object, links, nodes, - object, partitions = Partitions(), linkColorScheme = 'none', variables = VariableMetadataList(), @@ -160,10 +126,10 @@ setMethod("KPartiteNetwork", signature("LinkList", "NodeList", "missing"), funct }) #' @export -setMethod("KPartiteNetwork", signature("missing", "missing", "data.frame"), function( +setMethod("KPartiteNetwork", signature("data.frame", "missing", "missing"), function( + object = data.frame(source=character(),target=character()), links, nodes, - object = data.frame(source=character(),target=character()), partitions = Partitions(), linkColorScheme = 'none', variables = VariableMetadataList(), @@ -176,11 +142,31 @@ setMethod("KPartiteNetwork", signature("missing", "missing", "data.frame"), func new("KPartiteNetwork", links=LinkList(object), nodes=NodeList(object), partitions=partitions, linkColorScheme=linkColorScheme, variableMapping=variables) }) +#' @export +setMethod("KPartiteNetwork", signature("Network", "missing", "missing"), function( + object, + links, + nodes, + partitions = Partitions(), + linkColorScheme = 'none', + variables = VariableMetadataList(), + ... +) { + nodes <- object@nodes + links <- object@links + + # default to a single partition if none provided + if (length(partitions) == 0) { + partitions <- Partitions(list(nodes)) + } + new("KPartiteNetwork", links=links, nodes=nodes, partitions=partitions, linkColorScheme=linkColorScheme, variableMapping=variables) +}) + #' @export setMethod("KPartiteNetwork", signature("missing", "missing", "missing"), function( + object, links, nodes, - object, partitions = Partitions(), linkColorScheme = 'none', variables = VariableMetadataList(), diff --git a/R/class-Link.R b/R/class-Link.R index 5229461..f6894df 100644 --- a/R/class-Link.R +++ b/R/class-Link.R @@ -130,7 +130,8 @@ setClass("LinkList", #' Generate a LinkList #' #' Generate a LinkList from an edgeList -#' @param object Object containing data to be converted to a LinkList +#' @param object Object containing data to be converted to a LinkList. Could be a SimpleList of Links or a data.frame +#' with columns source, target, and optionally weight and color. #' @param linkColorScheme Either 'none' or 'posneg'. If 'posneg', the link color will be based on the sign of the weight. #' @return LinkList #' @export @@ -140,8 +141,8 @@ setGeneric("LinkList", function(object, linkColorScheme = c('none', 'posneg')) s #' @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 (!inherits(isValidEdgeList(object), "logical")) { + stop(paste("Invalid edgeList:", isValidEdgeList(object), collapse = '\n')) } if (nrow(object) == 0) { @@ -156,10 +157,8 @@ setMethod("LinkList", "data.frame", function(object = data.frame(source=characte 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 (linkColorScheme == 'posneg') { if (weight < 0) { color <- -1 } else if (weight > 0) { @@ -167,6 +166,8 @@ setMethod("LinkList", "data.frame", function(object = data.frame(source=characte } else { color <- 0 } + } else { + color <- NA_character_ } if (is.na(color)) { diff --git a/R/class-Network.R b/R/class-Network.R index 08c2cab..e994bd3 100644 --- a/R/class-Network.R +++ b/R/class-Network.R @@ -23,10 +23,6 @@ check_network <- function(object) { return(if (length(errors) == 0) TRUE else errors) } -## TODO -## i wonder if i can do something like `Network <- setClass("Network", slots = c(links = "LinkList", nodes = "NodeList"))` -## and then grab a generic from that generator fxn and build custom methods on top of it. thatd be cleaner. not urgent. - #' Network #' #' A class for representing networks. A network is composed of nodes and links (edges, connections, etc.). A link is represented @@ -36,9 +32,9 @@ check_network <- function(object) { #' @slot links LinkList object defining the links in the network. #' @slot nodes NodeList object defining the nodes in the network. Some nodes may not have any links. #' @slot linkColorScheme string defining the type of coloring scheme the links follow. Options are 'none' (default) and 'posneg'. -#' In the case of 'posneg', the links color slot will be set to 1 if the link is positive, and -1 if the link is negative. -#' @slot variableMapping veupathUtils::VariableMetadataList object defining the variable mappings in the network. +#' In the case of 'posneg', the links color slot will be set to 1 if the link is positive, and -1 if the link is negative. #' Use a method assignLinkColors() to assign colors to links and set this slot's value. +#' @slot variableMapping veupathUtils::VariableMetadataList object defining the variable mappings in the network. #' #' @name Network-class #' @rdname Network-class @@ -63,10 +59,13 @@ setClass("Network", #' @include utils.R #' Generate a Network #' -#' Generate a Network from a LinkList and NodeList, or from a data.frame +#' Generate a Network from a LinkList and NodeList, or from a +#' data.frame with columns 'source' and 'target', and optionally 'weight' and 'color'. #' @param links LinkList #' @param nodes NodeList #' @param object Object containing data to be converted to a Network +#' @param linkColorScheme string defining the type of coloring scheme the links follow. Options are 'none' (default) and 'posneg'. +#' @param variables VariableMetadataList #' @return Network #' @export #' @examples diff --git a/R/constructors-Node.R b/R/constructors-Node.R index 9325f83..743dbb6 100644 --- a/R/constructors-Node.R +++ b/R/constructors-Node.R @@ -14,12 +14,13 @@ NodeId <- function(value) { #' Create a NodeIdList #' #' @param object Object containing list of node ids +#' @param uniquifyIds Logical indicating whether to uniquify the node ids #' @export -setGeneric("NodeIdList", function(object, uniqueOnly = c(TRUE, FALSE)) standardGeneric("NodeIdList")) +setGeneric("NodeIdList", function(object, uniquifyIds = c(TRUE, FALSE)) standardGeneric("NodeIdList")) #' @export -setMethod("NodeIdList", "list", function(object, uniqueOnly = c(TRUE, FALSE)) { - uniqueOnly <- veupathUtils::matchArg(uniqueOnly) +setMethod("NodeIdList", "list", function(object, uniquifyIds = c(TRUE, FALSE)) { + uniquifyIds <- veupathUtils::matchArg(uniquifyIds) nodeIds <- object if (length(nodeIds) == 0) { @@ -32,12 +33,12 @@ setMethod("NodeIdList", "list", function(object, uniqueOnly = c(TRUE, FALSE)) { if (all(unlist(lapply(nodeIds, inherits, 'Node')))) { nodeIds <- lapply(nodeIds, id) - if (uniqueOnly) { + if (uniquifyIds) { nodeIds <- unique(nodeIds) } nodeIds <- lapply(nodeIds, NodeId) } else if (all(unlist(lapply(nodeIds, inherits, 'character')))) { - if (uniqueOnly) { + if (uniquifyIds) { nodeIds <- unique(nodeIds) } nodeIds <- lapply(nodeIds, NodeId) @@ -49,19 +50,19 @@ setMethod("NodeIdList", "list", function(object, uniqueOnly = c(TRUE, FALSE)) { }) #' @export -setMethod("NodeIdList", "NodeList", function(object, uniqueOnly = c(TRUE, FALSE)) { - return(NodeIdList(getNodeIds(object), uniqueOnly = uniqueOnly)) +setMethod("NodeIdList", "NodeList", function(object, uniquifyIds = c(TRUE, FALSE)) { + return(NodeIdList(getNodeIds(object), uniquifyIds = uniquifyIds)) }) #' @export -setMethod("NodeIdList", "character", function(object, uniqueOnly = c(TRUE, FALSE)) { - uniqueOnly <- veupathUtils::matchArg(uniqueOnly) +setMethod("NodeIdList", "character", function(object, uniquifyIds = c(TRUE, FALSE)) { + uniquifyIds <- veupathUtils::matchArg(uniquifyIds) if (length(object) == 0) { stop("nodeIds must not be empty") } - if (uniqueOnly) { + if (uniquifyIds) { object <- unique(object) } @@ -69,28 +70,29 @@ setMethod("NodeIdList", "character", function(object, uniqueOnly = c(TRUE, FALSE }) #' @export -setMethod("NodeIdList", "data.frame", function(object, uniqueOnly = c(TRUE, FALSE)) { +setMethod("NodeIdList", "data.frame", function(object, uniquifyIds = c(TRUE, FALSE)) { if (!isValidEdgeList(object)) { stop(paste(errors, collapse = '\n')) } - return(NodeIdList(c(object$source, object$target), uniqueOnly = uniqueOnly)) + return(NodeIdList(c(object$source, object$target), uniquifyIds = uniquifyIds)) }) #' @export -setMethod("NodeIdList", "missing", function(object, uniqueOnly = c(TRUE, FALSE)) { +setMethod("NodeIdList", "missing", function(object, uniquifyIds = c(TRUE, FALSE)) { return(new("NodeIdList")) }) #' @export -setMethod("NodeIdList", "Node", function(object, uniqueOnly = c(TRUE, FALSE)) { +setMethod("NodeIdList", "Node", function(object, uniquifyIds = c(TRUE, FALSE)) { return(NodeIdList(list(object))) }) #' Create a Node #' -#' @param id string a unique identifier for the node +#' Create a Node given a unique identifier as either string, NodeId or numeric. +#' @param id string, NodeId or numeric: a unique identifier for the node #' @param x numeric value indicating the x coordinate of the node. Optional. #' @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. @@ -132,8 +134,8 @@ setGeneric("NodeList", function(object) standardGeneric("NodeList")) #' @export setMethod("NodeList", "data.frame", function(object = data.frame(source=character(),target=character())) { - if (!isValidEdgeList(object)) { - stop(paste(errors, collapse = '\n')) + if (!inherits(isValidEdgeList(object), "logical")) { + stop(paste("Invalid edgeList:", isValidEdgeList(object), collapse = '\n')) } allNodeIds <- unique(c(object$source, object$target)) diff --git a/R/methods-Network.R b/R/methods-Network.R index c36304c..7a268d9 100644 --- a/R/methods-Network.R +++ b/R/methods-Network.R @@ -61,7 +61,7 @@ setMethod("pruneIsolatedNodes", "Network", function(net, verbose = c(TRUE, FALSE }) getLinkUniqueString <- function(link) { - paste0(id(source(link)), id(target(link))) + paste0(id(source(link)), ":||:" id(target(link))) } #' Find duplicate links diff --git a/R/utils.R b/R/utils.R index bb68d8e..48721c5 100644 --- a/R/utils.R +++ b/R/utils.R @@ -401,5 +401,9 @@ isValidEdgeList <- function(edgeList = data.frame(source=character(),target=char errors <- c(errors, 'edgeList must contain columns named "source" and "target"') } + if ('color' %in% colnames(edgeList)) { + errors <- c(errors, 'edgeList cannot contain a column named "color". Not yet supported.') + } + return(if (length(errors) == 0) TRUE else errors) } \ No newline at end of file From e583411116de24f5d9942ce9e3d5b3b8b836f422 Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Tue, 30 Jan 2024 10:39:22 -0500 Subject: [PATCH 29/37] move partitions class to own file --- R/class-Partitions.R | 78 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 78 insertions(+) create mode 100644 R/class-Partitions.R diff --git a/R/class-Partitions.R b/R/class-Partitions.R new file mode 100644 index 0000000..45bb913 --- /dev/null +++ b/R/class-Partitions.R @@ -0,0 +1,78 @@ +#' @include methods-Nodes.R +check_partitions <- function(object) { + errors <- character() + + if (!!length(unlist(lapply(as.list(object), getNodeIds)))) { + # Ensure that no node is in multiple partitions + 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.') + } + } + + return(if (length(errors) == 0) TRUE else errors) +} + +#' Partitions +#' +#' A class for representing partitions in a k-partite network +#' +#' @name Partitions-class +#' @rdname Partitions-class +#' @export +setClass("Partitions", + contains = "SimpleList", + prototype = prototype( + elementType = "NodeIdList" + ), + validity = check_partitions +) + +#' Create a Partition +#' +#' An alias to NodeIdList +#' +#' @name Partition-class +#' @rdname Partition-class +#' @export +Partition <- NodeIdList + +#' Create Partitions +#' +#' A list of Partition objects, each containing a list of node +#' ids that belong to a single partition +#' +#' @param partitions list of Partition (or NodeIdList) objects +#' @export +#' @rdname Partitions +Partitions <- function(partitions = list()) { + if (length(partitions) == 0) { + return(new("Partitions", S4Vectors:::SimpleList(list()))) + } + + if (length(partitions) == 1 && !is.list(partitions)) { + ## an edge case i suppose where we had a single partition w a single node + partitions <- list(Partition(partitions)) + } + + if (!is.list(partitions)) { + stop('Partitions must be a list') + } + + if (!all(unlist(lapply(partitions, inherits, "NodeIdList")))) { + stop('Partitions must be a list of NodeIdList objects') + } + + return(new("Partitions", S4Vectors:::SimpleList(partitions))) +} + +#' Get Partition index of a Node +#' +#' Given a list of partitions and a node id, return the index +#' of the partition that the node belongs to. +#' @param partitions Partitions +#' @param nodeId NodeId +#' @export +setGeneric("getPartitionIndex", function(partitions, nodeId) standardGeneric("getPartitionIndex")) +setMethod("getPartitionIndex", signature("Partitions", "NodeId"), function(partitions, nodeId) { + return(which(unlist(lapply(partitions, function(x) id(nodeId) %in% getNodeIds(x))))) +}) \ No newline at end of file From c3d4f6dfe7c1ddc30d003e9de19ec70b6c2496ae Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Tue, 30 Jan 2024 11:35:20 -0500 Subject: [PATCH 30/37] typo --- R/methods-Network.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/methods-Network.R b/R/methods-Network.R index 7a268d9..ab48bea 100644 --- a/R/methods-Network.R +++ b/R/methods-Network.R @@ -61,7 +61,7 @@ setMethod("pruneIsolatedNodes", "Network", function(net, verbose = c(TRUE, FALSE }) getLinkUniqueString <- function(link) { - paste0(id(source(link)), ":||:" id(target(link))) + paste0(id(source(link)), ":||:", id(target(link))) } #' Find duplicate links From 882dd0acd733a6040dfa3d5b8d79a76ae1d8d0b4 Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Tue, 30 Jan 2024 11:35:27 -0500 Subject: [PATCH 31/37] update collation --- DESCRIPTION | 1 + 1 file changed, 1 insertion(+) diff --git a/DESCRIPTION b/DESCRIPTION index e63c1d9..a75440c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -50,6 +50,7 @@ Collate: 'class-Network.R' 'methods-Links.R' 'methods-Nodes.R' + 'class-Partitions.R' 'class-KPartiteNetwork.R' 'class-plotdata-bar.R' 'class-plotdata-beeswarm.R' From f296876f18f5309d5d9c12990bdcfc2c72cd8138 Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Tue, 30 Jan 2024 13:19:36 -0500 Subject: [PATCH 32/37] get tests passing again --- R/class-KPartiteNetwork.R | 19 ++--- R/class-Link.R | 2 + R/class-Partitions.R | 14 +++- tests/testthat/test-kpartite-network.R | 100 ++++++++++++++----------- tests/testthat/test-network.R | 13 ---- 5 files changed, 80 insertions(+), 68 deletions(-) diff --git a/R/class-KPartiteNetwork.R b/R/class-KPartiteNetwork.R index f20ac96..3797ab7 100644 --- a/R/class-KPartiteNetwork.R +++ b/R/class-KPartiteNetwork.R @@ -1,10 +1,10 @@ - isLinkWithinPartition <- function(link) { - if (is.null(link)) { - return(FALSE) - } + isLinkWithinPartition <- function(link, partitions) { if (!inherits(link, "Link")) { stop('link must be a Link object') } + if (!inherits(partitions, "Partitions")) { + stop('partitions must be a Partitions object') + } source <- source(link) target <- target(link) @@ -14,7 +14,7 @@ } internalLink <- FALSE - if (getPartitionIndex(source) == getPartitionIndex(target)) { + if (getPartitionIndex(partitions, source) == getPartitionIndex(partitions, target)) { internalLink <- TRUE } @@ -29,15 +29,16 @@ check_kpartite_network <- function(object) { # Check that all nodes are in at least one of the partitions if (!all(getNodeIds(object@nodes) %in% getAllNodeIds(object@partitions))) { errors <- c(errors, 'Found a node that is not in any partition. All nodes must be assigned to a partition.') + } else if (any(sapply(getLinks(object), isLinkWithinPartition, object@partitions))) { + # Check that there are no links connecting nodes within a partition, only across the different partitions + # this check wont work if a node is missing from a partition + errors <- c(errors, 'Found a link between nodes in the same partition. Links between nodes in the same partition are not allowed.') } if (!all(getAllNodeIds(object@partitions) %in% getNodeIds(object@nodes))) { errors <- c(errors, 'Found an node id in a partition that is not in the nodes list. Node IDs must be consistent between partitions and nodes slots.') } - # Check that there are no links connecting nodes within a partition, only across the different partitions - if (any(sapply(getLinks(object), isLinkWithinPartition))) { - errors <- c(errors, 'Found a link between nodes in the same partition. Links between nodes in the same partition are not allowed.') - } + # Check that linkColorScheme is one of the accepted values diff --git a/R/class-Link.R b/R/class-Link.R index f6894df..6f5bc80 100644 --- a/R/class-Link.R +++ b/R/class-Link.R @@ -141,6 +141,8 @@ setGeneric("LinkList", function(object, linkColorScheme = c('none', 'posneg')) s #' @export setMethod("LinkList", "data.frame", function(object = data.frame(source=character(),target=character()), linkColorScheme = c('none', 'posneg')) { + linkColorScheme <- veupathUtils::matchArg(linkColorScheme) + if (!inherits(isValidEdgeList(object), "logical")) { stop(paste("Invalid edgeList:", isValidEdgeList(object), collapse = '\n')) } diff --git a/R/class-Partitions.R b/R/class-Partitions.R index 45bb913..2759d11 100644 --- a/R/class-Partitions.R +++ b/R/class-Partitions.R @@ -70,9 +70,15 @@ Partitions <- function(partitions = list()) { #' Given a list of partitions and a node id, return the index #' of the partition that the node belongs to. #' @param partitions Partitions -#' @param nodeId NodeId +#' @param node character, NodeId or Node object #' @export -setGeneric("getPartitionIndex", function(partitions, nodeId) standardGeneric("getPartitionIndex")) -setMethod("getPartitionIndex", signature("Partitions", "NodeId"), function(partitions, nodeId) { - return(which(unlist(lapply(partitions, function(x) id(nodeId) %in% getNodeIds(x))))) +setGeneric("getPartitionIndex", function(partitions, node) standardGeneric("getPartitionIndex")) +setMethod("getPartitionIndex", signature("Partitions", "NodeId"), function(partitions, node) { + return(which(unlist(lapply(partitions, function(x) id(node) %in% getNodeIds(x))))) +}) +setMethod("getPartitionIndex", signature("Partitions", "Node"), function(partitions, node) { + return(getPartitionIndex(partitions, id(node))) +}) +setMethod("getPartitionIndex", signature("Partitions", "character"), function(partitions, node) { + return(getPartitionIndex(partitions, NodeId(node))) }) \ No newline at end of file diff --git a/tests/testthat/test-kpartite-network.R b/tests/testthat/test-kpartite-network.R index a31ecb4..5b94e04 100644 --- a/tests/testthat/test-kpartite-network.R +++ b/tests/testthat/test-kpartite-network.R @@ -9,24 +9,27 @@ test_that("k-partite networks can be created", { nodeC <- Node( id = NodeId('C') ) + nodeD <- Node( + id = NodeId('D') + ) # Create links link1 <- Link(source = nodeA, target = nodeB, color = 1, weight = 10) - link2 <- Link(source = nodeB, target = nodeC, color = 2, weight = 20) - link3 <- Link(source = nodeC, target = nodeA, color = 3, weight = 30) + link2 <- Link(source = nodeB, target = nodeA, color = 2, weight = 20) + link3 <- Link(source = nodeC, target = nodeD, color = 3, weight = 30) # Create partitions - partition1 <- Partition(list(nodeA, nodeB)) - partition2 <- Partition(nodeC) + partition1 <- Partition(list(nodeA, nodeC)) + partition2 <- Partition(list(nodeB, nodeD)) # Create k-partite network bpnet <- KPartiteNetwork( links = LinkList(list(link1, link2, link3)), - nodes = NodeList(list(nodeA, nodeB, nodeC)), + nodes = NodeList(list(nodeA, nodeB, nodeC, nodeD)), partitions = Partitions(list(partition1, partition2)) ) - expect_equal(getNodes(bpnet), NodeList(c(nodeA, nodeB, nodeC))) + expect_equal(getNodes(bpnet), NodeList(c(nodeA, nodeB, nodeC, nodeD))) expect_equal(getLinks(bpnet), LinkList(c(link1, link2, link3))) expect_equal(getLinkColorScheme(bpnet), 'none') @@ -44,21 +47,24 @@ test_that("k-partite networks cannot be created from nonsensical inputs", { nodeC <- Node( id = NodeId('C') ) + nodeD <- Node( + id = NodeId('D') + ) # Create links link1 <- Link(source = nodeA, target = nodeB, color = 1, weight = 10) - link2 <- Link(source = nodeB, target = nodeC, color = 2, weight = 20) - link3 <- Link(source = nodeC, target = nodeA, color = 3, weight = 30) + link2 <- Link(source = nodeB, target = nodeA, color = 2, weight = 20) + link3 <- Link(source = nodeC, target = nodeD, color = 3, weight = 30) # Create columns partition1 <- Partition(list(nodeA, nodeB, nodeC)) - partition2 <- Partition(nodeC) + partition2 <- Partition(list(nodeB, nodeD)) # Nodes can't be in both columns expect_error(KPartiteNetwork( links = LinkList(list(link1, link2, link3)), - nodes = NodeList(list(nodeA, nodeB, nodeC)), + nodes = NodeList(list(nodeA, nodeB, nodeC, nodeD)), partitions = list(partition1, partition2) )) @@ -68,9 +74,24 @@ test_that("k-partite networks cannot be created from nonsensical inputs", { expect_error(KPartiteNetwork( links = LinkList(c(link1, link2, link3)), nodes = NodeList(c(nodeA, nodeB, nodeC)), - partitions = list(partition1IDs, partition2IDs) + partitions = list(partition1, partition2) )) + # No links within a partition + partition1 <- Partition(list(nodeA, nodeB)) + partition2 <- Partition(list(nodeC, nodeD)) + link4 <- Link(source = nodeA, target = nodeC, color = 1, weight = 10) + expect_error(KPartiteNetwork( + links = LinkList(c(link1, link2, link3, link4)), + nodes = NodeList(c(nodeA, nodeB, nodeC)), + partitions = list(partition1, partition2) + )) + + # no partitions specified + expect_error(KPartiteNetwork( + links = LinkList(c(link1, link2, link3)), + nodes = NodeList(c(nodeA, nodeB, nodeC)) + )) }) test_that("toJSON works for k-partite networks", { @@ -84,51 +105,46 @@ test_that("toJSON works for k-partite networks", { nodeC <- Node( id = NodeId('C') ) + nodeD <- Node( + id = NodeId('D') + ) # Create some links link1 <- Link(source = nodeA, target = nodeB, weight = 10) - link2 <- Link(source = nodeB, target = nodeC, weight = 20) - link3 <- Link(source = nodeC, target = nodeA, weight = 30) + link2 <- Link(source = nodeB, target = nodeA, weight = 20) + link3 <- Link(source = nodeC, target = nodeD, weight = 30) - # Create the network w a single default partition - net <- KPartiteNetwork(links = LinkList(c(link1, link2, link3)), nodes = NodeList(c(nodeA, nodeB, nodeC))) - json <- veupathUtils::toJSON(net) - jsonList <- jsonlite::fromJSON(json) - expect_equal(jsonList$network$data$links$source, c('A','B','C')) - expect_equal(jsonList$network$data$links$target, c('B','C','A')) - expect_equal(jsonList$network$data$links$weight, c(10,20,30)) - expect_equal(jsonList$network$data$nodes$id, c('A','B','C')) - expect_equal(as.list(jsonList$network$data$partitions), list('A','B','C')) - expect_equal(length(jsonList$network$config$variables), 0) - - # Create partitions - partition1 <- Partition(list(nodeA, nodeB)) - partition2 <- Partition(nodeC) - - # Create k-partite network - bpnet <- KPartiteNetwork( - links = LinkList(list(link1, link2, link3)), - nodes = NodeList(list(nodeA, nodeB, nodeC)), - partitions = Partitions(list(partition1, partition2)) + # Create the network + net <- KPartiteNetwork( + links = LinkList(c(link1, link2, link3)), + nodes = NodeList(c(nodeA, nodeB, nodeC, nodeD)), + partitions = Partitions(list(Partition(list(nodeA, nodeC)), Partition(list(nodeB, nodeD)))) ) - json <- veupathUtils::toJSON(bpnet) + json <- veupathUtils::toJSON(net) jsonList <- jsonlite::fromJSON(json) expect_equal(jsonList$network$data$links$source, c('A','B','C')) - expect_equal(jsonList$network$data$links$target, c('B','C','A')) + expect_equal(jsonList$network$data$links$target, c('B','A','D')) expect_equal(jsonList$network$data$links$weight, c(10,20,30)) - expect_equal(jsonList$network$data$nodes$id, c('A','B','C')) - expect_equal(jsonList$network$data$partitions, list(c('A','B'), c('C'))) + expect_equal(jsonList$network$data$nodes$id, c('A','B','C','D')) + expect_equal(list(jsonList$network$data$partitions[1,],jsonList$network$data$partitions[2,]), list(c('A','C'), c('B','D'))) expect_equal(length(jsonList$network$config$variables), 0) }) test_that("we can build a KPartiteNetwork from an edgeList data.frame", { edgeList <- data.frame( source = c('a', 'b', 'c'), - target = c('b', 'c', 'a') + target = c('b', 'a', 'd') ) - net <- KPartiteNetwork(object = edgeList) - expect_equal(getNodes(net), NodeList(c(Node('a'), Node('b'), Node('c')))) - expect_equal(getLinks(net), LinkList(c(Link(source = Node('a'), target = Node('b')), Link(source = Node('b'), target = Node('c')), Link(source = Node('c'), target = Node('a'))))) - expect_equal(partitions(net), Partitions(list(Partition(list(Node('a'), Node('b'), Node('c')))))) + net <- KPartiteNetwork( + object = edgeList, + partitions = Partitions(list( + Partition(list(Node('a'), Node('c'))), + Partition(list(Node('b'), Node('d'))) + )) + ) + + expect_equal(getNodes(net), NodeList(c(Node('a'), Node('b'), Node('c'), Node('d')))) + 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') }) \ No newline at end of file diff --git a/tests/testthat/test-network.R b/tests/testthat/test-network.R index 665aac3..63a359c 100644 --- a/tests/testthat/test-network.R +++ b/tests/testthat/test-network.R @@ -200,19 +200,6 @@ test_that("we can build a Network from an edgeList data.frame", { expect_equal(getLinks(net)[[3]]@weight, 3) expect_equal(getLinkColorScheme(net), 'none') - #w a color column - edgeList <- data.frame( - source = c('a', 'b', 'c'), - target = c('b', 'c', 'a'), - color = c("red", "green", "blue") - ) - net <- Network(object = edgeList) - expect_equal(getNodes(net), NodeList(c(Node('a'), Node('b'), Node('c')))) - expect_equal(getLinks(net)[[1]]@color, "red") - expect_equal(getLinks(net)[[2]]@color, "green") - expect_equal(getLinks(net)[[3]]@color, "blue") - expect_equal(getLinkColorScheme(net), 'none') - #w a color scheme edgeList <- data.frame( source = c('a', 'b', 'c'), From ae844fb0df2260146c27e4fe1e3a6d7af3031f4a Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Tue, 30 Jan 2024 13:22:25 -0500 Subject: [PATCH 33/37] fix another case of poor use of isValidEdgeList --- R/constructors-Node.R | 4 ++-- tests/testthat/test-nodes.R | 1 - 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/R/constructors-Node.R b/R/constructors-Node.R index 743dbb6..9b7a147 100644 --- a/R/constructors-Node.R +++ b/R/constructors-Node.R @@ -71,8 +71,8 @@ setMethod("NodeIdList", "character", function(object, uniquifyIds = c(TRUE, FALS #' @export setMethod("NodeIdList", "data.frame", function(object, uniquifyIds = c(TRUE, FALSE)) { - if (!isValidEdgeList(object)) { - stop(paste(errors, collapse = '\n')) + if (!inherits(isValidEdgeList(object), "logical")) { + stop(paste("Invalid edgeList:", isValidEdgeList(object), collapse = '\n')) } return(NodeIdList(c(object$source, object$target), uniquifyIds = uniquifyIds)) diff --git a/tests/testthat/test-nodes.R b/tests/testthat/test-nodes.R index 122a5de..5e4034c 100644 --- a/tests/testthat/test-nodes.R +++ b/tests/testthat/test-nodes.R @@ -84,7 +84,6 @@ test_that("NodeList methods work", { test_that("We cannot make nonsensical nodes", { expect_error(Node(id = FALSE)) - #expect_error(Node(id = 10)) # why is this nonsensical? expect_error(Node(id = 'A', color = FALSE)) expect_error(Node(id = 'A', weight = '10')) }) From 72f79966ec13916845120069d6530fcf59b8027a Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Tue, 30 Jan 2024 13:25:22 -0500 Subject: [PATCH 34/37] require kpartite networks have at min 2 partitions --- R/class-KPartiteNetwork.R | 17 +++++------------ 1 file changed, 5 insertions(+), 12 deletions(-) diff --git a/R/class-KPartiteNetwork.R b/R/class-KPartiteNetwork.R index 3797ab7..63d2b39 100644 --- a/R/class-KPartiteNetwork.R +++ b/R/class-KPartiteNetwork.R @@ -26,6 +26,11 @@ check_kpartite_network <- function(object) { errors <- character() + # Check we have at least two partitions + if (length(object@partitions) < 2) { + errors <- c(errors, 'k-partite networks must have at least two partitions.') + } + # Check that all nodes are in at least one of the partitions if (!all(getNodeIds(object@nodes) %in% getAllNodeIds(object@partitions))) { errors <- c(errors, 'Found a node that is not in any partition. All nodes must be assigned to a partition.') @@ -119,10 +124,6 @@ setMethod("KPartiteNetwork", signature("missing", "LinkList", "NodeList"), funct 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) }) @@ -136,10 +137,6 @@ setMethod("KPartiteNetwork", signature("data.frame", "missing", "missing"), func 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) }) @@ -156,10 +153,6 @@ setMethod("KPartiteNetwork", signature("Network", "missing", "missing"), functio nodes <- object@nodes links <- object@links - # default to a single partition if none provided - if (length(partitions) == 0) { - partitions <- Partitions(list(nodes)) - } new("KPartiteNetwork", links=links, nodes=nodes, partitions=partitions, linkColorScheme=linkColorScheme, variableMapping=variables) }) From 7d3caec6754a4ed8d81ee1a931619f8428aaf471 Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Tue, 30 Jan 2024 13:38:52 -0500 Subject: [PATCH 35/37] update kpartitenetwork toJSON to match new data service api --- R/class-Link.R | 1 - R/methods-KPartiteNetwork.R | 9 ++++++--- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/R/class-Link.R b/R/class-Link.R index 6f5bc80..991c0bd 100644 --- a/R/class-Link.R +++ b/R/class-Link.R @@ -151,7 +151,6 @@ setMethod("LinkList", "data.frame", function(object = data.frame(source=characte new("LinkList") } - # TODO this is probably not the right place for defaults... makeLink <- function(x, linkColorScheme) { source <- unname(x['source']) target <- unname(x['target']) diff --git a/R/methods-KPartiteNetwork.R b/R/methods-KPartiteNetwork.R index 9d1a317..0f90166 100644 --- a/R/methods-KPartiteNetwork.R +++ b/R/methods-KPartiteNetwork.R @@ -27,7 +27,6 @@ setMethod(toJSONGeneric, "Partitions", function(object, named = c(TRUE, FALSE)) return(tmp) }) -## TODO reduce repeated code, maybe call the Network method and figure how to add partitions? or a refactor? not urgent. #' Convert KPartiteNetwork object to JSON #' #' Converts a KPartiteNetwork object to JSON @@ -40,7 +39,7 @@ setMethod(toJSONGeneric, "KPartiteNetwork", function(object, named = c(TRUE, FAL nodes_json <- veupathUtils::toJSON(object@nodes, named = FALSE) links_json <- veupathUtils::toJSON(object@links, named = FALSE) - partitions_json <- veupathUtils::toJSON(object@partitions, named = FALSE) + partitions_json <- veupathUtils::toJSON(object@partitions, named = TRUE) # 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. @@ -48,7 +47,11 @@ setMethod(toJSONGeneric, "KPartiteNetwork", function(object, named = c(TRUE, FAL tmp <- paste0('"data":{', tmp, '}') tmp <- paste0('{', tmp, ',"config":{"variables":{', veupathUtils::toJSON(object@variableMapping, named = FALSE), '}}}') - if (named) tmp <- paste0('{"network":', tmp, '}') + if (named) { + name <- "kpartitenetwork" + if (length(object@partitions) == 2) name <- "bipartitenetwork" + tmp <- paste0('{"', name, '":', tmp, '}') + } return(tmp) }) \ No newline at end of file From 06ffea1dc24591f0d74a874488cc45c69d3c1450 Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Tue, 30 Jan 2024 13:45:54 -0500 Subject: [PATCH 36/37] get toJSON tests passing again --- R/methods-KPartiteNetwork.R | 4 ++-- R/methods-Nodes.R | 2 +- tests/testthat/test-kpartite-network.R | 12 ++++++------ 3 files changed, 9 insertions(+), 9 deletions(-) diff --git a/R/methods-KPartiteNetwork.R b/R/methods-KPartiteNetwork.R index 0f90166..504f264 100644 --- a/R/methods-KPartiteNetwork.R +++ b/R/methods-KPartiteNetwork.R @@ -20,7 +20,7 @@ toJSONGeneric <- getGeneric("toJSON", package = "veupathUtils") #' @export setMethod(toJSONGeneric, "Partitions", function(object, named = c(TRUE, FALSE)) { named <- veupathUtils::matchArg(named) - tmp <- veupathUtils::S4SimpleListToJSON(object, FALSE) + tmp <- veupathUtils::S4SimpleListToJSON(object, TRUE) if (named) tmp <- paste0('{"partitions":', tmp, "}") @@ -39,7 +39,7 @@ setMethod(toJSONGeneric, "KPartiteNetwork", function(object, named = c(TRUE, FAL nodes_json <- veupathUtils::toJSON(object@nodes, named = FALSE) links_json <- veupathUtils::toJSON(object@links, named = FALSE) - partitions_json <- veupathUtils::toJSON(object@partitions, named = TRUE) + 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. diff --git a/R/methods-Nodes.R b/R/methods-Nodes.R index 51a8d4a..6be5603 100644 --- a/R/methods-Nodes.R +++ b/R/methods-Nodes.R @@ -97,4 +97,4 @@ setMethod(toJSONGeneric, signature("NodeIdList"), function(object, named = c(TRU if (named) tmp <- paste0('{"nodeIds":', tmp, "}") return(tmp) -}) \ No newline at end of file +}) \ No newline at end of file diff --git a/tests/testthat/test-kpartite-network.R b/tests/testthat/test-kpartite-network.R index 5b94e04..8a2d8de 100644 --- a/tests/testthat/test-kpartite-network.R +++ b/tests/testthat/test-kpartite-network.R @@ -122,12 +122,12 @@ test_that("toJSON works for k-partite networks", { ) json <- veupathUtils::toJSON(net) jsonList <- jsonlite::fromJSON(json) - expect_equal(jsonList$network$data$links$source, c('A','B','C')) - expect_equal(jsonList$network$data$links$target, c('B','A','D')) - expect_equal(jsonList$network$data$links$weight, c(10,20,30)) - expect_equal(jsonList$network$data$nodes$id, c('A','B','C','D')) - expect_equal(list(jsonList$network$data$partitions[1,],jsonList$network$data$partitions[2,]), list(c('A','C'), c('B','D'))) - expect_equal(length(jsonList$network$config$variables), 0) + expect_equal(jsonList$bipartitenetwork$data$links$source, c('A','B','C')) + expect_equal(jsonList$bipartitenetwork$data$links$target, c('B','A','D')) + expect_equal(jsonList$bipartitenetwork$data$links$weight, c(10,20,30)) + expect_equal(jsonList$bipartitenetwork$data$nodes$id, c('A','B','C','D')) + expect_equal(jsonList$bipartitenetwork$data$partitions$nodeIds, list(c('A','C'), c('B','D'))) + expect_equal(length(jsonList$bipartitenetwork$config$variables), 0) }) test_that("we can build a KPartiteNetwork from an edgeList data.frame", { From 4c6f1ddf70e29224b3499ddea3b4a2cc35d080ad Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Wed, 31 Jan 2024 09:15:58 -0500 Subject: [PATCH 37/37] improve naming of helper fxn --- R/class-KPartiteNetwork.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/class-KPartiteNetwork.R b/R/class-KPartiteNetwork.R index 63d2b39..df6b2dd 100644 --- a/R/class-KPartiteNetwork.R +++ b/R/class-KPartiteNetwork.R @@ -1,4 +1,4 @@ - isLinkWithinPartition <- function(link, partitions) { + isIntraPartitionLink <- function(link, partitions) { if (!inherits(link, "Link")) { stop('link must be a Link object') } @@ -34,7 +34,7 @@ check_kpartite_network <- function(object) { # Check that all nodes are in at least one of the partitions if (!all(getNodeIds(object@nodes) %in% getAllNodeIds(object@partitions))) { errors <- c(errors, 'Found a node that is not in any partition. All nodes must be assigned to a partition.') - } else if (any(sapply(getLinks(object), isLinkWithinPartition, object@partitions))) { + } else if (any(sapply(getLinks(object), isIntraPartitionLink, object@partitions))) { # Check that there are no links connecting nodes within a partition, only across the different partitions # this check wont work if a node is missing from a partition errors <- c(errors, 'Found a link between nodes in the same partition. Links between nodes in the same partition are not allowed.')