From 5c0d08c8bd7ed4962e3e69a951b522924a41c64c Mon Sep 17 00:00:00 2001 From: Ed Hagen Date: Wed, 15 Nov 2023 10:26:17 -0800 Subject: [PATCH 1/5] support dagitty objects --- DESCRIPTION | 1 + NAMESPACE | 1 + R/dagitty.R | 9 +++++++++ man/tbl_graph.Rd | 13 +++++++++---- 4 files changed, 20 insertions(+), 4 deletions(-) create mode 100644 R/dagitty.R diff --git a/DESCRIPTION b/DESCRIPTION index 6d16731..9e7598b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -33,6 +33,7 @@ Suggests: ape, covr, data.tree, + dagitty, graph, influenceR, methods, diff --git a/NAMESPACE b/NAMESPACE index cda68ef..6bed630 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -10,6 +10,7 @@ S3method(as.data.frame,tbl_graph) S3method(as.igraph,tbl_graph) S3method(as.list,tbl_graph) S3method(as_tbl_graph,Node) +S3method(as_tbl_graph,dagitty) S3method(as_tbl_graph,data.frame) S3method(as_tbl_graph,default) S3method(as_tbl_graph,dendrogram) diff --git a/R/dagitty.R b/R/dagitty.R new file mode 100644 index 0000000..a8e7ff3 --- /dev/null +++ b/R/dagitty.R @@ -0,0 +1,9 @@ +#' @describeIn tbl_graph Method to deal with dagitty objects from the dagitty package +#' @export +as_tbl_graph.dagitty <- function(x, directed = TRUE, ...) { + rlang::check_installed('dagitty', 'in order to coerce a dagitty object to tbl_graph') + nodes <- data.frame(name = names(x)) + edges <- dagitty::edges(x)[1:2] + names(edges) <- c('from', 'to') + tbl_graph(nodes = nodes, edges = edges, directed = directed) +} diff --git a/man/tbl_graph.Rd b/man/tbl_graph.Rd index 2f2eb1e..b404de1 100644 --- a/man/tbl_graph.Rd +++ b/man/tbl_graph.Rd @@ -1,8 +1,9 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_frame.R, R/data_tree.R, R/dendrogram.R, -% R/graph.R, R/hclust.R, R/igraph.R, R/list.R, R/matrix.R, R/network.R, -% R/phylo.R, R/tbl_graph.R -\name{as_tbl_graph.data.frame} +% Please edit documentation in R/dagitty.R, R/data_frame.R, R/data_tree.R, +% R/dendrogram.R, R/graph.R, R/hclust.R, R/igraph.R, R/list.R, R/matrix.R, +% R/network.R, R/phylo.R, R/tbl_graph.R +\name{as_tbl_graph.dagitty} +\alias{as_tbl_graph.dagitty} \alias{as_tbl_graph.data.frame} \alias{as_tbl_graph.Node} \alias{as_tbl_graph.dendrogram} @@ -22,6 +23,8 @@ \alias{is.tbl_graph} \title{A data structure for tidy graph manipulation} \usage{ +\method{as_tbl_graph}{dagitty}(x, directed = TRUE, ...) + \method{as_tbl_graph}{data.frame}(x, directed = TRUE, ...) \method{as_tbl_graph}{Node}(x, directed = TRUE, mode = "out", ...) @@ -106,6 +109,8 @@ supported. } \section{Functions}{ \itemize{ +\item \code{as_tbl_graph(dagitty)}: Method to deal with dagitty objects from the dagitty package + \item \code{as_tbl_graph(data.frame)}: Method for edge table and set membership table \item \code{as_tbl_graph(Node)}: Method to deal with Node objects from the data.tree package From 2cef20c49de06a28008e33e41844dfc90693d096 Mon Sep 17 00:00:00 2001 From: Ed Hagen Date: Sun, 19 Nov 2023 19:59:10 -0800 Subject: [PATCH 2/5] Added node attributes for which there are getter functions. Added args to get an optional user specified attribute for nodes and edges (with a default of "beta" for edges) --- R/dagitty.R | 21 +++++++++++++++++---- 1 file changed, 17 insertions(+), 4 deletions(-) diff --git a/R/dagitty.R b/R/dagitty.R index a8e7ff3..142feb3 100644 --- a/R/dagitty.R +++ b/R/dagitty.R @@ -1,9 +1,22 @@ #' @describeIn tbl_graph Method to deal with dagitty objects from the dagitty package #' @export -as_tbl_graph.dagitty <- function(x, directed = TRUE, ...) { +as_tbl_graph.dagitty <- function(x, directed = TRUE, node_attr = NULL, edge_attr = 'beta', ...) { rlang::check_installed('dagitty', 'in order to coerce a dagitty object to tbl_graph') - nodes <- data.frame(name = names(x)) - edges <- dagitty::edges(x)[1:2] - names(edges) <- c('from', 'to') + if(vctrs::vec_as_names(edge_attr) != edge_attr) stop('edge_attr must be a string of length > 0') + coords <- dagitty::coordinates(x) + nodes <- tibble::tibble( + name = names(x), + outcome = name %in% dagitty::outcomes(x), + exposure = name %in% dagitty::exposures(x), + latent = name %in% dagitty::latents(x), + x = coords$x, + y = coords$y + ) + if (!is.null(node_attr)){ + if (vctrs::vec_as_names(node_attr) != node_attr) stop('node_attr must be a string of length > 0') + nodes[node_attr] <- dagitty:::.vertexAttributes(x, node_attr)$a + } + edges <- dagitty:::.edgeAttributes(x, edge_attr) + names(edges) <- c('from', 'to', 'type', edge_attr) tbl_graph(nodes = nodes, edges = edges, directed = directed) } From b245d80e3887d5323b828a6354fcd696ef4e839f Mon Sep 17 00:00:00 2001 From: Ed Hagen Date: Tue, 21 Nov 2023 18:42:47 -0800 Subject: [PATCH 3/5] Complete rewrite. Now handles multiple user-defined node and edge attributes. Better error handling. --- R/dagitty.R | 54 +++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 38 insertions(+), 16 deletions(-) diff --git a/R/dagitty.R b/R/dagitty.R index 142feb3..9d77acc 100644 --- a/R/dagitty.R +++ b/R/dagitty.R @@ -1,22 +1,44 @@ #' @describeIn tbl_graph Method to deal with dagitty objects from the dagitty package #' @export -as_tbl_graph.dagitty <- function(x, directed = TRUE, node_attr = NULL, edge_attr = 'beta', ...) { - rlang::check_installed('dagitty', 'in order to coerce a dagitty object to tbl_graph') - if(vctrs::vec_as_names(edge_attr) != edge_attr) stop('edge_attr must be a string of length > 0') - coords <- dagitty::coordinates(x) +#' @importFrom rlang is_empty check_installed +as_tbl_graph.dagitty <- function(x, directed = TRUE, node_attr = NULL, edge_attr = NULL, ...) { + check_installed('dagitty', 'in order to coerce a dagitty object to tbl_graph') + if (!is_empty(intersect(node_attr, c('adjusted', 'latent', 'exposure', 'outcome')))) stop('node_attr cannot be adjusted, exposure, outcome, or latent, as these are automatically added if present') + if (is_empty(names(x))) return(create_empty(0)) + nodes <- tibble::tibble( - name = names(x), - outcome = name %in% dagitty::outcomes(x), - exposure = name %in% dagitty::exposures(x), - latent = name %in% dagitty::latents(x), - x = coords$x, - y = coords$y - ) - if (!is.null(node_attr)){ - if (vctrs::vec_as_names(node_attr) != node_attr) stop('node_attr must be a string of length > 0') - nodes[node_attr] <- dagitty:::.vertexAttributes(x, node_attr)$a + name = names(x) + ) + adjusted <- dagitty::adjustedNodes(x) + if (!is_empty(adjusted)) nodes$adjusted <- nodes$name %in% adjusted + exposure <- dagitty::exposures(x) + if (!is_empty(exposure)) nodes$exposure <- nodes$name %in% exposure + outcome <- dagitty::outcomes(x) + if (!is_empty(outcome)) nodes$outcome <- nodes$name %in% outcome + latent <- dagitty::latents(x) + if (!is_empty(latent)) nodes$latent <- nodes$name %in% latent + coords <- coordinates(x) + if (!all(is.na(coords$x))) { + nodes$x <- coords$x + nodes$y <- coords$y + } + + for (a in node_attr){ + if (vctrs::vec_as_names(a, repair = 'unique') != a) stop('each node_attr must be a string of length > 0') + nodes[a] <- dagitty:::.vertexAttributes(x, a)$a + } + + edges <- dagitty::edges(x) + if (is_empty(edges)){ + edges <- tibble::tibble(from = int(), to = int()) + } else { + edges <- edges[c('v', 'w', 'e')] + names(edges) <- c('from', 'to', 'type') + for (a in edge_attr){ + if (vctrs::vec_as_names(a, repair = 'unique') != a) stop('each edge_attr must be a string of length > 0') + edges[a] <- dagitty:::.edgeAttributes(x, a)$a + } } - edges <- dagitty:::.edgeAttributes(x, edge_attr) - names(edges) <- c('from', 'to', 'type', edge_attr) + tbl_graph(nodes = nodes, edges = edges, directed = directed) } From 8e18e25c12e9a093d1190da7f2d431c99c59fbc8 Mon Sep 17 00:00:00 2001 From: Ed Hagen Date: Wed, 22 Nov 2023 04:02:11 -0800 Subject: [PATCH 4/5] fixed error in empty edges code --- R/dagitty.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/dagitty.R b/R/dagitty.R index 9d77acc..619d281 100644 --- a/R/dagitty.R +++ b/R/dagitty.R @@ -30,7 +30,7 @@ as_tbl_graph.dagitty <- function(x, directed = TRUE, node_attr = NULL, edge_attr edges <- dagitty::edges(x) if (is_empty(edges)){ - edges <- tibble::tibble(from = int(), to = int()) + edges <- tibble::tibble(from = integer(), to = integer()) } else { edges <- edges[c('v', 'w', 'e')] names(edges) <- c('from', 'to', 'type') From f6ba04e0b8544a4bbb14f79eda858dd50e43f134 Mon Sep 17 00:00:00 2001 From: Edward Hagen Date: Sun, 26 Nov 2023 13:34:11 -0800 Subject: [PATCH 5/5] Removed use of internal functions --- NAMESPACE | 2 ++ R/dagitty.R | 26 ++++++++------------------ 2 files changed, 10 insertions(+), 18 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 6bed630..ca0ab8b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -594,11 +594,13 @@ importFrom(rlang,.data) importFrom(rlang,UQS) importFrom(rlang,as_quosure) importFrom(rlang,caller_env) +importFrom(rlang,check_installed) importFrom(rlang,enexpr) importFrom(rlang,enquo) importFrom(rlang,eval_bare) importFrom(rlang,eval_tidy) importFrom(rlang,is_bare_list) +importFrom(rlang,is_empty) importFrom(rlang,list2) importFrom(rlang,quo) importFrom(rlang,quo_text) diff --git a/R/dagitty.R b/R/dagitty.R index 619d281..b752ed4 100644 --- a/R/dagitty.R +++ b/R/dagitty.R @@ -1,9 +1,8 @@ #' @describeIn tbl_graph Method to deal with dagitty objects from the dagitty package #' @export #' @importFrom rlang is_empty check_installed -as_tbl_graph.dagitty <- function(x, directed = TRUE, node_attr = NULL, edge_attr = NULL, ...) { +as_tbl_graph.dagitty <- function(x, directed = TRUE, ...) { check_installed('dagitty', 'in order to coerce a dagitty object to tbl_graph') - if (!is_empty(intersect(node_attr, c('adjusted', 'latent', 'exposure', 'outcome')))) stop('node_attr cannot be adjusted, exposure, outcome, or latent, as these are automatically added if present') if (is_empty(names(x))) return(create_empty(0)) nodes <- tibble::tibble( @@ -17,28 +16,19 @@ as_tbl_graph.dagitty <- function(x, directed = TRUE, node_attr = NULL, edge_attr if (!is_empty(outcome)) nodes$outcome <- nodes$name %in% outcome latent <- dagitty::latents(x) if (!is_empty(latent)) nodes$latent <- nodes$name %in% latent - coords <- coordinates(x) + coords <- dagitty::coordinates(x) if (!all(is.na(coords$x))) { nodes$x <- coords$x nodes$y <- coords$y } - for (a in node_attr){ - if (vctrs::vec_as_names(a, repair = 'unique') != a) stop('each node_attr must be a string of length > 0') - nodes[a] <- dagitty:::.vertexAttributes(x, a)$a - } - - edges <- dagitty::edges(x) - if (is_empty(edges)){ - edges <- tibble::tibble(from = integer(), to = integer()) + e <- dagitty::edges(x) + if (is_empty(e)){ + e <- tibble::tibble(from = integer(), to = integer()) } else { - edges <- edges[c('v', 'w', 'e')] - names(edges) <- c('from', 'to', 'type') - for (a in edge_attr){ - if (vctrs::vec_as_names(a, repair = 'unique') != a) stop('each edge_attr must be a string of length > 0') - edges[a] <- dagitty:::.edgeAttributes(x, a)$a - } + e <- e[c('v', 'w', 'e')] + names(e) <- c('from', 'to', 'type') } - tbl_graph(nodes = nodes, edges = edges, directed = directed) + tbl_graph(nodes = nodes, edges = e, directed = directed) }