Skip to content

Commit

Permalink
Fix checks
Browse files Browse the repository at this point in the history
  • Loading branch information
@edelarua
edelarua committed Feb 19, 2025
1 parent 396f5c6 commit a9737e4
Show file tree
Hide file tree
Showing 2 changed files with 73 additions and 99 deletions.
88 changes: 25 additions & 63 deletions R/tbl_filter.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -71,98 +71,60 @@ tbl_filter.tbl_hierarchical <- function(x, filter, keep_empty_summary = TRUE, ..
by_cols <- paste0("group", seq_along(length(ard_args$by)), c("", "_level"))
x_ard <- x$cards$tbl_hierarchical

# add dummy rows for variables not in include so their label rows are filtered correctly
x_ard <- x_ard |> .append_not_incl(ard_args)

# add indices to ARD
x_ard <- x_ard |>
dplyr::group_by(across(c(cards::all_ard_groups(), cards::all_ard_variables(), -all_of(by_cols)))) |>
dplyr::mutate(idx_nofilter = dplyr::cur_group_id())

gps <- x_ard |>
dplyr::group_keys() |>
dplyr::mutate(idx_nofilter = dplyr::row_number()) |>
cards::as_card() |>
cards::rename_ard_groups_shift(shift = -1) |>
dplyr::filter(!variable %in% ard_args$by) |>
dplyr::rename(label = variable_level)

overall_lbl <- x$table_body$label[x$table_body$variable == "..ard_hierarchical_overall.."]
if (length(overall_lbl) > 0) {
gps$label[gps$variable == "..ard_hierarchical_overall.."] <- overall_lbl
if (length(ard_args$variables) > 1) {
gps$group1[gps$variable == "..ard_hierarchical_overall.."] <- "..ard_hierarchical_overall.."
}
}

# match structure of ARD grouping columns to x$table_body grouping columns
gps <- gps |> tidyr::unnest(everything())
outer_cols <- if (length(ard_args$variables) > 1) {
ard_args$variables |>
utils::head(-1) |>
stats::setNames(paste0("group", seq_len(length(ard_args$variables) - 1)))
} else {
NULL
}
for (g in names(outer_cols)) {
which_g <- gps$variable == outer_cols[g]
gps[g][which_g, ] <- gps$variable[which_g]
gps[paste0(g, "_level")][which_g, ] <- gps$label[which_g]
}
x$table_body <- x$table_body |> dplyr::left_join(gps, by = names(gps) |> utils::head(-1))

# re-add dropped args attribute
x_ard <- x_ard |>
dplyr::ungroup() |>
cards::as_card()
attr(x_ard, "args") <- ard_args
# add row indices to match structure of ard to x$table_body
reshape_x <- .reshape_ard_compare(x, x_ard, ard_args)
x <- reshape_x$x
x_ard <- reshape_x$x_ard

# get `by` variable count rows (do not correspond to a table row)
rm_idx <- x_ard |>
dplyr::filter(is.na(group1)) |>
dplyr::pull("idx_nofilter") |>
dplyr::filter(is.na(.data$group1)) |>
dplyr::pull("pre_idx") |>
unique()

# apply filtering
x_ard_filter <- x_ard |> cards::ard_filter({{ filter }})

# pull updated index order after filtering
idx_filter <- x_ard_filter |>
dplyr::pull("idx_nofilter") |>
dplyr::pull("pre_idx") |>
unique() |>
setdiff(rm_idx)

# apply filtering while retaining original row order
idx_filter <- intersect(x$table_body$idx_nofilter, idx_filter)
x$table_body <- x$table_body[match(idx_filter, x$table_body$idx_nofilter), ]
idx_filter <- intersect(x$table_body$pre_idx, idx_filter)
x$table_body <- x$table_body[match(idx_filter, x$table_body$pre_idx), ]

if ("tmp" %in% names(x_ard_filter)) {
x_ard_filter <- x_ard_filter |>
dplyr::filter(is.na(tmp)) |>
dplyr::filter(is.na(.data$tmp)) |>
select(-"tmp")
}

# remove summary rows from empty sections if requested
if (!keep_empty_summary) {
if (!dplyr::last(ard_args$variables) %in% x$table_body$variable) {
x$table_body <- x$table_body |> dplyr::filter(!variable %in% outer_cols)
x_ard_filter <- x_ard_filter |> dplyr::filter(!variable %in% outer_cols)
} else {
for (v in rev(outer_cols)) {
empty_rows <- x$table_body |>
dplyr::filter(variable == dplyr::lead(variable) & variable == v) |>
dplyr::pull("idx_nofilter")
x$table_body <- x$table_body |> dplyr::filter(!idx_nofilter %in% empty_rows)
x_ard_filter <- x_ard_filter |> dplyr::filter(!idx_nofilter %in% empty_rows)
if (length(ard_args$variables) > 1) {
outer_cols <- ard_args$variables |> utils::head(-1)
if (!dplyr::last(ard_args$variables) %in% x$table_body$variable) {
x$table_body <- x$table_body |> dplyr::filter(!.data$variable %in% outer_cols)
x_ard_filter <- x_ard_filter |> dplyr::filter(!.data$variable %in% outer_cols)
} else {
for (v in rev(outer_cols)) {
empty_rows <- x$table_body |>
dplyr::filter(.data$variable == dplyr::lead(.data$variable) & .data$variable == v) |>
dplyr::pull("pre_idx")
x$table_body <- x$table_body |> dplyr::filter(!.data$pre_idx %in% empty_rows)
x_ard_filter <- x_ard_filter |> dplyr::filter(!.data$pre_idx %in% empty_rows)
}
}
}
}

# update x$table_body
x$table_body <- x$table_body |> select(-"idx_nofilter")
x$table_body <- x$table_body |> select(-"pre_idx")

# update x$cards
x$cards$tbl_hierarchical <- x_ard_filter |> select(-"idx_nofilter")
x$cards$tbl_hierarchical <- x_ard_filter |> select(-"pre_idx")

x
}
84 changes: 48 additions & 36 deletions R/tbl_sort.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -56,25 +56,64 @@ tbl_sort.tbl_hierarchical <- function(x, sort = "descending", ...) {
set_cli_abort_call()

ard_args <- attributes(x$cards$tbl_hierarchical)$args
by_cols <- paste0("group", seq_along(length(ard_args$by)), c("", "_level"))
x_ard <- x$cards$tbl_hierarchical

# add row indices match structure of ard to x$table_body
reshape_x <- .reshape_ard_compare(x, x_ard, ard_args, sort)
x <- reshape_x$x
x_ard <- reshape_x$x_ard

# get `by` variable count rows (do not correspond to a table row)
rm_idx <- x_ard |>
dplyr::filter(is.na(.data$group1)) |>
dplyr::pull("pre_idx") |>
unique()

# apply sorting
x_ard_sort <- x_ard |> cards::ard_sort(sort)

# pull updated index order after sorting
idx_sort <- x_ard_sort |>
dplyr::pull("pre_idx") |>
unique() |>
setdiff(rm_idx)

if ("tmp" %in% names(x_ard_sort)) {
x_ard_sort <- x_ard_sort |>
dplyr::filter(is.na(.data$tmp)) |>
select(-"tmp")
}

# update x$cards
x$cards$tbl_hierarchical <- x_ard_sort |> select(-"pre_idx")

# update x$table_body
x$table_body <- x$table_body[match(idx_sort, x$table_body$pre_idx), ] |> select(-"pre_idx")

x
}

.reshape_ard_compare <- function(x, x_ard, ard_args, sort = NULL) {
by_cols <- paste0("group", seq_along(length(ard_args$by)), c("", "_level"))

# add dummy rows for variables not in include so their label rows are sorted correctly
x_ard <- x_ard |> .append_not_incl(ard_args, sort)

# add indices to ARD
x_ard <- x_ard |>
dplyr::group_by(across(c(cards::all_ard_groups(), cards::all_ard_variables(), -all_of(by_cols)))) |>
dplyr::mutate(idx_unsort = dplyr::cur_group_id())
dplyr::mutate(pre_idx = dplyr::cur_group_id())

# get grouping structure
gps <- x_ard |>
dplyr::group_keys() |>
dplyr::mutate(idx_unsort = dplyr::row_number()) |>
dplyr::mutate(pre_idx = dplyr::row_number()) |>
cards::as_card() |>
cards::rename_ard_groups_shift(shift = -1) |>
dplyr::filter(!variable %in% ard_args$by) |>
dplyr::rename(label = variable_level)
dplyr::filter(!.data$variable %in% ard_args$by) |>
dplyr::rename(label = "variable_level")

# match overall row if present
overall_lbl <- x$table_body$label[x$table_body$variable == "..ard_hierarchical_overall.."]
if (length(overall_lbl) > 0) {
gps$label[gps$variable == "..ard_hierarchical_overall.."] <- overall_lbl
Expand Down Expand Up @@ -105,34 +144,7 @@ tbl_sort.tbl_hierarchical <- function(x, sort = "descending", ...) {
cards::as_card()
attr(x_ard, "args") <- ard_args

# get `by` variable count rows (do not correspond to a table row)
rm_idx <- x_ard |>
dplyr::filter(is.na(group1)) |>
dplyr::pull("idx_unsort") |>
unique()

# apply sorting
x_ard_sort <- x_ard |> cards::ard_sort(sort)

# pull updated index order after sorting
idx_sort <- x_ard_sort |>
dplyr::pull("idx_unsort") |>
unique() |>
setdiff(rm_idx)

if ("tmp" %in% names(x_ard_sort)) {
x_ard_sort <- x_ard_sort |>
dplyr::filter(is.na(tmp)) |>
select(-"tmp")
}

# update x$cards
x$cards$tbl_hierarchical <- x_ard_sort |> select(-"idx_unsort")

# update x$table_body
x$table_body <- x$table_body[match(idx_sort, x$table_body$idx_unsort), ] |> select(-"idx_unsort")

x
list(x = x, x_ard = x_ard)
}

.append_not_incl <- function(x, ard_args, sort = NULL) {
Expand All @@ -155,9 +167,9 @@ tbl_sort.tbl_hierarchical <- function(x, sort = "descending", ...) {
if (!is.null(sort) && sort == "descending") {
stat_nm <- setdiff(.df$stat_name, "N")[1]
sum <- .df |>
dplyr::filter(stat_name == !!stat_nm) |>
dplyr::summarize(s = sum(unlist(stat))) |>
dplyr::pull(s)
dplyr::filter(.data$stat_name == !!stat_nm) |>
dplyr::summarize(sum_stat = sum(unlist(.data$stat))) |>
dplyr::pull("sum_stat")
}
g_cur <- .g[[ncol(.g) - 1]]
if (!is.na(g_cur) && g_cur == v) {
Expand Down

0 comments on commit a9737e4

Please sign in to comment.