Skip to content

Commit

Permalink
Merge pull request #18 from UchidaMizuki/use-tidygraph
Browse files Browse the repository at this point in the history
Use tidygraph
  • Loading branch information
UchidaMizuki authored Jul 28, 2024
2 parents 14b3efe + 41f7b2b commit f80e8b9
Show file tree
Hide file tree
Showing 33 changed files with 735 additions and 1,006 deletions.
4 changes: 2 additions & 2 deletions DESCRIPTION
Original file line number Diff line number Diff line change
Expand Up @@ -15,17 +15,17 @@ Description: Provides data frames for forest or tree data structures. You can
License: MIT + file LICENSE
Encoding: UTF-8
LazyData: true
RoxygenNote: 7.2.3
RoxygenNote: 7.3.2
Imports:
cli,
dplyr,
lifecycle,
memoise,
pillar,
purrr,
rlang,
tibble,
tidygraph,
tidyselect,
vctrs (>= 0.5.2)
Suggests:
covr,
Expand Down
61 changes: 29 additions & 32 deletions NAMESPACE
Original file line number Diff line number Diff line change
Expand Up @@ -2,44 +2,43 @@

S3method(as_forest,grouped_df)
S3method(as_forest,rowwise_df)
S3method(as_tbl_graph,forest)
S3method(as_tibble,forest)
S3method(dim,forest)
S3method(format,forest)
S3method(as_tbl_graph,timbr_forest)
S3method(as_tibble,timbr_forest)
S3method(format,timbr_forest)
S3method(format,timbr_node)
S3method(group_data,forest)
S3method(group_indices,forest)
S3method(group_keys,forest)
S3method(group_size,forest)
S3method(group_vars,forest)
S3method(groups,forest)
S3method(mutate,forest)
S3method(n_groups,forest)
S3method(group_data,timbr_forest)
S3method(group_indices,timbr_forest)
S3method(group_keys,timbr_forest)
S3method(group_size,timbr_forest)
S3method(group_vars,timbr_forest)
S3method(groups,timbr_forest)
S3method(mutate,timbr_forest)
S3method(n_groups,timbr_forest)
S3method(pillar_shaft,timbr_node)
S3method(print,forest)
S3method(rbind,forest)
S3method(relocate,forest)
S3method(rows_patch,forest)
S3method(rows_update,forest)
S3method(rowwise,forest)
S3method(select,forest)
S3method(summarise,forest)
S3method(tbl_format_body,forest)
S3method(tbl_format_footer,forest)
S3method(tbl_format_header,forest)
S3method(tbl_format_setup,forest)
S3method(tbl_sum,forest)
S3method(ungroup,forest)
S3method(print,timbr_forest)
S3method(rbind,timbr_forest)
S3method(rows_patch,timbr_forest)
S3method(rows_update,timbr_forest)
S3method(select,timbr_forest)
S3method(summarise,timbr_forest)
S3method(tbl_format_body,timbr_forest)
S3method(tbl_format_footer,timbr_forest)
S3method(tbl_format_header,timbr_forest)
S3method(tbl_format_setup,timbr_forest)
S3method(tbl_sum,timbr_forest)
S3method(vec_cast,timbr_node)
S3method(vec_cast,timbr_node.timbr_node)
S3method(vec_ptype2,timbr_node)
S3method(vec_ptype2,timbr_node.timbr_node)
S3method(vec_ptype_abbr,timbr_node)
S3method(vec_ptype_full,timbr_node)
export(as_forest)
export(children)
export(climb)
export(forest_by)
export(is_forest)
export(leaves)
export(map_forest)
export(node_name)
export(node_parent)
export(node_value)
export(traverse)
import(vctrs)
Expand All @@ -54,18 +53,16 @@ importFrom(dplyr,n_groups)
importFrom(dplyr,relocate)
importFrom(dplyr,rows_patch)
importFrom(dplyr,rows_update)
importFrom(dplyr,rowwise)
importFrom(dplyr,select)
importFrom(dplyr,summarise)
importFrom(dplyr,ungroup)
importFrom(pillar,pillar_shaft)
importFrom(pillar,tbl_format_body)
importFrom(pillar,tbl_format_footer)
importFrom(pillar,tbl_format_header)
importFrom(pillar,tbl_format_setup)
importFrom(pillar,tbl_sum)
importFrom(rlang,":=")
importFrom(rlang,.data)
importFrom(rlang,.env)
importFrom(tibble,as_tibble)
importFrom(tidygraph,as_tbl_graph)
importFrom(vctrs,vec_cast)
importFrom(vctrs,vec_ptype2)
66 changes: 21 additions & 45 deletions R/children.R
Original file line number Diff line number Diff line change
Expand Up @@ -14,51 +14,27 @@ children <- function(data,
name <- rlang::enquo(name)

if (rlang::quo_is_null(name)) {
name <- vec_slice(data$nodes$.$name, data$roots$.)
name <- vec_unique(name)
stopifnot(
rlang::is_scalar_character(name)
)
} else {
name <- rlang::as_name(name)
root_nodes <- get_root_nodes(data)
name <- vec_unique(get_node_name(root_nodes$.))
}

data <- timbr_pull(data, name)
timbr_children(data, name)
}

