From 7705a6d6502ee6fc2aba1fcbc1eec9a742794a56 Mon Sep 17 00:00:00 2001 From: asizemore Date: Fri, 13 Oct 2023 07:21:38 -0400 Subject: [PATCH 01/31] created first network --- R/class-network.R | 68 +++++++++++++++++++++++++++++++++++ tests/testthat/test-network.R | 15 ++++++++ 2 files changed, 83 insertions(+) create mode 100644 R/class-network.R create mode 100644 tests/testthat/test-network.R diff --git a/R/class-network.R b/R/class-network.R new file mode 100644 index 0000000..cb4ff4f --- /dev/null +++ b/R/class-network.R @@ -0,0 +1,68 @@ +#' @param dt data table with one row per link. Columns represent source node, target node, edge weight, and other edge data +newNetwork <- function(dt = data.table(), + sourceNodeColumn = character(), + targetNodeColumn = character(), + linkWeightColumn = NULL, + linkColorScheme = c('none', 'posneg'), + nodeColorScheme = c('none', 'degree'), + directed = c('FALSE', 'TRUE'), + verbose = logical(), + class = character() +) { + + linkColorScheme <- veupathUtils::matchArg(linkColorScheme) + # check - linkColorScheme != none requires linkWeightColumn + nodeColorScheme <- veupathUtils::matchArg(nodeColorScheme) # Placeholder: Not yet implemented + directed <- veupathUtils::matchArg(directed) # Placeholder: Not yet implemented + + # Check for self edges (maybe uses boolean allowSelfLinks) + + + # For now, all we need to do is to subset dt to columns that matter, then add the link color column + networkColumnNames <- c('source', 'target') + if (!is.null(linkWeightColumn)) networkColumnNames <- c(networkColumnNames, 'weightData') + setnames(dt, c(sourceNodeColumn, targetNodeColumn, linkWeightColumn), networkColumnNames) + dt <- dt[, ..networkColumnNames] + print(names(dt)) + + if (identical(linkColorScheme, 'posneg')) { + dt[, linkColor:=sign(as.numeric(linkWeightColumn))] + } + + # So dt will be the links part of the response, and nodes wil be the nodes part. The bp net class + # just adds the attributes column1NodeIDs and column2NodeIDs + + + attr <- attributes(dt) + # Add attribute for nodes (just a list of the nodes) + # attr$variables <- variables + attr$class <- c(class, 'network', attr$class) + + veupathUtils::setAttrFromList(dt, attr) + # .pd <- validatePlotdata(.dt) + net <- dt + veupathUtils::logWithTime('Network object created.', verbose) + + return(net) +} + +validatePlotdata <- function(net) { + .dt <- unclass(.pd) + variables <- attr(.pd, 'variables') + + # also check there is only one collection in variables + # collectionsCount <- sum(unlist(lapply(as.list(variables), function(x) {x@isCollection}))) + # if (collectionsCount > 1) stop("More than one collection variable was specified.") + + class <- attr(.pd, 'class') + stopifnot(is.character(class)) + + return(.pd) +} + +# # Additional accessor functions +# sampleSizeTable <- function(.pd) { attr(.pd, 'sampleSizeTable') } +# completeCasesTable <- function(.pd) { attr(.pd, 'completeCasesTable') } +# #these helpers need either validation or to be a dedicated method +# statsTable <- function(.pd) { attr(.pd, 'statsTable') } +# variablesList <- function(.pd) { as.list(attr(.pd, 'variables')) } diff --git a/tests/testthat/test-network.R b/tests/testthat/test-network.R new file mode 100644 index 0000000..b936080 --- /dev/null +++ b/tests/testthat/test-network.R @@ -0,0 +1,15 @@ +test_that("network class is created okay", { + + nNodes <- 50 + nLinks <- 500 + + nodeIDs <- stringi::stri_rand_strings(nNodes, 5, '[A-Z]') + + networkData <- data.table::as.data.table(list( + source1 = sample(nodeIDs, nLinks, replace=T), + target1 = sample(nodeIDs, nLinks, replace=T) + )) + + network <- newNetwork(dt = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', verbose = 'TRUE') + +}) \ No newline at end of file From b6f1af03165c2c635036d5ea424316cb567e8667 Mon Sep 17 00:00:00 2001 From: asizemore Date: Fri, 13 Oct 2023 13:27:57 -0400 Subject: [PATCH 02/31] add support for posneg color scheme --- R/class-network.R | 19 +++++++++------ tests/testthat/test-network.R | 46 +++++++++++++++++++++++++++++++++-- 2 files changed, 55 insertions(+), 10 deletions(-) diff --git a/R/class-network.R b/R/class-network.R index cb4ff4f..ae4d65b 100644 --- a/R/class-network.R +++ b/R/class-network.R @@ -3,6 +3,7 @@ newNetwork <- function(dt = data.table(), sourceNodeColumn = character(), targetNodeColumn = character(), linkWeightColumn = NULL, + nodeIDs = NULL, linkColorScheme = c('none', 'posneg'), nodeColorScheme = c('none', 'degree'), directed = c('FALSE', 'TRUE'), @@ -11,32 +12,34 @@ newNetwork <- function(dt = data.table(), ) { linkColorScheme <- veupathUtils::matchArg(linkColorScheme) - # check - linkColorScheme != none requires linkWeightColumn + if (!identical(linkColorScheme, 'none') && is.null(linkWeightColumn)) { + stop('A linkWeightColumn is required for converting link weights to a color scheme') + } nodeColorScheme <- veupathUtils::matchArg(nodeColorScheme) # Placeholder: Not yet implemented directed <- veupathUtils::matchArg(directed) # Placeholder: Not yet implemented # Check for self edges (maybe uses boolean allowSelfLinks) + # If nodeIDs, check to see if any have no edges. Also ensure all nodes in the dt are in nodeIDs # For now, all we need to do is to subset dt to columns that matter, then add the link color column networkColumnNames <- c('source', 'target') - if (!is.null(linkWeightColumn)) networkColumnNames <- c(networkColumnNames, 'weightData') - setnames(dt, c(sourceNodeColumn, targetNodeColumn, linkWeightColumn), networkColumnNames) + if (!is.null(linkWeightColumn)) networkColumnNames <- c(networkColumnNames, 'linkWeight') + setnames(dt, c(sourceNodeColumn, targetNodeColumn, linkWeightColumn), networkColumnNames, skip_absent=TRUE) dt <- dt[, ..networkColumnNames] - print(names(dt)) + if (identical(linkColorScheme, 'posneg')) { - dt[, linkColor:=sign(as.numeric(linkWeightColumn))] + dt[, linkColor:=sign(as.numeric(linkWeight))] } # So dt will be the links part of the response, and nodes wil be the nodes part. The bp net class # just adds the attributes column1NodeIDs and column2NodeIDs - attr <- attributes(dt) - # Add attribute for nodes (just a list of the nodes) - # attr$variables <- variables + attr$nodes <- if(is.null(nodeIDs)) sort(unique(c(dt[['source']], dt[['target']]))) else sort(nodeIDs) attr$class <- c(class, 'network', attr$class) + attr$linkColorScheme <- linkColorScheme veupathUtils::setAttrFromList(dt, attr) # .pd <- validatePlotdata(.dt) diff --git a/tests/testthat/test-network.R b/tests/testthat/test-network.R index b936080..e17ae73 100644 --- a/tests/testthat/test-network.R +++ b/tests/testthat/test-network.R @@ -1,4 +1,4 @@ -test_that("network class is created okay", { +test_that("Network objects have the correct attributes", { nNodes <- 50 nLinks <- 500 @@ -10,6 +10,48 @@ test_that("network class is created okay", { target1 = sample(nodeIDs, nLinks, replace=T) )) + ## The simplest case - a binary network with no colors or isolated nodes network <- newNetwork(dt = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', verbose = 'TRUE') + attributes <- attributes(network) + expect_equal(attributes$class, c('network', 'data.table', 'data.frame')) + expect_equal(attributes$nodes, sort(unique(nodeIDs))) + expect_equal(attributes$linkColorScheme, 'none') -}) \ No newline at end of file + ## Network with edge weights and colors + networkData[, edgeData := rnorm(nLinks)] + network <- newNetwork(dt = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', linkColorScheme = 'posneg', verbose = 'TRUE') + attributes <- attributes(network) + expect_equal(attributes$class, c('network', 'data.table', 'data.frame')) + expect_equal(attributes$nodes, sort(unique(nodeIDs))) + expect_equal(attributes$linkColorScheme, 'posneg') + +}) + +test_that("Networks objects contain the correct link data", { + + nNodes <- 50 + nLinks <- 500 + + nodeIDs <- stringi::stri_rand_strings(nNodes, 5, '[A-Z]') + + networkData <- data.table::as.data.table(list( + source1 = sample(nodeIDs, nLinks, replace=T), + target1 = sample(nodeIDs, nLinks, replace=T) + )) + + ## The simplest case - a binary network with no colors or isolated nodes + network <- newNetwork(dt = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', verbose = 'TRUE') + expect_equal(names(network), c('source', 'target')) + expect_equal(nrow(network), nLinks) + expect_equal(unname(unlist(lapply(network, class))), c('character', 'character')) + + ## Network with weighted, colored links + networkData[, edgeData := rnorm(nLinks)] + network <- newNetwork(dt = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', linkWeightColumn = 'edgeData', linkColorScheme = 'posneg', verbose = 'TRUE') + expect_equal(names(network), c('source', 'target', 'linkWeight', 'linkColor')) + expect_equal(nrow(network), nLinks) + expect_equal(unname(unlist(lapply(network, class))), c('character', 'character', 'numeric', 'numeric')) + expect_true(all(unique(network$linkColor) %in% c(-1, 0, 1))) + + +}) From 8b3318dfca19eefd94839cf66d7c60546687a439 Mon Sep 17 00:00:00 2001 From: asizemore Date: Fri, 13 Oct 2023 14:21:14 -0400 Subject: [PATCH 03/31] add bipartite network --- R/class-network-bipartite.R | 84 +++++++++++++++++++++++++ R/class-network.R | 40 ++++++------ tests/testthat/test-bipartite-network.R | 65 +++++++++++++++++++ tests/testthat/test-network.R | 2 +- 4 files changed, 172 insertions(+), 19 deletions(-) create mode 100644 R/class-network-bipartite.R create mode 100644 tests/testthat/test-bipartite-network.R diff --git a/R/class-network-bipartite.R b/R/class-network-bipartite.R new file mode 100644 index 0000000..ae6295e --- /dev/null +++ b/R/class-network-bipartite.R @@ -0,0 +1,84 @@ +#' @param dt data table with one row per link. Columns represent source node, target node, edge weight, and other edge data +newBipartiteNetwork <- function(df = data.frame(), + sourceNodeColumn = character(), + targetNodeColumn = character(), + linkWeightColumn = NULL, + nodeIDs = NULL, + linkColorScheme = c('none', 'posneg'), + nodeColorScheme = c('none', 'degree'), + verbose = logical() +) { + + # Create a data table from df + dt <- data.table::as.data.table(df) + + # Assume the source nodes are column 1, and the target are all in column 2. + column1NodeIDs <- sort(unique(dt[[sourceNodeColumn]])) + column2NodeIDs <- sort(unique(dt[[targetNodeColumn]])) + + # TODO check that no nodes are in both cols + + # Create a basic network. We'll threshold the edges in here so we want to know about all the nodes + # before that happens. (add boolean removeIsolatedNodes and linkWeightThreshold fn i guess...) + net <- newNetwork(dt = dt, + sourceNodeColumn = sourceNodeColumn, + targetNodeColumn = targetNodeColumn, + linkWeightColumn = linkWeightColumn, + nodeIDs = nodeIDs, + linkColorScheme = linkColorScheme, + nodeColorScheme = nodeColorScheme, + directed = FALSE, + verbose = verbose, + class = 'bipartite' + ) + + attr <- attributes(net) + attr$column1NodeIDs <- column1NodeIDs + attr$column2NodeIDs <- column2NodeIDs + + veupathUtils::setAttrFromList(net, attr) + net <- validateNetwork(net, verbose) + veupathUtils::logWithTime('Network object successfully created.', verbose) + + return(net) +} + +validateBipartiteNetwork <- function(bpnet, verbose) { + + class <- attr(bpnet, 'class') + stopifnot(is.character(class)) + + veupathUtils::logWithTime("Bipartite network object validated.", verbose) + + return(net) +} + + +#' @export +bipartiteNetwork <- function(df = data.frame(), + sourceNodeColumn = character(), + targetNodeColumn = character(), + linkWeightColumn = NULL, + nodeIDs = NULL, + linkColorScheme = c('none', 'posneg'), + nodeColorScheme = c('none', 'degree'), + verbose = logical() +) { + + bpnet <- newBipartiteNetwork(df = df, + sourceNodeColumn = sourceNodeColumn, + targetNodeColumn = targetNodeColumn, + linkWeightColumn = linkWeightColumn, + nodeIDs = nodeIDs, + linkColorScheme = linkColorScheme, + nodeColorScheme = nodeColorScheme, + verbose = verbose + ) + + return(bpnet) + # outFile <- writeNetworkToJSON(bpnet, 'bipartiteNetwork', verbose=verbose) No, this just goes in the plugin + +} + + + diff --git a/R/class-network.R b/R/class-network.R index ae4d65b..9170028 100644 --- a/R/class-network.R +++ b/R/class-network.R @@ -6,7 +6,7 @@ newNetwork <- function(dt = data.table(), nodeIDs = NULL, linkColorScheme = c('none', 'posneg'), nodeColorScheme = c('none', 'degree'), - directed = c('FALSE', 'TRUE'), + directed = c(FALSE, TRUE), verbose = logical(), class = character() ) { @@ -42,30 +42,34 @@ newNetwork <- function(dt = data.table(), attr$linkColorScheme <- linkColorScheme veupathUtils::setAttrFromList(dt, attr) - # .pd <- validatePlotdata(.dt) - net <- dt - veupathUtils::logWithTime('Network object created.', verbose) + net <- validateNetwork(dt, verbose) + veupathUtils::logWithTime('Network object successfully created.', verbose) return(net) } -validatePlotdata <- function(net) { - .dt <- unclass(.pd) - variables <- attr(.pd, 'variables') +validateNetwork <- function(net, verbose) { - # also check there is only one collection in variables - # collectionsCount <- sum(unlist(lapply(as.list(variables), function(x) {x@isCollection}))) - # if (collectionsCount > 1) stop("More than one collection variable was specified.") + # Could check that all source and target are still in nodeIDs - class <- attr(.pd, 'class') + class <- attr(net, 'class') stopifnot(is.character(class)) - return(.pd) + veupathUtils::logWithTime("Network object validated.", verbose) + + return(net) } -# # Additional accessor functions -# sampleSizeTable <- function(.pd) { attr(.pd, 'sampleSizeTable') } -# completeCasesTable <- function(.pd) { attr(.pd, 'completeCasesTable') } -# #these helpers need either validation or to be a dedicated method -# statsTable <- function(.pd) { attr(.pd, 'statsTable') } -# variablesList <- function(.pd) { as.list(attr(.pd, 'variables')) } + +#' Write json to local tmp file +#' +#' This function returns the name of a json file which it has +#' written a data.table object out to. +#' @param .pd a data.table to convert to json and write to a tmp file +#' @param pattern optional tmp file prefix +#' @return character name of a tmp file w ext *.json +#' @importFrom jsonlite toJSON +#' @importFrom jsonlite prettify +writeNetworkToJSON <- function(net, pattern=NULL, verbose = c(TRUE, FALSE) ) { + print("hi ann :)") +} \ No newline at end of file diff --git a/tests/testthat/test-bipartite-network.R b/tests/testthat/test-bipartite-network.R new file mode 100644 index 0000000..3541209 --- /dev/null +++ b/tests/testthat/test-bipartite-network.R @@ -0,0 +1,65 @@ +test_that("Bipartite network objects have the correct attributes", { + + nNodesColumn1 <- 30 + nNodesColumn2 <- 50 + nLinks <- 500 + + column1NodeIDs <- stringi::stri_rand_strings(nNodesColumn1, 5, '[A-Z]') + column2NodeIDs <- stringi::stri_rand_strings(nNodesColumn2, 5, '[A-Z]') + + networkData <- data.frame(list( + source1 = sample(column1NodeIDs, nLinks, replace=T), + target1 = sample(column2NodeIDs, nLinks, replace=T) + )) + + ## The simplest case - a binary network with no colors or isolated nodes + network <- bipartiteNetwork(df = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', verbose = 'TRUE') + attributes <- attributes(network) + expect_equal(attributes$class, c('bipartite', 'network', 'data.table', 'data.frame')) + expect_equal(attributes$nodes, sort(unique(c(column1NodeIDs, column2NodeIDs)))) + expect_equal(attributes$linkColorScheme, 'none') + expect_equal(attributes$column1NodeIDs, sort(unique(column1NodeIDs))) + expect_equal(attributes$column2NodeIDs, sort(unique(column2NodeIDs))) + + ## Network with edge weights and colors + networkData$edgeData <- rnorm(nLinks) + network <- bipartiteNetwork(df = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', linkWeightColumn = 'edgeData', linkColorScheme = 'posneg', verbose = 'TRUE') + attributes <- attributes(network) + expect_equal(attributes$class, c('bipartite', 'network', 'data.table', 'data.frame')) + expect_equal(attributes$nodes, sort(unique(c(column1NodeIDs, column2NodeIDs)))) + expect_equal(attributes$linkColorScheme, 'posneg') + expect_equal(attributes$column1NodeIDs, sort(unique(column1NodeIDs))) + expect_equal(attributes$column2NodeIDs, sort(unique(column2NodeIDs))) + +}) + +test_that("Bipartite network objects contain the correct link data", { + + nNodesColumn1 <- 30 + nNodesColumn2 <- 50 + nLinks <- 500 + + column1NodeIDs <- stringi::stri_rand_strings(nNodesColumn1, 5, '[A-Z]') + column2NodeIDs <- stringi::stri_rand_strings(nNodesColumn2, 5, '[A-Z]') + + networkData <- data.frame(list( + source1 = sample(column1NodeIDs, nLinks, replace=T), + target1 = sample(column2NodeIDs, nLinks, replace=T) + )) + + ## The simplest case - a binary network with no colors or isolated nodes + network <- bipartiteNetwork(df = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', verbose = 'TRUE') + expect_equal(names(network), c('source', 'target')) + expect_equal(nrow(network), nLinks) + expect_equal(unname(unlist(lapply(network, class))), c('character', 'character')) + + ## Network with weighted, colored links + networkData$edgeData <- rnorm(nLinks) + network <- bipartiteNetwork(df = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', linkWeightColumn = 'edgeData', linkColorScheme = 'posneg', verbose = 'TRUE') + expect_equal(names(network), c('source', 'target', 'linkWeight', 'linkColor')) + expect_equal(nrow(network), nLinks) + expect_equal(unname(unlist(lapply(network, class))), c('character', 'character', 'numeric', 'numeric')) + expect_true(all(unique(network$linkColor) %in% c(-1, 0, 1))) + + +}) diff --git a/tests/testthat/test-network.R b/tests/testthat/test-network.R index e17ae73..cef19f4 100644 --- a/tests/testthat/test-network.R +++ b/tests/testthat/test-network.R @@ -19,7 +19,7 @@ test_that("Network objects have the correct attributes", { ## Network with edge weights and colors networkData[, edgeData := rnorm(nLinks)] - network <- newNetwork(dt = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', linkColorScheme = 'posneg', verbose = 'TRUE') + network <- newNetwork(dt = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', linkWeightColumn = 'edgeData', linkColorScheme = 'posneg', verbose = 'TRUE') attributes <- attributes(network) expect_equal(attributes$class, c('network', 'data.table', 'data.frame')) expect_equal(attributes$nodes, sort(unique(nodeIDs))) From c8e804f69b597900cfe726e83ec2ac060b36e388 Mon Sep 17 00:00:00 2001 From: asizemore Date: Mon, 16 Oct 2023 06:28:53 -0400 Subject: [PATCH 04/31] add json methods for networks --- R/class-network.R | 32 +++++++++++- tests/testthat/test-bipartite-network.R | 68 ++++++++++++++++++++----- 2 files changed, 86 insertions(+), 14 deletions(-) diff --git a/R/class-network.R b/R/class-network.R index 9170028..c53b596 100644 --- a/R/class-network.R +++ b/R/class-network.R @@ -70,6 +70,36 @@ validateNetwork <- function(net, verbose) { #' @return character name of a tmp file w ext *.json #' @importFrom jsonlite toJSON #' @importFrom jsonlite prettify +#' @export writeNetworkToJSON <- function(net, pattern=NULL, verbose = c(TRUE, FALSE) ) { print("hi ann :)") -} \ No newline at end of file +} + +# Just write the json part +getNetworkJSON <- function(net, verbose = c(TRUE, FALSE)) { + + networkAttributes <- attributes(net) + # Network json object should have nodes = Node[], links = Link[] + + # Covert all columns to character + netChar <- data.frame(lapply(net, as.character)) + + # Extract the list of node ids + nodeList <- data.frame(id = networkAttributes$nodes) + + obj <- list( + nodes = nodeList, + links = netChar + ) + + # Optional additional props if exist are column1NodeIDs and 2 + 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) + + + return(json) +} diff --git a/tests/testthat/test-bipartite-network.R b/tests/testthat/test-bipartite-network.R index 3541209..4493c96 100644 --- a/tests/testthat/test-bipartite-network.R +++ b/tests/testthat/test-bipartite-network.R @@ -13,8 +13,8 @@ test_that("Bipartite network objects have the correct attributes", { )) ## The simplest case - a binary network with no colors or isolated nodes - network <- bipartiteNetwork(df = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', verbose = 'TRUE') - attributes <- attributes(network) + bpnet <- bipartiteNetwork(df = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', verbose = 'TRUE') + attributes <- attributes(bpnet) expect_equal(attributes$class, c('bipartite', 'network', 'data.table', 'data.frame')) expect_equal(attributes$nodes, sort(unique(c(column1NodeIDs, column2NodeIDs)))) expect_equal(attributes$linkColorScheme, 'none') @@ -23,8 +23,8 @@ test_that("Bipartite network objects have the correct attributes", { ## Network with edge weights and colors networkData$edgeData <- rnorm(nLinks) - network <- bipartiteNetwork(df = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', linkWeightColumn = 'edgeData', linkColorScheme = 'posneg', verbose = 'TRUE') - attributes <- attributes(network) + bpnet <- bipartiteNetwork(df = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', linkWeightColumn = 'edgeData', linkColorScheme = 'posneg', verbose = 'TRUE') + attributes <- attributes(bpnet) expect_equal(attributes$class, c('bipartite', 'network', 'data.table', 'data.frame')) expect_equal(attributes$nodes, sort(unique(c(column1NodeIDs, column2NodeIDs)))) expect_equal(attributes$linkColorScheme, 'posneg') @@ -48,18 +48,60 @@ test_that("Bipartite network objects contain the correct link data", { )) ## The simplest case - a binary network with no colors or isolated nodes - network <- bipartiteNetwork(df = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', verbose = 'TRUE') - expect_equal(names(network), c('source', 'target')) - expect_equal(nrow(network), nLinks) - expect_equal(unname(unlist(lapply(network, class))), c('character', 'character')) + bpnet <- bipartiteNetwork(df = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', verbose = 'TRUE') + expect_equal(names(bpnet), c('source', 'target')) + expect_equal(nrow(bpnet), nLinks) + expect_equal(unname(unlist(lapply(bpnet, class))), c('character', 'character')) ## Network with weighted, colored links networkData$edgeData <- rnorm(nLinks) - network <- bipartiteNetwork(df = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', linkWeightColumn = 'edgeData', linkColorScheme = 'posneg', verbose = 'TRUE') - expect_equal(names(network), c('source', 'target', 'linkWeight', 'linkColor')) - expect_equal(nrow(network), nLinks) - expect_equal(unname(unlist(lapply(network, class))), c('character', 'character', 'numeric', 'numeric')) - expect_true(all(unique(network$linkColor) %in% c(-1, 0, 1))) + bpnet <- bipartiteNetwork(df = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', linkWeightColumn = 'edgeData', linkColorScheme = 'posneg', verbose = 'TRUE') + expect_equal(names(bpnet), c('source', 'target', 'linkWeight', 'linkColor')) + expect_equal(nrow(bpnet), nLinks) + expect_equal(unname(unlist(lapply(bpnet, class))), c('character', 'character', 'numeric', 'numeric')) + expect_true(all(unique(bpnet$linkColor) %in% c(-1, 0, 1))) +}) + +test_that("Writing a bipartite network to json works as expected", { + + nNodesColumn1 <- 30 + nNodesColumn2 <- 50 + nLinks <- 500 + + column1NodeIDs <- stringi::stri_rand_strings(nNodesColumn1, 5, '[A-Z]') + column2NodeIDs <- stringi::stri_rand_strings(nNodesColumn2, 5, '[A-Z]') + + networkData <- data.frame(list( + source1 = sample(column1NodeIDs, nLinks, replace=T), + target1 = sample(column2NodeIDs, nLinks, replace=T) + )) + + ## The simple case with no edge weights + bpnet <- bipartiteNetwork(df = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', verbose = 'TRUE') + + outJSON <- getNetworkJSON(bpnet, verbose=FALSE) + jsonList <- jsonlite::fromJSON(outJSON) + expect_equal(names(jsonList), c('nodes', 'links', 'column1NodeIDs', 'column2NodeIDs')) + expect_equal(jsonList$nodes$id, sort(unique(c(column1NodeIDs, column2NodeIDs)))) + expect_equal(names(jsonList$links), c('source', 'target')) + expect_equal(nrow(jsonList$links), nLinks) + expect_equal(unname(unlist(lapply(jsonList$links, class))), c('character', 'character')) + expect_equal(jsonList$column1NodeIDs, sort(column1NodeIDs)) + expect_equal(jsonList$column2NodeIDs, sort(column2NodeIDs)) + + + ## With link weights and colors + networkData$edgeData <- rnorm(nLinks) + bpnet <- bipartiteNetwork(df = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', linkWeightColumn = 'edgeData', linkColorScheme = 'posneg', verbose = 'TRUE') + outJSON <- getNetworkJSON(bpnet, verbose=FALSE) + jsonList <- jsonlite::fromJSON(outJSON) + expect_equal(names(jsonList), c('nodes', 'links', 'column1NodeIDs', 'column2NodeIDs')) + expect_equal(jsonList$nodes$id, sort(unique(c(column1NodeIDs, column2NodeIDs)))) + expect_equal(names(jsonList$links), c('source', 'target', 'linkWeight', 'linkColor')) + expect_equal(nrow(jsonList$links), nLinks) + expect_equal(unname(unlist(lapply(jsonList$links, class))), c('character', 'character', 'character', 'character')) + expect_equal(jsonList$column1NodeIDs, sort(column1NodeIDs)) + expect_equal(jsonList$column2NodeIDs, sort(column2NodeIDs)) }) From 35cef0697383989997b64eec2ef5cc7304a2f94b Mon Sep 17 00:00:00 2001 From: asizemore Date: Mon, 16 Oct 2023 06:48:40 -0400 Subject: [PATCH 05/31] add writeNetworkToJSON --- R/class-network.R | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/R/class-network.R b/R/class-network.R index c53b596..14f7947 100644 --- a/R/class-network.R +++ b/R/class-network.R @@ -72,7 +72,20 @@ validateNetwork <- function(net, verbose) { #' @importFrom jsonlite prettify #' @export writeNetworkToJSON <- function(net, pattern=NULL, verbose = c(TRUE, FALSE) ) { - print("hi ann :)") + 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) } # Just write the json part From 3263dd08d40f63e110b8c1d41313945d34d8bb22 Mon Sep 17 00:00:00 2001 From: asizemore Date: Mon, 16 Oct 2023 07:21:54 -0400 Subject: [PATCH 06/31] update document --- NAMESPACE | 2 ++ R/class-network-bipartite.R | 9 +++++++-- R/class-network.R | 1 - man/bipartiteNetwork.Rd | 29 +++++++++++++++++++++++++++++ man/writeNetworkToJSON.Rd | 20 ++++++++++++++++++++ 5 files changed, 58 insertions(+), 3 deletions(-) create mode 100644 man/bipartiteNetwork.Rd create mode 100644 man/writeNetworkToJSON.Rd diff --git a/NAMESPACE b/NAMESPACE index c24ee55..b8a278c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -22,6 +22,7 @@ export(beeswarm.dt) export(bestFitLine) export(bin) export(binWidthToNumBins) +export(bipartiteNetwork) export(box) export(box.dt) export(chiSqResults) @@ -59,6 +60,7 @@ export(sensitivity) export(smoothedMean) export(specificity) export(writeJSON) +export(writeNetworkToJSON) exportClasses(ContingencyTable) exportClasses(TwoByTwoTable) exportMethods(allStats) diff --git a/R/class-network-bipartite.R b/R/class-network-bipartite.R index ae6295e..e742623 100644 --- a/R/class-network-bipartite.R +++ b/R/class-network-bipartite.R @@ -1,4 +1,3 @@ -#' @param dt data table with one row per link. Columns represent source node, target node, edge weight, and other edge data newBipartiteNetwork <- function(df = data.frame(), sourceNodeColumn = character(), targetNodeColumn = character(), @@ -53,7 +52,13 @@ validateBipartiteNetwork <- function(bpnet, verbose) { return(net) } - +#' Create bipartite network +#' +#' This function returns the name of a json file which it has +#' written a data.table object out to. +#' @param .pd a data.table to convert to json and write to a tmp file +#' @param pattern optional tmp file prefix +#' @return bipartite network #' @export bipartiteNetwork <- function(df = data.frame(), sourceNodeColumn = character(), diff --git a/R/class-network.R b/R/class-network.R index 14f7947..cc7b67e 100644 --- a/R/class-network.R +++ b/R/class-network.R @@ -1,4 +1,3 @@ -#' @param dt data table with one row per link. Columns represent source node, target node, edge weight, and other edge data newNetwork <- function(dt = data.table(), sourceNodeColumn = character(), targetNodeColumn = character(), diff --git a/man/bipartiteNetwork.Rd b/man/bipartiteNetwork.Rd new file mode 100644 index 0000000..74be6c7 --- /dev/null +++ b/man/bipartiteNetwork.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/class-network-bipartite.R +\name{bipartiteNetwork} +\alias{bipartiteNetwork} +\title{Create bipartite network} +\usage{ +bipartiteNetwork( + df = data.frame(), + sourceNodeColumn = character(), + targetNodeColumn = character(), + linkWeightColumn = NULL, + nodeIDs = NULL, + linkColorScheme = c("none", "posneg"), + nodeColorScheme = c("none", "degree"), + verbose = logical() +) +} +\arguments{ +\item{.pd}{a data.table to convert to json and write to a tmp file} + +\item{pattern}{optional tmp file prefix} +} +\value{ +bipartite network +} +\description{ +This function returns the name of a json file which it has +written a data.table object out to. +} diff --git a/man/writeNetworkToJSON.Rd b/man/writeNetworkToJSON.Rd new file mode 100644 index 0000000..895513f --- /dev/null +++ b/man/writeNetworkToJSON.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/class-network.R +\name{writeNetworkToJSON} +\alias{writeNetworkToJSON} +\title{Write json to local tmp file} +\usage{ +writeNetworkToJSON(net, pattern = NULL, verbose = c(TRUE, FALSE)) +} +\arguments{ +\item{pattern}{optional tmp file prefix} + +\item{.pd}{a data.table to convert to json and write to a tmp file} +} +\value{ +character name of a tmp file w ext *.json +} +\description{ +This function returns the name of a json file which it has +written a data.table object out to. +} From f0e985a8e09122905303bc478ad8901bd887bae3 Mon Sep 17 00:00:00 2001 From: asizemore Date: Tue, 17 Oct 2023 13:56:57 -0400 Subject: [PATCH 07/31] update network json --- R/class-network.R | 5 +++++ tests/testthat/test-bipartite-network.R | 23 ++++++++++++++--------- 2 files changed, 19 insertions(+), 9 deletions(-) diff --git a/R/class-network.R b/R/class-network.R index cc7b67e..65a1097 100644 --- a/R/class-network.R +++ b/R/class-network.R @@ -96,8 +96,13 @@ getNetworkJSON <- function(net, verbose = c(TRUE, FALSE)) { # Covert all columns to character netChar <- data.frame(lapply(net, as.character)) + # Each source and target needs to be {id: string}!!! + # Extract the list of node ids 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)))}) + print(head(netChar)) obj <- list( nodes = nodeList, diff --git a/tests/testthat/test-bipartite-network.R b/tests/testthat/test-bipartite-network.R index 4493c96..4d5da31 100644 --- a/tests/testthat/test-bipartite-network.R +++ b/tests/testthat/test-bipartite-network.R @@ -65,17 +65,18 @@ test_that("Bipartite network objects contain the correct link data", { test_that("Writing a bipartite network to json works as expected", { - nNodesColumn1 <- 30 - nNodesColumn2 <- 50 - nLinks <- 500 + nNodesColumn1 <- length(letters) + nNodesColumn2 <- length(LETTERS) - column1NodeIDs <- stringi::stri_rand_strings(nNodesColumn1, 5, '[A-Z]') - column2NodeIDs <- stringi::stri_rand_strings(nNodesColumn2, 5, '[A-Z]') + column1NodeIDs <- letters + column2NodeIDs <- LETTERS + # Make terribly boring network networkData <- data.frame(list( - source1 = sample(column1NodeIDs, nLinks, replace=T), - target1 = sample(column2NodeIDs, nLinks, replace=T) + source1 = column1NodeIDs, + target1 = column2NodeIDs )) + nLinks <- nrow(networkData) ## The simple case with no edge weights bpnet <- bipartiteNetwork(df = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', verbose = 'TRUE') @@ -85,8 +86,10 @@ test_that("Writing a bipartite network to json works as expected", { expect_equal(names(jsonList), c('nodes', 'links', 'column1NodeIDs', 'column2NodeIDs')) expect_equal(jsonList$nodes$id, sort(unique(c(column1NodeIDs, column2NodeIDs)))) expect_equal(names(jsonList$links), c('source', 'target')) + expect_equal(names(jsonList$links$source), c('id')) + expect_equal(names(jsonList$links$target), c('id')) expect_equal(nrow(jsonList$links), nLinks) - expect_equal(unname(unlist(lapply(jsonList$links, class))), c('character', 'character')) + expect_equal(unname(unlist(lapply(jsonList$links, class))), c('data.frame', 'data.frame')) expect_equal(jsonList$column1NodeIDs, sort(column1NodeIDs)) expect_equal(jsonList$column2NodeIDs, sort(column2NodeIDs)) @@ -100,8 +103,10 @@ test_that("Writing a bipartite network to json works as expected", { expect_equal(names(jsonList), c('nodes', 'links', 'column1NodeIDs', 'column2NodeIDs')) expect_equal(jsonList$nodes$id, sort(unique(c(column1NodeIDs, column2NodeIDs)))) expect_equal(names(jsonList$links), c('source', 'target', 'linkWeight', 'linkColor')) + expect_equal(names(jsonList$links$source), c('id')) + expect_equal(names(jsonList$links$target), c('id')) expect_equal(nrow(jsonList$links), nLinks) - expect_equal(unname(unlist(lapply(jsonList$links, class))), c('character', 'character', 'character', 'character')) + expect_equal(unname(unlist(lapply(jsonList$links, class))), c('data.frame', 'data.frame', 'character', 'character')) expect_equal(jsonList$column1NodeIDs, sort(column1NodeIDs)) expect_equal(jsonList$column2NodeIDs, sort(column2NodeIDs)) }) From ed945c596bd54ba3753ac0cef9a92b0e4b91b3b0 Mon Sep 17 00:00:00 2001 From: asizemore Date: Wed, 18 Oct 2023 10:47:32 -0400 Subject: [PATCH 08/31] update network class json and docs --- R/class-network-bipartite.R | 14 ++---- R/class-network.R | 61 ++++++++++++++----------- tests/testthat/test-bipartite-network.R | 6 +-- tests/testthat/test-network.R | 27 +++++------ 4 files changed, 54 insertions(+), 54 deletions(-) diff --git a/R/class-network-bipartite.R b/R/class-network-bipartite.R index e742623..f4ab488 100644 --- a/R/class-network-bipartite.R +++ b/R/class-network-bipartite.R @@ -4,29 +4,23 @@ newBipartiteNetwork <- function(df = data.frame(), linkWeightColumn = NULL, nodeIDs = NULL, linkColorScheme = c('none', 'posneg'), - nodeColorScheme = c('none', 'degree'), verbose = logical() ) { - # Create a data table from df - dt <- data.table::as.data.table(df) - # Assume the source nodes are column 1, and the target are all in column 2. - column1NodeIDs <- sort(unique(dt[[sourceNodeColumn]])) - column2NodeIDs <- sort(unique(dt[[targetNodeColumn]])) + column1NodeIDs <- sort(unique(df[[sourceNodeColumn]])) + column2NodeIDs <- sort(unique(df[[targetNodeColumn]])) # TODO check that no nodes are in both cols # Create a basic network. We'll threshold the edges in here so we want to know about all the nodes # before that happens. (add boolean removeIsolatedNodes and linkWeightThreshold fn i guess...) - net <- newNetwork(dt = dt, + net <- newNetwork(df = df, sourceNodeColumn = sourceNodeColumn, targetNodeColumn = targetNodeColumn, linkWeightColumn = linkWeightColumn, nodeIDs = nodeIDs, linkColorScheme = linkColorScheme, - nodeColorScheme = nodeColorScheme, - directed = FALSE, verbose = verbose, class = 'bipartite' ) @@ -66,7 +60,6 @@ bipartiteNetwork <- function(df = data.frame(), linkWeightColumn = NULL, nodeIDs = NULL, linkColorScheme = c('none', 'posneg'), - nodeColorScheme = c('none', 'degree'), verbose = logical() ) { @@ -76,7 +69,6 @@ bipartiteNetwork <- function(df = data.frame(), linkWeightColumn = linkWeightColumn, nodeIDs = nodeIDs, linkColorScheme = linkColorScheme, - nodeColorScheme = nodeColorScheme, verbose = verbose ) diff --git a/R/class-network.R b/R/class-network.R index 65a1097..4b2ed37 100644 --- a/R/class-network.R +++ b/R/class-network.R @@ -1,42 +1,47 @@ -newNetwork <- function(dt = data.table(), +newNetwork <- function(df = data.frame(), sourceNodeColumn = character(), targetNodeColumn = character(), linkWeightColumn = NULL, nodeIDs = NULL, linkColorScheme = c('none', 'posneg'), - nodeColorScheme = c('none', 'degree'), - directed = c(FALSE, TRUE), verbose = logical(), class = character() ) { + # Input checks linkColorScheme <- veupathUtils::matchArg(linkColorScheme) if (!identical(linkColorScheme, 'none') && is.null(linkWeightColumn)) { stop('A linkWeightColumn is required for converting link weights to a color scheme') } - nodeColorScheme <- veupathUtils::matchArg(nodeColorScheme) # Placeholder: Not yet implemented - directed <- veupathUtils::matchArg(directed) # Placeholder: Not yet implemented - - # Check for self edges (maybe uses boolean allowSelfLinks) - # If nodeIDs, check to see if any have no edges. Also ensure all nodes in the dt are in nodeIDs + # Create a data table from df + dt <- data.table::as.data.table(df) + + if (!is.null(nodeIDs)) { + if (any(duplicated(nodeIDs))) stop('nodeIDs must be unique') + if (!all(c(dt[[sourceNodeColumn]], dt[[targetNodeColumn]]) %in% nodeIDs)) { + stop('the nodeIDs argument must contain all nodes seen in dt') + } + nodeIDs <- sort(unique(nodeIDs)) + } else { + nodeIDs <- sort(unique(c(dt[[sourceNodeColumn]], dt[[targetNodeColumn]]))) + } - # For now, all we need to do is to subset dt to columns that matter, then add the link color column + ## Create the network + # Subset the dt to the columns we care about networkColumnNames <- c('source', 'target') - if (!is.null(linkWeightColumn)) networkColumnNames <- c(networkColumnNames, 'linkWeight') + if (!is.null(linkWeightColumn)) networkColumnNames <- c(networkColumnNames, 'weight') setnames(dt, c(sourceNodeColumn, targetNodeColumn, linkWeightColumn), networkColumnNames, skip_absent=TRUE) dt <- dt[, ..networkColumnNames] - + # Add link color if requested if (identical(linkColorScheme, 'posneg')) { - dt[, linkColor:=sign(as.numeric(linkWeight))] + dt[, color:=sign(as.numeric(weight))] } - # So dt will be the links part of the response, and nodes wil be the nodes part. The bp net class - # just adds the attributes column1NodeIDs and column2NodeIDs - + # Add attributes attr <- attributes(dt) - attr$nodes <- if(is.null(nodeIDs)) sort(unique(c(dt[['source']], dt[['target']]))) else sort(nodeIDs) + attr$nodes <- nodeIDs attr$class <- c(class, 'network', attr$class) attr$linkColorScheme <- linkColorScheme @@ -49,7 +54,12 @@ newNetwork <- function(dt = data.table(), validateNetwork <- function(net, verbose) { - # Could check that all source and target are still in nodeIDs + networkAttributes <- attributes(net) + + # Check that all source and target nodes are in nodes + if (!all(c(net$source, net$target) %in% networkAttributes$nodes)) { + stop('Found nodes in the network that are not included in the nodes attribute') + } class <- attr(net, 'class') stopifnot(is.character(class)) @@ -63,12 +73,12 @@ validateNetwork <- function(net, verbose) { #' Write json to local tmp file #' #' This function returns the name of a json file which it has -#' written a data.table object out to. -#' @param .pd a data.table to convert to json and write to a tmp file +#' 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 -#' @importFrom jsonlite prettify #' @export writeNetworkToJSON <- function(net, pattern=NULL, verbose = c(TRUE, FALSE) ) { verbose <- veupathUtils::matchArg(verbose) @@ -87,29 +97,26 @@ writeNetworkToJSON <- function(net, pattern=NULL, verbose = c(TRUE, FALSE) ) { return(outFileName) } -# Just write the json part +# Write a network to a json string getNetworkJSON <- function(net, verbose = c(TRUE, FALSE)) { networkAttributes <- attributes(net) - # Network json object should have nodes = Node[], links = Link[] # Covert all columns to character netChar <- data.frame(lapply(net, as.character)) - # Each source and target needs to be {id: string}!!! - - # Extract the list of node ids + # 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)))}) - print(head(netChar)) obj <- list( nodes = nodeList, links = netChar ) - # Optional additional props if exist are column1NodeIDs and 2 + # 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 diff --git a/tests/testthat/test-bipartite-network.R b/tests/testthat/test-bipartite-network.R index 4d5da31..1c4fa66 100644 --- a/tests/testthat/test-bipartite-network.R +++ b/tests/testthat/test-bipartite-network.R @@ -56,10 +56,10 @@ test_that("Bipartite network objects contain the correct link data", { ## Network with weighted, colored links networkData$edgeData <- rnorm(nLinks) bpnet <- bipartiteNetwork(df = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', linkWeightColumn = 'edgeData', linkColorScheme = 'posneg', verbose = 'TRUE') - expect_equal(names(bpnet), c('source', 'target', 'linkWeight', 'linkColor')) + expect_equal(names(bpnet), c('source', 'target', 'weight', 'color')) expect_equal(nrow(bpnet), nLinks) expect_equal(unname(unlist(lapply(bpnet, class))), c('character', 'character', 'numeric', 'numeric')) - expect_true(all(unique(bpnet$linkColor) %in% c(-1, 0, 1))) + expect_true(all(unique(bpnet$color) %in% c(-1, 0, 1))) }) @@ -102,7 +102,7 @@ test_that("Writing a bipartite network to json works as expected", { jsonList <- jsonlite::fromJSON(outJSON) expect_equal(names(jsonList), c('nodes', 'links', 'column1NodeIDs', 'column2NodeIDs')) expect_equal(jsonList$nodes$id, sort(unique(c(column1NodeIDs, column2NodeIDs)))) - expect_equal(names(jsonList$links), c('source', 'target', 'linkWeight', 'linkColor')) + expect_equal(names(jsonList$links), c('source', 'target', 'weight', 'color')) expect_equal(names(jsonList$links$source), c('id')) expect_equal(names(jsonList$links$target), c('id')) expect_equal(nrow(jsonList$links), nLinks) diff --git a/tests/testthat/test-network.R b/tests/testthat/test-network.R index cef19f4..5983079 100644 --- a/tests/testthat/test-network.R +++ b/tests/testthat/test-network.R @@ -3,23 +3,24 @@ test_that("Network objects have the correct attributes", { nNodes <- 50 nLinks <- 500 - nodeIDs <- stringi::stri_rand_strings(nNodes, 5, '[A-Z]') + nodeIDs <- unique(stringi::stri_rand_strings(nNodes, 5, '[A-Z]')) + nNodes <- length(nodeIDs) - networkData <- data.table::as.data.table(list( + networkData <- data.frame( source1 = sample(nodeIDs, nLinks, replace=T), target1 = sample(nodeIDs, nLinks, replace=T) - )) + ) ## The simplest case - a binary network with no colors or isolated nodes - network <- newNetwork(dt = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', verbose = 'TRUE') + network <- newNetwork(df = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', verbose = 'TRUE') attributes <- attributes(network) expect_equal(attributes$class, c('network', 'data.table', 'data.frame')) expect_equal(attributes$nodes, sort(unique(nodeIDs))) expect_equal(attributes$linkColorScheme, 'none') ## Network with edge weights and colors - networkData[, edgeData := rnorm(nLinks)] - network <- newNetwork(dt = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', linkWeightColumn = 'edgeData', linkColorScheme = 'posneg', verbose = 'TRUE') + networkData$edgeData <- rnorm(nLinks) + network <- newNetwork(df = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', linkWeightColumn = 'edgeData', linkColorScheme = 'posneg', verbose = 'TRUE') attributes <- attributes(network) expect_equal(attributes$class, c('network', 'data.table', 'data.frame')) expect_equal(attributes$nodes, sort(unique(nodeIDs))) @@ -34,24 +35,24 @@ test_that("Networks objects contain the correct link data", { nodeIDs <- stringi::stri_rand_strings(nNodes, 5, '[A-Z]') - networkData <- data.table::as.data.table(list( + networkData <- data.frame( source1 = sample(nodeIDs, nLinks, replace=T), target1 = sample(nodeIDs, nLinks, replace=T) - )) + ) ## The simplest case - a binary network with no colors or isolated nodes - network <- newNetwork(dt = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', verbose = 'TRUE') + network <- newNetwork(df = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', verbose = 'TRUE') expect_equal(names(network), c('source', 'target')) expect_equal(nrow(network), nLinks) expect_equal(unname(unlist(lapply(network, class))), c('character', 'character')) ## Network with weighted, colored links - networkData[, edgeData := rnorm(nLinks)] - network <- newNetwork(dt = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', linkWeightColumn = 'edgeData', linkColorScheme = 'posneg', verbose = 'TRUE') - expect_equal(names(network), c('source', 'target', 'linkWeight', 'linkColor')) + networkData$edgeData <- rnorm(nLinks) + network <- newNetwork(df = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', linkWeightColumn = 'edgeData', linkColorScheme = 'posneg', verbose = 'TRUE') + expect_equal(names(network), c('source', 'target', 'weight', 'color')) expect_equal(nrow(network), nLinks) expect_equal(unname(unlist(lapply(network, class))), c('character', 'character', 'numeric', 'numeric')) - expect_true(all(unique(network$linkColor) %in% c(-1, 0, 1))) + expect_true(all(unique(network$color) %in% c(-1, 0, 1))) }) From 730d8a7458e1f2463f1a07412d06cd72ce4ccbb3 Mon Sep 17 00:00:00 2001 From: asizemore Date: Thu, 19 Oct 2023 13:57:12 -0400 Subject: [PATCH 09/31] clean bipartite network docs --- R/class-network-bipartite.R | 37 +++++++++++++++++++++++++++---------- man/bipartiteNetwork.Rd | 25 ++++++++++++++++++++----- man/writeNetworkToJSON.Rd | 6 ++++-- 3 files changed, 51 insertions(+), 17 deletions(-) diff --git a/R/class-network-bipartite.R b/R/class-network-bipartite.R index f4ab488..bb47ffb 100644 --- a/R/class-network-bipartite.R +++ b/R/class-network-bipartite.R @@ -7,14 +7,11 @@ newBipartiteNetwork <- function(df = data.frame(), verbose = logical() ) { - # Assume the source nodes are column 1, and the target are all in column 2. + # Assume the source nodes are column 1, and the target are column 2. column1NodeIDs <- sort(unique(df[[sourceNodeColumn]])) column2NodeIDs <- sort(unique(df[[targetNodeColumn]])) - # TODO check that no nodes are in both cols - - # Create a basic network. We'll threshold the edges in here so we want to know about all the nodes - # before that happens. (add boolean removeIsolatedNodes and linkWeightThreshold fn i guess...) + # Create a network net <- newNetwork(df = df, sourceNodeColumn = sourceNodeColumn, targetNodeColumn = targetNodeColumn, @@ -25,6 +22,7 @@ newBipartiteNetwork <- function(df = data.frame(), class = 'bipartite' ) + # Add bipartite network attributes attr <- attributes(net) attr$column1NodeIDs <- column1NodeIDs attr$column2NodeIDs <- column2NodeIDs @@ -38,6 +36,13 @@ newBipartiteNetwork <- function(df = data.frame(), validateBipartiteNetwork <- function(bpnet, verbose) { + networkAttributes <- attributes(bpnet) + + # Ensure no node is in both columns + if (any(networkAttributes$column1NodeIDs %in% networkAttributes$column2NodeIDs)) { + stop('Nodes cannot reside in both columns of a bipartite network') + } + class <- attr(bpnet, 'class') stopifnot(is.character(class)) @@ -46,12 +51,25 @@ validateBipartiteNetwork <- function(bpnet, verbose) { return(net) } + + #' Create bipartite network #' -#' This function returns the name of a json file which it has -#' written a data.table object out to. -#' @param .pd a data.table to convert to json and write to a tmp file -#' @param pattern optional tmp file prefix +#' This function creates an object that represents a bipartite network. A bipartite network is a network +#' in which there are two groups (columns) of nodes, and links only connect nodes in separate groups (columns). +#' @param df a data.frame of links, with one row per link. One column should contain the link source node, and one +#' column should contain the link target node. It will be assumed that all nodes in the source column are in one group, +#' and that all nodes in the target column are in the second group. +#' @param sourceNodeColumn string defining the name of the column in df that corresponds to the source nodes +#' @param targetNodeColumn string defining the name of the column in df that corresponds to the target nodes +#' @param linkWeightColumn optional string defining the name of the column in df that corresponds to the weight of the link +#' @param nodeIDs optional string array. Should contain at least all nodes in the sourceNodeColumn and targetNodeColumn of df. +#' May also include nodes that do not have any links (isolated nodes). If not specified, the complete list of network nodes +#' will be the union of those in the sourceNodeColumn and targetNodeColumn. +#' @param linkColorScheme string denoting the type of coloring scheme to apply to edges. Options are 'none' (default) which +#' which does not attempt to assign a color to links. The 'posneg' option assigns the link color to the sign of the linkWeightColumn. +#' If linkColorSheme is not 'none', a linkWeightColumn must be specified. +#' @param verbose boolean to determine if time-stamped logging is desired. #' @return bipartite network #' @export bipartiteNetwork <- function(df = data.frame(), @@ -73,7 +91,6 @@ bipartiteNetwork <- function(df = data.frame(), ) return(bpnet) - # outFile <- writeNetworkToJSON(bpnet, 'bipartiteNetwork', verbose=verbose) No, this just goes in the plugin } diff --git a/man/bipartiteNetwork.Rd b/man/bipartiteNetwork.Rd index 74be6c7..bc15984 100644 --- a/man/bipartiteNetwork.Rd +++ b/man/bipartiteNetwork.Rd @@ -11,19 +11,34 @@ bipartiteNetwork( linkWeightColumn = NULL, nodeIDs = NULL, linkColorScheme = c("none", "posneg"), - nodeColorScheme = c("none", "degree"), verbose = logical() ) } \arguments{ -\item{.pd}{a data.table to convert to json and write to a tmp file} +\item{df}{a data.frame of links, with one row per link. One column should contain the link source node, and one +column should contain the link target node. It will be assumed that all nodes in the source column are in one group, +and that all nodes in the target column are in the second group.} -\item{pattern}{optional tmp file prefix} +\item{sourceNodeColumn}{string defining the name of the column in df that corresponds to the source nodes} + +\item{targetNodeColumn}{string defining the name of the column in df that corresponds to the target nodes} + +\item{linkWeightColumn}{optional string defining the name of the column in df that corresponds to the weight of the link} + +\item{nodeIDs}{optional string array. Should contain at least all nodes in the sourceNodeColumn and targetNodeColumn of df. +May also include nodes that do not have any links (isolated nodes). If not specified, the complete list of network nodes +will be the union of those in the sourceNodeColumn and targetNodeColumn.} + +\item{linkColorScheme}{string denoting the type of coloring scheme to apply to edges. Options are 'none' (default) which +which does not attempt to assign a color to links. The 'posneg' option assigns the link color to the sign of the linkWeightColumn. +If linkColorSheme is not 'none', a linkWeightColumn must be specified.} + +\item{verbose}{boolean to determine if time-stamped logging is desired.} } \value{ bipartite network } \description{ -This function returns the name of a json file which it has -written a data.table object out to. +This function creates an object that represents a bipartite network. A bipartite network is a network +in which there are two groups (columns) of nodes, and links only connect nodes in separate groups (columns). } diff --git a/man/writeNetworkToJSON.Rd b/man/writeNetworkToJSON.Rd index 895513f..4d876e4 100644 --- a/man/writeNetworkToJSON.Rd +++ b/man/writeNetworkToJSON.Rd @@ -7,14 +7,16 @@ writeNetworkToJSON(net, pattern = NULL, verbose = c(TRUE, FALSE)) } \arguments{ +\item{net}{a data.table to convert to json and write to a tmp file} + \item{pattern}{optional tmp file prefix} -\item{.pd}{a data.table to convert to json and write to a tmp file} +\item{verbose}{boolean that declares if logging is desired} } \value{ character name of a tmp file w ext *.json } \description{ This function returns the name of a json file which it has -written a data.table object out to. +written a network object out to. } From 4f068681aac5a3f61b019d5ee79183348d64a811 Mon Sep 17 00:00:00 2001 From: asizemore Date: Tue, 31 Oct 2023 18:44:31 +0000 Subject: [PATCH 10/31] add link and node classes --- DESCRIPTION | 27 ++++ NAMESPACE | 11 +- R/class-Link.R | 66 +++++++++ R/class-Node.R | 40 +++++ R/class-network.R | 284 ++++++++++++++++++++---------------- R/methods-Links.R | 27 ++++ man/Link-class.Rd | 11 ++ man/LinkList-class.Rd | 22 +++ man/Network-class.Rd | 24 +++ man/Node-class.Rd | 20 +++ man/NodeList-class.Rd | 10 ++ man/writeNetworkToJSON.Rd | 22 --- tests/testthat/test-links.R | 34 +++++ 13 files changed, 453 insertions(+), 145 deletions(-) create mode 100644 R/class-Link.R create mode 100644 R/class-Node.R create mode 100644 R/methods-Links.R create mode 100644 man/Link-class.Rd create mode 100644 man/LinkList-class.Rd create mode 100644 man/Network-class.Rd create mode 100644 man/Node-class.Rd create mode 100644 man/NodeList-class.Rd delete mode 100644 man/writeNetworkToJSON.Rd create mode 100644 tests/testthat/test-links.R diff --git a/DESCRIPTION b/DESCRIPTION index 57452b6..7a9fbb7 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -40,3 +40,30 @@ Suggests: testthat (>= 2.1.0) Depends: R (>= 2.10) +Collate: + 'bin.R' + 'class-ContingencyTable.R' + 'class-Node.R' + 'class-Link.R' + 'class-network-bipartite.R' + 'class-network.R' + 'class-plotdata-bar.R' + 'class-plotdata-beeswarm.R' + 'class-plotdata-box.R' + 'class-plotdata-heatmap.R' + 'class-plotdata-histogram.R' + 'class-plotdata-line.R' + 'class-plotdata-map-markers.R' + 'class-plotdata-mosaic.R' + 'class-plotdata-scatter.R' + 'class-plotdata.R' + 'group.R' + 'methods-ContingencyTable.R' + 'methods-Links.R' + 'panel.R' + 'plot.data-package.R' + 'utils-bin.R' + 'utils-json.R' + 'utils-pipe.R' + 'utils-stats.R' + 'utils.R' diff --git a/NAMESPACE b/NAMESPACE index b8a278c..6427584 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -12,6 +12,11 @@ S3method(numBinsToBinWidth,Date) S3method(numBinsToBinWidth,default) export("%>%") export(ContingencyTable) +export(Link) +export(LinkList) +export(Network) +export(Node) +export(NodeList) export(TwoByTwoTable) export(adjustToViewport) export(allStats) @@ -60,8 +65,12 @@ export(sensitivity) export(smoothedMean) export(specificity) export(writeJSON) -export(writeNetworkToJSON) exportClasses(ContingencyTable) +exportClasses(Link) +exportClasses(LinkList) +exportClasses(Network) +exportClasses(Node) +exportClasses(NodeList) exportClasses(TwoByTwoTable) exportMethods(allStats) exportMethods(chiSqResults) diff --git a/R/class-Link.R b/R/class-Link.R new file mode 100644 index 0000000..9b3c562 --- /dev/null +++ b/R/class-Link.R @@ -0,0 +1,66 @@ + + +check_link <- function(object) { + + errors <- character() + + return(if (length(errors) == 0) TRUE else errors) +} + + +# i hate this +#' Link +#' +#' Represent one singular link. A link has a source, and a target. It may be directed or undirected. +#' It may have an associated weight, color, timestamp, or label (coming soon!) +#' +#' @name Link-class +#' @rdname Link-class +#' @include class-Node.R +#' @export +Link <- setClass("Link", + representation( + source = "Node", + target = "Node", + weight = "numeric", + color = 'ANY', + isDirected = "logical" + # label = "character" # coming soon + ), + prototype = prototype( + source = new("Node"), + target = new("Node"), + weight = 1, + isDirected = FALSE + ), + validity = check_link +) + + + +#' Link Data +#' +#' A class for representing links in a network +#' +#' @slot data data.frame +#' @slot sourceNodeColumn character defining the name of the column in data that corresponds to the source node +#' @slot targetNodeColumn character defining the name of the column in data that corresponds to the target node +#' @slot weightColumn optional character defining the name of the column in data that corresponds to the weight of the link +#' +#' @name LinkList-class +#' @rdname LinkList-class +#' @importFrom S4Vectors SimpleList +#' @export +LinkList <- setClass("LinkList", + contains = "SimpleList", + prototype = prototype( + elementType = "Link" + ) +) + + +### To Do: +## - LinkList needs a method assignLinkColors() to assign colors to links. Could take LinkList or Network i guess +## - i think all the coloring should go in the Network. Coloring edges or nodes could depend on edges or nodes, so ... +## - validation + diff --git a/R/class-Node.R b/R/class-Node.R new file mode 100644 index 0000000..a9d53dd --- /dev/null +++ b/R/class-Node.R @@ -0,0 +1,40 @@ + +#' Node +#' +#' A class for representing nodes in a network +#' +#' @slot id string a unique identifier for the node +#' @slot color string or numeric that determines the color of the node +#' @slot weight numeric value associated with the node, such as timestamp or other node-associated data. Optional. +#' +#' @name Node-class +#' @rdname Node-class +#' @export +Node <- setClass("Node", + representation( + id = "character", + color = "character", + weight = "numeric" + ), + prototype = prototype( + id = character() + ) +) + + +#' NodeList +#' +#' A class for representing a list of nodes. +#' +#' @name NodeList-class +#' @rdname NodeList-class +#' @importFrom S4Vectors SimpleList +#' @export +NodeList <- setClass("NodeList", + contains = "SimpleList", + prototype = prototype( + elementType = "Node" + ) +) + + diff --git a/R/class-network.R b/R/class-network.R index 4b2ed37..34ee757 100644 --- a/R/class-network.R +++ b/R/class-network.R @@ -1,129 +1,169 @@ -newNetwork <- function(df = data.frame(), - sourceNodeColumn = character(), - targetNodeColumn = character(), - linkWeightColumn = NULL, - nodeIDs = NULL, - linkColorScheme = c('none', 'posneg'), - verbose = logical(), - class = character() -) { - - # Input checks - linkColorScheme <- veupathUtils::matchArg(linkColorScheme) - if (!identical(linkColorScheme, 'none') && is.null(linkWeightColumn)) { - stop('A linkWeightColumn is required for converting link weights to a color scheme') - } - - # Create a data table from df - dt <- data.table::as.data.table(df) - - if (!is.null(nodeIDs)) { - if (any(duplicated(nodeIDs))) stop('nodeIDs must be unique') - if (!all(c(dt[[sourceNodeColumn]], dt[[targetNodeColumn]]) %in% nodeIDs)) { - stop('the nodeIDs argument must contain all nodes seen in dt') - } - nodeIDs <- sort(unique(nodeIDs)) - } else { - nodeIDs <- sort(unique(c(dt[[sourceNodeColumn]], dt[[targetNodeColumn]]))) - } - - ## Create the network - # Subset the dt to the columns we care about - networkColumnNames <- c('source', 'target') - if (!is.null(linkWeightColumn)) networkColumnNames <- c(networkColumnNames, 'weight') - setnames(dt, c(sourceNodeColumn, targetNodeColumn, linkWeightColumn), networkColumnNames, skip_absent=TRUE) - dt <- dt[, ..networkColumnNames] - - # Add link color if requested - if (identical(linkColorScheme, 'posneg')) { - dt[, color:=sign(as.numeric(weight))] - } - - # Add attributes - attr <- attributes(dt) - attr$nodes <- nodeIDs - attr$class <- c(class, 'network', attr$class) - attr$linkColorScheme <- linkColorScheme - - veupathUtils::setAttrFromList(dt, attr) - net <- validateNetwork(dt, verbose) - veupathUtils::logWithTime('Network object successfully created.', verbose) - - return(net) -} - -validateNetwork <- function(net, verbose) { - - networkAttributes <- attributes(net) - - # Check that all source and target nodes are in nodes - if (!all(c(net$source, net$target) %in% networkAttributes$nodes)) { - stop('Found nodes in the network that are not included in the nodes attribute') - } +# Network class +check_network <- function(object) { - class <- attr(net, 'class') - stopifnot(is.character(class)) + errors <- character() - veupathUtils::logWithTime("Network object validated.", verbose) + # Check that the linkColorScheme matches link weights - return(net) + return(if (length(errors) == 0) TRUE else errors) } - -#' 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 +#' Network +#' +#' A class for representing networks. A network is composed of nodes and links (edges, connections, etc.). A link is represented +#' as a pair of nodes, with optional attributes such as weight. To represent a network, we need the list of links in the network, and we need +#' to know if there are any nodes that do not have any links (since that means will not show up in the list of links). Additionally, +#' the network can have other properties such as direction, multiple levels, colored nodes, and more (all coming soon!) +#' +#' @slot links LinkList object +#' @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'. +#' Use a method assignLinkColors() to assign colors to links and set this slot's value. +#' +#' @name Network-class +#' @rdname Network-class #' @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) -} - -# Write a network to a json string -getNetworkJSON <- function(net, verbose = c(TRUE, FALSE)) { - - networkAttributes <- attributes(net) +Network <- setClass("Network", + representation( + links = "LinkList", + nodes = "NodeList", + linkColorScheme = "character" + ), prototype = prototype( + links = LinkList(), + nodes = NodeList(), + linkColorScheme = 'none' + ), + validity = check_network +) + + + +# newNetwork <- function(df = data.frame(), +# sourceNodeColumn = character(), +# targetNodeColumn = character(), +# linkWeightColumn = NULL, +# nodeIDs = NULL, +# linkColorScheme = c('none', 'posneg'), +# verbose = logical(), +# class = character() +# ) { + +# # Input checks +# linkColorScheme <- veupathUtils::matchArg(linkColorScheme) +# if (!identical(linkColorScheme, 'none') && is.null(linkWeightColumn)) { +# stop('A linkWeightColumn is required for converting link weights to a color scheme') +# } + +# # Create a data table from df +# dt <- data.table::as.data.table(df) + +# if (!is.null(nodeIDs)) { +# if (any(duplicated(nodeIDs))) stop('nodeIDs must be unique') +# if (!all(c(dt[[sourceNodeColumn]], dt[[targetNodeColumn]]) %in% nodeIDs)) { +# stop('the nodeIDs argument must contain all nodes seen in dt') +# } +# nodeIDs <- sort(unique(nodeIDs)) +# } else { +# nodeIDs <- sort(unique(c(dt[[sourceNodeColumn]], dt[[targetNodeColumn]]))) +# } + +# ## Create the network +# # Subset the dt to the columns we care about +# networkColumnNames <- c('source', 'target') +# if (!is.null(linkWeightColumn)) networkColumnNames <- c(networkColumnNames, 'weight') +# setnames(dt, c(sourceNodeColumn, targetNodeColumn, linkWeightColumn), networkColumnNames, skip_absent=TRUE) +# dt <- dt[, ..networkColumnNames] + +# # Add link color if requested +# if (identical(linkColorScheme, 'posneg')) { +# dt[, color:=sign(as.numeric(weight))] +# } + +# # Add attributes +# attr <- attributes(dt) +# attr$nodes <- nodeIDs +# attr$class <- c(class, 'network', attr$class) +# attr$linkColorScheme <- linkColorScheme + +# veupathUtils::setAttrFromList(dt, attr) +# net <- validateNetwork(dt, verbose) +# veupathUtils::logWithTime('Network object successfully created.', verbose) + +# return(net) +# } + +# validateNetwork <- function(net, verbose) { + +# networkAttributes <- attributes(net) + +# # Check that all source and target nodes are in nodes +# if (!all(c(net$source, net$target) %in% networkAttributes$nodes)) { +# stop('Found nodes in the network that are not included in the nodes attribute') +# } + +# class <- attr(net, 'class') +# stopifnot(is.character(class)) + +# veupathUtils::logWithTime("Network object validated.", verbose) + +# return(net) +# } + + +# #' 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) +# } + +# # Write a network to a json string +# getNetworkJSON <- function(net, verbose = c(TRUE, FALSE)) { + +# 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 + + +# # Covert to json string +# json <- jsonlite::toJSON(obj, na=NULL) + - # 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 - - - # Covert to json string - json <- jsonlite::toJSON(obj, na=NULL) - - - return(json) -} +# return(json) +# } diff --git a/R/methods-Links.R b/R/methods-Links.R new file mode 100644 index 0000000..fc6e1e2 --- /dev/null +++ b/R/methods-Links.R @@ -0,0 +1,27 @@ +# Methods for Link and LinkList objects + +# Accessors for fanciness +setGeneric("source", function(object) standardGeneric("source")) +setGeneric("source<-", function(object, value) standardGeneric("source<-")) +setGeneric("target", function(object) standardGeneric("target")) +setGeneric("target<-", function(object, value) standardGeneric("target<-")) +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<-")) + +setMethod("source", "Link", function(object) object@source) +setMethod("source<-", "Link", function(object, value) {object@source <- value; object}) +setMethod("target", "Link", function(object) object@target) +setMethod("target<-", "Link", function(object, value) {object@target <- value; object}) +setMethod("weight", "Link", function(object) object@weight) +setMethod("weight<-", "Link", function(object, value) {object@weight <- value; object}) +setMethod("color", "Link", function(object) object@color) +setMethod("color<-", "Link", function(object, value) {object@color <- value; object}) + + +# For LinkLists, let's return vectors of data from the nodes +setMethod("source", "LinkList", function(object) lapply(object, function(x) source(x))) +setMethod("target", "LinkList", function(object) lapply(object, function(x) target(x))) +setMethod("weight", "LinkList", function(object) lapply(object, function(x) weight(x))) +setMethod("color", "LinkList", function(object) lapply(object, function(x) color(x))) \ No newline at end of file diff --git a/man/Link-class.Rd b/man/Link-class.Rd new file mode 100644 index 0000000..78c8efa --- /dev/null +++ b/man/Link-class.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/class-Link.R +\docType{class} +\name{Link-class} +\alias{Link-class} +\alias{Link} +\title{Link} +\description{ +Represent one singular link. A link has a source, and a target. It may be directed or undirected. +It may have an associated weight, color, timestamp, or label (coming soon!) +} diff --git a/man/LinkList-class.Rd b/man/LinkList-class.Rd new file mode 100644 index 0000000..3acaabc --- /dev/null +++ b/man/LinkList-class.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/class-Link.R +\docType{class} +\name{LinkList-class} +\alias{LinkList-class} +\alias{LinkList} +\title{Link Data} +\description{ +A class for representing links in a network +} +\section{Slots}{ + +\describe{ +\item{\code{data}}{data.frame} + +\item{\code{sourceNodeColumn}}{character defining the name of the column in data that corresponds to the source node} + +\item{\code{targetNodeColumn}}{character defining the name of the column in data that corresponds to the target node} + +\item{\code{weightColumn}}{optional character defining the name of the column in data that corresponds to the weight of the link} +}} + diff --git a/man/Network-class.Rd b/man/Network-class.Rd new file mode 100644 index 0000000..334d653 --- /dev/null +++ b/man/Network-class.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/class-network.R +\docType{class} +\name{Network-class} +\alias{Network-class} +\alias{Network} +\title{Network} +\description{ +A class for representing networks. A network is composed of nodes and links (edges, connections, etc.). A link is represented +as a pair of nodes, with optional attributes such as weight. To represent a network, we need the list of links in the network, and we need +to know if there are any nodes that do not have any links (since that means will not show up in the list of links). Additionally, +the network can have other properties such as direction, multiple levels, colored nodes, and more (all coming soon!) +} +\section{Slots}{ + +\describe{ +\item{\code{links}}{LinkList object} + +\item{\code{nodes}}{NodeList object defining the nodes in the network. Some nodes may not have any links.} + +\item{\code{linkColorScheme}}{string defining the type of coloring scheme the links follow. Options are 'none' (default) and 'posneg'. +Use a method assignLinkColors() to assign colors to links and set this slot's value.} +}} + diff --git a/man/Node-class.Rd b/man/Node-class.Rd new file mode 100644 index 0000000..ae2f58b --- /dev/null +++ b/man/Node-class.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/class-Node.R +\docType{class} +\name{Node-class} +\alias{Node-class} +\alias{Node} +\title{Node} +\description{ +A class for representing nodes in a network +} +\section{Slots}{ + +\describe{ +\item{\code{id}}{string a unique identifier for the node} + +\item{\code{color}}{string or numeric that determines the color of the node} + +\item{\code{weight}}{numeric value associated with the node, such as timestamp or other node-associated data. Optional.} +}} + diff --git a/man/NodeList-class.Rd b/man/NodeList-class.Rd new file mode 100644 index 0000000..e02ead8 --- /dev/null +++ b/man/NodeList-class.Rd @@ -0,0 +1,10 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/class-Node.R +\docType{class} +\name{NodeList-class} +\alias{NodeList-class} +\alias{NodeList} +\title{NodeList} +\description{ +A class for representing a list of nodes. +} diff --git a/man/writeNetworkToJSON.Rd b/man/writeNetworkToJSON.Rd deleted file mode 100644 index 4d876e4..0000000 --- a/man/writeNetworkToJSON.Rd +++ /dev/null @@ -1,22 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/class-network.R -\name{writeNetworkToJSON} -\alias{writeNetworkToJSON} -\title{Write json to local tmp file} -\usage{ -writeNetworkToJSON(net, pattern = NULL, verbose = c(TRUE, FALSE)) -} -\arguments{ -\item{net}{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} -} -\value{ -character name of a tmp file w ext *.json -} -\description{ -This function returns the name of a json file which it has -written a network object out to. -} diff --git a/tests/testthat/test-links.R b/tests/testthat/test-links.R new file mode 100644 index 0000000..5f42e32 --- /dev/null +++ b/tests/testthat/test-links.R @@ -0,0 +1,34 @@ +test_that("Links work", { + # Make a link + nodeA <- Node( + id = 'A' + ) + nodeB <- Node( + id = 'B' + ) + link <- Link(source = nodeA, target = nodeB) + expect_equal(class(link)[1], 'Link') +}) + +test_that("Link methods work", { + + nodeA <- Node( + id = 'A' + ) + nodeB <- Node( + id = 'B' + ) + + link <- Link(source = nodeA, target = nodeB) + expect_equal(source(link), nodeA) + expect_equal(target(link), nodeB) + expect_equal(weight(link), 1) + expect_true(is.null(color(link))) + + link <- Link(source = nodeA, target = nodeB, color = 'red', weight = 10) + expect_equal(source(link), nodeA) + expect_equal(target(link), nodeB) + expect_equal(color(link), 'red') + expect_equal(weight(link), 10) + +}) From 721f116676127941c491f014334fdcb53b02dd79 Mon Sep 17 00:00:00 2001 From: asizemore Date: Wed, 1 Nov 2023 10:46:37 +0000 Subject: [PATCH 11/31] add link methods --- R/class-Link.R | 19 +++++++++++------- R/methods-Links.R | 17 ++++++++++++---- tests/testthat/test-links.R | 39 +++++++++++++++++++++++++++++++++++++ 3 files changed, 64 insertions(+), 11 deletions(-) diff --git a/R/class-Link.R b/R/class-Link.R index 9b3c562..72f4000 100644 --- a/R/class-Link.R +++ b/R/class-Link.R @@ -37,16 +37,20 @@ Link <- setClass("Link", ) +check_link_list <- function(object) { -#' Link Data + errors <- character() + + # If one link has a color, all must have colors + + return(if (length(errors) == 0) TRUE else errors) + +} + +#' Link List #' #' A class for representing links in a network #' -#' @slot data data.frame -#' @slot sourceNodeColumn character defining the name of the column in data that corresponds to the source node -#' @slot targetNodeColumn character defining the name of the column in data that corresponds to the target node -#' @slot weightColumn optional character defining the name of the column in data that corresponds to the weight of the link -#' #' @name LinkList-class #' @rdname LinkList-class #' @importFrom S4Vectors SimpleList @@ -55,7 +59,8 @@ LinkList <- setClass("LinkList", contains = "SimpleList", prototype = prototype( elementType = "Link" - ) + ), + validity = check_link_list ) diff --git a/R/methods-Links.R b/R/methods-Links.R index fc6e1e2..4729b63 100644 --- a/R/methods-Links.R +++ b/R/methods-Links.R @@ -21,7 +21,16 @@ setMethod("color<-", "Link", function(object, value) {object@color <- value; obj # For LinkLists, let's return vectors of data from the nodes -setMethod("source", "LinkList", function(object) lapply(object, function(x) source(x))) -setMethod("target", "LinkList", function(object) lapply(object, function(x) target(x))) -setMethod("weight", "LinkList", function(object) lapply(object, function(x) weight(x))) -setMethod("color", "LinkList", function(object) lapply(object, function(x) color(x))) \ No newline at end of file +setGeneric("getSourceNodes", function(object) standardGeneric("getSourceNodes")) +setMethod("getSourceNodes", "LinkList", function(object) lapply(object, function(x) source(x))) +setGeneric("getTargetNodes", function(object) standardGeneric("getTargetNodes")) +setMethod("getTargetNodes", "LinkList", function(object) lapply(object, function(x) target(x))) +setGeneric("getWeights", function(object) standardGeneric("getWeights")) +setMethod("getWeights", "LinkList", function(object) unlist(lapply(object, function(x) weight(x)))) +setGeneric("getColors", function(object) standardGeneric("getColors")) +setMethod("getColors", "LinkList", function(object) unlist(lapply(object, function(x) color(x)))) + + + +# Remove redundant links? + diff --git a/tests/testthat/test-links.R b/tests/testthat/test-links.R index 5f42e32..97de77f 100644 --- a/tests/testthat/test-links.R +++ b/tests/testthat/test-links.R @@ -32,3 +32,42 @@ test_that("Link methods work", { expect_equal(weight(link), 10) }) + +test_that("LinkList methods work", { + + # Create some nodes + nodeA <- Node( + id = 'A' + ) + nodeB <- Node( + id = 'B' + ) + nodeC <- Node( + id = 'C' + ) + + # Create some links + link1 <- Link(source = nodeA, target = nodeB) + link2 <- Link(source = nodeB, target = nodeC) + link3 <- Link(source = nodeC, target = nodeA) + + linkList <- LinkList(S4Vectors::SimpleList(c(link1, link2, link3))) + expect_equal(length(linkList), 3) + expect_equal(getSourceNodes(linkList), list(nodeA, nodeB, nodeC)) + expect_equal(getTargetNodes(linkList), list(nodeB, nodeC, nodeA)) + expect_equal(getWeights(linkList), c(1, 1, 1)) + expect_equal(getColors(linkList), c(NULL, NULL, NULL)) + + + # Create some more links + link1 <- Link(source = nodeA, target = nodeB, weight = 2, color = 'red') + link2 <- Link(source = nodeB, target = nodeC, weight = 0.1, color = 'blue') + link3 <- Link(source = nodeC, target = nodeA, weight = 3, color = 'green') + + linkList <- LinkList(S4Vectors::SimpleList(c(link1, link2, link3))) + expect_equal(length(linkList), 3) + expect_equal(getSourceNodes(linkList), list(nodeA, nodeB, nodeC)) + expect_equal(getTargetNodes(linkList), list(nodeB, nodeC, nodeA)) + expect_equal(getWeights(linkList), c(2, 0.1, 3)) + expect_equal(getColors(linkList), c('red', 'blue', 'green')) +}) From daf1f31428dd24b84959c80a7092ed41cf305be4 Mon Sep 17 00:00:00 2001 From: asizemore Date: Wed, 1 Nov 2023 11:32:29 +0000 Subject: [PATCH 12/31] add Node class and accessors --- DESCRIPTION | 1 + R/class-network.R | 149 ++++-------------------------------- R/methods-Links.R | 12 +-- R/methods-Nodes.R | 24 ++++++ R/methods-network.R | 82 ++++++++++++++++++++ man/LinkList-class.Rd | 14 +--- tests/testthat/test-nodes.R | 67 ++++++++++++++++ 7 files changed, 192 insertions(+), 157 deletions(-) create mode 100644 R/methods-Nodes.R create mode 100644 R/methods-network.R create mode 100644 tests/testthat/test-nodes.R diff --git a/DESCRIPTION b/DESCRIPTION index 7a9fbb7..7729b33 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -60,6 +60,7 @@ Collate: 'group.R' 'methods-ContingencyTable.R' 'methods-Links.R' + 'methods-Nodes.R' 'panel.R' 'plot.data-package.R' 'utils-bin.R' diff --git a/R/class-network.R b/R/class-network.R index 34ee757..63e9019 100644 --- a/R/class-network.R +++ b/R/class-network.R @@ -3,17 +3,26 @@ check_network <- function(object) { errors <- character() - # Check that the linkColorScheme matches link weights + # Check that all nodes in links are in nodes + if (!all(getNodeIds(object@links) %in% getNodeIds(object@nodes))) { + errors <- c(errors, 'Found a node in a link that is not in the node list. All nodes in links must also be in nodes.') + } + + # 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"') + } + return(if (length(errors) == 0) TRUE else errors) } + #' Network #' #' A class for representing networks. A network is composed of nodes and links (edges, connections, etc.). A link is represented -#' as a pair of nodes, with optional attributes such as weight. To represent a network, we need the list of links in the network, and we need -#' to know if there are any nodes that do not have any links (since that means will not show up in the list of links). Additionally, -#' the network can have other properties such as direction, multiple levels, colored nodes, and more (all coming soon!) +#' as a pair of nodes, with optional attributes such as weight (see Link). To represent a network, we need both the list of links in the network and a list of nodes +#' in case some nodes have no links. A network can also have properties such as directedness, levels, colors, etc. (coming soon). #' #' @slot links LinkList object #' @slot nodes NodeList object defining the nodes in the network. Some nodes may not have any links. @@ -35,135 +44,3 @@ Network <- setClass("Network", ), validity = check_network ) - - - -# newNetwork <- function(df = data.frame(), -# sourceNodeColumn = character(), -# targetNodeColumn = character(), -# linkWeightColumn = NULL, -# nodeIDs = NULL, -# linkColorScheme = c('none', 'posneg'), -# verbose = logical(), -# class = character() -# ) { - -# # Input checks -# linkColorScheme <- veupathUtils::matchArg(linkColorScheme) -# if (!identical(linkColorScheme, 'none') && is.null(linkWeightColumn)) { -# stop('A linkWeightColumn is required for converting link weights to a color scheme') -# } - -# # Create a data table from df -# dt <- data.table::as.data.table(df) - -# if (!is.null(nodeIDs)) { -# if (any(duplicated(nodeIDs))) stop('nodeIDs must be unique') -# if (!all(c(dt[[sourceNodeColumn]], dt[[targetNodeColumn]]) %in% nodeIDs)) { -# stop('the nodeIDs argument must contain all nodes seen in dt') -# } -# nodeIDs <- sort(unique(nodeIDs)) -# } else { -# nodeIDs <- sort(unique(c(dt[[sourceNodeColumn]], dt[[targetNodeColumn]]))) -# } - -# ## Create the network -# # Subset the dt to the columns we care about -# networkColumnNames <- c('source', 'target') -# if (!is.null(linkWeightColumn)) networkColumnNames <- c(networkColumnNames, 'weight') -# setnames(dt, c(sourceNodeColumn, targetNodeColumn, linkWeightColumn), networkColumnNames, skip_absent=TRUE) -# dt <- dt[, ..networkColumnNames] - -# # Add link color if requested -# if (identical(linkColorScheme, 'posneg')) { -# dt[, color:=sign(as.numeric(weight))] -# } - -# # Add attributes -# attr <- attributes(dt) -# attr$nodes <- nodeIDs -# attr$class <- c(class, 'network', attr$class) -# attr$linkColorScheme <- linkColorScheme - -# veupathUtils::setAttrFromList(dt, attr) -# net <- validateNetwork(dt, verbose) -# veupathUtils::logWithTime('Network object successfully created.', verbose) - -# return(net) -# } - -# validateNetwork <- function(net, verbose) { - -# networkAttributes <- attributes(net) - -# # Check that all source and target nodes are in nodes -# if (!all(c(net$source, net$target) %in% networkAttributes$nodes)) { -# stop('Found nodes in the network that are not included in the nodes attribute') -# } - -# class <- attr(net, 'class') -# stopifnot(is.character(class)) - -# veupathUtils::logWithTime("Network object validated.", verbose) - -# return(net) -# } - - -# #' 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) -# } - -# # Write a network to a json string -# getNetworkJSON <- function(net, verbose = c(TRUE, FALSE)) { - -# 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 - - -# # Covert to json string -# json <- jsonlite::toJSON(obj, na=NULL) - - -# return(json) -# } diff --git a/R/methods-Links.R b/R/methods-Links.R index 4729b63..69271e8 100644 --- a/R/methods-Links.R +++ b/R/methods-Links.R @@ -11,13 +11,13 @@ setGeneric("color", function(object) standardGeneric("color")) setGeneric("color<-", function(object, value) standardGeneric("color<-")) setMethod("source", "Link", function(object) object@source) -setMethod("source<-", "Link", function(object, value) {object@source <- value; object}) +setMethod("source<-", "Link", function(object, value) {object@source <- value; validObject(object); object}) setMethod("target", "Link", function(object) object@target) -setMethod("target<-", "Link", function(object, value) {object@target <- value; object}) +setMethod("target<-", "Link", function(object, value) {object@target <- value; validObject(object); object}) setMethod("weight", "Link", function(object) object@weight) -setMethod("weight<-", "Link", function(object, value) {object@weight <- value; object}) +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; object}) +setMethod("color<-", "Link", function(object, value) {object@color <- value; validObject(object); object}) # For LinkLists, let's return vectors of data from the nodes @@ -30,7 +30,3 @@ 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)))) - - -# Remove redundant links? - diff --git a/R/methods-Nodes.R b/R/methods-Nodes.R new file mode 100644 index 0000000..90722be --- /dev/null +++ b/R/methods-Nodes.R @@ -0,0 +1,24 @@ +# Methods for Node and NodeList objects + + +# Accessors for fanciness +setGeneric("id", function(object) standardGeneric("id")) +setGeneric("color", function(object) standardGeneric("color")) +setGeneric("weight", function(object) standardGeneric("weight")) +setGeneric("id<-", function(object, value) standardGeneric("id<-")) +setGeneric("color<-", function(object, value) standardGeneric("color<-")) +setGeneric("weight<-", function(object, value) standardGeneric("weight<-")) + +setMethod("id", "Node", function(object) object@id) +setMethod("color", "Node", function(object) object@color) +setMethod("weight", "Node", function(object) object@weight) +setMethod("id<-", "Node", function(object, value) {object@id <- value; validObject(object); object}) +setMethod("color<-", "Node", function(object, value) {object@color <- value; validObject(object); object}) +setMethod("weight<-", "Node", function(object, value) {object@weight <- value; validObject(object); object}) + + +## Methods for NodeLists +setGeneric("getNodeIds", function(object) standardGeneric("getNodeIds")) +setMethod("getNodeIds", "NodeList", function(object) unlist(lapply(object, function(x) id(x)))) +setMethod("getWeights", "NodeList", function(object) unlist(lapply(object, function(x) weight(x)))) +setMethod("getColors", "NodeList", function(object) unlist(lapply(object, function(x) color(x)))) \ No newline at end of file diff --git a/R/methods-network.R b/R/methods-network.R new file mode 100644 index 0000000..ac5bf86 --- /dev/null +++ b/R/methods-network.R @@ -0,0 +1,82 @@ +# Methods for the Network class + + +# Fancy accessors +setGeneric("getNodes", function(object) standardGeneric("getNodes")) +setMethod("getNodes", "Network", function(object) object@nodes) +setGeneric("getLinks", function(object) standardGeneric("getLinks")) +setMethod("getLinks", "Network", function(object) object@links) +setGeneric("getLinkColorScheme", function(object) standardGeneric("getLinkColorScheme")) +setMethod("getLinkColorScheme", "Network", function(object) object@linkColorScheme) +# No setters! Once created, a network should only be updated via network methods + +# Remove isolated nodes +# Get isolated nodes +# Remove redundant links +# Remove redundant nodes +# Get Degree list +# Get Weighted Degree list +# etc. +# Threshold network by edge weight +# Assign color scheme + + + +# #' 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) +# } + +# # Write a network to a json string +# getNetworkJSON <- function(net, verbose = c(TRUE, FALSE)) { + +# 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 + + +# # Covert to json string +# json <- jsonlite::toJSON(obj, na=NULL) + + +# return(json) +# } + diff --git a/man/LinkList-class.Rd b/man/LinkList-class.Rd index 3acaabc..e5b8502 100644 --- a/man/LinkList-class.Rd +++ b/man/LinkList-class.Rd @@ -4,19 +4,7 @@ \name{LinkList-class} \alias{LinkList-class} \alias{LinkList} -\title{Link Data} +\title{Link List} \description{ A class for representing links in a network } -\section{Slots}{ - -\describe{ -\item{\code{data}}{data.frame} - -\item{\code{sourceNodeColumn}}{character defining the name of the column in data that corresponds to the source node} - -\item{\code{targetNodeColumn}}{character defining the name of the column in data that corresponds to the target node} - -\item{\code{weightColumn}}{optional character defining the name of the column in data that corresponds to the weight of the link} -}} - diff --git a/tests/testthat/test-nodes.R b/tests/testthat/test-nodes.R new file mode 100644 index 0000000..ba8d7ef --- /dev/null +++ b/tests/testthat/test-nodes.R @@ -0,0 +1,67 @@ +test_that("Node methods work", { + + # Create a node + nodeA <- Node( + id = 'A' + ) + expect_equal(id(nodeA), 'A') + expect_equal(color(nodeA), character()) + expect_equal(weight(nodeA), numeric()) + + nodeB <- Node( + id = 'B', + color = 'red', + weight = 10 + ) + + expect_equal(id(nodeB), 'B') + expect_equal(color(nodeB), 'red') + expect_equal(weight(nodeB), 10) +}) + +test_that("NodeList methods work", { + + # Create some nodes + nodeA <- Node( + id = 'A' + ) + nodeB <- Node( + id = 'B' + ) + nodeC <- Node( + id = 'C' + ) + + nodeList <- NodeList(S4Vectors::SimpleList(c(nodeA, nodeB, nodeC))) + expect_equal(length(nodeList), 3) + expect_equal(getNodeIds(nodeList), c('A', 'B', 'C')) + expect_equal(getWeights(nodeList), c(numeric(), numeric(), numeric())) + expect_equal(getColors(nodeList), c(character(), character(), character())) + + + # Create more interesting nodes + nodeA <- Node( + id = 'A', + color = 'red', + weight = 10 + ) + nodeB <- Node( + id = 'B', + color = 'blue', + weight = 20 + ) + nodeC <- Node( + id = 'C', + color = 'green', + weight = 30 + ) + + nodeList <- NodeList(S4Vectors::SimpleList(c(nodeA, nodeB, nodeC))) + expect_equal(length(nodeList), 3) + expect_equal(getNodeIds(nodeList), c('A', 'B', 'C')) + expect_equal(getWeights(nodeList), c(10, 20, 30)) + expect_equal(getColors(nodeList), c('red', 'blue', 'green')) + + + +}) From 1fa00f6b45c9a6aafb2f1ad25b481e6f55abd755 Mon Sep 17 00:00:00 2001 From: asizemore Date: Wed, 1 Nov 2023 14:41:06 +0000 Subject: [PATCH 13/31] add Network Class and tests --- DESCRIPTION | 1 + R/class-network.R | 3 +- man/Network-class.Rd | 5 +-- tests/testthat/test-network.R | 84 ++++++++++++++++------------------- 4 files changed, 44 insertions(+), 49 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 7729b33..62f9495 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -61,6 +61,7 @@ Collate: 'methods-ContingencyTable.R' 'methods-Links.R' 'methods-Nodes.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 63e9019..9f39db7 100644 --- a/R/class-network.R +++ b/R/class-network.R @@ -4,7 +4,8 @@ check_network <- function(object) { errors <- character() # Check that all nodes in links are in nodes - if (!all(getNodeIds(object@links) %in% getNodeIds(object@nodes))) { + nodesInLinks <- NodeList(union(getSourceNodes(object@links), getTargetNodes(object@links))) # may become a method later if i find i use it elsewhere + if (!all(getNodeIds(nodesInLinks) %in% getNodeIds(object@nodes))) { errors <- c(errors, 'Found a node in a link that is not in the node list. All nodes in links must also be in nodes.') } diff --git a/man/Network-class.Rd b/man/Network-class.Rd index 334d653..30acd12 100644 --- a/man/Network-class.Rd +++ b/man/Network-class.Rd @@ -7,9 +7,8 @@ \title{Network} \description{ A class for representing networks. A network is composed of nodes and links (edges, connections, etc.). A link is represented -as a pair of nodes, with optional attributes such as weight. To represent a network, we need the list of links in the network, and we need -to know if there are any nodes that do not have any links (since that means will not show up in the list of links). Additionally, -the network can have other properties such as direction, multiple levels, colored nodes, and more (all coming soon!) +as a pair of nodes, with optional attributes such as weight (see Link). To represent a network, we need both the list of links in the network and a list of nodes +in case some nodes have no links. A network can also have properties such as directedness, levels, colors, etc. (coming soon). } \section{Slots}{ diff --git a/tests/testthat/test-network.R b/tests/testthat/test-network.R index 5983079..38778a7 100644 --- a/tests/testthat/test-network.R +++ b/tests/testthat/test-network.R @@ -1,58 +1,52 @@ -test_that("Network objects have the correct attributes", { +test_that("Networks can be created and their properties accessed", { - nNodes <- 50 - nLinks <- 500 - - nodeIDs <- unique(stringi::stri_rand_strings(nNodes, 5, '[A-Z]')) - nNodes <- length(nodeIDs) - - networkData <- data.frame( - source1 = sample(nodeIDs, nLinks, replace=T), - target1 = sample(nodeIDs, nLinks, replace=T) + # Create some nodes + nodeA <- Node( + id = 'A' + ) + nodeB <- Node( + id = 'B' + ) + nodeC <- Node( + id = 'C' ) - ## The simplest case - a binary network with no colors or isolated nodes - network <- newNetwork(df = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', verbose = 'TRUE') - attributes <- attributes(network) - expect_equal(attributes$class, c('network', 'data.table', 'data.frame')) - expect_equal(attributes$nodes, sort(unique(nodeIDs))) - expect_equal(attributes$linkColorScheme, 'none') - - ## Network with edge weights and colors - networkData$edgeData <- rnorm(nLinks) - network <- newNetwork(df = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', linkWeightColumn = 'edgeData', linkColorScheme = 'posneg', verbose = 'TRUE') - attributes <- attributes(network) - expect_equal(attributes$class, c('network', 'data.table', 'data.frame')) - expect_equal(attributes$nodes, sort(unique(nodeIDs))) - expect_equal(attributes$linkColorScheme, 'posneg') + # Create some edges + 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) -}) + # Create a network + net <- Network(links = LinkList(c(link1, link2, link3)), nodes = NodeList(c(nodeA, nodeB, nodeC))) -test_that("Networks objects contain the correct link data", { + expect_equal(getNodes(net), NodeList(c(nodeA, nodeB, nodeC))) + expect_equal(getLinks(net), LinkList(c(link1, link2, link3))) + expect_equal(getLinkColorScheme(net), 'none') - nNodes <- 50 - nLinks <- 500 - nodeIDs <- stringi::stri_rand_strings(nNodes, 5, '[A-Z]') +}) - networkData <- data.frame( - source1 = sample(nodeIDs, nLinks, replace=T), - target1 = sample(nodeIDs, nLinks, replace=T) - ) +test_that("We cannot make inappropriate networks", { - ## The simplest case - a binary network with no colors or isolated nodes - network <- newNetwork(df = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', verbose = 'TRUE') - expect_equal(names(network), c('source', 'target')) - expect_equal(nrow(network), nLinks) - expect_equal(unname(unlist(lapply(network, class))), c('character', 'character')) + # Create some nodes + nodeA <- Node( + id = 'A' + ) + nodeB <- Node( + id = 'B' + ) + nodeC <- Node( + id = 'C' + ) - ## Network with weighted, colored links - networkData$edgeData <- rnorm(nLinks) - network <- newNetwork(df = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', linkWeightColumn = 'edgeData', linkColorScheme = 'posneg', verbose = 'TRUE') - expect_equal(names(network), c('source', 'target', 'weight', 'color')) - expect_equal(nrow(network), nLinks) - expect_equal(unname(unlist(lapply(network, class))), c('character', 'character', 'numeric', 'numeric')) - expect_true(all(unique(network$color) %in% c(-1, 0, 1))) + # Create links + link1 <- Link(source = nodeA, target = nodeB, color = 1, weight = 10) + link2 <- Link(source = nodeB, target = nodeC, color = 2, weight = 20) + # Create a network with a node in links that isn't in nodes + expect_error(Network(links = LinkList(c(link1, link2)), nodes = NodeList(c(nodeB, nodeC)))) + # Create a network with an invalid linkColorScheme + expect_error(Network(links = LinkList(c(link1, link2)), nodes = NodeList(c(nodeA, nodeB)), linkColorScheme = 'nope')) + }) From e9eb42b83d4b21137152d3721c159b776ab658a1 Mon Sep 17 00:00:00 2001 From: asizemore Date: Thu, 2 Nov 2023 10:03:09 +0000 Subject: [PATCH 14/31] add bipartite network class and tests --- DESCRIPTION | 2 +- NAMESPACE | 3 +- R/class-network-bipartite.R | 134 ++++++------------ R/class-network.R | 2 +- man/BipartiteNetwork-class.Rd | 29 ++++ man/Network-class.Rd | 2 +- man/bipartiteNetwork.Rd | 44 ------ tests/testthat/test-bipartite-network.R | 172 ++++++++++-------------- 8 files changed, 145 insertions(+), 243 deletions(-) create mode 100644 man/BipartiteNetwork-class.Rd delete mode 100644 man/bipartiteNetwork.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 62f9495..a40a22f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -45,8 +45,8 @@ Collate: 'class-ContingencyTable.R' 'class-Node.R' 'class-Link.R' - 'class-network-bipartite.R' 'class-network.R' + 'class-network-bipartite.R' 'class-plotdata-bar.R' 'class-plotdata-beeswarm.R' 'class-plotdata-box.R' diff --git a/NAMESPACE b/NAMESPACE index 6427584..f8e055a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -11,6 +11,7 @@ S3method(findBinWidth,numeric) S3method(numBinsToBinWidth,Date) S3method(numBinsToBinWidth,default) export("%>%") +export(BipartiteNetwork) export(ContingencyTable) export(Link) export(LinkList) @@ -27,7 +28,6 @@ export(beeswarm.dt) export(bestFitLine) export(bin) export(binWidthToNumBins) -export(bipartiteNetwork) export(box) export(box.dt) export(chiSqResults) @@ -65,6 +65,7 @@ export(sensitivity) export(smoothedMean) export(specificity) export(writeJSON) +exportClasses(BipartiteNetwork) exportClasses(ContingencyTable) exportClasses(Link) exportClasses(LinkList) diff --git a/R/class-network-bipartite.R b/R/class-network-bipartite.R index bb47ffb..a41ef79 100644 --- a/R/class-network-bipartite.R +++ b/R/class-network-bipartite.R @@ -1,98 +1,50 @@ -newBipartiteNetwork <- function(df = data.frame(), - sourceNodeColumn = character(), - targetNodeColumn = character(), - linkWeightColumn = NULL, - nodeIDs = NULL, - linkColorScheme = c('none', 'posneg'), - verbose = logical() -) { +check_bipartite_network <- function(object) { - # Assume the source nodes are column 1, and the target are column 2. - column1NodeIDs <- sort(unique(df[[sourceNodeColumn]])) - column2NodeIDs <- sort(unique(df[[targetNodeColumn]])) + errors <- character() - # Create a network - net <- newNetwork(df = df, - sourceNodeColumn = sourceNodeColumn, - targetNodeColumn = targetNodeColumn, - linkWeightColumn = linkWeightColumn, - nodeIDs = nodeIDs, - linkColorScheme = linkColorScheme, - verbose = verbose, - class = 'bipartite' - ) - - # Add bipartite network attributes - attr <- attributes(net) - attr$column1NodeIDs <- column1NodeIDs - attr$column2NodeIDs <- column2NodeIDs - - veupathUtils::setAttrFromList(net, attr) - net <- validateNetwork(net, verbose) - veupathUtils::logWithTime('Network object successfully created.', verbose) - - return(net) -} - -validateBipartiteNetwork <- function(bpnet, verbose) { - - networkAttributes <- attributes(bpnet) - - # Ensure no node is in both columns - if (any(networkAttributes$column1NodeIDs %in% networkAttributes$column2NodeIDs)) { - stop('Nodes cannot reside in both columns of a bipartite network') + # Ensure that no node is in both columns + if (length(intersect(object@column1NodeIDs, object@column2NodeIDs)) > 0) { + errors <- c(errors, 'Bipartite networks cannot have nodes in both columns.') } - class <- attr(bpnet, 'class') - stopifnot(is.character(class)) - - veupathUtils::logWithTime("Bipartite network object validated.", verbose) - - return(net) -} - - - -#' Create bipartite network -#' -#' This function creates an object that represents a bipartite network. A bipartite network is a network -#' in which there are two groups (columns) of nodes, and links only connect nodes in separate groups (columns). -#' @param df a data.frame of links, with one row per link. One column should contain the link source node, and one -#' column should contain the link target node. It will be assumed that all nodes in the source column are in one group, -#' and that all nodes in the target column are in the second group. -#' @param sourceNodeColumn string defining the name of the column in df that corresponds to the source nodes -#' @param targetNodeColumn string defining the name of the column in df that corresponds to the target nodes -#' @param linkWeightColumn optional string defining the name of the column in df that corresponds to the weight of the link -#' @param nodeIDs optional string array. Should contain at least all nodes in the sourceNodeColumn and targetNodeColumn of df. -#' May also include nodes that do not have any links (isolated nodes). If not specified, the complete list of network nodes -#' will be the union of those in the sourceNodeColumn and targetNodeColumn. -#' @param linkColorScheme string denoting the type of coloring scheme to apply to edges. Options are 'none' (default) which -#' which does not attempt to assign a color to links. The 'posneg' option assigns the link color to the sign of the linkWeightColumn. -#' If linkColorSheme is not 'none', a linkWeightColumn must be specified. -#' @param verbose boolean to determine if time-stamped logging is desired. -#' @return bipartite network -#' @export -bipartiteNetwork <- function(df = data.frame(), - sourceNodeColumn = character(), - targetNodeColumn = character(), - linkWeightColumn = NULL, - nodeIDs = NULL, - linkColorScheme = c('none', 'posneg'), - verbose = logical() -) { - - bpnet <- newBipartiteNetwork(df = df, - sourceNodeColumn = sourceNodeColumn, - targetNodeColumn = targetNodeColumn, - linkWeightColumn = linkWeightColumn, - nodeIDs = nodeIDs, - linkColorScheme = linkColorScheme, - verbose = verbose - ) - - return(bpnet) + # Check that all nodes are in at least one of the columns + if (!all(getNodeIds(object@nodes) %in% c(object@column1NodeIDs, object@column2NodeIDs))) { + errors <- c(errors, 'Found a node with a link that does not belong to either column. All nodes must exist in exactly one of the two columns in a bipartite network.') + } + return(if (length(errors) == 0) TRUE else errors) } - - +#' Bipartite Network +#' +#' The bipartite network class represents data in the form of a network with two distinct groups of nodes +#' in which nodes connect only with nodes from the other group. In other words, there are only inter-group +#' links, no intra-group links. The two groups of nodes are commonly displayed as two columns of nodes. +#' Bipartite networks can have any property of a regular network, but they also designate the node ids +#' that belong to each column (group). +#' +#' @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'. +#' Use a method assignLinkColors() to assign colors to links and set this slot's value. +#' @slot column1NodeIDs character vector listing the IDs of the nodes in the first column +#' @slot column2NodeIDs character vector listing the IDs of the nodes in the second column +#' +#' @name BipartiteNetwork-class +#' @rdname BipartiteNetwork-class +#' @include class-network.R +#' @export +BipartiteNetwork <- setClass("BipartiteNetwork", + contains = "Network", + representation( + column1NodeIDs = "character", + column2NodeIDs = "character" + ), prototype = prototype( + links = LinkList(), + nodes = NodeList(), + linkColorScheme = 'none', + column1NodeIDs = character(), + column2NodeIDs = character() + ), + validity = check_bipartite_network +) \ No newline at end of file diff --git a/R/class-network.R b/R/class-network.R index 9f39db7..591280e 100644 --- a/R/class-network.R +++ b/R/class-network.R @@ -25,7 +25,7 @@ check_network <- function(object) { #' as a pair of nodes, with optional attributes such as weight (see Link). To represent a network, we need both the list of links in the network and a list of nodes #' in case some nodes have no links. A network can also have properties such as directedness, levels, colors, etc. (coming soon). #' -#' @slot links LinkList 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'. #' Use a method assignLinkColors() to assign colors to links and set this slot's value. diff --git a/man/BipartiteNetwork-class.Rd b/man/BipartiteNetwork-class.Rd new file mode 100644 index 0000000..d3f7f72 --- /dev/null +++ b/man/BipartiteNetwork-class.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/class-network-bipartite.R +\docType{class} +\name{BipartiteNetwork-class} +\alias{BipartiteNetwork-class} +\alias{BipartiteNetwork} +\title{Bipartite Network} +\description{ +The bipartite network class represents data in the form of a network with two distinct groups of nodes +in which nodes connect only with nodes from the other group. In other words, there are only inter-group +links, no intra-group links. The two groups of nodes are commonly displayed as two columns of nodes. +Bipartite networks can have any property of a regular network, but they also designate the node ids +that belong to each column (group). +} +\section{Slots}{ + +\describe{ +\item{\code{links}}{LinkList object defining the links in the network.} + +\item{\code{nodes}}{NodeList object defining the nodes in the network. Some nodes may not have any links.} + +\item{\code{linkColorScheme}}{string defining the type of coloring scheme the links follow. Options are 'none' (default) and 'posneg'. +Use a method assignLinkColors() to assign colors to links and set this slot's value.} + +\item{\code{column1NodeIDs}}{character vector listing the IDs of the nodes in the first column} + +\item{\code{column2NodeIDs}}{character vector listing the IDs of the nodes in the second column} +}} + diff --git a/man/Network-class.Rd b/man/Network-class.Rd index 30acd12..acfc111 100644 --- a/man/Network-class.Rd +++ b/man/Network-class.Rd @@ -13,7 +13,7 @@ in case some nodes have no links. A network can also have properties such as dir \section{Slots}{ \describe{ -\item{\code{links}}{LinkList object} +\item{\code{links}}{LinkList object defining the links in the network.} \item{\code{nodes}}{NodeList object defining the nodes in the network. Some nodes may not have any links.} diff --git a/man/bipartiteNetwork.Rd b/man/bipartiteNetwork.Rd deleted file mode 100644 index bc15984..0000000 --- a/man/bipartiteNetwork.Rd +++ /dev/null @@ -1,44 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/class-network-bipartite.R -\name{bipartiteNetwork} -\alias{bipartiteNetwork} -\title{Create bipartite network} -\usage{ -bipartiteNetwork( - df = data.frame(), - sourceNodeColumn = character(), - targetNodeColumn = character(), - linkWeightColumn = NULL, - nodeIDs = NULL, - linkColorScheme = c("none", "posneg"), - verbose = logical() -) -} -\arguments{ -\item{df}{a data.frame of links, with one row per link. One column should contain the link source node, and one -column should contain the link target node. It will be assumed that all nodes in the source column are in one group, -and that all nodes in the target column are in the second group.} - -\item{sourceNodeColumn}{string defining the name of the column in df that corresponds to the source nodes} - -\item{targetNodeColumn}{string defining the name of the column in df that corresponds to the target nodes} - -\item{linkWeightColumn}{optional string defining the name of the column in df that corresponds to the weight of the link} - -\item{nodeIDs}{optional string array. Should contain at least all nodes in the sourceNodeColumn and targetNodeColumn of df. -May also include nodes that do not have any links (isolated nodes). If not specified, the complete list of network nodes -will be the union of those in the sourceNodeColumn and targetNodeColumn.} - -\item{linkColorScheme}{string denoting the type of coloring scheme to apply to edges. Options are 'none' (default) which -which does not attempt to assign a color to links. The 'posneg' option assigns the link color to the sign of the linkWeightColumn. -If linkColorSheme is not 'none', a linkWeightColumn must be specified.} - -\item{verbose}{boolean to determine if time-stamped logging is desired.} -} -\value{ -bipartite network -} -\description{ -This function creates an object that represents a bipartite network. A bipartite network is a network -in which there are two groups (columns) of nodes, and links only connect nodes in separate groups (columns). -} diff --git a/tests/testthat/test-bipartite-network.R b/tests/testthat/test-bipartite-network.R index 1c4fa66..3960d9a 100644 --- a/tests/testthat/test-bipartite-network.R +++ b/tests/testthat/test-bipartite-network.R @@ -1,112 +1,76 @@ -test_that("Bipartite network objects have the correct attributes", { - - nNodesColumn1 <- 30 - nNodesColumn2 <- 50 - nLinks <- 500 - - column1NodeIDs <- stringi::stri_rand_strings(nNodesColumn1, 5, '[A-Z]') - column2NodeIDs <- stringi::stri_rand_strings(nNodesColumn2, 5, '[A-Z]') - - networkData <- data.frame(list( - source1 = sample(column1NodeIDs, nLinks, replace=T), - target1 = sample(column2NodeIDs, nLinks, replace=T) - )) - - ## The simplest case - a binary network with no colors or isolated nodes - bpnet <- bipartiteNetwork(df = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', verbose = 'TRUE') - attributes <- attributes(bpnet) - expect_equal(attributes$class, c('bipartite', 'network', 'data.table', 'data.frame')) - expect_equal(attributes$nodes, sort(unique(c(column1NodeIDs, column2NodeIDs)))) - expect_equal(attributes$linkColorScheme, 'none') - expect_equal(attributes$column1NodeIDs, sort(unique(column1NodeIDs))) - expect_equal(attributes$column2NodeIDs, sort(unique(column2NodeIDs))) - - ## Network with edge weights and colors - networkData$edgeData <- rnorm(nLinks) - bpnet <- bipartiteNetwork(df = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', linkWeightColumn = 'edgeData', linkColorScheme = 'posneg', verbose = 'TRUE') - attributes <- attributes(bpnet) - expect_equal(attributes$class, c('bipartite', 'network', 'data.table', 'data.frame')) - expect_equal(attributes$nodes, sort(unique(c(column1NodeIDs, column2NodeIDs)))) - expect_equal(attributes$linkColorScheme, 'posneg') - expect_equal(attributes$column1NodeIDs, sort(unique(column1NodeIDs))) - expect_equal(attributes$column2NodeIDs, sort(unique(column2NodeIDs))) +test_that("Bipartite networks can be created", { + # Create nodes + nodeA <- Node( + id = 'A' + ) + nodeB <- Node( + id = 'B' + ) + nodeC <- Node( + id = 'C' + ) + + # 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) + + # Create columns + col1IDs <- c('A', 'B') + col2IDs <- c('C') + + # Create bipartite network + bpnet <- BipartiteNetwork( + links = LinkList(c(link1, link2, link3)), + nodes = NodeList(c(nodeA, nodeB, nodeC)), + column1NodeIDs = col1IDs, + column2NodeIDs = col2IDs + ) + + expect_equal(getNodes(bpnet), NodeList(c(nodeA, nodeB, nodeC))) + expect_equal(getLinks(bpnet), LinkList(c(link1, link2, link3))) + expect_equal(getLinkColorScheme(bpnet), 'none') }) -test_that("Bipartite network objects contain the correct link data", { - - nNodesColumn1 <- 30 - nNodesColumn2 <- 50 - nLinks <- 500 - - column1NodeIDs <- stringi::stri_rand_strings(nNodesColumn1, 5, '[A-Z]') - column2NodeIDs <- stringi::stri_rand_strings(nNodesColumn2, 5, '[A-Z]') - - networkData <- data.frame(list( - source1 = sample(column1NodeIDs, nLinks, replace=T), - target1 = sample(column2NodeIDs, nLinks, replace=T) +test_that("Bipartite networks cannot be created from nonsensical inputs", { + + # Create nodes + nodeA <- Node( + id = 'A' + ) + nodeB <- Node( + id = 'B' + ) + nodeC <- Node( + id = 'C' + ) + + # 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) + + # Create columns + col1IDs <- c('A', 'B', 'C') + col2IDs <- c('C') + + # Nodes can't be in both columns + expect_error(BipartiteNetwork( + links = LinkList(c(link1, link2, link3)), + nodes = NodeList(c(nodeA, nodeB, nodeC)), + column1NodeIDs = col1IDs, + column2NodeIDs = col2IDs )) - ## The simplest case - a binary network with no colors or isolated nodes - bpnet <- bipartiteNetwork(df = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', verbose = 'TRUE') - expect_equal(names(bpnet), c('source', 'target')) - expect_equal(nrow(bpnet), nLinks) - expect_equal(unname(unlist(lapply(bpnet, class))), c('character', 'character')) - - ## Network with weighted, colored links - networkData$edgeData <- rnorm(nLinks) - bpnet <- bipartiteNetwork(df = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', linkWeightColumn = 'edgeData', linkColorScheme = 'posneg', verbose = 'TRUE') - expect_equal(names(bpnet), c('source', 'target', 'weight', 'color')) - expect_equal(nrow(bpnet), nLinks) - expect_equal(unname(unlist(lapply(bpnet, class))), c('character', 'character', 'numeric', 'numeric')) - expect_true(all(unique(bpnet$color) %in% c(-1, 0, 1))) - -}) - -test_that("Writing a bipartite network to json works as expected", { - - nNodesColumn1 <- length(letters) - nNodesColumn2 <- length(LETTERS) - - column1NodeIDs <- letters - column2NodeIDs <- LETTERS - - # Make terribly boring network - networkData <- data.frame(list( - source1 = column1NodeIDs, - target1 = column2NodeIDs + # All nodes must be in one of the columns + col1IDs <- c('A') + col2IDs <- c('C') + expect_error(BipartiteNetwork( + links = LinkList(c(link1, link2, link3)), + nodes = NodeList(c(nodeA, nodeB, nodeC)), + column1NodeIDs = col1IDs, + column2NodeIDs = col2IDs )) - nLinks <- nrow(networkData) - - ## The simple case with no edge weights - bpnet <- bipartiteNetwork(df = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', verbose = 'TRUE') - - outJSON <- getNetworkJSON(bpnet, verbose=FALSE) - jsonList <- jsonlite::fromJSON(outJSON) - expect_equal(names(jsonList), c('nodes', 'links', 'column1NodeIDs', 'column2NodeIDs')) - expect_equal(jsonList$nodes$id, sort(unique(c(column1NodeIDs, column2NodeIDs)))) - expect_equal(names(jsonList$links), c('source', 'target')) - expect_equal(names(jsonList$links$source), c('id')) - expect_equal(names(jsonList$links$target), c('id')) - expect_equal(nrow(jsonList$links), nLinks) - expect_equal(unname(unlist(lapply(jsonList$links, class))), c('data.frame', 'data.frame')) - expect_equal(jsonList$column1NodeIDs, sort(column1NodeIDs)) - expect_equal(jsonList$column2NodeIDs, sort(column2NodeIDs)) - - - ## With link weights and colors - networkData$edgeData <- rnorm(nLinks) - bpnet <- bipartiteNetwork(df = networkData, sourceNodeColumn = 'source1', targetNodeColumn = 'target1', linkWeightColumn = 'edgeData', linkColorScheme = 'posneg', verbose = 'TRUE') - outJSON <- getNetworkJSON(bpnet, verbose=FALSE) - jsonList <- jsonlite::fromJSON(outJSON) - expect_equal(names(jsonList), c('nodes', 'links', 'column1NodeIDs', 'column2NodeIDs')) - expect_equal(jsonList$nodes$id, sort(unique(c(column1NodeIDs, column2NodeIDs)))) - expect_equal(names(jsonList$links), c('source', 'target', 'weight', 'color')) - expect_equal(names(jsonList$links$source), c('id')) - expect_equal(names(jsonList$links$target), c('id')) - expect_equal(nrow(jsonList$links), nLinks) - expect_equal(unname(unlist(lapply(jsonList$links, class))), c('data.frame', 'data.frame', 'character', 'character')) - expect_equal(jsonList$column1NodeIDs, sort(column1NodeIDs)) - expect_equal(jsonList$column2NodeIDs, sort(column2NodeIDs)) }) From e206d098f50dc5c3962dcdae551af0e079e690b5 Mon Sep 17 00:00:00 2001 From: asizemore Date: Thu, 2 Nov 2023 06:52:43 -0400 Subject: [PATCH 15/31] clean up validators and tests --- DESCRIPTION | 4 +- ...k-bipartite.R => class-BipartiteNetwork.R} | 0 R/class-Link.R | 33 ++++++++--- R/class-Node.R | 57 +++++++++++++++++-- R/class-network.R | 1 + R/methods-Nodes.R | 4 -- man/BipartiteNetwork-class.Rd | 2 +- man/Node-class.Rd | 2 +- tests/testthat/test-links.R | 43 ++++++++++++++ tests/testthat/test-nodes.R | 32 +++++++++++ 10 files changed, 156 insertions(+), 22 deletions(-) rename R/{class-network-bipartite.R => class-BipartiteNetwork.R} (100%) diff --git a/DESCRIPTION b/DESCRIPTION index a40a22f..f67abba 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -42,11 +42,11 @@ Depends: R (>= 2.10) Collate: 'bin.R' - 'class-ContingencyTable.R' 'class-Node.R' 'class-Link.R' 'class-network.R' - 'class-network-bipartite.R' + 'class-BipartiteNetwork.R' + 'class-ContingencyTable.R' 'class-plotdata-bar.R' 'class-plotdata-beeswarm.R' 'class-plotdata-box.R' diff --git a/R/class-network-bipartite.R b/R/class-BipartiteNetwork.R similarity index 100% rename from R/class-network-bipartite.R rename to R/class-BipartiteNetwork.R diff --git a/R/class-Link.R b/R/class-Link.R index 72f4000..79aeff2 100644 --- a/R/class-Link.R +++ b/R/class-Link.R @@ -4,11 +4,15 @@ check_link <- function(object) { errors <- character() + # Link color must be a string or number + if (!is.null(object@color) & !is.character(object@color) & !is.numeric(object@color)) { + errors <- c(errors, "Link color must be a string or number") + } + return(if (length(errors) == 0) TRUE else errors) } -# i hate this #' Link #' #' Represent one singular link. A link has a source, and a target. It may be directed or undirected. @@ -42,6 +46,24 @@ check_link_list <- function(object) { errors <- character() # If one link has a color, all must have colors + if (any(unlist(lapply(object, function(x) {!is.null(color(x))})))) { + if (all(unlist(lapply(object, function(x) {!is.null(color(x))})))) { + errors <- c(errors, "If one link has a color, all links must have a color") + } + } + + # Link colors must be all the same class + if (unique(unlist(lapply(ll, function(x) {class(color(x))})) > 1)) { + errors <- c(errors, "Link colors must be all the same class") + } + + # If one link has a weight, all must have weights + if (any(unlist(lapply(object, function(x) {!is.null(weight(x))})))) { + if (all(unlist(lapply(object, function(x) {!is.null(weight(x))})))) { + errors <- c(errors, "If one link has a weight, all links must have a weight") + } + } + return(if (length(errors) == 0) TRUE else errors) @@ -61,11 +83,4 @@ LinkList <- setClass("LinkList", elementType = "Link" ), validity = check_link_list -) - - -### To Do: -## - LinkList needs a method assignLinkColors() to assign colors to links. Could take LinkList or Network i guess -## - i think all the coloring should go in the Network. Coloring edges or nodes could depend on edges or nodes, so ... -## - validation - +) \ No newline at end of file diff --git a/R/class-Node.R b/R/class-Node.R index a9d53dd..f101898 100644 --- a/R/class-Node.R +++ b/R/class-Node.R @@ -1,10 +1,27 @@ +check_node <- function(object) { + + errors <- character() + + # Node color must be a string or number + if (!is.null(object@color) & !is.character(object@color) & !is.numeric(object@color)) { + errors <- c(errors, "Node color must be a string or number") + } + + # Node weight must be a number + if (!is.null(object@weight) & !is.numeric(object@weight)) { + errors <- c(errors, "Node weight must be a number") + } + + return(if (length(errors) == 0) TRUE else errors) +} + #' Node #' #' A class for representing nodes in a network #' #' @slot id string a unique identifier for the node -#' @slot color string or numeric that determines the color of the node +#' @slot color string or numeric that determines the color of the node. Optional. #' @slot weight numeric value associated with the node, such as timestamp or other node-associated data. Optional. #' #' @name Node-class @@ -13,15 +30,44 @@ Node <- setClass("Node", representation( id = "character", - color = "character", - weight = "numeric" + color = "ANY", + weight = "ANY" ), prototype = prototype( id = character() - ) + ), + validity = check_node ) + +check_node_list <- function(object) { + + errors <- character() + + # If one node has a color, all must have colors + if (any(unlist(lapply(object, function(x) {!is.null(color(x))})))) { + if (all(unlist(lapply(object, function(x) {!is.null(color(x))})))) { + errors <- c(errors, "If one node has a color, all nodes must have a color") + } + } + + # If one node has a weight, all must have weights + if (any(unlist(lapply(object, function(x) {!is.null(weight(x))})))) { + if (all(unlist(lapply(object, function(x) {!is.null(weight(x))})))) { + errors <- c(errors, "If one node has a weight, all nodes must have a weight") + } + } + + # Node colors must be all the same class + if (unique(unlist(lapply(object, function(x) {class(color(x))})) > 1)) { + errors <- c(errors, "Node colors must be all the same class") + } + + return(if (length(errors) == 0) TRUE else errors) +} + + #' NodeList #' #' A class for representing a list of nodes. @@ -34,7 +80,8 @@ NodeList <- setClass("NodeList", contains = "SimpleList", prototype = prototype( elementType = "Node" - ) + ), + validity = check_node_list ) diff --git a/R/class-network.R b/R/class-network.R index 591280e..80a77b2 100644 --- a/R/class-network.R +++ b/R/class-network.R @@ -32,6 +32,7 @@ check_network <- function(object) { #' #' @name Network-class #' @rdname Network-class +#' @include class-Link.R #' @export Network <- setClass("Network", representation( diff --git a/R/methods-Nodes.R b/R/methods-Nodes.R index 90722be..8c213bb 100644 --- a/R/methods-Nodes.R +++ b/R/methods-Nodes.R @@ -3,11 +3,7 @@ # Accessors for fanciness setGeneric("id", function(object) standardGeneric("id")) -setGeneric("color", function(object) standardGeneric("color")) -setGeneric("weight", function(object) standardGeneric("weight")) setGeneric("id<-", function(object, value) standardGeneric("id<-")) -setGeneric("color<-", function(object, value) standardGeneric("color<-")) -setGeneric("weight<-", function(object, value) standardGeneric("weight<-")) setMethod("id", "Node", function(object) object@id) setMethod("color", "Node", function(object) object@color) diff --git a/man/BipartiteNetwork-class.Rd b/man/BipartiteNetwork-class.Rd index d3f7f72..d04a87b 100644 --- a/man/BipartiteNetwork-class.Rd +++ b/man/BipartiteNetwork-class.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/class-network-bipartite.R +% Please edit documentation in R/class-BipartiteNetwork.R \docType{class} \name{BipartiteNetwork-class} \alias{BipartiteNetwork-class} diff --git a/man/Node-class.Rd b/man/Node-class.Rd index ae2f58b..4f57b4d 100644 --- a/man/Node-class.Rd +++ b/man/Node-class.Rd @@ -13,7 +13,7 @@ A class for representing nodes in a network \describe{ \item{\code{id}}{string a unique identifier for the node} -\item{\code{color}}{string or numeric that determines the color of the node} +\item{\code{color}}{string or numeric that determines the color of the node. Optional.} \item{\code{weight}}{numeric value associated with the node, such as timestamp or other node-associated data. Optional.} }} diff --git a/tests/testthat/test-links.R b/tests/testthat/test-links.R index 97de77f..db48d7b 100644 --- a/tests/testthat/test-links.R +++ b/tests/testthat/test-links.R @@ -71,3 +71,46 @@ test_that("LinkList methods work", { expect_equal(getWeights(linkList), c(2, 0.1, 3)) expect_equal(getColors(linkList), c('red', 'blue', 'green')) }) + +test_that("Links cannot be created from nonsensical inputs", { + + # Create nodes + nodeA <- Node( + id = 'A' + ) + nodeB <- Node( + id = 'B' + ) + + expect_error(Link(source = nodeA, target = nodeB, color = false, weight = 10)) +}) + +test_that("LinkLists cannot be created from nonsensical inputs", { + + # Create nodes + nodeA <- Node( + id = 'A' + ) + nodeB <- Node( + id = 'B' + ) + nodeC <- Node( + id = 'C' + ) + + # Create links + link1 <- Link(source = nodeA, target = nodeB) + link2 <- Link(source = nodeB, target = nodeC) + link3 <- Link(source = nodeC, target = nodeA, color='red') + + # If one link has a color, all must have colors + expect_error(LinkList(S4Vectors::SimpleList(c(link1, link2, link3)))) + + # Link colors must be of the same class + color(link2) <- 2 + expect_error(LinkList(S4Vectors::SimpleList(c(link1, link2, link3)))) + + # If one link has a weight, all must have weights + weight(link3) <- 100 + expect_error(LinkList(S4Vectors::SimpleList(c(link1, link2, link3)))) +}) diff --git a/tests/testthat/test-nodes.R b/tests/testthat/test-nodes.R index ba8d7ef..7b0569b 100644 --- a/tests/testthat/test-nodes.R +++ b/tests/testthat/test-nodes.R @@ -65,3 +65,35 @@ 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 = 'A', color = FALSE)) + expect_error(Node(id = 'A', weight = '10')) +}) + + +test_that("We cannot make nonsensical NodeLists", { + + # Create some nodes + nodeA <- Node( + id = 'A' + ) + nodeB <- Node( + id = 'B', + color = 'red' + ) + + # If one node has a color, all must have colors + expect_error(NodeList(S4Vectors::SimpleList(c(nodeA, nodeB)))) + + # Nodes must have the same class of colors + color(nodeA) <- 1 + expect_error(NodeList(S4Vectors::SimpleList(c(nodeA, nodeB)))) + + # If one node has a weight, all much have weights + weight(nodeA) <- 100 + expect_error(NodeList(S4Vectors::SimpleList(c(nodeA, nodeB)))) +}) From 74b9ac7388234261c3601c907fe7e777bd6a6b97 Mon Sep 17 00:00:00 2001 From: asizemore Date: Thu, 2 Nov 2023 07:05:36 -0400 Subject: [PATCH 16/31] fix tests --- R/class-Link.R | 15 ++++++++------- R/class-Node.R | 15 ++++++++------- tests/testthat/test-nodes.R | 8 ++++---- 3 files changed, 20 insertions(+), 18 deletions(-) diff --git a/R/class-Link.R b/R/class-Link.R index 79aeff2..91a7a07 100644 --- a/R/class-Link.R +++ b/R/class-Link.R @@ -45,21 +45,22 @@ check_link_list <- function(object) { errors <- character() - # If one link has a color, all must have colors if (any(unlist(lapply(object, function(x) {!is.null(color(x))})))) { - if (all(unlist(lapply(object, function(x) {!is.null(color(x))})))) { + # If one link has a color, all must have colors + if (!all(unlist(lapply(object, function(x) {!is.null(color(x))})))) { errors <- c(errors, "If one link has a color, all links must have a color") } + + # Link colors must be all the same class + if (length(unique(unlist(lapply(object, function(x) {class(color(x))})))) > 1) { + errors <- c(errors, "Link colors must be all the same class") + } } - # Link colors must be all the same class - if (unique(unlist(lapply(ll, function(x) {class(color(x))})) > 1)) { - errors <- c(errors, "Link colors must be all the same class") - } # If one link has a weight, all must have weights if (any(unlist(lapply(object, function(x) {!is.null(weight(x))})))) { - if (all(unlist(lapply(object, function(x) {!is.null(weight(x))})))) { + if (!all(unlist(lapply(object, function(x) {!is.null(weight(x))})))) { errors <- c(errors, "If one link has a weight, all links must have a weight") } } diff --git a/R/class-Node.R b/R/class-Node.R index f101898..e5ea71e 100644 --- a/R/class-Node.R +++ b/R/class-Node.R @@ -45,24 +45,25 @@ check_node_list <- function(object) { errors <- character() - # If one node has a color, all must have colors if (any(unlist(lapply(object, function(x) {!is.null(color(x))})))) { - if (all(unlist(lapply(object, function(x) {!is.null(color(x))})))) { + # If one node has a color, all must have colors + if (!all(unlist(lapply(object, function(x) {!is.null(color(x))})))) { errors <- c(errors, "If one node has a color, all nodes must have a color") } + + # Node colors must be all the same class + if (length(unique(unlist(lapply(object, function(x) {class(color(x))})))) > 1) { + errors <- c(errors, "Node colors must be all the same class") + } } # If one node has a weight, all must have weights if (any(unlist(lapply(object, function(x) {!is.null(weight(x))})))) { - if (all(unlist(lapply(object, function(x) {!is.null(weight(x))})))) { + if (!all(unlist(lapply(object, function(x) {!is.null(weight(x))})))) { errors <- c(errors, "If one node has a weight, all nodes must have a weight") } } - # Node colors must be all the same class - if (unique(unlist(lapply(object, function(x) {class(color(x))})) > 1)) { - errors <- c(errors, "Node colors must be all the same class") - } return(if (length(errors) == 0) TRUE else errors) } diff --git a/tests/testthat/test-nodes.R b/tests/testthat/test-nodes.R index 7b0569b..1827a2f 100644 --- a/tests/testthat/test-nodes.R +++ b/tests/testthat/test-nodes.R @@ -5,8 +5,8 @@ test_that("Node methods work", { id = 'A' ) expect_equal(id(nodeA), 'A') - expect_equal(color(nodeA), character()) - expect_equal(weight(nodeA), numeric()) + expect_equal(color(nodeA), NULL) + expect_equal(weight(nodeA), NULL) nodeB <- Node( id = 'B', @@ -35,8 +35,8 @@ test_that("NodeList methods work", { nodeList <- NodeList(S4Vectors::SimpleList(c(nodeA, nodeB, nodeC))) expect_equal(length(nodeList), 3) expect_equal(getNodeIds(nodeList), c('A', 'B', 'C')) - expect_equal(getWeights(nodeList), c(numeric(), numeric(), numeric())) - expect_equal(getColors(nodeList), c(character(), character(), character())) + expect_equal(getWeights(nodeList), c(NULL, NULL, NULL)) + expect_equal(getColors(nodeList), c(NULL, NULL, NULL)) # Create more interesting nodes From 1568fd385889c86f00f525c8530c3953ec171641 Mon Sep 17 00:00:00 2001 From: asizemore Date: Fri, 3 Nov 2023 06:39:40 -0400 Subject: [PATCH 17/31] clarify docs and messaging --- R/class-Link.R | 2 +- R/methods-Links.R | 4 +++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/R/class-Link.R b/R/class-Link.R index 91a7a07..51f6a48 100644 --- a/R/class-Link.R +++ b/R/class-Link.R @@ -6,7 +6,7 @@ check_link <- function(object) { # Link color must be a string or number if (!is.null(object@color) & !is.character(object@color) & !is.numeric(object@color)) { - errors <- c(errors, "Link color must be a string or number") + errors <- c(errors, "Link color must be a string or number that represents a color or can be mapped to a color.") } return(if (length(errors) == 0) TRUE else errors) diff --git a/R/methods-Links.R b/R/methods-Links.R index 69271e8..40f2dfb 100644 --- a/R/methods-Links.R +++ b/R/methods-Links.R @@ -20,7 +20,9 @@ setMethod("color", "Link", function(object) object@color) setMethod("color<-", "Link", function(object, value) {object@color <- value; validObject(object); object}) -# For LinkLists, let's return vectors of data from the nodes +# Additional methods +# Link properties such as color are returned as vectors, while grabbing particular nodes from the +# LinkList returns lists of nodes. setGeneric("getSourceNodes", function(object) standardGeneric("getSourceNodes")) setMethod("getSourceNodes", "LinkList", function(object) lapply(object, function(x) source(x))) setGeneric("getTargetNodes", function(object) standardGeneric("getTargetNodes")) From 31a184a72c57201f6df8d8782a7a8814bf0c9bc1 Mon Sep 17 00:00:00 2001 From: asizemore Date: Fri, 3 Nov 2023 06:55:27 -0400 Subject: [PATCH 18/31] change bipartite to k-partite --- DESCRIPTION | 4 +- NAMESPACE | 4 +- R/class-BipartiteNetwork.R | 50 ------------------- R/class-KPartiteNetwork.R | 47 +++++++++++++++++ man/BipartiteNetwork-class.Rd | 29 ----------- man/KPartiteNetwork-class.Rd | 27 ++++++++++ ...tite-network.R => test-kpartite-network.R} | 35 ++++++------- 7 files changed, 94 insertions(+), 102 deletions(-) delete mode 100644 R/class-BipartiteNetwork.R create mode 100644 R/class-KPartiteNetwork.R delete mode 100644 man/BipartiteNetwork-class.Rd create mode 100644 man/KPartiteNetwork-class.Rd rename tests/testthat/{test-bipartite-network.R => test-kpartite-network.R} (69%) diff --git a/DESCRIPTION b/DESCRIPTION index f67abba..31a862e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -42,11 +42,11 @@ Depends: R (>= 2.10) Collate: 'bin.R' + 'class-ContingencyTable.R' 'class-Node.R' 'class-Link.R' 'class-network.R' - 'class-BipartiteNetwork.R' - 'class-ContingencyTable.R' + 'class-KPartiteNetwork.R' 'class-plotdata-bar.R' 'class-plotdata-beeswarm.R' 'class-plotdata-box.R' diff --git a/NAMESPACE b/NAMESPACE index f8e055a..9096a89 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -11,8 +11,8 @@ S3method(findBinWidth,numeric) S3method(numBinsToBinWidth,Date) S3method(numBinsToBinWidth,default) export("%>%") -export(BipartiteNetwork) export(ContingencyTable) +export(KPartiteNetwork) export(Link) export(LinkList) export(Network) @@ -65,8 +65,8 @@ export(sensitivity) export(smoothedMean) export(specificity) export(writeJSON) -exportClasses(BipartiteNetwork) exportClasses(ContingencyTable) +exportClasses(KPartiteNetwork) exportClasses(Link) exportClasses(LinkList) exportClasses(Network) diff --git a/R/class-BipartiteNetwork.R b/R/class-BipartiteNetwork.R deleted file mode 100644 index a41ef79..0000000 --- a/R/class-BipartiteNetwork.R +++ /dev/null @@ -1,50 +0,0 @@ -check_bipartite_network <- function(object) { - - errors <- character() - - # Ensure that no node is in both columns - if (length(intersect(object@column1NodeIDs, object@column2NodeIDs)) > 0) { - errors <- c(errors, 'Bipartite networks cannot have nodes in both columns.') - } - - # Check that all nodes are in at least one of the columns - if (!all(getNodeIds(object@nodes) %in% c(object@column1NodeIDs, object@column2NodeIDs))) { - errors <- c(errors, 'Found a node with a link that does not belong to either column. All nodes must exist in exactly one of the two columns in a bipartite network.') - } - - return(if (length(errors) == 0) TRUE else errors) -} - -#' Bipartite Network -#' -#' The bipartite network class represents data in the form of a network with two distinct groups of nodes -#' in which nodes connect only with nodes from the other group. In other words, there are only inter-group -#' links, no intra-group links. The two groups of nodes are commonly displayed as two columns of nodes. -#' Bipartite networks can have any property of a regular network, but they also designate the node ids -#' that belong to each column (group). -#' -#' @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'. -#' Use a method assignLinkColors() to assign colors to links and set this slot's value. -#' @slot column1NodeIDs character vector listing the IDs of the nodes in the first column -#' @slot column2NodeIDs character vector listing the IDs of the nodes in the second column -#' -#' @name BipartiteNetwork-class -#' @rdname BipartiteNetwork-class -#' @include class-network.R -#' @export -BipartiteNetwork <- setClass("BipartiteNetwork", - contains = "Network", - representation( - column1NodeIDs = "character", - column2NodeIDs = "character" - ), prototype = prototype( - links = LinkList(), - nodes = NodeList(), - linkColorScheme = 'none', - column1NodeIDs = character(), - column2NodeIDs = character() - ), - validity = check_bipartite_network -) \ No newline at end of file diff --git a/R/class-KPartiteNetwork.R b/R/class-KPartiteNetwork.R new file mode 100644 index 0000000..742dded --- /dev/null +++ b/R/class-KPartiteNetwork.R @@ -0,0 +1,47 @@ +check_kpartite_network <- function(object) { + + errors <- character() + + # Ensure that no node is in multiple partitions + if (length(unique(unlist(object@partitions))) < length(unlist(object@partitions))) { + errors <- c(errors, 'Found a node in multiple partitions. Nodes can only exist in one partition.') + } + + # Check that all nodes are in at least one of the columns + if (!all(getNodeIds(object@nodes) %in% unlist(object@partitions))) { + errors <- c(errors, 'Found a node that is not in any partition. All nodes must be assigned to a partition.') + } + + return(if (length(errors) == 0) TRUE else errors) +} + +#' k-Partite Network +#' +#' The k-partite network class represents data in the form of a network with k distinct groups of nodes +#' in which nodes connect only with nodes from the other groups. In other words, there are only inter-group +#' links, no intra-group links. These k groups are commonly called partitions. +#' k-partite networks can have any property of a regular network, but they also designate the node ids +#' that belong to each partition (group). +#' +#' @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'. +#' Use a method assignLinkColors() to assign colors to links and set this slot's value. +#' @slot partitions list of node ids that belong to each partition +#' +#' @name KPartiteNetwork-class +#' @rdname KPartiteNetwork-class +#' @include class-network.R +#' @export +KPartiteNetwork <- setClass("KPartiteNetwork", + contains = "Network", + representation( + partitions = "list" + ), prototype = prototype( + links = LinkList(), + nodes = NodeList(), + linkColorScheme = 'none', + partitions = list() + ), + validity = check_kpartite_network +) \ No newline at end of file diff --git a/man/BipartiteNetwork-class.Rd b/man/BipartiteNetwork-class.Rd deleted file mode 100644 index d04a87b..0000000 --- a/man/BipartiteNetwork-class.Rd +++ /dev/null @@ -1,29 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/class-BipartiteNetwork.R -\docType{class} -\name{BipartiteNetwork-class} -\alias{BipartiteNetwork-class} -\alias{BipartiteNetwork} -\title{Bipartite Network} -\description{ -The bipartite network class represents data in the form of a network with two distinct groups of nodes -in which nodes connect only with nodes from the other group. In other words, there are only inter-group -links, no intra-group links. The two groups of nodes are commonly displayed as two columns of nodes. -Bipartite networks can have any property of a regular network, but they also designate the node ids -that belong to each column (group). -} -\section{Slots}{ - -\describe{ -\item{\code{links}}{LinkList object defining the links in the network.} - -\item{\code{nodes}}{NodeList object defining the nodes in the network. Some nodes may not have any links.} - -\item{\code{linkColorScheme}}{string defining the type of coloring scheme the links follow. Options are 'none' (default) and 'posneg'. -Use a method assignLinkColors() to assign colors to links and set this slot's value.} - -\item{\code{column1NodeIDs}}{character vector listing the IDs of the nodes in the first column} - -\item{\code{column2NodeIDs}}{character vector listing the IDs of the nodes in the second column} -}} - diff --git a/man/KPartiteNetwork-class.Rd b/man/KPartiteNetwork-class.Rd new file mode 100644 index 0000000..c998bdd --- /dev/null +++ b/man/KPartiteNetwork-class.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/class-KPartiteNetwork.R +\docType{class} +\name{KPartiteNetwork-class} +\alias{KPartiteNetwork-class} +\alias{KPartiteNetwork} +\title{k-Partite Network} +\description{ +The k-partite network class represents data in the form of a network with k distinct groups of nodes +in which nodes connect only with nodes from the other groups. In other words, there are only inter-group +links, no intra-group links. These k groups are commonly called partitions. +k-partite networks can have any property of a regular network, but they also designate the node ids +that belong to each partition (group). +} +\section{Slots}{ + +\describe{ +\item{\code{links}}{LinkList object defining the links in the network.} + +\item{\code{nodes}}{NodeList object defining the nodes in the network. Some nodes may not have any links.} + +\item{\code{linkColorScheme}}{string defining the type of coloring scheme the links follow. Options are 'none' (default) and 'posneg'. +Use a method assignLinkColors() to assign colors to links and set this slot's value.} + +\item{\code{partitions}}{list of node ids that belong to each partition} +}} + diff --git a/tests/testthat/test-bipartite-network.R b/tests/testthat/test-kpartite-network.R similarity index 69% rename from tests/testthat/test-bipartite-network.R rename to tests/testthat/test-kpartite-network.R index 3960d9a..d5e698d 100644 --- a/tests/testthat/test-bipartite-network.R +++ b/tests/testthat/test-kpartite-network.R @@ -1,4 +1,4 @@ -test_that("Bipartite networks can be created", { +test_that("k-partite networks can be created", { # Create nodes nodeA <- Node( id = 'A' @@ -15,16 +15,15 @@ test_that("Bipartite networks can be created", { link2 <- Link(source = nodeB, target = nodeC, color = 2, weight = 20) link3 <- Link(source = nodeC, target = nodeA, color = 3, weight = 30) - # Create columns - col1IDs <- c('A', 'B') - col2IDs <- c('C') + # Create partitions + partition1IDs <- c('A', 'B') + partition2IDs <- c('C') - # Create bipartite network - bpnet <- BipartiteNetwork( + # Create k-partite network + bpnet <- KPartiteNetwork( links = LinkList(c(link1, link2, link3)), nodes = NodeList(c(nodeA, nodeB, nodeC)), - column1NodeIDs = col1IDs, - column2NodeIDs = col2IDs + partitions = list(partition1IDs, partition2IDs) ) expect_equal(getNodes(bpnet), NodeList(c(nodeA, nodeB, nodeC))) @@ -33,7 +32,7 @@ test_that("Bipartite networks can be created", { }) -test_that("Bipartite networks cannot be created from nonsensical inputs", { +test_that("k-partite networks cannot be created from nonsensical inputs", { # Create nodes nodeA <- Node( @@ -52,25 +51,23 @@ test_that("Bipartite networks cannot be created from nonsensical inputs", { link3 <- Link(source = nodeC, target = nodeA, color = 3, weight = 30) # Create columns - col1IDs <- c('A', 'B', 'C') - col2IDs <- c('C') + partition1IDs <- c('A', 'B', 'C') + partition2IDs <- c('C') # Nodes can't be in both columns - expect_error(BipartiteNetwork( + expect_error(KPartiteNetwork( links = LinkList(c(link1, link2, link3)), nodes = NodeList(c(nodeA, nodeB, nodeC)), - column1NodeIDs = col1IDs, - column2NodeIDs = col2IDs + partitons = list(partition1IDs, partition2IDs) )) # All nodes must be in one of the columns - col1IDs <- c('A') - col2IDs <- c('C') - expect_error(BipartiteNetwork( + partition1IDs <- c('A') + partition2IDs <- c('C') + expect_error(KPartiteNetwork( links = LinkList(c(link1, link2, link3)), nodes = NodeList(c(nodeA, nodeB, nodeC)), - column1NodeIDs = col1IDs, - column2NodeIDs = col2IDs + partitons = list(partition1IDs, partition2IDs) )) }) From d8a5c857de40890aa03d5205aae21c24e5e40281 Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Tue, 9 Jan 2024 23:20:42 -0500 Subject: [PATCH 19/31] add coordinates to Node class --- R/class-Node.R | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/R/class-Node.R b/R/class-Node.R index e5ea71e..516d6cc 100644 --- a/R/class-Node.R +++ b/R/class-Node.R @@ -7,6 +7,13 @@ check_node <- function(object) { errors <- c(errors, "Node color must be a string or number") } + # If Node has x it must have y and vice versa + if (!is.null(object@x) & is.null(object@y)) { + errors <- c(errors, "If Node has x it must have y and vice versa") + } else if (is.null(object@x) & !is.null(object@y)) { + errors <- c(errors, "If Node has y it must have x and vice versa") + } + # Node weight must be a number if (!is.null(object@weight) & !is.numeric(object@weight)) { errors <- c(errors, "Node weight must be a number") @@ -21,6 +28,8 @@ check_node <- function(object) { #' A class for representing nodes in a network #' #' @slot id string a unique identifier for the node +#' @slot x numeric value indicating the x coordinate of the node. Optional. +#' @slot y numeric value indicating the y coordinate of the node. Optional. #' @slot color string or numeric that determines the color of the node. Optional. #' @slot weight numeric value associated with the node, such as timestamp or other node-associated data. Optional. #' @@ -30,6 +39,8 @@ check_node <- function(object) { Node <- setClass("Node", representation( id = "character", + x = "numeric", + y = "numeric", color = "ANY", weight = "ANY" ), From e2451b33221940ff92ad541803d0835a2d38be10 Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Tue, 9 Jan 2024 23:23:20 -0500 Subject: [PATCH 20/31] add a variable metadata list to the network --- R/class-network.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/class-network.R b/R/class-network.R index 80a77b2..ed5ac7f 100644 --- a/R/class-network.R +++ b/R/class-network.R @@ -38,7 +38,8 @@ Network <- setClass("Network", representation( links = "LinkList", nodes = "NodeList", - linkColorScheme = "character" + linkColorScheme = "character", + variableMetadata = "VariableMetadataList" ), prototype = prototype( links = LinkList(), nodes = NodeList(), From 1c2b0a67cd2f58da11cfc26437aa07b3a883c605 Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Tue, 9 Jan 2024 23:24:32 -0500 Subject: [PATCH 21/31] update language and inline docs --- R/class-network.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/class-network.R b/R/class-network.R index ed5ac7f..65aead2 100644 --- a/R/class-network.R +++ b/R/class-network.R @@ -28,6 +28,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'. +#' @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. #' #' @name Network-class @@ -39,7 +40,7 @@ Network <- setClass("Network", links = "LinkList", nodes = "NodeList", linkColorScheme = "character", - variableMetadata = "VariableMetadataList" + variableMapping = "VariableMetadataList" ), prototype = prototype( links = LinkList(), nodes = NodeList(), From 5b55bfc63852aa1664840bb4b2418c4edc02968f Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Wed, 10 Jan 2024 23:17:29 -0500 Subject: [PATCH 22/31] formalize node ids --- R/class-KPartiteNetwork.R | 42 ++++++++++++++++++++++------- R/class-Node.R | 56 ++++++++++++++++++++++++++++++++++++++- R/methods-Nodes.R | 28 +++++++++++++++++--- 3 files changed, 112 insertions(+), 14 deletions(-) diff --git a/R/class-KPartiteNetwork.R b/R/class-KPartiteNetwork.R index 742dded..b4d3088 100644 --- a/R/class-KPartiteNetwork.R +++ b/R/class-KPartiteNetwork.R @@ -2,14 +2,9 @@ check_kpartite_network <- function(object) { errors <- character() - # Ensure that no node is in multiple partitions - if (length(unique(unlist(object@partitions))) < length(unlist(object@partitions))) { - errors <- c(errors, 'Found a node in multiple partitions. Nodes can only exist in one partition.') - } - - # Check that all nodes are in at least one of the columns - if (!all(getNodeIds(object@nodes) %in% unlist(object@partitions))) { - errors <- c(errors, 'Found a node that is not in any partition. All nodes must be assigned to a partition.') + # 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"') } return(if (length(errors) == 0) TRUE else errors) @@ -36,12 +31,39 @@ check_kpartite_network <- function(object) { KPartiteNetwork <- setClass("KPartiteNetwork", contains = "Network", representation( - partitions = "list" + partitions = Partitions ), prototype = prototype( links = LinkList(), nodes = NodeList(), linkColorScheme = 'none', - partitions = list() + partitions = Partitions() ), validity = check_kpartite_network +) + +check_partitions <- function(object) { + errors <- character() + + # Ensure that no node is in multiple partitions + if (length(unique(unlist(object@partitions))) < length(unlist(object@partitions))) { + errors <- c(errors, 'Found a node in multiple partitions. Nodes can only exist in one partition.') + } + + # Check that all nodes are in at least one of the columns + if (!all(getNodeIds(object@nodes) %in% unlist(object@partitions))) { + errors <- c(errors, 'Found a node that is not in any partition. All nodes must be assigned to a partition.') + } + if (!all(unlist(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.') + } + + return(if (length(errors) == 0) TRUE else errors) +} + +Partitions <- setClass("Partitions", + contains = "SimpleList", + prototype = prototype( + elementType = "NodeIdList" + ), + validity = check_partitions ) \ No newline at end of file diff --git a/R/class-Node.R b/R/class-Node.R index 516d6cc..c3498f3 100644 --- a/R/class-Node.R +++ b/R/class-Node.R @@ -38,7 +38,7 @@ check_node <- function(object) { #' @export Node <- setClass("Node", representation( - id = "character", + id = NodeId, x = "numeric", y = "numeric", color = "ANY", @@ -50,6 +50,60 @@ Node <- setClass("Node", validity = check_node ) +check_node_id <- function(object) { + errors <- character() + + # node id must not be empty + if (length(object@id) == 0) { + errors <- c(errors, "Node id must not be empty") + } + + return(if (length(errors) == 0) TRUE else errors) +} + +#' A Node Id +#' +#' A class for representing node ids +#' +#' @name NodeId-class +#' @rdname NodeId-class +#' @export +NodeId <- setClass("NodeId", + representation( + id = "character" + ), + prototype = prototype( + id = character() + ), + validity = check_node_id +) + +check_node_id_list <- function(object) { + errors <- character() + + # make sure all ids are unique + if (length(unique(unlist(lapply(object, id)))) != length(unlist(lapply(object, id)))) { + errors <- c(errors, "Node ids must be unique") + } + + return(if (length(errors) == 0) TRUE else errors) +} + + +#' A Node Id List +#' +#' A class for representing node id lists +#' +#' @name NodeIdList-class +#' @rdname NodeIdList-class +#' @export +NodeIdList <- setClass("NodeIdList", + contains = "SimpleList", + prototype = prototype( + elementType = "NodeId" + ), + validity = check_node_id_list +) check_node_list <- function(object) { diff --git a/R/methods-Nodes.R b/R/methods-Nodes.R index 8c213bb..176decb 100644 --- a/R/methods-Nodes.R +++ b/R/methods-Nodes.R @@ -4,17 +4,39 @@ # Accessors for fanciness setGeneric("id", function(object) standardGeneric("id")) setGeneric("id<-", function(object, value) standardGeneric("id<-")) +setGeneric("x", function(object) standardGeneric("x")) +setGeneric("x<-", function(object, value) standardGeneric("x<-")) +setGeneric("y", function(object) standardGeneric("y")) +setGeneric("y<-", function(object, value) standardGeneric("y<-")) +setGeneric("color", function(object) standardGeneric("color")) +setGeneric("color<-", function(object, value) standardGeneric("color<-")) +setGeneric("weight", function(object) standardGeneric("weight")) +setGeneric("weight<-", function(object, value) standardGeneric("weight<-")) -setMethod("id", "Node", function(object) object@id) +## Methods for Nodes +setMethod("id", "Node", function(object) object@NodeId@id) +setMethod("x", "Node", function(object) object@x) +setMethod("y", "Node", function(object) object@y) setMethod("color", "Node", function(object) object@color) setMethod("weight", "Node", function(object) object@weight) -setMethod("id<-", "Node", function(object, value) {object@id <- value; validObject(object); object}) +setMethod("id<-", "Node", function(object, value) {object@NodeId@id <- value; validObject(object); object}) +setMethod("x<-", "Node", function(object, value) {object@x <- value; validObject(object); object}) +setMethod("y<-", "Node", function(object, value) {object@y <- value; validObject(object); object}) setMethod("color<-", "Node", function(object, value) {object@color <- value; validObject(object); object}) setMethod("weight<-", "Node", function(object, value) {object@weight <- value; validObject(object); object}) +## Methods for NodeId +setMethod("id", "NodeId", function(object) object@id) +setMethod("id<-", "NodeId", function(object, value) {object@id <- value; validObject(object); object}) ## Methods for NodeLists setGeneric("getNodeIds", function(object) standardGeneric("getNodeIds")) +setGeneric("getWeights", function(object) standardGeneric("getWeights")) +setGeneric("getColors", function(object) standardGeneric("getColors")) + setMethod("getNodeIds", "NodeList", function(object) unlist(lapply(object, function(x) id(x)))) setMethod("getWeights", "NodeList", function(object) unlist(lapply(object, function(x) weight(x)))) -setMethod("getColors", "NodeList", function(object) unlist(lapply(object, function(x) color(x)))) \ No newline at end of file +setMethod("getColors", "NodeList", function(object) unlist(lapply(object, function(x) color(x)))) + +## Methods for NodeIdList +setMethod("getNodeIds", "NodeIdList", function(object) unlist(lapply(object, function(x) id(x)))) \ No newline at end of file From 468c942e4d9c702b074ec9b13afc0275e1328fea Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Thu, 11 Jan 2024 23:31:09 -0500 Subject: [PATCH 23/31] clean up partitions some --- R/class-KPartiteNetwork.R | 18 +++++++++--------- R/methods-Nodes.R | 12 ++++++++---- 2 files changed, 17 insertions(+), 13 deletions(-) diff --git a/R/class-KPartiteNetwork.R b/R/class-KPartiteNetwork.R index b4d3088..caa4cab 100644 --- a/R/class-KPartiteNetwork.R +++ b/R/class-KPartiteNetwork.R @@ -2,6 +2,14 @@ check_kpartite_network <- function(object) { errors <- character() + # Check that all nodes are in at least one of the columns + 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.') + } + 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.') + } + # 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"') @@ -45,18 +53,10 @@ check_partitions <- function(object) { errors <- character() # Ensure that no node is in multiple partitions - if (length(unique(unlist(object@partitions))) < length(unlist(object@partitions))) { + if (getAllNodeIds(object) > unique(getAllNodeIds(object))) { errors <- c(errors, 'Found a node in multiple partitions. Nodes can only exist in one partition.') } - # Check that all nodes are in at least one of the columns - if (!all(getNodeIds(object@nodes) %in% unlist(object@partitions))) { - errors <- c(errors, 'Found a node that is not in any partition. All nodes must be assigned to a partition.') - } - if (!all(unlist(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.') - } - return(if (length(errors) == 0) TRUE else errors) } diff --git a/R/methods-Nodes.R b/R/methods-Nodes.R index 176decb..9d8754a 100644 --- a/R/methods-Nodes.R +++ b/R/methods-Nodes.R @@ -34,9 +34,13 @@ setGeneric("getNodeIds", function(object) standardGeneric("getNodeIds")) setGeneric("getWeights", function(object) standardGeneric("getWeights")) setGeneric("getColors", function(object) standardGeneric("getColors")) -setMethod("getNodeIds", "NodeList", function(object) unlist(lapply(object, function(x) id(x)))) -setMethod("getWeights", "NodeList", function(object) unlist(lapply(object, function(x) weight(x)))) -setMethod("getColors", "NodeList", function(object) unlist(lapply(object, function(x) color(x)))) +setMethod("getNodeIds", "NodeList", function(object) unlist(lapply(as.list(object), function(x) id(x)))) +setMethod("getWeights", "NodeList", function(object) unlist(lapply(as.list(object), function(x) weight(x)))) +setMethod("getColors", "NodeList", function(object) unlist(lapply(as.list(object), function(x) color(x)))) ## Methods for NodeIdList -setMethod("getNodeIds", "NodeIdList", function(object) unlist(lapply(object, function(x) id(x)))) \ No newline at end of file +setMethod("getNodeIds", "NodeIdList", function(object) unlist(lapply(as.list(object), function(x) id(x)))) + +## Methods for Partitions +setGeneric("getAllNodeIds", function(object) standardGeneric("getAllNodeIds")) +setMethod("getAllNodeIds", "Partitions", function(object) unlist(lapply(as.list(object), function(x) getNodeIds(x)))) \ No newline at end of file From 2a67f31617c0c7fbad7a43c2ea2aff1648b4a67c Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Mon, 22 Jan 2024 09:16:44 -0500 Subject: [PATCH 24/31] clean up --- R/class-KPartiteNetwork.R | 49 +++++++++++++++++++++------------------ R/class-Node.R | 5 +--- 2 files changed, 28 insertions(+), 26 deletions(-) diff --git a/R/class-KPartiteNetwork.R b/R/class-KPartiteNetwork.R index caa4cab..9d3c714 100644 --- a/R/class-KPartiteNetwork.R +++ b/R/class-KPartiteNetwork.R @@ -1,3 +1,29 @@ +check_partitions <- function(object) { + errors <- character() + + # Ensure that no node is in multiple partitions + if (getAllNodeIds(object) > unique(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 +Partitions <- setClass("Partitions", + contains = "SimpleList", + prototype = prototype( + elementType = "NodeIdList" + ), + validity = check_partitions +) + check_kpartite_network <- function(object) { errors <- character() @@ -38,32 +64,11 @@ check_kpartite_network <- function(object) { #' @export KPartiteNetwork <- setClass("KPartiteNetwork", contains = "Network", - representation( - partitions = Partitions - ), prototype = prototype( + prototype = prototype( links = LinkList(), nodes = NodeList(), linkColorScheme = 'none', partitions = Partitions() ), validity = check_kpartite_network -) - -check_partitions <- function(object) { - errors <- character() - - # Ensure that no node is in multiple partitions - if (getAllNodeIds(object) > unique(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 <- setClass("Partitions", - contains = "SimpleList", - prototype = prototype( - elementType = "NodeIdList" - ), - validity = check_partitions ) \ No newline at end of file diff --git a/R/class-Node.R b/R/class-Node.R index c3498f3..cae47cc 100644 --- a/R/class-Node.R +++ b/R/class-Node.R @@ -38,15 +38,12 @@ check_node <- function(object) { #' @export Node <- setClass("Node", representation( - id = NodeId, + id = "NodeId", x = "numeric", y = "numeric", color = "ANY", weight = "ANY" ), - prototype = prototype( - id = character() - ), validity = check_node ) From 072d93629db0f74307d5a6b5720ec6b3aa43d91d Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Mon, 22 Jan 2024 09:17:02 -0500 Subject: [PATCH 25/31] update documentation --- NAMESPACE | 6 ++++++ man/Network-class.Rd | 4 +++- man/Node-class.Rd | 4 ++++ man/NodeId-class.Rd | 10 ++++++++++ man/NodeIdList-class.Rd | 10 ++++++++++ man/Partitions-class.Rd | 10 ++++++++++ 6 files changed, 43 insertions(+), 1 deletion(-) create mode 100644 man/NodeId-class.Rd create mode 100644 man/NodeIdList-class.Rd create mode 100644 man/Partitions-class.Rd diff --git a/NAMESPACE b/NAMESPACE index 9096a89..5187299 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -17,7 +17,10 @@ export(Link) export(LinkList) export(Network) export(Node) +export(NodeId) +export(NodeIdList) export(NodeList) +export(Partitions) export(TwoByTwoTable) export(adjustToViewport) export(allStats) @@ -71,7 +74,10 @@ exportClasses(Link) exportClasses(LinkList) exportClasses(Network) exportClasses(Node) +exportClasses(NodeId) +exportClasses(NodeIdList) exportClasses(NodeList) +exportClasses(Partitions) exportClasses(TwoByTwoTable) exportMethods(allStats) exportMethods(chiSqResults) diff --git a/man/Network-class.Rd b/man/Network-class.Rd index acfc111..4f4d281 100644 --- a/man/Network-class.Rd +++ b/man/Network-class.Rd @@ -17,7 +17,9 @@ in case some nodes have no links. A network can also have properties such as dir \item{\code{nodes}}{NodeList object defining the nodes in the network. Some nodes may not have any links.} -\item{\code{linkColorScheme}}{string defining the type of coloring scheme the links follow. Options are 'none' (default) and 'posneg'. +\item{\code{linkColorScheme}}{string defining the type of coloring scheme the links follow. Options are 'none' (default) and 'posneg'.} + +\item{\code{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.} }} diff --git a/man/Node-class.Rd b/man/Node-class.Rd index 4f57b4d..04238e6 100644 --- a/man/Node-class.Rd +++ b/man/Node-class.Rd @@ -13,6 +13,10 @@ A class for representing nodes in a network \describe{ \item{\code{id}}{string a unique identifier for the node} +\item{\code{x}}{numeric value indicating the x coordinate of the node. Optional.} + +\item{\code{y}}{numeric value indicating the y coordinate of the node. Optional.} + \item{\code{color}}{string or numeric that determines the color of the node. Optional.} \item{\code{weight}}{numeric value associated with the node, such as timestamp or other node-associated data. Optional.} diff --git a/man/NodeId-class.Rd b/man/NodeId-class.Rd new file mode 100644 index 0000000..a651ea3 --- /dev/null +++ b/man/NodeId-class.Rd @@ -0,0 +1,10 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/class-Node.R +\docType{class} +\name{NodeId-class} +\alias{NodeId-class} +\alias{NodeId} +\title{A Node Id} +\description{ +A class for representing node ids +} diff --git a/man/NodeIdList-class.Rd b/man/NodeIdList-class.Rd new file mode 100644 index 0000000..40da43d --- /dev/null +++ b/man/NodeIdList-class.Rd @@ -0,0 +1,10 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/class-Node.R +\docType{class} +\name{NodeIdList-class} +\alias{NodeIdList-class} +\alias{NodeIdList} +\title{A Node Id List} +\description{ +A class for representing node id lists +} diff --git a/man/Partitions-class.Rd b/man/Partitions-class.Rd new file mode 100644 index 0000000..0833d33 --- /dev/null +++ b/man/Partitions-class.Rd @@ -0,0 +1,10 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/class-KPartiteNetwork.R +\docType{class} +\name{Partitions-class} +\alias{Partitions-class} +\alias{Partitions} +\title{Partitions} +\description{ +A class for representing partitions in a k-partite network +} From 83e61c8eaebb7cd96ad49bacab658b458a9af4b3 Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Mon, 22 Jan 2024 11:37:26 -0500 Subject: [PATCH 26/31] clean up and add some helpers/ constructors --- R/class-KPartiteNetwork.R | 53 +++++++- R/{class-network.R => class-Network.R} | 3 +- R/class-Node.R | 163 +++++++++++++++++-------- R/methods-Nodes.R | 22 ++-- 4 files changed, 168 insertions(+), 73 deletions(-) rename R/{class-network.R => class-Network.R} (96%) diff --git a/R/class-KPartiteNetwork.R b/R/class-KPartiteNetwork.R index 9d3c714..5c91fd6 100644 --- a/R/class-KPartiteNetwork.R +++ b/R/class-KPartiteNetwork.R @@ -1,9 +1,12 @@ +#' @include methods-Nodes.R check_partitions <- function(object) { errors <- character() - # Ensure that no node is in multiple partitions - if (getAllNodeIds(object) > unique(getAllNodeIds(object))) { - errors <- c(errors, 'Found a node in multiple partitions. Nodes can only exist in one partition.') + if (!!length(getAllNodeIds(object))) { + # Ensure that no node is in multiple partitions + if (length(getAllNodeIds(object)) > 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) @@ -16,7 +19,7 @@ check_partitions <- function(object) { #' @name Partitions-class #' @rdname Partitions-class #' @export -Partitions <- setClass("Partitions", +setClass("Partitions", contains = "SimpleList", prototype = prototype( elementType = "NodeIdList" @@ -24,6 +27,42 @@ Partitions <- setClass("Partitions", 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 +#' +#' @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))) +} + check_kpartite_network <- function(object) { errors <- character() @@ -60,14 +99,18 @@ check_kpartite_network <- function(object) { #' #' @name KPartiteNetwork-class #' @rdname KPartiteNetwork-class -#' @include class-network.R +#' @include class-Network.R #' @export KPartiteNetwork <- setClass("KPartiteNetwork", contains = "Network", + slots = c( + partitions = "Partitions" + ), prototype = prototype( links = LinkList(), nodes = NodeList(), linkColorScheme = 'none', + variableMapping = VariableMetadataList(), partitions = Partitions() ), validity = check_kpartite_network diff --git a/R/class-network.R b/R/class-Network.R similarity index 96% rename from R/class-network.R rename to R/class-Network.R index 65aead2..5edc04f 100644 --- a/R/class-network.R +++ b/R/class-Network.R @@ -44,7 +44,8 @@ Network <- setClass("Network", ), prototype = prototype( links = LinkList(), nodes = NodeList(), - linkColorScheme = 'none' + linkColorScheme = 'none', + variableMapping = VariableMetadataList() ), validity = check_network ) diff --git a/R/class-Node.R b/R/class-Node.R index cae47cc..f9ee1d7 100644 --- a/R/class-Node.R +++ b/R/class-Node.R @@ -1,58 +1,19 @@ -check_node <- function(object) { - +check_node_id <- function(object) { errors <- character() - # Node color must be a string or number - if (!is.null(object@color) & !is.character(object@color) & !is.numeric(object@color)) { - errors <- c(errors, "Node color must be a string or number") + # node id must not be empty + if (length(object@value) == 0) { + errors <- c(errors, "Node id must not be empty") } - # If Node has x it must have y and vice versa - if (!is.null(object@x) & is.null(object@y)) { - errors <- c(errors, "If Node has x it must have y and vice versa") - } else if (is.null(object@x) & !is.null(object@y)) { - errors <- c(errors, "If Node has y it must have x and vice versa") + # must not be NA + if (is.na(object@value)) { + errors <- c(errors, "Node id must not be NA") } - # Node weight must be a number - if (!is.null(object@weight) & !is.numeric(object@weight)) { - errors <- c(errors, "Node weight must be a number") - } - - return(if (length(errors) == 0) TRUE else errors) -} - - -#' Node -#' -#' A class for representing nodes in a network -#' -#' @slot id string a unique identifier for the node -#' @slot x numeric value indicating the x coordinate of the node. Optional. -#' @slot y numeric value indicating the y coordinate of the node. Optional. -#' @slot color string or numeric that determines the color of the node. Optional. -#' @slot weight numeric value associated with the node, such as timestamp or other node-associated data. Optional. -#' -#' @name Node-class -#' @rdname Node-class -#' @export -Node <- setClass("Node", - representation( - id = "NodeId", - x = "numeric", - y = "numeric", - color = "ANY", - weight = "ANY" - ), - validity = check_node -) - -check_node_id <- function(object) { - errors <- character() - - # node id must not be empty - if (length(object@id) == 0) { - errors <- c(errors, "Node id must not be empty") + # must not be '' + if (object@value == "") { + errors <- c(errors, "Node id must not be an empty string") } return(if (length(errors) == 0) TRUE else errors) @@ -65,16 +26,28 @@ check_node_id <- function(object) { #' @name NodeId-class #' @rdname NodeId-class #' @export -NodeId <- setClass("NodeId", +setClass("NodeId", representation( - id = "character" + value = "character" ), prototype = prototype( - id = character() + value = character() ), 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() @@ -94,7 +67,7 @@ check_node_id_list <- function(object) { #' @name NodeIdList-class #' @rdname NodeIdList-class #' @export -NodeIdList <- setClass("NodeIdList", +setClass("NodeIdList", contains = "SimpleList", prototype = prototype( elementType = "NodeId" @@ -102,6 +75,90 @@ NodeIdList <- setClass("NodeIdList", validity = check_node_id_list ) +#' Create a NodeIdList +#' +#' @param nodeIds list of node ids +#' @export +NodeIdList <- function(nodeIds) { + + 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) + nodeIds <- lapply(nodeIds, NodeId) + } else if (all(unlist(lapply(nodeIds, inherits, 'character')))) { + 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))) +} + +check_node <- function(object) { + + errors <- character() + + # Node color must be a string or number + if (!is.null(object@color) & !is.character(object@color) & !is.numeric(object@color)) { + errors <- c(errors, "Node color must be a string or number") + } + + # If Node has x it must have y and vice versa + if (!is.null(object@x) & is.null(object@y)) { + errors <- c(errors, "If Node has x it must have y and vice versa") + } else if (is.null(object@x) & !is.null(object@y)) { + errors <- c(errors, "If Node has y it must have x and vice versa") + } + + # Node weight must be a number + if (!is.null(object@weight) & !is.numeric(object@weight)) { + errors <- c(errors, "Node weight must be a number") + } + + return(if (length(errors) == 0) TRUE else errors) +} + +# this could be made into a generic helper in veupathUtils +# it just generates random alpha-numeric strings +generate_node_id <- function(n = 5000) { + a <- do.call(paste0, replicate(5, sample(LETTERS, n, TRUE), FALSE)) + paste0(a, sprintf("%04d", sample(9999, n, TRUE)), sample(LETTERS, n, TRUE)) +} + +#' Node +#' +#' A class for representing nodes in a network +#' +#' @slot id string a unique identifier for the node +#' @slot x numeric value indicating the x coordinate of the node. Optional. +#' @slot y numeric value indicating the y coordinate of the node. Optional. +#' @slot color string or numeric that determines the color of the node. Optional. +#' @slot weight numeric value associated with the node, such as timestamp or other node-associated data. Optional. +#' +#' @name Node-class +#' @rdname Node-class +#' @export +Node <- setClass("Node", + slots = c( + id = "NodeId", + x = "numeric", + y = "numeric", + color = "ANY", + weight = "ANY" + ), + validity = check_node +) check_node_list <- function(object) { diff --git a/R/methods-Nodes.R b/R/methods-Nodes.R index 9d8754a..f52ee6a 100644 --- a/R/methods-Nodes.R +++ b/R/methods-Nodes.R @@ -8,13 +8,10 @@ setGeneric("x", function(object) standardGeneric("x")) setGeneric("x<-", function(object, value) standardGeneric("x<-")) setGeneric("y", function(object) standardGeneric("y")) setGeneric("y<-", function(object, value) standardGeneric("y<-")) -setGeneric("color", function(object) standardGeneric("color")) -setGeneric("color<-", function(object, value) standardGeneric("color<-")) -setGeneric("weight", function(object) standardGeneric("weight")) -setGeneric("weight<-", function(object, value) standardGeneric("weight<-")) +#' @include methods-Links.R ## Methods for Nodes -setMethod("id", "Node", function(object) object@NodeId@id) +setMethod("id", "Node", function(object) id(object@id)) setMethod("x", "Node", function(object) object@x) setMethod("y", "Node", function(object) object@y) setMethod("color", "Node", function(object) object@color) @@ -26,21 +23,18 @@ setMethod("color<-", "Node", function(object, value) {object@color <- value; val setMethod("weight<-", "Node", function(object, value) {object@weight <- value; validObject(object); object}) ## Methods for NodeId -setMethod("id", "NodeId", function(object) object@id) +setMethod("id", "NodeId", function(object) object@value) setMethod("id<-", "NodeId", function(object, value) {object@id <- value; validObject(object); object}) ## Methods for NodeLists setGeneric("getNodeIds", function(object) standardGeneric("getNodeIds")) -setGeneric("getWeights", function(object) standardGeneric("getWeights")) -setGeneric("getColors", function(object) standardGeneric("getColors")) - -setMethod("getNodeIds", "NodeList", function(object) unlist(lapply(as.list(object), function(x) id(x)))) -setMethod("getWeights", "NodeList", function(object) unlist(lapply(as.list(object), function(x) weight(x)))) -setMethod("getColors", "NodeList", function(object) unlist(lapply(as.list(object), function(x) color(x)))) +setMethod("getNodeIds", "NodeList", function(object) unlist(lapply(as.list(object), id))) +setMethod("getWeights", "NodeList", function(object) unlist(lapply(as.list(object), weight))) +setMethod("getColors", "NodeList", function(object) unlist(lapply(as.list(object), color))) ## Methods for NodeIdList -setMethod("getNodeIds", "NodeIdList", function(object) unlist(lapply(as.list(object), function(x) id(x)))) +setMethod("getNodeIds", "NodeIdList", function(object) unlist(lapply(as.list(object), id))) ## Methods for Partitions setGeneric("getAllNodeIds", function(object) standardGeneric("getAllNodeIds")) -setMethod("getAllNodeIds", "Partitions", function(object) unlist(lapply(as.list(object), function(x) getNodeIds(x)))) \ No newline at end of file +setMethod("getAllNodeIds", "Partitions", function(object) unlist(lapply(as.list(object), getNodeIds))) \ No newline at end of file From 61d49c15f3ce90d82cbba6f8ff0eb3cbd5b46447 Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Mon, 22 Jan 2024 11:37:55 -0500 Subject: [PATCH 27/31] update documentation --- DESCRIPTION | 6 +++--- NAMESPACE | 1 + man/Network-class.Rd | 2 +- man/NodeId-class.Rd | 1 - man/NodeId.Rd | 15 +++++++++++++++ man/NodeIdList-class.Rd | 1 - man/NodeIdList.Rd | 14 ++++++++++++++ man/Partition-class.Rd | 12 ++++++++++++ man/Partitions-class.Rd | 1 - man/Partitions.Rd | 11 +++++++++++ 10 files changed, 57 insertions(+), 7 deletions(-) create mode 100644 man/NodeId.Rd create mode 100644 man/NodeIdList.Rd create mode 100644 man/Partition-class.Rd create mode 100644 man/Partitions.Rd diff --git a/DESCRIPTION b/DESCRIPTION index c139d46..0f2af54 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -45,7 +45,9 @@ Collate: 'class-ContingencyTable.R' 'class-Node.R' 'class-Link.R' - 'class-network.R' + 'class-Network.R' + 'methods-Links.R' + 'methods-Nodes.R' 'class-KPartiteNetwork.R' 'class-plotdata-bar.R' 'class-plotdata-beeswarm.R' @@ -59,8 +61,6 @@ Collate: 'class-plotdata.R' 'group.R' 'methods-ContingencyTable.R' - 'methods-Links.R' - 'methods-Nodes.R' 'methods-network.R' 'panel.R' 'plot.data-package.R' diff --git a/NAMESPACE b/NAMESPACE index 5187299..fe1daf4 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -20,6 +20,7 @@ export(Node) export(NodeId) export(NodeIdList) export(NodeList) +export(Partition) export(Partitions) export(TwoByTwoTable) export(adjustToViewport) diff --git a/man/Network-class.Rd b/man/Network-class.Rd index 4f4d281..ab77309 100644 --- a/man/Network-class.Rd +++ b/man/Network-class.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/class-network.R +% Please edit documentation in R/class-Network.R \docType{class} \name{Network-class} \alias{Network-class} diff --git a/man/NodeId-class.Rd b/man/NodeId-class.Rd index a651ea3..409fa90 100644 --- a/man/NodeId-class.Rd +++ b/man/NodeId-class.Rd @@ -3,7 +3,6 @@ \docType{class} \name{NodeId-class} \alias{NodeId-class} -\alias{NodeId} \title{A Node Id} \description{ A class for representing node ids diff --git a/man/NodeId.Rd b/man/NodeId.Rd new file mode 100644 index 0000000..f8d1b16 --- /dev/null +++ b/man/NodeId.Rd @@ -0,0 +1,15 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/class-Node.R +\name{NodeId} +\alias{NodeId} +\title{Create a Node Id} +\usage{ +NodeId(value) +} +\arguments{ +\item{value}{string a unique identifier for the node} +} +\description{ +Because typing `NodeId(id = 'foo')` is annoying, this function is provided +to make things easier. Now you can do `NodeId('foo')` +} diff --git a/man/NodeIdList-class.Rd b/man/NodeIdList-class.Rd index 40da43d..1720a1b 100644 --- a/man/NodeIdList-class.Rd +++ b/man/NodeIdList-class.Rd @@ -3,7 +3,6 @@ \docType{class} \name{NodeIdList-class} \alias{NodeIdList-class} -\alias{NodeIdList} \title{A Node Id List} \description{ A class for representing node id lists diff --git a/man/NodeIdList.Rd b/man/NodeIdList.Rd new file mode 100644 index 0000000..6ddb4a3 --- /dev/null +++ b/man/NodeIdList.Rd @@ -0,0 +1,14 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/class-Node.R +\name{NodeIdList} +\alias{NodeIdList} +\title{Create a NodeIdList} +\usage{ +NodeIdList(nodeIds) +} +\arguments{ +\item{nodeIds}{list of node ids} +} +\description{ +Create a NodeIdList +} diff --git a/man/Partition-class.Rd b/man/Partition-class.Rd new file mode 100644 index 0000000..9ad0e46 --- /dev/null +++ b/man/Partition-class.Rd @@ -0,0 +1,12 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/class-KPartiteNetwork.R +\name{Partition-class} +\alias{Partition-class} +\alias{Partition} +\title{Create a Partition} +\usage{ +Partition(nodeIds) +} +\description{ +An alias to NodeIdList +} diff --git a/man/Partitions-class.Rd b/man/Partitions-class.Rd index 0833d33..3745ab7 100644 --- a/man/Partitions-class.Rd +++ b/man/Partitions-class.Rd @@ -3,7 +3,6 @@ \docType{class} \name{Partitions-class} \alias{Partitions-class} -\alias{Partitions} \title{Partitions} \description{ A class for representing partitions in a k-partite network diff --git a/man/Partitions.Rd b/man/Partitions.Rd new file mode 100644 index 0000000..616a13d --- /dev/null +++ b/man/Partitions.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/class-KPartiteNetwork.R +\name{Partitions} +\alias{Partitions} +\title{Create Partitions} +\usage{ +Partitions(partitions = list()) +} +\description{ +A list of Partition objects +} From 28543cb191fa64214cda1054ffc2736b2193bf3a Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Mon, 22 Jan 2024 11:38:04 -0500 Subject: [PATCH 28/31] get existing tests passing again --- tests/testthat/test-kpartite-network.R | 39 +++++++++++++------------- tests/testthat/test-links.R | 24 ++++++++-------- tests/testthat/test-network.R | 12 ++++---- tests/testthat/test-nodes.R | 22 +++++++-------- 4 files changed, 49 insertions(+), 48 deletions(-) diff --git a/tests/testthat/test-kpartite-network.R b/tests/testthat/test-kpartite-network.R index d5e698d..9c569b1 100644 --- a/tests/testthat/test-kpartite-network.R +++ b/tests/testthat/test-kpartite-network.R @@ -1,13 +1,13 @@ test_that("k-partite networks can be created", { # Create nodes nodeA <- Node( - id = 'A' + id = NodeId('A') ) nodeB <- Node( - id = 'B' + id = NodeId('B') ) nodeC <- Node( - id = 'C' + id = NodeId('C') ) # Create links @@ -16,14 +16,14 @@ test_that("k-partite networks can be created", { link3 <- Link(source = nodeC, target = nodeA, color = 3, weight = 30) # Create partitions - partition1IDs <- c('A', 'B') - partition2IDs <- c('C') + partition1 <- Partition(list(nodeA, nodeB)) + partition2 <- Partition(nodeC) # Create k-partite network bpnet <- KPartiteNetwork( - links = LinkList(c(link1, link2, link3)), - nodes = NodeList(c(nodeA, nodeB, nodeC)), - partitions = list(partition1IDs, partition2IDs) + links = LinkList(list(link1, link2, link3)), + nodes = NodeList(list(nodeA, nodeB, nodeC)), + partitions = Partitions(list(partition1, partition2)) ) expect_equal(getNodes(bpnet), NodeList(c(nodeA, nodeB, nodeC))) @@ -36,13 +36,13 @@ test_that("k-partite networks cannot be created from nonsensical inputs", { # Create nodes nodeA <- Node( - id = 'A' + id = NodeId('A') ) nodeB <- Node( - id = 'B' + id = NodeId('B') ) nodeC <- Node( - id = 'C' + id = NodeId('C') ) # Create links @@ -51,23 +51,24 @@ test_that("k-partite networks cannot be created from nonsensical inputs", { link3 <- Link(source = nodeC, target = nodeA, color = 3, weight = 30) # Create columns - partition1IDs <- c('A', 'B', 'C') - partition2IDs <- c('C') + partition1 <- Partition(list(nodeA, nodeB, nodeC)) + partition2 <- Partition(nodeC) + # Nodes can't be in both columns expect_error(KPartiteNetwork( - links = LinkList(c(link1, link2, link3)), - nodes = NodeList(c(nodeA, nodeB, nodeC)), - partitons = list(partition1IDs, partition2IDs) + links = LinkList(list(link1, link2, link3)), + nodes = NodeList(list(nodeA, nodeB, nodeC)), + partitions = list(partition1, partition2) )) # All nodes must be in one of the columns - partition1IDs <- c('A') - partition2IDs <- c('C') + partition1 <- Partition(nodeA) + partition2 <- Partition(nodeC) expect_error(KPartiteNetwork( links = LinkList(c(link1, link2, link3)), nodes = NodeList(c(nodeA, nodeB, nodeC)), - partitons = list(partition1IDs, partition2IDs) + partitions = list(partition1IDs, partition2IDs) )) }) diff --git a/tests/testthat/test-links.R b/tests/testthat/test-links.R index db48d7b..383dc5e 100644 --- a/tests/testthat/test-links.R +++ b/tests/testthat/test-links.R @@ -1,10 +1,10 @@ test_that("Links work", { # Make a link nodeA <- Node( - id = 'A' + id = NodeId('A') ) nodeB <- Node( - id = 'B' + id = NodeId('B') ) link <- Link(source = nodeA, target = nodeB) expect_equal(class(link)[1], 'Link') @@ -13,10 +13,10 @@ test_that("Links work", { test_that("Link methods work", { nodeA <- Node( - id = 'A' + id = NodeId('A') ) nodeB <- Node( - id = 'B' + id = NodeId('B') ) link <- Link(source = nodeA, target = nodeB) @@ -37,13 +37,13 @@ test_that("LinkList methods work", { # Create some nodes nodeA <- Node( - id = 'A' + id = NodeId('A') ) nodeB <- Node( - id = 'B' + id = NodeId('B') ) nodeC <- Node( - id = 'C' + id = NodeId('C') ) # Create some links @@ -76,10 +76,10 @@ test_that("Links cannot be created from nonsensical inputs", { # Create nodes nodeA <- Node( - id = 'A' + id = NodeId('A') ) nodeB <- Node( - id = 'B' + id = NodeId('B') ) expect_error(Link(source = nodeA, target = nodeB, color = false, weight = 10)) @@ -89,13 +89,13 @@ test_that("LinkLists cannot be created from nonsensical inputs", { # Create nodes nodeA <- Node( - id = 'A' + id = NodeId('A') ) nodeB <- Node( - id = 'B' + id = NodeId('B') ) nodeC <- Node( - id = 'C' + id = NodeId('C') ) # Create links diff --git a/tests/testthat/test-network.R b/tests/testthat/test-network.R index 38778a7..5a3c12b 100644 --- a/tests/testthat/test-network.R +++ b/tests/testthat/test-network.R @@ -2,13 +2,13 @@ test_that("Networks can be created and their properties accessed", { # Create some nodes nodeA <- Node( - id = 'A' + id = NodeId('A') ) nodeB <- Node( - id = 'B' + id = NodeId('B') ) nodeC <- Node( - id = 'C' + id = NodeId('C') ) # Create some edges @@ -30,13 +30,13 @@ test_that("We cannot make inappropriate networks", { # Create some nodes nodeA <- Node( - id = 'A' + id = NodeId('A') ) nodeB <- Node( - id = 'B' + id = NodeId('B') ) nodeC <- Node( - id = 'C' + id = NodeId('C') ) # Create links diff --git a/tests/testthat/test-nodes.R b/tests/testthat/test-nodes.R index 1827a2f..19ba6cd 100644 --- a/tests/testthat/test-nodes.R +++ b/tests/testthat/test-nodes.R @@ -2,14 +2,14 @@ test_that("Node methods work", { # Create a node nodeA <- Node( - id = 'A' + id = NodeId('A') ) expect_equal(id(nodeA), 'A') expect_equal(color(nodeA), NULL) expect_equal(weight(nodeA), NULL) nodeB <- Node( - id = 'B', + id = NodeId('B'), color = 'red', weight = 10 ) @@ -23,14 +23,14 @@ test_that("NodeList methods work", { # Create some nodes nodeA <- Node( - id = 'A' + id = NodeId('A') ) nodeB <- Node( - id = 'B' + id = NodeId('B') ) nodeC <- Node( - id = 'C' - ) + id = NodeId('C') + ) nodeList <- NodeList(S4Vectors::SimpleList(c(nodeA, nodeB, nodeC))) expect_equal(length(nodeList), 3) @@ -41,17 +41,17 @@ test_that("NodeList methods work", { # Create more interesting nodes nodeA <- Node( - id = 'A', + id = NodeId('A'), color = 'red', weight = 10 ) nodeB <- Node( - id = 'B', + id = NodeId('B'), color = 'blue', weight = 20 ) nodeC <- Node( - id = 'C', + id = NodeId('C'), color = 'green', weight = 30 ) @@ -79,10 +79,10 @@ test_that("We cannot make nonsensical NodeLists", { # Create some nodes nodeA <- Node( - id = 'A' + id = NodeId('A') ) nodeB <- Node( - id = 'B', + id = NodeId('B'), color = 'red' ) From b2948bd64d5a9b0401db1729968cd53c15e3f9a6 Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Mon, 22 Jan 2024 11:48:19 -0500 Subject: [PATCH 29/31] add some tests for NodeId and NodeIdList --- tests/testthat/test-nodes.R | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/tests/testthat/test-nodes.R b/tests/testthat/test-nodes.R index 19ba6cd..52bdf4d 100644 --- a/tests/testthat/test-nodes.R +++ b/tests/testthat/test-nodes.R @@ -1,3 +1,18 @@ +test_that("NodeId works", { + expect_equal(class(NodeId('A'))[1], 'NodeId') +}) + +test_that("NodeIdList works", { + expect_equal(class(NodeIdList(list(NodeId('A'), NodeId('B'))))[1], 'NodeIdList') + expect_equal(class(NodeIdList(list('A', 'B')))[1], 'NodeIdList') + expect_equal(class(NodeIdList(list(Node(id=NodeId('A')))))[1], 'NodeIdList') + expect_equal(class(NodeIdList(Node(id=NodeId('A'))))[1], 'NodeIdList') + expect_equal(class(NodeIdList(list(Node(id=NodeId('A')), Node(id=NodeId('B')))))[1], 'NodeIdList') + + expect_error(NodeIdList(S4Vectors::SimpleList(c(NodeId('A'), 'B')))) + expect_error(NodeIdList(S4Vectors::SimpleList(c('A', 'B')))) +}) + test_that("Node methods work", { # Create a node From 35e41669330c2b7b352c55e610710c7a515aa590 Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Fri, 26 Jan 2024 15:20:03 -0500 Subject: [PATCH 30/31] address review feedback --- DESCRIPTION | 1 + R/class-KPartiteNetwork.R | 8 +++++--- R/class-Link.R | 5 +++++ R/class-Node.R | 2 +- R/methods-KPartiteNetwork.R | 4 ++++ R/methods-Nodes.R | 10 ++++++---- man/Node-class.Rd | 2 +- man/Partitions.Rd | 6 +++++- 8 files changed, 28 insertions(+), 10 deletions(-) create mode 100644 R/methods-KPartiteNetwork.R diff --git a/DESCRIPTION b/DESCRIPTION index 0f2af54..c679767 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -48,6 +48,7 @@ Collate: 'class-Network.R' 'methods-Links.R' 'methods-Nodes.R' + 'methods-KPartiteNetwork.R' 'class-KPartiteNetwork.R' 'class-plotdata-bar.R' 'class-plotdata-beeswarm.R' diff --git a/R/class-KPartiteNetwork.R b/R/class-KPartiteNetwork.R index 5c91fd6..e8a3669 100644 --- a/R/class-KPartiteNetwork.R +++ b/R/class-KPartiteNetwork.R @@ -1,4 +1,4 @@ -#' @include methods-Nodes.R +#' @include methods-KPartiteNetwork.R check_partitions <- function(object) { errors <- character() @@ -38,8 +38,10 @@ Partition <- NodeIdList #' Create Partitions #' -#' A list of Partition objects +#' 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()) { @@ -67,7 +69,7 @@ check_kpartite_network <- function(object) { errors <- character() - # Check that all nodes are in at least one of the columns + # 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.') } diff --git a/R/class-Link.R b/R/class-Link.R index 51f6a48..0ba6b64 100644 --- a/R/class-Link.R +++ b/R/class-Link.R @@ -9,6 +9,11 @@ check_link <- function(object) { errors <- c(errors, "Link color must be a string or number that represents a color or can be mapped to a color.") } + #dont allow self-links for now + if (object@source@id == object@target@id) { + errors <- c(errors, "Links cannot be self-links. They must have a different source and target.") + } + return(if (length(errors) == 0) TRUE else errors) } diff --git a/R/class-Node.R b/R/class-Node.R index f9ee1d7..dfa6fdb 100644 --- a/R/class-Node.R +++ b/R/class-Node.R @@ -140,7 +140,7 @@ generate_node_id <- function(n = 5000) { #' #' A class for representing nodes in a network #' -#' @slot id string a unique identifier for the node +#' @slot id NodeId a unique identifier for the node #' @slot x numeric value indicating the x coordinate of the node. Optional. #' @slot y numeric value indicating the y coordinate of the node. Optional. #' @slot color string or numeric that determines the color of the node. Optional. diff --git a/R/methods-KPartiteNetwork.R b/R/methods-KPartiteNetwork.R new file mode 100644 index 0000000..d646fbd --- /dev/null +++ b/R/methods-KPartiteNetwork.R @@ -0,0 +1,4 @@ +#' @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 diff --git a/R/methods-Nodes.R b/R/methods-Nodes.R index f52ee6a..c6e363b 100644 --- a/R/methods-Nodes.R +++ b/R/methods-Nodes.R @@ -25,6 +25,11 @@ setMethod("weight<-", "Node", function(object, value) {object@weight <- value; v ## Methods for NodeId setMethod("id", "NodeId", function(object) object@value) setMethod("id<-", "NodeId", function(object, value) {object@id <- value; validObject(object); object}) +#alias for the id methods for NodeId +setGeneric("value", function(object) standardGeneric("value")) +setGeneric("value<-", function(object, value) standardGeneric("value<-")) +setMethod("value", "NodeId", function(object) id(object)) +setMethod("value<-", "NodeId", function(object, value) {id(object) <- value; validObject(object); object}) ## Methods for NodeLists setGeneric("getNodeIds", function(object) standardGeneric("getNodeIds")) @@ -34,7 +39,4 @@ setMethod("getColors", "NodeList", function(object) unlist(lapply(as.list(object ## Methods for NodeIdList setMethod("getNodeIds", "NodeIdList", function(object) unlist(lapply(as.list(object), id))) - -## 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("getNodeIds", "Network", function(object) getNodeIds(object@nodes)) \ No newline at end of file diff --git a/man/Node-class.Rd b/man/Node-class.Rd index 04238e6..f62ec59 100644 --- a/man/Node-class.Rd +++ b/man/Node-class.Rd @@ -11,7 +11,7 @@ A class for representing nodes in a network \section{Slots}{ \describe{ -\item{\code{id}}{string a unique identifier for the node} +\item{\code{id}}{NodeId a unique identifier for the node} \item{\code{x}}{numeric value indicating the x coordinate of the node. Optional.} diff --git a/man/Partitions.Rd b/man/Partitions.Rd index 616a13d..1d49f22 100644 --- a/man/Partitions.Rd +++ b/man/Partitions.Rd @@ -6,6 +6,10 @@ \usage{ Partitions(partitions = list()) } +\arguments{ +\item{partitions}{list of Partition (or NodeIdList) objects} +} \description{ -A list of Partition objects +A list of Partition objects, each containing a list of node +ids that belong to a single partition } From 2ce05c6bd64c9056b4cf9bae01fe7549a3a852f8 Mon Sep 17 00:00:00 2001 From: Danielle Callan Date: Fri, 26 Jan 2024 15:21:54 -0500 Subject: [PATCH 31/31] fix bug in link validation --- R/class-Link.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/class-Link.R b/R/class-Link.R index 0ba6b64..425dc8b 100644 --- a/R/class-Link.R +++ b/R/class-Link.R @@ -10,7 +10,7 @@ check_link <- function(object) { } #dont allow self-links for now - if (object@source@id == object@target@id) { + if (id(object@source) == id(object@target)) { errors <- c(errors, "Links cannot be self-links. They must have a different source and target.") }