timbr_children <- function(data,
name = NULL) {
roots <- data$roots
nodes <- data$nodes

new_root_keys <- drop_node(roots)

if (!is.null(name)) {
new_root_keys <- cbind_check(new_root_keys,
!!name := vec_slice(nodes$.$value, roots$.))
}

# new_nodes
new_root_locs <- vec_in(nodes$.$parent, roots$.)
new_root_nodes <- vec_slice(nodes, new_root_locs)

new_root_keys <- vec_slice(new_root_keys,
vec_match_mem(new_root_nodes$.$parent, roots$.))

new_root_nodes$.$parent <- vec_init_along(NA_integer_, new_root_nodes)
vec_slice(nodes, new_root_locs) <- new_root_nodes

node_locs <- vec_as_location(-roots$., vec_size(nodes))
new_nodes <- vec_slice(nodes, node_locs)
new_node_locs <- vec_seq_along(new_nodes)
new_nodes$.$parent <- new_nodes$.$parent + new_node_locs - node_locs

# new_roots
new_roots <- cbind_check(new_root_keys,
. = vec_slice(new_node_locs,
vec_detect_missing(new_nodes$.$parent)))
new_roots <- dplyr::grouped_df(new_roots, names(new_root_keys))

forest(new_roots, new_nodes)
data <- timbr_pull(data, {{ name }})

roots <- get_root_nodes(data)[names(data$roots)]
name <- vec_unique(get_node_name(roots$.))
roots <- data_frame(drop_node(roots),
!!name := get_node_value(roots$.))

root_node_ids <- get_root_node_ids(data)
parent_node_ids <- get_parent_node_ids(data) |>
purrr::keep(\(x) x %in% root_node_ids)

data$roots <- vec_slice(roots,
vec_match(parent_node_ids, root_node_ids)) |>
grouped_df_roots()
data$graph <- data$graph |>
tidygraph::activate("nodes") |>
dplyr::filter(!tidygraph::node_is_root())
data$roots$. <- get_root_node_ids(data)
data
}
128 changes: 35 additions & 93 deletions R/climb.R
Original file line number Diff line number Diff line change
Expand Up @@ -19,114 +19,56 @@ climb <- function(.data, ...,
}

names <- rlang::enquos(...)

data <- .data
data$nodes <- cbind_check(. = data$nodes$.,
loc = vec_seq_along(data$nodes))
data <- timbr_climb(data, names, .recurse)
data$nodes <- cbind_check(. = data$nodes$.,
vec_slice(drop_node(.data$nodes), data$nodes$loc))
data
timbr_climb(.data, names, .recurse)
}

timbr_climb <- function(data, names, recurse) {
if (vec_is_empty(names)) {
data
} else {
name <- rlang::as_name(names[[1L]])
names <- names[-1L]
return(data)
}

if (recurse) {
nodes <- data$nodes
root_nodes <- vec_slice(nodes, data$roots$.)
root_node_names <- vec_unique(root_nodes$.$name)
name <- rlang::as_name(names[[1]])
names <- names[-1]

frs <- vec_init_along(list(), root_node_names)
if (recurse) {
root_nodes <- get_root_nodes(data)
root_node_names <- vec_unique(get_node_name(root_nodes$.))

for (i in vec_seq_along(root_node_names)) {
root_node_name <- root_node_names[[i]]
fr <- timbr_pull(data, root_node_name)
forests <- vec_init_along(list(), root_node_names)

if (root_node_name == name) {
if (vec_is_empty(names)) {
frs[[i]] <- fr
} else {
fr <- timbr_children(fr, name)
frs[[i]] <- timbr_climb(fr, names, recurse)
}
} else {
fr <- timbr_children(fr)
for (i in vec_seq_along(root_node_names)) {
root_node_name <- root_node_names[[i]]
forest <- timbr_pull(data, root_node_name)

if (vec_is_empty(fr$nodes)) {
frs[[i]] <- fr
} else {
frs[[i]] <- timbr_climb(fr, c(name, names), recurse)
}
if (root_node_name == name) {
if (vec_is_empty(names)) {
forests[[i]] <- forest
} else {
forest <- children(forest, name)
forests[[i]] <- timbr_climb(forest, names, recurse)
}
}
} else {
node_name <- vec_unique(get_node_name(get_root_nodes(forest)$.))

rlang::exec(rbind, !!!frs)
} else {
out <- timbr_pull(data, name)
forest <- children(forest)

if (!vec_is_empty(names)) {
out <- timbr_children(out, name)
out <- timbr_climb(out, names, recurse)
roots <- forest$roots |>
dplyr::ungroup() |>
dplyr::select(!dplyr::all_of(node_name))
forest$roots <- roots |>
grouped_df_roots()

forests[[i]] <- timbr_climb(forest, c(name, names), recurse)
}
out
}
}
}

timbr_pull <- function(data, name) {
roots <- data$roots
nodes <- data$nodes

loc <- timbr_pull_loc(roots, nodes$., name)
new_roots <- loc$new_roots
node_locs <- loc$node_locs

# new_nodes
node_locs <- vec_sort(node_locs)
new_node_locs <- vec_seq_along(node_locs)

new_nodes <- vec_slice(nodes, node_locs)
new_nodes$.$parent <- new_nodes$.$parent + new_node_locs - node_locs

# new_roots
new_root_keys <- drop_node(new_roots)
new_roots <- cbind_check(new_root_keys,
. = vec_slice(new_node_locs, vec_detect_missing(new_nodes$.$parent)))

if (dplyr::is_grouped_df(new_root_keys)) {
new_roots <- dplyr::new_grouped_df(new_roots, group_data(new_root_keys))
}

forest(new_roots, new_nodes)
}

timbr_pull_loc <- function(roots, nodes, name) {
root_nodes <- vec_slice(nodes, roots$.)
name <- tidyselect::vars_pull(vec_unique(root_nodes$name), name)

locs <- vec_equal(root_nodes$name, name,
na_equal = TRUE)
new_roots <- vec_slice(roots, locs)
new_root_nodes <- new_roots$.

grps <- vec_group_loc(nodes$parent)
grps <- vec_slice(grps, !vec_detect_missing(grps$key))
grp_keys <- grps$key
rlang::exec(rbind.timbr_forest, !!!forests)
} else {
forest <- timbr_pull(data, name)

node_locs <- integer()
repeat {
node_locs <- vec_c(new_root_nodes, node_locs)
root_grps <- vec_slice(grps, vec_in(grp_keys, new_root_nodes))
new_root_nodes <- vec_c(!!!root_grps$loc)
if (vec_is_empty(new_root_nodes)) {
break
if (!vec_is_empty(names)) {
forest <- children(forest, name)
forest <- timbr_climb(forest, names, recurse)
}
forest
}
list(new_roots = new_roots,
node_locs = node_locs)
}
58 changes: 58 additions & 0 deletions R/dplyr-rows.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,58 @@
#' @export
rows_update.timbr_forest <- function(x, y,
by = NULL, ...) {
by <- timbr_common_by(by, x, y)
timbr_rows(dplyr::rows_update, x, y, by, ...)
}

#' @export
rows_patch.timbr_forest <- function(x, y,
by = NULL, ...) {
by <- timbr_common_by(by, x, y)
timbr_rows(dplyr::rows_patch, x, y, by, ...)
}

timbr_common_by <- function(by = NULL,
x, y) {
if (!is.null(by)) {
return(by)
}

names_x <- c(names(drop_node(x$roots)),
get_node_name(get_nodes(x)$.))

by <- intersect(names(y), names_x)

# Source: https://github.com/tidyverse/dplyr/blob/main/R/join-common-by.R
by_quoted <- encodeString(by, quote = "\"")
if (length(by_quoted) == 1L) {
by_code <- by_quoted
}
else {
by_code <- paste0("c(", paste(by_quoted, collapse = ", "), ")")
}
cli::cli_inform("Matching, by = {by_code}")

by
}

timbr_rows <- function(f, x, y, by, ...) {
root_nodes <- get_root_nodes(x)
x$graph <- x$graph |>
tidygraph::activate("nodes") |>
dplyr::mutate(.rows = dplyr::row_number())
new_nodes <- x |>
climb(!!!setdiff(by, names(drop_node(root_nodes)))) |>
tibble::as_tibble() |>
dplyr::ungroup() |>
f(y, by, ...) |>
dplyr::select(!dplyr::all_of(by))

x$graph <- x$graph |>
tidygraph::activate("nodes") |>
quiet_focus(dplyr::row_number() %in% new_nodes$.rows) |>
dplyr::mutate(new_nodes) |>
tidygraph::unfocus() |>
dplyr::select(!".rows")
x
}
Loading

0 comments on commit f80e8b9

Please sign in to comment.