diff --git a/.Rbuildignore b/.Rbuildignore index 1ae7c11f8e..f4b12d124a 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -16,3 +16,4 @@ tests/examples tests/manual_tests ^vignettes/videos$ ^vignettes/images/apng$ +^TODOS diff --git a/.gitignore b/.gitignore index bb8552d8b6..c3bb66933e 100644 --- a/.gitignore +++ b/.gitignore @@ -36,3 +36,4 @@ vignettes/*.pdf # Other files .DS_Store +test.rtf diff --git a/NAMESPACE b/NAMESPACE index b6fd535260..57975c6abb 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,5 +1,6 @@ # Generated by roxygen2: do not edit by hand +S3method(as.data.frame,gt_tbl) S3method(print,gt_tbl) export("%>%") export(adjust_luminance) @@ -10,6 +11,7 @@ export(cell_borders) export(cell_fill) export(cell_text) export(cells_column_labels) +export(cells_column_spanners) export(cells_data) export(cells_grand_summary) export(cells_group) @@ -27,7 +29,6 @@ export(cols_merge_uncert) export(cols_move) export(cols_move_to_end) export(cols_move_to_start) -export(cols_split_delim) export(cols_width) export(contains) export(currency) @@ -78,6 +79,7 @@ export(tab_options) export(tab_row_group) export(tab_source_note) export(tab_spanner) +export(tab_spanner_delim) export(tab_stubhead) export(tab_style) export(test_image) diff --git a/R/as_data_frame.R b/R/as_data_frame.R new file mode 100644 index 0000000000..ceb141bb94 --- /dev/null +++ b/R/as_data_frame.R @@ -0,0 +1,30 @@ +#' @export +as.data.frame.gt_tbl <- function(x, ...) { + + data <- x + + data_built <- + data %>% + build_data(context = "html") + + ret <- + data_built %>% + dt_body_get() %>% + as.data.frame(stringsAsFactors = FALSE) + + has_rowname <- + data_built %>% + dt_stub_components() %>% + dt_stub_components_has_rowname() + + if (has_rowname) { + rowname_vals <- + data_built %>% + dt_stub_df_get() %>% + dplyr::pull(rowname) + + rownames(ret) <- rowname_vals + } + + ret +} diff --git a/R/as_latex.R b/R/as_latex.R index 422c31d6f5..a19b9dd1d6 100644 --- a/R/as_latex.R +++ b/R/as_latex.R @@ -37,128 +37,53 @@ as_latex <- function(data) { # Build all table data objects through a common pipeline - built_data <- data %>% build_data(context = "latex") + data <- data %>% build_data(context = "latex") - # Use LaTeX-specific builders to generate the Latex table code - with(built_data, { + # Composition of LaTeX ---------------------------------------------------- - # Add footnote marks to elements of the table columns - boxh_df <- - set_footnote_marks_columns( - footnotes_resolved = footnotes_resolved, - boxh_df = boxh_df, - output = "latex" - ) + # Create a LaTeX fragment for the start of the table + table_start <- create_table_start_l(data = data) - # Add footnote marks to the `data` rows - output_df <- - apply_footnotes_to_output( - output_df = output_df, - footnotes_resolved = footnotes_resolved, - output = "latex" - ) + # Create the heading component + heading_component <- create_heading_component(data = data, context = "latex") - # Add footnote marks to stub group title elements - groups_rows_df <- - set_footnote_marks_stub_groups( - footnotes_resolved = footnotes_resolved, - groups_rows_df = groups_rows_df, - output = "latex" - ) + # Create the columns component + columns_component <- create_columns_component_l(data = data) - # Add footnote marks to the `summary` rows - list_of_summaries <- - apply_footnotes_to_summary( - list_of_summaries = list_of_summaries, - footnotes_resolved = footnotes_resolved - ) + # Create the body component + body_component <- create_body_component_l(data = data) - # Extraction of body content as a vector ---------------------------------- - body_content <- as.vector(t(output_df)) + # Create the source notes component + source_notes_component <- create_source_note_component_l(data = data) - # Composition of LaTeX ---------------------------------------------------- + # Create the footnotes component + footnotes_component <- create_footnotes_component_l(data = data) - # Split `body_content` by slices of rows - row_splits <- split(body_content, ceiling(seq_along(body_content) / n_cols)) + # Create a LaTeX fragment for the ending tabular statement + table_end <- create_table_end_l() - # Create a LaTeX fragment for the start of the table - table_start <- create_table_start_l(col_alignment = col_alignment) + # If the `rmarkdown` package is available, use the + # `latex_dependency()` function to load latex packages + # without requiring the user to do so + if (requireNamespace("rmarkdown", quietly = TRUE)) { - # Create the heading component of the table - heading_component <- - create_heading_component( - heading = heading, - footnotes_resolved = footnotes_resolved, - styles_resolved = styles_resolved, - n_cols = n_cols, - subtitle_defined = subtitle_defined, - output = "latex" - ) + latex_packages <- + lapply(latex_packages(), rmarkdown::latex_dependency) - # Create the columns component of the table - columns_component <- - create_columns_component_l( - boxh_df = boxh_df, - output_df = output_df, - stub_available = stub_available, - spanners_present = spanners_present, - stubhead = stubhead - ) + } else { + latex_packages <- NULL + } - # Create the body component of the table - body_component <- - create_body_component_l( - row_splits = row_splits, - groups_rows_df = groups_rows_df, - col_alignment = col_alignment, - stub_available = stub_available, - summaries_present = summaries_present, - list_of_summaries = list_of_summaries, - n_rows = n_rows, - n_cols = n_cols - ) - - # Create a LaTeX fragment for the ending tabular statement - table_end <- create_table_end_l() - - # Create the footnote component of the table - footnote_component <- - create_footnote_component_l( - footnotes_resolved = footnotes_resolved, - opts_df = opts_df - ) - - # Create the source note component of the table - source_note_component <- - create_source_note_component_l( - source_note = source_note - ) - - # If the `rmarkdown` package is available, use the - # `latex_dependency()` function to load latex packages - # without requiring the user to do so - if (requireNamespace("rmarkdown", quietly = TRUE)) { - - latex_packages <- - lapply(latex_packages(), rmarkdown::latex_dependency) - - } else { - latex_packages <- NULL - } - - # Compose the LaTeX table - latex_table <- - paste0( - table_start, - heading_component, - columns_component, - body_component, - table_end, - footnote_component, - source_note_component, - collapse = "") %>% - knitr::asis_output(meta = latex_packages) - - latex_table - }) + # Compose the LaTeX table + paste0( + table_start, + heading_component, + columns_component, + body_component, + table_end, + footnotes_component, + source_notes_component, + collapse = "" + ) %>% + knitr::asis_output(meta = latex_packages) } diff --git a/R/as_rtf.R b/R/as_rtf.R index edba1fb753..9e17b25fae 100644 --- a/R/as_rtf.R +++ b/R/as_rtf.R @@ -29,398 +29,33 @@ #' @import checkmate #' @export as_rtf <- function(data) { - checkmate::assert_class(data, "gt_tbl") - - context <- "latex" - - # Preparation Work -------------------------------------------------------- - - # Extract all attributes from the data object into `data_attr`; - # this will be one of the main objects going forward - data_attr <- attributes(data) - - # Check the names of objects in `data_attr` - checkmate::assert_names( - x = names(data_attr), - must.include = c( - "names", "row.names", "class", "boxh_df", "stub_df", - "footnotes_df", "styles_df", "rows_df", "cols_df", - "arrange_groups", "opts_df", "formats")) - - # Move original data frame to `data_df` - data_df <- as.data.frame(data) - - # Get the `boxh_df` data frame - boxh_df <- data_attr$boxh_df - - # Get the `stub_df` data frame - stub_df <- data_attr$stub_df - - # Get the `opts_df` data frame - opts_df <- data_attr$opts_df - - # Get the `footnotes_df` data frame - footnotes_df <- data_attr$footnotes_df - - # Get the `styles_df` data frame - styles_df <- data_attr$styles_df - - # Get the `rows_df` data frame - rows_df <- data_attr$rows_df - - # Get the `cols_df` data frame - cols_df <- data_attr$cols_df - - # - # Obtain initial list objects from `data_attr` - # - - # Get the `col_labels` list - col_labels <- data_attr$col_labels - - # Get the `grp_labels` list - grp_labels <- data_attr$grp_labels - - # Get the `formats` list - formats <- data_attr$formats - - # Get the `transforms` list - transforms <- data_attr$transforms - - # Get the `arrange_groups` vector - arrange_groups <- data_attr$arrange_groups - - # Get the `others_group` vector - others_group <- data_attr$others_group[[1]] %||% NA_character_ - - # Get the `heading` object - heading <- data_attr$heading - - # Get the `stubhead` object - stubhead <- data_attr$stubhead - - # Get the `source_note` object - source_note <- data_attr$source_note - - # Get the `col_merge` object - col_merge <- data_attr$col_merge - - # Get the `summary_list` object - summary_list <- data_attr$summary - - # Initialize `output_df` - output_df <- initialize_output_df(data_df) - - # Create `output_df` with rendered values - output_df <- render_formats(output_df, data_df, formats, context) - - # Move input data cells to `output_df` that didn't have - # any rendering applied during `render_formats()` - output_df <- migrate_unformatted_to_output(data_df, output_df, context) - - # Get the reordering df (`rows_df`) for the data rows - rows_df <- get_row_reorder_df(arrange_groups, stub_df) - - # Get the `columns_df` data frame for the data columns - columns_df <- get_column_reorder_df(cols_df, boxh_df) - - # Reassemble the rows and columns of `data_df` in the correct order - output_df <- reassemble_output_df(output_df, rows_df, columns_df) - - # Get the `groups_df` data frame, which is a rearranged representation - # of the stub `groupname` and `rowname` columns - groups_df <- get_groupnames_rownames_df(stub_df, rows_df) - - # Get a `columns_spanners` vector, which has the unique, non-NA - # column spanner labels - columns_spanners <- get_columns_spanners_vec(boxh_df) - - # Create the `groups_rows_df` data frame, which provides information - # on which rows the group rows should appear above - groups_rows_df <- get_groups_rows_df(arrange_groups, groups_df, context) - - # Replace NA values in the `groupname` column if there is a reserved - # label for the unlabeled group - groups_df[is.na(groups_df[, "groupname"]), "groupname"] <- others_group - - # Replace NA values in the `group` and `group_label` columns of - # `group_rows_df` - if (!is.na(others_group)) { - groups_rows_df[ - is.na(groups_rows_df[, "group"]), - c("group", "group_label")] <- others_group - } - - # Apply column names to column labels for any of those column labels not - # explicitly set - boxh_df <- migrate_colnames_to_labels(boxh_df, col_labels, context) - - # Assign default alignment for all columns that haven't had alignment - # explicitly set - boxh_df <- set_default_alignments(boxh_df) - - data_attr$boxh_df <- boxh_df - data_attr$stub_df <- stub_df - data_attr$cols_df <- cols_df - data_attr$data_df <- data_df - data_attr$arrange_groups <- arrange_groups - data_attr$output_df <- output_df - - # Text transformation - for (transform in transforms) { - data_attr <- text_transform_at_location( - loc = transform$resolved, - data_attr = data_attr, - fn = transform$fn) - } - - output_df <- data_attr$output_df - boxh_df <- data_attr$boxh_df - - # Perform any necessary column merge operations - col_merge_output <- - perform_col_merge( - col_merge, data_df, output_df, boxh_df, columns_df, context - ) - - # Rewrite `output_df`, `boxh_df`, and `columns_df` as a result of merging - output_df <- col_merge_output$output_df - boxh_df <- col_merge_output$boxh_df - columns_df <- col_merge_output$columns_df - - # Create the `list_of_summaries` list of lists - list_of_summaries <- - create_summary_dfs(summary_list, data_df, stub_df, output_df, context) - - # Determine if there is a populated stub - stub_available <- is_stub_available(stub_df) - - # Determine if the title has been defined - title_defined <- is_title_defined(heading) - - # Determine if a subtitle has been defined - subtitle_defined <- is_subtitle_defined(heading) - - # Determine if there are any summaries present - summaries_present <- are_summaries_present(list_of_summaries) - - # Determine if there are any spanners present - spanners_present <- are_spanners_present(boxh_df) - # Get the available stub components, if any - stub_components <- get_stub_components(stub_df) - - # Define the `col_alignment` vector, which is a - # vector of column alignment values for all of - # the relevant columns in a table - col_alignment <- - boxh_df["column_align", ] %>% - unlist() %>% unname() - - if (stub_component_is_rowname(stub_components) || - stub_component_is_rowname_groupname(stub_components)) { - - # Combine reordered stub with output table - output_df <- cbind(groups_df["rowname"], output_df) - - # Define the `col_alignment` vector, which is a - # vector of column alignment values for all of - # the relevant columns in a table - col_alignment <- c("right", col_alignment) - } - - # Get the number of rows, columns, and cells in the `output_df` - n_rows <- nrow(output_df) - n_cols <- ncol(output_df) - - # Footnotes --------------------------------------------------------------- - - # Resolve and tidy footnotes - footnotes_resolved <- - resolve_footnotes_styles( - output_df, boxh_df, groups_rows_df, opts_df, arrange_groups, - columns_spanners, title_defined, subtitle_defined, - footnotes_df = footnotes_df, styles_df = NULL) - - # The styles table is not yet available for RTF - styles_resolved <- NULL - - # Add footnote marks to elements of the table columns - boxh_df <- - set_footnote_marks_columns(footnotes_resolved, boxh_df, output = "rtf") - - # Add footnote marks to the `data` rows - output_df <- - apply_footnotes_to_output(output_df, footnotes_resolved, output = "rtf") - - # Add footnote marks to stub group title elements - groups_rows_df <- - set_footnote_marks_stub_groups( - footnotes_resolved, groups_rows_df, output = "rtf" - ) - - # Add footnote marks to the `summary` rows - list_of_summaries <- - apply_footnotes_to_summary(list_of_summaries, footnotes_resolved) - - body_content <- as.vector(t(output_df)) + checkmate::assert_class(data, "gt_tbl") - # Split `body_content` by slices of rows - row_splits_body <- split_body_content(body_content, n_cols) + # Build all table data objects through a common pipeline + data <- data %>% build_data(context = "rtf") # Composition of RTF ------------------------------------------------------ - # Create an RTF fragment for the start of the table + # Create a RTF fragment for the start of the table table_start <- rtf_head() - # Create a heading component of the table and handle any available footnotes - heading_component <- - create_heading_component( - heading, footnotes_resolved, styles_resolved, n_cols, - subtitle_defined, output = "rtf") - - # Get the headings - headings <- names(output_df) - - # Merge the heading labels - headings_rev <- headings %>% rev() - labels_rev <- boxh_df[2, ] %>% unname() %>% t() %>% as.vector() %>% rev() - - for (i in seq(labels_rev)) { - headings_rev[i] <- labels_rev[i] - } - headings <- rev(headings_rev) - - # If `stub_available` == TRUE, then replace with a set stubhead - # caption or nothing - if (stub_available && length(stubhead) > 0 && - "rowname" %in% headings) { - - headings[which(headings == "rowname")] <- stubhead$label - - } else if ("rowname" %in% headings) { - - headings[which(headings == "rowname")] <- "" - } - - # Remove any HTML tags from `headings` - headings <- remove_html(headings) + # Create the heading component + heading_component <- create_heading_component(data = data, context = "rtf") - if (spanners_present == FALSE) { + # Create the columns component + columns_component <- create_columns_component_r(data = data) - columns_component <- - paste0(rtf_heading_row(content = headings), collapse = "") + # Create the body component + body_component <- create_body_component_r(data = data) - } else { + # Create the footnotes component + footnotes_component <- create_footnotes_component_r(data = data) - # spanners - spanners <- boxh_df[1, ] %>% t() %>% as.vector() - - # Remove any HTML tags from `spanners` - spanners <- remove_html(spanners) - - if (stub_available) { - spanners <- c(NA_character_, spanners) - } - - for (i in seq(spanners)) { - if (is.na(spanners[i])) { - spanners[i] <- headings[i] - } - } - - spanners_lengths <- rle(spanners) - - columns_component <- - rtf_heading_group_row( - spanners_lengths = spanners_lengths, - headings = headings, - spanners = spanners) - } - - # Create the body component of the table - # Split the body_content by slices of rows - row_splits <- split(body_content, ceiling(seq_along(body_content)/n_cols)) - - body_rows <- c() - for (i in 1:n_rows) { - - # Process group rows - if (!is.null(groups_rows_df) && - i %in% groups_rows_df$row) { - - body_rows <- - c(body_rows, - rtf_body_row( - c( - groups_rows_df[which(groups_rows_df$row %in% i), 1][[1]], - rep("", n_cols - 1)), type = "group")) - } - - # Process "data" rows - if (i != length(row_splits)) { - body_rows <- - c(body_rows, rtf_body_row(row_splits[[i]], type = "row")) - } else { - body_rows <- - c(body_rows, rtf_last_body_row(content = row_splits[[i]])) - } - - # Process summary rows - if (stub_available && summaries_present && - i %in% groups_rows_df$row_end) { - - group <- - groups_rows_df %>% - dplyr::filter(row_end == i) %>% - dplyr::pull(group) - - if (group %in% names(list_of_summaries$summary_df_display_list)) { - - summary_df <- - list_of_summaries$summary_df_display_list[[ - which(names(list_of_summaries$summary_df_display_list) == group)]] %>% - as.data.frame(stringsAsFactors = FALSE) - - body_content_summary <- - as.vector(t(summary_df)) %>% - tidy_gsub("\u2014", "-") - - row_splits_summary <- - split_body_content( - body_content = body_content_summary, - n_cols = n_cols) - - for (j in seq(length(row_splits_summary))) { - - body_rows <- - c(body_rows, rtf_body_row(row_splits_summary[[j]], type = "row")) - } - } - } - } - - body_component <- paste0(body_rows, collapse = "") - - # Create the source note rows and handle any available footnotes - if (length(source_note) != 0) { - - # Create a source note - source_note_rows <- - paste0( - "\\pard\\pardeftab720\\sl288\\slmult1\\partightenfactor0\n", - paste0( - "\\cf0 \\strokec2 ", remove_html(data_attr$source_note[[1]]), "\\\n", - collapse = ""), - collapse = "") - } else { - source_note_rows <- "" - } - - # Handle any available footnotes - footnote_component <- - create_footnote_component_rtf(footnotes_resolved, opts_df) + # Create the source notes component + source_notes_component <- create_source_notes_component_r(data = data) + # Create a LaTeX fragment for the ending tabular statement table_end <- "}\n" # Compose the RTF table @@ -430,10 +65,11 @@ as_rtf <- function(data) { heading_component, columns_component, body_component, - footnote_component, - source_note_rows, + footnotes_component, + source_notes_component, table_end, - collapse = "") + collapse = "" + ) if (isTRUE(getOption('knitr.in.progress'))) { rtf_table <- rtf_table %>% knitr::raw_output() diff --git a/R/build_data.R b/R/build_data.R index 85891119de..c362db5027 100644 --- a/R/build_data.R +++ b/R/build_data.R @@ -5,329 +5,73 @@ build_data <- function(data, context) { checkmate::assert_class(data, "gt_tbl") - # Extract all attributes from the data object into `data_attr`; - # this will be one of the main objects going forward - data_attr <- attributes(data) + # # Check the names of objects in `data` + # checkmate::assert_names( + # x = names(data_attr), + # must.include = c( + # "_boxh", "_spanners", + # "names", "row.names", "class", "stub_df", + # "footnotes_df", "styles_df", "rows_df", "cols_df", + # "arrange_groups", "opts_df", + # "formats", "transforms") + # ) + + # Create `body` with rendered values; move + # input data cells to `body` that didn't have + # any rendering applied during `render_formats()`; + # Reassemble the rows and columns of `body` in + # the correct order + data <- + data %>% + dt_body_build() %>% + render_formats(context = context) %>% + migrate_unformatted_to_output(context = context) %>% + perform_col_merge(context = context) %>% + perform_text_transforms() + + data <- + data %>% + dt_body_reassemble() %>% + reorder_stub_df() %>% + reorder_footnotes() %>% + reorder_styles() + + # Use `dt_*_build()` methods + data <- + data %>% + dt_boxhead_build(context = context) %>% + dt_spanners_build(context = context) %>% + dt_heading_build(context = context) %>% + dt_stubhead_build(context = context) %>% + dt_source_notes_build(context = context) %>% + dt_summary_build(context = context) %>% + dt_groups_rows_build(context = context) - # Check the names of objects in `data_attr` - checkmate::assert_names( - x = names(data_attr), - must.include = c( - "names", "row.names", "class", "boxh_df", "stub_df", - "footnotes_df", "styles_df", "rows_df", "cols_df", - "col_labels", "grp_labels", "arrange_groups", "opts_df", - "formats", "transforms") - ) - - # Move original data frame to `data_df` - data_df <- as.data.frame(data) - - # - # Obtain initial data frame objects from `data_attr` - # - - # Get the `boxh_df` data frame - boxh_df <- data_attr$boxh_df - - # Get the `stub_df` data frame - stub_df <- data_attr$stub_df - - # Get the `opts_df` data frame - opts_df <- data_attr$opts_df - - # Get the `footnotes_df` data frame - footnotes_df <- data_attr$footnotes_df - - # Get the `styles_df` data frame - styles_df <- data_attr$styles_df - - # Get the `rows_df` data frame - rows_df <- data_attr$rows_df - - # Get the `cols_df` data frame - cols_df <- data_attr$cols_df - - # - # Obtain initial list objects from `data_attr` - # - - # Get the `col_labels` list - col_labels <- data_attr$col_labels - - # Get the `grp_labels` list - grp_labels <- data_attr$grp_labels - - # Get the `formats` list - formats <- data_attr$formats - - # Get the `transforms` list - transforms <- data_attr$transforms - - # Get the `arrange_groups` vector - arrange_groups <- data_attr$arrange_groups - - # Get the `others_group` vector - others_group <- data_attr$others_group[[1]] %||% NA_character_ - - # Get and process the `heading` object - heading <- - data_attr$heading %>% - process_heading(context = context) - - # Get and process the `stubhead` object - stubhead <- - data_attr$stubhead %>% - process_stubhead(context = context) - - # Get and process the `source_note` object - source_note <- - data_attr$source_note %>% - process_source_notes(context = context) - - # Get the `col_merge` object - col_merge <- data_attr$col_merge - - # Get the `summary_list` object - summary_list <- data_attr$summary - - # Initialize `output_df` - output_df <- initialize_output_df(data_df = data_df) - - # Create `output_df` with rendered values - output_df <- - render_formats( - output_df = output_df, - data_df = data_df, - formats = formats, - context = context - ) - - # Move input data cells to `output_df` that didn't have - # any rendering applied during `render_formats()` - output_df <- - migrate_unformatted_to_output( - data_df = data_df, - output_df = output_df, - context = context - ) - - # Get the reordering df (`rows_df`) for the data rows - rows_df <- - get_row_reorder_df( - arrange_groups = arrange_groups, - stub_df = stub_df - ) - - # Get the `columns_df` data frame for the data columns - columns_df <- - get_column_reorder_df( - cols_df = cols_df, - boxh_df = boxh_df - ) - - # Reassemble the rows and columns of `data_df` in the correct order - output_df <- - reassemble_output_df( - output_df = output_df, - rows_df = rows_df, - columns_df = columns_df - ) - - # Get the `groups_df` data frame, which is a rearranged representation - # of the stub `groupname` and `rowname` columns - groups_df <- - get_groupnames_rownames_df( - stub_df = stub_df, - rows_df = rows_df - ) - - # Process column labels and migrate those to `boxh_df` - boxh_df <- migrate_colnames_to_labels(boxh_df, col_labels, context) - - # Process group labels and migrate those to `boxh_df` - boxh_df <- migrate_grpnames_to_labels(boxh_df, grp_labels, context) - - # Assign default alignment for all columns that haven't had alignment - # explicitly set - boxh_df <- set_default_alignments(boxh_df = boxh_df) - - # Get a `columns_spanners` vector, which has the unique, non-NA - # spanner column labels - columns_spanners <- get_columns_spanners_vec(boxh_df = boxh_df) - - # Create the `groups_rows_df` data frame, which provides information - # on which rows the group rows should appear above - groups_rows_df <- - get_groups_rows_df( - arrange_groups = arrange_groups, - groups_df = groups_df, - context = context - ) - - # Replace NA values in the `groupname` column if there is a reserved - # label for the unlabeled group - groups_df <- replace_na_groups_df(groups_df, others_group) - - # Replace NA values in the `group` and `group_label` columns of - # `group_rows_df` - groups_rows_df <- replace_na_groups_rows_df(groups_rows_df, others_group) - - data_attr$boxh_df <- boxh_df - data_attr$stub_df <- stub_df - data_attr$cols_df <- cols_df - data_attr$data_df <- data_df - data_attr$arrange_groups <- arrange_groups - data_attr$output_df <- output_df - - # Text transformation - for (transform in transforms) { - - data_attr <- - text_transform_at_location( - loc = transform$resolved, - data_attr = data_attr, - fn = transform$fn - ) - } - - output_df <- data_attr$output_df - boxh_df <- data_attr$boxh_df - - # Perform any necessary column merge operations - col_merge_output <- - perform_col_merge( - col_merge = col_merge, - data_df = data_df, - output_df = output_df, - boxh_df = boxh_df, - columns_df = columns_df, - context = context - ) - - # Rewrite `output_df`, `boxh_df`, and `columns_df` as a result of merging - output_df <- col_merge_output$output_df - boxh_df <- col_merge_output$boxh_df - columns_df <- col_merge_output$columns_df - - # Create the `list_of_summaries` list of lists - list_of_summaries <- - create_summary_dfs( - summary_list = summary_list, - data_df = data_df, - stub_df = stub_df, - output_df = output_df, - context = context - ) - - # Determine if there is a populated stub - stub_available <- is_stub_available(stub_df = stub_df) - - # Determine if the title has been defined - title_defined <- is_title_defined(heading = heading) - - # Determine if a subtitle has been defined - subtitle_defined <- is_subtitle_defined(heading = heading) - - # Determine if there are any summaries present - summaries_present <- - are_summaries_present(list_of_summaries = list_of_summaries) - - # Determine if there are any spanners present - spanners_present <- are_spanners_present(boxh_df = boxh_df) - - # Get the available stub components, if any - stub_components <- get_stub_components(stub_df = stub_df) - - # Define the `col_alignment` vector, which is a - # vector of column alignment values for all of - # the relevant columns in a table - col_alignment <- - boxh_df["column_align", ] %>% - unlist() %>% unname() + # Resolution of footnotes and styles -------------------------------------- - if (stub_component_is_rowname(stub_components = stub_components) || - stub_component_is_rowname_groupname(stub_components = stub_components)) { + # Resolve footnotes and styles + data <- + data %>% + resolve_footnotes_styles(tbl_type = "footnotes") %>% + resolve_footnotes_styles(tbl_type = "styles") - # Combine reordered stub with output table - output_df <- cbind(groups_df["rowname"], output_df) + # Add footnote marks to elements of the table columns + data <- set_footnote_marks_columns(data = data, context = context) - # Define the `col_alignment` vector, which is a - # vector of column alignment values for all of - # the relevant columns in a table - col_alignment <- c("left", col_alignment) - } + # Add footnote marks to the stubhead label + data <- set_footnote_marks_stubhead(data = data, context = context) - # Get the number of rows, columns, and cells in the `output_df` - n_rows <- nrow(output_df) - n_cols <- ncol(output_df) + # Add footnote marks to the `data` rows + data <- apply_footnotes_to_output(data = data, context = context) - # Resolution of footnotes and styles -------------------------------------- + # Add footnote marks to the row group cells + data <- set_footnote_marks_row_groups(data = data, context = context) - # Resolve and tidy footnotes - footnotes_resolved <- - resolve_footnotes_styles( - output_df = output_df, - boxh_df = boxh_df, - groups_rows_df = groups_rows_df, - opts_df = opts_df, - arrange_groups = arrange_groups, - columns_spanners = columns_spanners, - title_defined = title_defined, - subtitle_defined = subtitle_defined, - footnotes_df = footnotes_df, - styles_df = NULL - ) + # Add footnote marks to the `summary` cells + # TODO: `context` is missing in `apply_footnotes_to_summary()` + data <- apply_footnotes_to_summary(data = data) - # Resolve the styles table - styles_resolved <- - resolve_footnotes_styles( - output_df = output_df, - boxh_df = boxh_df, - groups_rows_df = groups_rows_df, - opts_df = opts_df, - arrange_groups = arrange_groups, - columns_spanners = columns_spanners, - title_defined = title_defined, - subtitle_defined = subtitle_defined, - footnotes_df = NULL, - styles_df = styles_df - ) + data <- dt_has_built_set(data = data, value = TRUE) - list( - data_df = data_df, - boxh_df = boxh_df, - stub_df = stub_df, - opts_df = opts_df, - footnotes_df = footnotes_df, - styles_df = styles_df, - output_df = output_df, - rows_df = rows_df, - cols_df = cols_df, - columns_df = columns_df, - formats = formats, - transforms = transforms, - arrange_groups = arrange_groups, - others_group = others_group, - groups_df = groups_df, - groups_rows_df = groups_rows_df, - heading = heading, - columns_spanners = columns_spanners, - source_note = source_note, - stubhead = stubhead, - stub_components = stub_components, - col_alignment = col_alignment, - col_merge = col_merge, - col_merge_output = col_merge_output, - list_of_summaries = list_of_summaries, - summary_list = summary_list, - footnotes_resolved = footnotes_resolved, - styles_resolved = styles_resolved, - stub_available = stub_available, - title_defined = title_defined, - subtitle_defined = subtitle_defined, - spanners_present = spanners_present, - summaries_present = summaries_present, - n_rows = n_rows, - n_cols = n_cols - ) + data } diff --git a/R/cells_column_labels.R b/R/cells_column_labels.R deleted file mode 100644 index e5fbe74c7d..0000000000 --- a/R/cells_column_labels.R +++ /dev/null @@ -1,42 +0,0 @@ - -resolve_location.cells_column_labels <- function(loc, data_attr) { - - data_df <- data_attr[["data_df"]] - - if (!is.null(loc$columns)) { - - loc$colnames <- - resolve_vars( - var_expr = !!loc$columns, - data = data_df) - } - - # TODO: for now, when groups is set to TRUE, the - # behavior is not to select all groups; this - # should be changed to select all group - - # TODO: implement a stop() if groups provided not - # in the available set of groups - class(loc) <- c("resolved", class(loc)) - - loc -} - -text_transform_at_location.cells_column_labels <- function(loc, - data_attr, - func = identity) { - - loc <- to_output_location(loc, data_attr) - boxh_df <- data_attr[["boxh_df"]] - - for (colname in loc$colnames) { - - if (colname %in% colnames(boxh_df)) { - boxh_df["column_label", colname] <- func(boxh_df["column_label", colname]) - } - } - - data_attr$boxh_df <- boxh_df - - data_attr -} diff --git a/R/cells_data.R b/R/cells_data.R deleted file mode 100644 index a5350f8e42..0000000000 --- a/R/cells_data.R +++ /dev/null @@ -1,69 +0,0 @@ - -resolve_location.cells_data <- function(loc, data_attr) { - - data_df <- data_attr[["data_df"]] - stub_df <- data_attr[["stub_df"]] - - loc$columns <- - resolve_vars_idx( - var_expr = !!loc[["columns"]], - data = data_df - ) - - loc$rows <- - resolve_data_vals_idx( - var_expr = !!loc[["rows"]], - data = data_df, - vals = stub_df$rowname - ) - - class(loc) <- c("resolved", class(loc)) - - loc -} - -to_output_location.cells_data <- function(loc, data_attr) { - - loc <- resolve_location(loc, data_attr) - - columns_df <- - get_column_reorder_df( - cols_df = data_attr$cols_df, - boxh_df = data_attr$boxh_df - ) - - rows_df <- - get_row_reorder_df( - arrange_groups = data_attr$arrange_groups, - stub_df = data_attr$stub_df - ) - - # We shouldn't need to do this, but output_df doesn't match up exactly to - # the colnum_final values due to groupnames/rownames - loc$colnames <- colnames(data_attr[["data_df"]])[loc$columns] - loc$columns <- columns_df$colnum_final[loc$columns] - loc$rows <- rows_df$rownum_final[loc$rows] - - class(loc) <- c("output_relative", class(loc)) - loc -} - -text_transform_at_location.cells_data <- function(loc, - data_attr, - fn = identity) { - - loc <- to_output_location(loc, data_attr) - output_df <- data_attr[["output_df"]] - - # Do one vectorized operation per column - for (col in loc$colnames) { - - if (col %in% colnames(output_df)) { - output_df[[col]][loc$rows] <- fn(output_df[[col]][loc$rows]) - } - } - - data_attr$output_df <- output_df - - data_attr -} diff --git a/R/cells_stub.R b/R/cells_stub.R deleted file mode 100644 index bdab3e753d..0000000000 --- a/R/cells_stub.R +++ /dev/null @@ -1,50 +0,0 @@ -# cells_stub - -resolve_location.cells_stub <- function(loc, data_attr) { - - stub_df <- data_attr[["stub_df"]] - - resolved <- resolve_cells_stub(data = stub_df, object = loc) - - loc$rows <- resolved$rows - - class(loc) <- c("resolved", class(loc)) - - loc -} - -to_output_location.cells_stub <- function(loc, data_attr) { - - loc <- resolve_location(loc, data_attr) - - rows_df <- - get_row_reorder_df( - arrange_groups = data_attr$arrange_groups, - stub_df = data_attr$stub_df - ) - - loc$rows <- rows_df$rownum_final[loc$rows] - - class(loc) <- c("output_relative", class(loc)) - loc -} - -text_transform_at_location.cells_stub <- function(loc, - data_attr, - func = identity) { - - loc <- to_output_location(loc, data_attr) - stub_df <- data_attr[["stub_df"]] - - # Do one vectorized operation per - for (row in loc$rows) { - - if (row %in% stub_df$rowname) { - stub_df[row, "rowname"] <- func(stub_df[row, "rowname"]) - } - } - - data_attr$stub_df <- stub_df - - data_attr -} diff --git a/R/compile_scss.R b/R/compile_scss.R index a987ac5b3b..5be69212a5 100644 --- a/R/compile_scss.R +++ b/R/compile_scss.R @@ -3,7 +3,7 @@ compile_scss <- function(data, id = NULL) { # Obtain the SCSS options table from `data` gt_options_tbl <- - attr(data, "opts_df", exact = TRUE) %>% + dt_options_get(data = data) %>% subset(scss) %>% subset(!is.na(value)) diff --git a/R/data_color.R b/R/data_color.R index b52defa124..731e53dcaf 100644 --- a/R/data_color.R +++ b/R/data_color.R @@ -102,7 +102,7 @@ #' type %in% c("chicken", "supreme")) %>% #' dplyr::group_by(type, size) %>% #' dplyr::summarize( -#' sold = n(), +#' sold = dplyr::n(), #' income = sum(price) #' ) %>% #' gt(rowname_col = "size") %>% @@ -131,12 +131,10 @@ data_color <- function(data, apply_to = "fill", autocolor_text = TRUE) { - # Extract `data_df` from the gt object - data_df <- attr(data, "data_df", exact = TRUE) + data_tbl <- dt_data_get(data = data) - # Collect the column names and column indices - # from `data_df` - colnames <- names(data_df) + # Collect the column names from `data_tbl` + colnames <- names(data_tbl) # # Resolution of columns as integer vectors providing the @@ -148,7 +146,7 @@ data_color <- function(data, for (column in resolved_columns) { - data_vals <- data_df[[column]] + data_vals <- data_tbl[[column]] if (inherits(colors, "character")) { @@ -183,11 +181,11 @@ data_color <- function(data, } color_fn <- rlang::enquo(color_fn) - color_fn <- rlang::eval_tidy(color_fn, data_df) + color_fn <- rlang::eval_tidy(color_fn, data_tbl) colors_cols <- color_fn(data_vals) - for (i in seq(data_vals)) { + for (i in seq_along(data_vals)) { color <- colors_cols[i] @@ -252,12 +250,12 @@ scale_apply_styles <- function(data, column, apply_to, styles, - rows_i) { + rows_i = NULL) { - data_df <- attr(data, "data_df") + data_tbl <- dt_data_get(data = data) - if (missing(rows_i)) { - rows_i <- seq(nrow(data_df)) + if (is.null(rows_i)) { + rows_i <- seq(nrow(data_tbl)) } if (length(styles) != length(rows_i)) { @@ -267,8 +265,6 @@ scale_apply_styles <- function(data, call. = FALSE) } - # TODO: this part should be vectorized, with `tab_style()` - # taking a vector of style property values. for (i in seq_along(rows_i)) { if (apply_to == "fill") { diff --git a/R/dt__.R b/R/dt__.R new file mode 100644 index 0000000000..001446fb70 --- /dev/null +++ b/R/dt__.R @@ -0,0 +1,11 @@ +dt__get <- function(data, key) { + + data[[key, exact = TRUE]] +} + +dt__set <- function(data, key, value) { + + data[[key]] <- value + + data +} diff --git a/R/dt_body.R b/R/dt_body.R new file mode 100644 index 0000000000..86ba730139 --- /dev/null +++ b/R/dt_body.R @@ -0,0 +1,63 @@ +.dt_body_key <- "_body" + +dt_body_get <- function(data) { + + ret <- dt__get(data, .dt_body_key) + + if (is.null(ret)) { + stop("Must call `dt_body_build_init()` first.") + } + + ret +} + +dt_body_set <- function(data, body) { + + dt__set(data, .dt_body_key, body %>% dplyr::as_tibble()) +} + +dt_body_build_init <- function(data) { + + body <- dt_data_get(data = data)[, dt_boxhead_get_vars(data = data)] + + if (NROW(body) > 0) { + body[] <- NA_character_ + } + + body %>% + dt_body_set(body = ., data = data) +} + +# Function to reassemble the rows and columns of the `body` +# in a revised order +dt_body_reassemble <- function(data) { + + body <- dt_body_get(data = data) + stub_df <- dt_stub_df_get(data = data) + + groups <- dt_stub_groups_get(data = data) + + # Get the reordering df (`rows_df`) for the data rows + rows_df <- + get_row_reorder_df( + groups = groups, + stub_df = stub_df + ) + + # Get the `columns_df` data frame for the data columns + #columns_df <- get_column_reorder_df(data = data) + + rows <- rows_df$rownum_final + + cols <- dt_boxhead_get_vars(data = data) + + data <- dt_body_set(data = data, body = body[rows, cols, drop = FALSE]) + + data +} + +dt_body_build <- function(data) { + + data %>% + dt_body_build_init() +} diff --git a/R/dt_boxhead.R b/R/dt_boxhead.R new file mode 100644 index 0000000000..a4e4e6f93d --- /dev/null +++ b/R/dt_boxhead.R @@ -0,0 +1,161 @@ +.dt_boxhead_key <- "_boxhead" + +dt_boxhead_get <- function(data) { + + dt__get(data, .dt_boxhead_key) +} + +dt_boxhead_set <- function(data, boxh) { + + dt__set(data, .dt_boxhead_key, boxh) +} + +dt_boxhead_init <- function(data) { + + vars <- colnames(dt_data_get(data = data)) + + empty_list <- lapply(seq_along(vars), function(x) NULL) + + dplyr::tibble( + # Matches to the name of the `data` column + var = vars, + # The mode of the column in the rendered table + # - `default` appears as a column with values below + # - `stub` appears as part of a table stub, set to the left + # and styled differently + # - `row_group` uses values as categoricals and groups rows + # under row group headings + # - `hidden` hides this column from the final table render + # but retains values to use in expressions + # - `hidden_at_px` similar to hidden but takes a list of + # screen widths (in px) whereby the column would be hidden + type = "default", + # # The shared spanner label between columns, where column names + # # act as the keys + # spanner_label = empty_list, + # # The label for row groups, which is maintained as a list of + # # labels by render context (e.g., HTML, LaTeX, etc.) + # row_group_label = lapply(seq_along(names(data)), function(x) NULL), + # The presentation label, which is a list of labels by + # render context (e.g., HTML, LaTeX, etc.) + column_label = as.list(vars), + # The alignment of the column ("left", "right", "center") + column_align = "center", + # The width of the column in `px` + column_width = empty_list, + # The widths at which the column disappears from view (this is + # HTML specific) + hidden_px = empty_list + ) %>% + dt_boxhead_set(boxh = ., data = data) +} + +dt_boxhead_edit <- function(data, var, ...) { + + dt_boxhead <- + data %>% + dt_boxhead_get() + + var_name <- var + + val_list <- list(...) + + check_names_dt_boxhead_expr(val_list) + + check_vars_dt_boxhead(var, dt_boxhead) + + dt_boxhead[which(dt_boxhead$var == var_name), names(val_list)] <- + dplyr::as_tibble(val_list) + + dt_boxhead %>% dt_boxhead_set(data = data) +} + +dt_boxhead_set_hidden <- function(data, vars) { + + dt_boxhead <- dt_boxhead_get(data = data) + + lapply(vars, function(var) check_vars_dt_boxhead(var = var, dt_boxhead = boxhead)) + + dt_boxhead[which(dt_boxhead$var %in% vars), "type"] <- "hidden" + + dt_boxhead %>% dt_boxhead_set(data = data) +} + +dt_boxhead_edit_column_label <- function(data, var, column_label) { + + dt_boxhead_edit(data, var, column_label = list(column_label)) +} + +dt_boxhead_get_vars <- function(data) { + + data %>% + dt_boxhead_get() %>% + magrittr::extract2("var") +} + +dt_boxhead_get_vars_default <- function(data) { + + data %>% + dt_boxhead_get() %>% + dplyr::filter(type == "default") %>% + magrittr::extract2("var") +} + +dt_boxhead_get_vars_labels_default <- function(data) { + + data %>% + dt_boxhead_get() %>% + dplyr::filter(type == "default") %>% + magrittr::extract2("column_label") %>% + unlist() +} + +check_names_dt_boxhead_expr <- function(expr) { + + if (!all(names(expr) %in% c( + "type", "column_label", "column_align", "column_width", "hidden_px" + ))) { + stop("Expressions must use names available in `dt_boxhead`.", + call. = FALSE) + } +} + +check_vars_dt_boxhead <- function(var, dt_boxhead) { + + if (!(var %in% dt_boxhead$var)) { + stop("The `var` value must be value in `dt_boxhead$var`.", + call. = FALSE) + } +} + +dt_boxhead_build <- function(data, context) { + + boxh <- dt_boxhead_get(data) + + boxh$column_label <- + lapply(boxh$column_label, function(label) process_text(label, context)) + + data <- dt_boxhead_set(data = data, boxh = boxh) + + data +} + +dt_boxhead_set_var_order <- function(data, vars) { + + boxh <- dt_boxhead_get(data) + + if (length(vars) != nrow(boxh) || + length(unique(vars)) != nrow(boxh) || + !all(vars %in% boxh$var) + ) { + stop("The length of `vars` must be the same the number of rows in `_boxh.") + } + + order_vars <- vapply(vars, function(x) {which(boxh$var == x)}, numeric(1)) + + boxh <- boxh[order_vars, ] + + data <- dt_boxhead_set(data = data, boxh = boxh) + + data +} diff --git a/R/dt_cols_merge.R b/R/dt_cols_merge.R new file mode 100644 index 0000000000..2777d7b03c --- /dev/null +++ b/R/dt_cols_merge.R @@ -0,0 +1,37 @@ +.dt_col_merge_key <- "_col_merge" + +dt_col_merge_get <- function(data) { + + dt__get(data, .dt_col_merge_key) +} + +dt_col_merge_set <- function(data, col_merge) { + + dt__set(data, .dt_col_merge_key, col_merge) +} + +dt_col_merge_init <- function(data) { + + list() %>% + dt_col_merge_set(col_merge = ., data = data) +} + +dt_col_merge_add <- function(data, col_merge) { + + data %>% + dt_col_merge_get() %>% + append( + list(col_merge) + ) %>% + dt_col_merge_set(col_merge = ., data = data) +} + +dt_col_merge_entry <- function(vars, type, pattern = NULL, ...) { + + list( + vars = vars, + type = type, + pattern = pattern, + ... + ) +} diff --git a/R/dt_data.R b/R/dt_data.R new file mode 100644 index 0000000000..17bb2f4179 --- /dev/null +++ b/R/dt_data.R @@ -0,0 +1,16 @@ +.dt_data_key <- "_data" + +dt_data_get <- function(data) { + + dt__get(data, .dt_data_key) +} + +dt_data_set <- function(data, data_tbl) { + + dt__set(data, .dt_data_key, data_tbl %>% dplyr::as_tibble()) +} + +dt_data_init <- function(data, data_tbl = NULL) { + + dt_data_set(data, data_tbl) +} diff --git a/R/dt_footnotes.R b/R/dt_footnotes.R new file mode 100644 index 0000000000..ea3aa3147b --- /dev/null +++ b/R/dt_footnotes.R @@ -0,0 +1,49 @@ +.dt_footnotes_key <- "_footnotes" + +dt_footnotes_get <- function(data) { + + dt__get(data, .dt_footnotes_key) +} + +dt_footnotes_set <- function(data, footnotes) { + + dt__set(data, .dt_footnotes_key, footnotes) +} + +dt_footnotes_init <- function(data) { + + dplyr::tibble( + locname = character(0), + grpname = character(0), + colname = character(0), + locnum = numeric(0), + rownum = integer(0), + colnum = integer(0), + footnotes = character(0) + ) %>% + dt_footnotes_set(footnotes = ., data = data) +} + +dt_footnotes_add <- function(data, + locname, + grpname, + colname, + locnum, + rownum, + footnotes) { + + data %>% + dt_footnotes_get() %>% + dplyr::bind_rows( + dplyr::tibble( + locname = locname, + grpname = grpname, + colname = colname, + locnum = locnum, + rownum = rownum, + colnum = NA_integer_, + footnotes = footnotes + ) + ) %>% + dt_footnotes_set(footnotes = ., data = data) +} diff --git a/R/dt_formats.R b/R/dt_formats.R new file mode 100644 index 0000000000..658403c7d6 --- /dev/null +++ b/R/dt_formats.R @@ -0,0 +1,43 @@ +.dt_formats_key <- "_formats" + +dt_formats_get <- function(data) { + + dt__get(data, .dt_formats_key) +} + +dt_formats_set <- function(data, formats) { + + dt__set(data, .dt_formats_key, formats) +} + +dt_formats_init <- function(data) { + + list() %>% + dt_formats_set(formats = ., data = data) +} + +dt_formats_add <- function(data, formats) { + + data %>% + dt_formats_get() %>% + append( + list(formats) + ) %>% + dt_formats_set(formats = ., data = data) +} + +# This function is used in `dt_summary_build()` to get a +# formatter function for the computed summary cells +# The `data` provided is not the body data but generated +# summary data (from aggregation functions); this is +# guaranteed to have just one formatter (hence the `[[1]]` +# index used here) +dt_formats_summary_formatter <- function(data, context) { + + formatter <- + data %>% + dt_formats_get() %>% + {.[[1]]$func} + + formatter[[context]] %||% formatter$default +} diff --git a/R/dt_groups_rows.R b/R/dt_groups_rows.R new file mode 100644 index 0000000000..e58f8a6d29 --- /dev/null +++ b/R/dt_groups_rows.R @@ -0,0 +1,66 @@ +.dt_groups_rows_key <- "_groups_rows" + +dt_groups_rows_get <- function(data) { + + ret <- dt__get(data, .dt_groups_rows_key) + + if (is.null(ret)) { + stop("Must call `dt_groups_rows_build()` first.") + } + + ret +} + +dt_groups_rows_set <- function(data, groups_rows) { + + dt__set(data, .dt_groups_rows_key, groups_rows) +} + +dt_groups_rows_build <- function(data, context) { + + stub_df <- dt_stub_df_get(data = data) + ordering <- dt_stub_groups_get(data = data) + + others_group <- dt_stub_others_get(data = data) + + groups_rows <- + data.frame( + group = rep(NA_character_, length(ordering)), + group_label = rep(NA_character_, length(ordering)), + row = rep(NA_integer_, length(ordering)), + row_end = rep(NA_integer_, length(ordering)), + stringsAsFactors = FALSE + ) + + for (i in seq(ordering)) { + + if (!is.na(ordering[i])) { + rows_matched <- which(stub_df$groupname == ordering[i]) + } else { + rows_matched <- which(is.na(stub_df$groupname)) + } + + groups_rows[i, "group"] <- ordering[i] + groups_rows[i, "group_label"] <- ordering[i] + + groups_rows[i, "row"] <- min(rows_matched) + groups_rows[i, "row_end"] <- max(rows_matched) + } + + groups_rows <- + groups_rows %>% + dplyr::mutate(group_label = process_text(group_label, context)) + + if (nrow(groups_rows) > 0) { + + others_group <- dt_stub_others_get(data = data) %||% NA_character_ + + groups_rows[ + is.na(groups_rows[, "group"]), + c("group", "group_label")] <- others_group + } + + data <- dt_groups_rows_set(data = data, groups_rows = groups_rows) + + data +} diff --git a/R/dt_has_built.R b/R/dt_has_built.R new file mode 100644 index 0000000000..f19c10ff2a --- /dev/null +++ b/R/dt_has_built.R @@ -0,0 +1,28 @@ +.dt_has_built_key <- "_has_built" + +dt_has_built_get <- function(data) { + + dt__get(data, .dt_has_built_key) +} + +dt_has_built_set <- function(data, value) { + + dt__set(data, .dt_has_built_key, value) +} + +dt_has_built_init <- function(data) { + + dt_has_built_set(data = data, value = FALSE) +} + +dt_has_built <- function(data) { + + isTRUE(dt_has_built_get(data = data)) +} + +dt_has_built_assert <- function(data) { + + if (!dt_has_built(data = data)) { + stop("The build hasn't occurred; must call `build_data()` before retrieving.") + } +} diff --git a/R/dt_heading.R b/R/dt_heading.R new file mode 100644 index 0000000000..b53a230dbe --- /dev/null +++ b/R/dt_heading.R @@ -0,0 +1,54 @@ +.dt_heading_key <- "_heading" + +dt_heading_get <- function(data) { + + dt__get(data, .dt_heading_key) +} + +dt_heading_set <- function(data, heading) { + + dt__set(data, .dt_heading_key, heading) +} + +dt_heading_init <- function(data) { + + list( + title = NULL, + subtitle = NULL + ) %>% + dt_heading_set(heading = ., data = data) +} + +dt_heading_title_subtitle <- function(data, title, subtitle) { + + heading <- dt_heading_get(data = data) + + heading[c("title", "subtitle")] <- + list(title = title, subtitle = subtitle) + + dt_heading_set(data = data, heading = heading) +} + +dt_heading_build <- function(data, context) { + + heading <- dt_heading_get(data = data) + + heading <- lapply(heading, function(val) process_text(val, context = context)) + + dt_heading_set(data = data, heading = heading) +} + +dt_heading_has_title <- function(data) { + + heading <- dt_heading_get(data = data) + + length(heading) > 0 && !is.null(heading$title) +} + +dt_heading_has_subtitle <- function(data) { + + heading <- dt_heading_get(data = data) + + length(heading) > 0 && !is.null(heading$subtitle) +} + diff --git a/R/gt_options_default.R b/R/dt_options.R similarity index 90% rename from R/gt_options_default.R rename to R/dt_options.R index eb6564daea..a3dfb7d4a2 100644 --- a/R/gt_options_default.R +++ b/R/dt_options.R @@ -1,4 +1,16 @@ -gt_options_default <- function() { +.dt_options_key <- "_options" + +dt_options_get <- function(data) { + + dt__get(data, .dt_options_key) +} + +dt_options_set <- function(data, options) { + + dt__set(data, .dt_options_key, options) +} + +dt_options_init <- function(data) { dplyr::tribble( ~parameter, ~scss, ~category, ~type, ~value, @@ -76,5 +88,27 @@ gt_options_default <- function() { "row_striping_background_color", TRUE, "row", "value", "#8080800D", "row_striping_include_stub", FALSE, "row", "logical", FALSE, "row_striping_include_table_body", FALSE, "row", "logical", TRUE, - )[-1, ] + )[-1, ] %>% + dt_options_set(options = ., data = data) +} + +dt_options_set_value <- function(data, option, value) { + + dt_options <- + data %>% + dt_options_get() + + dt_options$value[[which(dt_options$parameter == option)]] <- value + + dt_options %>% + dt_options_set(options = ., data = data) +} + +dt_options_get_value <- function(data, option) { + + dt_options <- + data %>% + dt_options_get() + + dt_options$value[[which(dt_options$parameter == option)]] } diff --git a/R/dt_source_notes.R b/R/dt_source_notes.R new file mode 100644 index 0000000000..3265f1f441 --- /dev/null +++ b/R/dt_source_notes.R @@ -0,0 +1,38 @@ +.dt_source_notes_key <- "_source_notes" + +dt_source_notes_get <- function(data) { + + dt__get(data, .dt_source_notes_key) +} + +dt_source_notes_set <- function(data, source_notes) { + + dt__set(data, .dt_source_notes_key, source_notes) +} + +dt_source_notes_init <- function(data) { + + list() %>% + dt_source_notes_set(source_notes = ., data = data) +} + +dt_source_notes_add <- function(data, source_note) { + + data %>% + dt_source_notes_get() %>% + append( + list(source_note) + ) %>% + dt_source_notes_set(source_notes = ., data = data) +} + +dt_source_notes_build <- function(data, context) { + + source_notes <- dt_source_notes_get(data) + + source_notes <- + lapply(source_notes, function(label) process_text(label, context)) %>% + unlist() + + dt_source_notes_set(data = data, source_notes = source_notes) +} diff --git a/R/dt_spanners.R b/R/dt_spanners.R new file mode 100644 index 0000000000..42a4c7006e --- /dev/null +++ b/R/dt_spanners.R @@ -0,0 +1,80 @@ +.dt_spanners_key <- "_spanners" + +dt_spanners_get <- function(data) { + + dt__get(data, .dt_spanners_key) +} + +dt_spanners_set <- function(data, spanners) { + + dt__set(data, .dt_spanners_key, spanners) +} + +dt_spanners_init <- function(data) { + + empty_list <- lapply(seq_along(names(data)), function(x) NULL) + + dplyr::tibble( + # Column names that are part of the spanner + vars = list(), + # The spanner label + spanner_label = list(), + # Should be columns be gathered under a single spanner label? + gather = logical(0), + built = NA_character_ + ) %>% + dt_spanners_set(spanners = ., data = data) +} + +dt_spanners_add <- function(data, vars, spanner_label, gather) { + + data %>% + dt_spanners_get() %>% + dplyr::bind_rows( + dplyr::tibble( + vars = list(vars), + spanner_label = list(spanner_label), + gather = gather, + built = NA_character_ + ) + ) %>% + dt_spanners_set(spanners = ., data = data) +} + +dt_spanners_exists <- function(data) { + + spanners <- dt_spanners_get(data = data) + + nrow(spanners) > 0 +} + +dt_spanners_build <- function(data, context) { + + spanners <- dt_spanners_get(data) + + spanners$built <- + vapply(spanners$spanner_label, function(label) process_text(label, context), character(1)) + + data <- dt_spanners_set(data = data, spanners = spanners) + + data +} + +dt_spanners_print <- function(data, include_hidden = TRUE) { + + spanners <- data %>% dt_spanners_get() + + if (!include_hidden) { + vars <- dt_boxhead_get_vars_default(data = data) + } else { + vars <- dt_boxhead_get_vars(data = data) + } + + vars_list <- rep(NA_character_, length(vars)) %>% magrittr::set_names(vars) + + for (i in seq_len(nrow(spanners))) { + vars_list[spanners$vars[[i]]] <- spanners$built[[i]] + } + + vars_list[names(vars_list) %in% vars] %>% unname() +} diff --git a/R/dt_stub_df.R b/R/dt_stub_df.R new file mode 100644 index 0000000000..1b3c06a684 --- /dev/null +++ b/R/dt_stub_df.R @@ -0,0 +1,200 @@ +.dt_stub_df_key <- "_stub_df" + +dt_stub_df_get <- function(data) { + + dt__get(data, .dt_stub_df_key) +} + +dt_stub_df_set <- function(data, stub_df) { + + dt__set(data, .dt_stub_df_key, stub_df) +} + +dt_stub_df_init <- function(data, + data_df, + rowname_col, + groupname_col, + rownames_to_stub, + stub_group.sep) { + + vars_to_hide <- c() + + # If the option to place rownames in the stub + # is taken, then the `stub_df` data frame will + # be pre-populated with rownames in the `rowname` + # column; otherwise, this will be an empty df + if (isTRUE(rownames_to_stub)) { + + data_rownames <- rownames(data_df) + + stub_df <- + dplyr::tibble( + rownum_i = seq_len(nrow(data_df)), + groupname = NA_character_, + rowname = data_rownames, + ) + + } else { + + stub_df <- + dplyr::tibble( + rownum_i = seq_len(nrow(data_df)), + groupname = rep(NA_character_, nrow(data_df)), + rowname = rep(NA_character_, nrow(data_df)) + ) + } + + # If `rowname` is a column available in `data`, + # place that column's data into `stub_df` and + # remove it from `data` + if (rowname_col %in% colnames(data_df)) { + + # Place the `rowname` values into `stub_df$rowname` + stub_df[["rowname"]] <- as.character(data_df[[rowname_col]]) + + vars_to_hide <- c(vars_to_hide, rowname_col) + } + + # If `data` is a `grouped_df` then create groups from the + # group columns; note that this will overwrite any values + # already in `stub_df$groupname` + if (inherits(data_df, "grouped_df")) { + + row_group_columns <- dplyr::group_vars(data_df) + row_group_columns <- base::intersect(row_group_columns, colnames(data_df)) + + row_group_labels <- + apply( + data_df[, row_group_columns], + MARGIN = 1, + paste, collapse = stub_group.sep + ) + + # Place the `group_labels` values into `stub_df$groupname` + stub_df[["groupname"]] <- row_group_labels + + vars_to_hide <- c(vars_to_hide, row_group_columns) + + } else if (groupname_col %in% colnames(data_df)) { + + # If `groupname` is a column available in `data`, + # place that column's data into `stub_df` + + # Place the `groupname` values into `stub_df$groupname` + stub_df[["groupname"]] <- as.character(data_df[[groupname_col]]) + + vars_to_hide <- c(vars_to_hide, groupname_col) + } + + # Stop if input `data` has no columns (after modifying + # `data` for groups) + if (ncol(data_df) == 0) { + stop("The `data` must have at least one column that isn't a 'group' column.", + call. = FALSE) + } + + data <- + data %>% + dt_stub_df_set(stub_df = stub_df) + + if (length(vars_to_hide) > 0) { + data <- + data %>% + cols_hide(columns = vars_to_hide) + } + + data +} + +dt_stub_df_exists <- function(data) { + + stub_df <- dt_stub_df_get(data = data) + + available <- !all(is.na((stub_df)[["rowname"]])) + + available +} + +# Function to obtain a reordered version of `stub_df` +reorder_stub_df <- function(data) { + + stub_df <- dt_stub_df_get(data = data) + + stub_groups <- dt_stub_groups_get(data = data) + + rows_df <- + get_row_reorder_df( + groups = stub_groups, + stub_df = stub_df + ) + + stub_df <- stub_df[rows_df$rownum_final, ] + + stub_df %>% dt_stub_df_set(data = data) +} + +dt_stub_groupname_has_na <- function(data) { + + stub_df <- dt_stub_df_get(data = data) + + any(is.na(stub_df$groupname)) +} + +dt_stub_components <- function(data) { + + stub_df <- dt_stub_df_get(data = data) + + stub_components <- c() + + if (any(!is.na(stub_df[["rowname"]]))) { + stub_components <- c(stub_components, "rowname") + } + + if (any(!is.na(stub_df[["groupname"]]))) { + stub_components <- c(stub_components, "groupname") + } + + stub_components +} + +# Function that checks `stub_components` and determines whether just the +# `rowname` part is available; TRUE indicates that we are working with a table +# with rownames +dt_stub_components_is_rowname <- function(stub_components) { + + identical(stub_components, "rowname") +} + +# Function that checks `stub_components` and determines whether just the +# `groupname` part is available; TRUE indicates that we are working with a table +# with groups but it doesn't have rownames +dt_stub_components_is_groupname <- function(stub_components) { + + identical(stub_components, "groupname") +} + +# Function that checks `stub_components` and determines whether the +# `rowname` and `groupname` parts are available; TRUE indicates that we are +# working with a table with rownames and groups +dt_stub_components_is_rowname_groupname <- function(stub_components) { + + identical(stub_components, c("rowname", "groupname")) +} + +dt_stub_components_has_rowname <- function(stub_components) { + + isTRUE("rowname" %in% stub_components) +} + +dt_stub_rowname_at_position <- function(data, i) { + + stub_components <- dt_stub_components(data = data) + + if (!(dt_stub_components_has_rowname(stub_components = stub_components))) { + return(NULL) + } + + stub_df <- dt_stub_df_get(data = data) + + stub_df$rowname[[i]] +} diff --git a/R/dt_stub_groups.R b/R/dt_stub_groups.R new file mode 100644 index 0000000000..87d04d0043 --- /dev/null +++ b/R/dt_stub_groups.R @@ -0,0 +1,28 @@ +.dt_stub_groups_key <- "_stub_groups" + +dt_stub_groups_get <- function(data) { + + dt__get(data, .dt_stub_groups_key) +} + +dt_stub_groups_set <- function(data, stub_groups) { + + dt__set(data, .dt_stub_groups_key, stub_groups) +} + +dt_stub_groups_init <- function(data) { + + stub_df <- dt_stub_df_get(data = data) + + if (any(!is.na(stub_df[["groupname"]]))) { + stub_groups <- unique(stub_df[["groupname"]]) + } else { + stub_groups <- character(0) + } + + data <- + stub_groups %>% + dt_stub_groups_set(data = data) + + data +} diff --git a/R/dt_stub_others.R b/R/dt_stub_others.R new file mode 100644 index 0000000000..708816c339 --- /dev/null +++ b/R/dt_stub_others.R @@ -0,0 +1,20 @@ +.dt_stub_others_key <- "_stub_others" + +dt_stub_others_get <- function(data) { + + dt__get(data, .dt_stub_others_key) +} + +dt_stub_others_set <- function(data, stub_others) { + + dt__set(data, .dt_stub_others_key, stub_others) +} + +dt_stub_others_init <- function(data) { + + data <- + NA_character_ %>% + dt_stub_others_set(data = data) + + data +} diff --git a/R/dt_stubhead.R b/R/dt_stubhead.R new file mode 100644 index 0000000000..f6d8ef0f5e --- /dev/null +++ b/R/dt_stubhead.R @@ -0,0 +1,44 @@ +.dt_stubhead_key <- "_stubhead" + +dt_stubhead_get <- function(data) { + + dt__get(data, .dt_stubhead_key) +} + +dt_stubhead_set <- function(data, stubhead) { + + dt__set(data, .dt_stubhead_key, stubhead) +} + +dt_stubhead_init <- function(data) { + + list( + label = NULL + ) %>% + dt_stubhead_set(data = data) +} + +dt_stubhead_label <- function(data, label) { + + stubhead <- dt_stubhead_get(data = data) + + stubhead["label"] <- list(label = label) + + dt_stubhead_set(data = data, stubhead = stubhead) +} + +dt_stubhead_build <- function(data, context) { + + stubhead <- dt_stubhead_get(data = data) + + stubhead <- lapply(stubhead, function(val) process_text(val, context = context)) + + dt_stubhead_set(data = data, stubhead = stubhead) +} + +dt_stubhead_has_label <- function(data) { + + stubhead <- dt_stubhead_get(data = data) + + length(stubhead) > 0 && !is.null(stubhead$label) +} diff --git a/R/dt_styles.R b/R/dt_styles.R new file mode 100644 index 0000000000..1f111657ee --- /dev/null +++ b/R/dt_styles.R @@ -0,0 +1,49 @@ +.dt_styles_key <- "_styles" + +dt_styles_get <- function(data) { + + dt__get(data, .dt_styles_key) +} + +dt_styles_set <- function(data, styles) { + + dt__set(data, .dt_styles_key, styles) +} + +dt_styles_init <- function(data) { + + dplyr::tibble( + locname = NA_character_, + grpname = NA_character_, + colname = NA_character_, + locnum = NA_real_, + rownum = NA_integer_, + colnum = NA_integer_, + styles = list() + )[-1, ] %>% + dt_styles_set(styles = ., data = data) +} + +dt_styles_add <- function(data, + locname, + grpname, + colname, + locnum, + rownum, + styles) { + + data %>% + dt_styles_get() %>% + dplyr::bind_rows( + dplyr::tibble( + locname = locname, + grpname = grpname, + colname = colname, + locnum = locnum, + rownum = rownum, + colnum = NA_integer_, + styles = list(styles) + ) + ) %>% + dt_styles_set(styles = ., data = data) +} diff --git a/R/dt_summary.R b/R/dt_summary.R new file mode 100644 index 0000000000..45b11276d9 --- /dev/null +++ b/R/dt_summary.R @@ -0,0 +1,311 @@ +.dt_summary_key <- "_summary" + +.dt_summary_build_key <- paste0(.dt_summary_key, "_build") + +dt_summary_get <- function(data) { + + dt__get(data, .dt_summary_key) +} + +dt_summary_df_get <- function(data) { + + dt__get(data, .dt_summary_build_key) +} + +dt_summary_df_data_get <- function(data) { + + dt_has_built_assert(data = data) + + dt <- dt_summary_df_get(data) + + dt["summary_df_data_list"] %>% as.list() +} + +dt_summary_df_display_get <- function(data) { + + dt_has_built_assert(data = data) + + dt <- dt_summary_df_get(data) + + dt["summary_df_display_list"] %>% as.list() +} + +dt_summary_set <- function(data, summary) { + + dt__set(data, .dt_summary_key, summary) +} + +dt_summary_data_set <- function(data, summary) { + + dt__set(data, .dt_summary_build_key, summary) +} + +dt_summary_init <- function(data) { + + list() %>% + dt_summary_set(summary = ., data = data) +} + +dt_summary_add <- function(data, summary) { + + data %>% + dt_summary_get() %>% + append( + list(summary) + ) %>% + dt_summary_set(summary = ., data = data) +} + +dt_summary_exists <- function(data) { + + length(dt_summary_get(data = data)) > 0 +} + +dt_summary_build <- function(data, + context) { + + # TODO: is `dt_body_get()` necessary here? `dt_boxh_vars_default()` could be used + + summary_list <- dt_summary_get(data = data) + body <- dt_body_get(data = data) + data_tbl <- dt_data_get(data = data) + stub_df <- dt_stub_df_get(data = data) + + # If the `summary_list` object is an empty list, + # return an empty list as the `list_of_summaries` + if (length(summary_list) == 0) { + + return(dt_summary_data_set(data = data, list())) + } + + # Create empty lists that are to contain summary + # data frames for display and for data collection + # purposes + summary_df_display_list <- list() + summary_df_data_list <- list() + + for (i in seq(summary_list)) { + + summary_attrs <- summary_list[[i]] + + groups <- summary_attrs$groups + columns <- summary_attrs$columns + fns <- summary_attrs$fns + missing_text <- summary_attrs$missing_text + formatter <- summary_attrs$formatter + formatter_options <- summary_attrs$formatter_options + labels <- summary_attrs$summary_labels + + if (length(labels) != length(unique(labels))) { + + stop("All summary labels must be unique:\n", + " * Review the names provided in `fns`\n", + " * These labels are in conflict: ", + paste0(labels, collapse = ", "), ".", + call. = FALSE) + } + + # Resolve the `missing_text` + missing_text <- + context_missing_text(missing_text = missing_text, context = context) + + assert_rowgroups <- function() { + + if (all(is.na(stub_df$groupname))) { + stop("There are no row groups in the gt object:\n", + " * Use `groups = NULL` to create a grand summary\n", + " * Define row groups using `gt()` or `tab_row_group()`", + call. = FALSE) + } + } + + # Resolve the groups to consider; if + # `groups` is TRUE then we are to obtain + # summary row data for all groups + if (isTRUE(groups)) { + + assert_rowgroups() + + groups <- unique(stub_df$groupname) + + } else if (!is.null(groups) && is.character(groups)) { + + assert_rowgroups() + + # Get the names of row groups available + # in the gt object + groups_available <- unique(stub_df$groupname) + + if (any(!(groups %in% groups_available))) { + + # Stop function if one or more `groups` + # are not present in the gt table + stop("All `groups` should be available in the gt object:\n", + " * The following groups aren't present: ", + paste0( + base::setdiff(groups, groups_available), + collapse = ", " + ), "\n", + call. = FALSE) + } + + } else if (is.null(groups)) { + + # If groups is given as NULL (the default) + # then use a special group (`::GRAND_SUMMARY`) + groups <- grand_summary_col + } + + # Resolve the columns to exclude + columns_excl <- + base::setdiff( + base::setdiff( + colnames(body), + c("groupname", "rowname") + ), + columns) + + # Combine `groupname` with the table body data in order to + # process data by groups + if (identical(groups, grand_summary_col)) { + + select_data_tbl <- + cbind( + stub_df[c("groupname", "rowname")], + data_tbl + )[, -2] %>% + dplyr::mutate(groupname = grand_summary_col) %>% + dplyr::select(groupname, columns) + + } else { + + select_data_tbl <- + cbind( + stub_df[c("groupname", "rowname")], + data_tbl + )[, -2] %>% + dplyr::select(groupname, columns) + } + + # Get the registered function calls + agg_funs <- fns %>% lapply(rlang::as_closure) + + summary_dfs_data <- + lapply( + seq(agg_funs), function(j) { + select_data_tbl %>% + dplyr::filter(groupname %in% groups) %>% + dplyr::group_by(groupname) %>% + dplyr::summarize_all(.funs = agg_funs[[j]]) %>% + dplyr::ungroup() %>% + dplyr::mutate(rowname = labels[j]) %>% + dplyr::select(groupname, rowname, dplyr::everything()) + } + ) %>% + dplyr::bind_rows() + + # Add those columns that were not part of + # the aggregation, filling those with NA values + summary_dfs_data[, columns_excl] <- NA_real_ + + summary_dfs_data <- + summary_dfs_data %>% + dplyr::select(groupname, rowname, colnames(body)) + + # Format the displayed summary lines + summary_dfs_display <- + summary_dfs_data %>% + dplyr::mutate_at( + .vars = columns, + .funs = function(x) { + + # This creates a gt structure so that the + # formatter can be easily extracted by using + # the regular `dt_*()` methods + summary_data <- data.frame(x = x) %>% gt() + + format_data <- + do.call( + summary_attrs$formatter, + append( + list( + summary_data, + columns = "x" + ), + summary_attrs$formatter_options + ) + ) + + formatter <- + dt_formats_summary_formatter( + data = format_data, + context = context + ) + + formatter(x) + } + ) %>% + dplyr::mutate_at( + .vars = columns_excl, + .funs = function(x) {NA_character_} + ) + + for (group in groups) { + + # Place data frame in separate list component by `group` + group_sym <- rlang::enquo(group) + + group_summary_data_df <- + summary_dfs_data %>% + dplyr::filter(groupname == !!group_sym) + + group_summary_display_df <- + summary_dfs_display %>% + dplyr::filter(groupname == !!group_sym) + + summary_df_data_list <- + c(summary_df_data_list, + stats::setNames(list(group_summary_data_df), group)) + + summary_df_display_list <- + c(summary_df_display_list, + stats::setNames(list(group_summary_display_df), group)) + } + } + + # Condense data in `summary_df_display_list` in a + # groupwise manner + summary_df_display_list <- + tapply( + summary_df_display_list, + names(summary_df_display_list), + dplyr::bind_rows + ) + + for (i in seq(summary_df_display_list)) { + + arrangement <- unique(summary_df_display_list[[i]]$rowname) + + summary_df_display_list[[i]] <- + summary_df_display_list[[i]] %>% + dplyr::select(-groupname) %>% + dplyr::group_by(rowname) %>% + dplyr::summarize_all(last_non_na) + + summary_df_display_list[[i]] <- + summary_df_display_list[[i]][ + match(arrangement, summary_df_display_list[[i]]$rowname), ] %>% + replace(is.na(.), missing_text) + } + + # Return a list of lists, each of which have + # summary data frames for display and for data + # collection purposes + list_of_summaries <- + list( + summary_df_data_list = summary_df_data_list, + summary_df_display_list = summary_df_display_list + ) + + dt_summary_data_set(data = data, list_of_summaries) +} diff --git a/R/dt_transforms.R b/R/dt_transforms.R new file mode 100644 index 0000000000..65886ab194 --- /dev/null +++ b/R/dt_transforms.R @@ -0,0 +1,36 @@ +.dt_transforms_key <- "_transforms" + +dt_transforms_get <- function(data) { + + dt__get(data, .dt_transforms_key) +} + +dt_transforms_set <- function(data, transforms) { + + dt__set(data, .dt_transforms_key, transforms) +} + +dt_transforms_init <- function(data) { + + list() %>% + dt_transforms_set(transforms = ., data = data) +} + +dt_transforms_add <- function(data, loc, fn) { + + existing_transforms <- dt_transforms_get(data = data) + resolved <- resolve_location(loc = loc, data = data) + + transforms <- + c( + existing_transforms, + list( + list( + resolved = resolved, + fn = fn + ) + ) + ) + + dt_transforms_set(data = data, transforms = transforms) +} diff --git a/R/extract_summary.R b/R/extract_summary.R index 57135dd421..5f7c036d72 100644 --- a/R/extract_summary.R +++ b/R/extract_summary.R @@ -48,6 +48,7 @@ #' # row groups and a stub) #' tab_1 <- #' summary_extracted %>% +#' unlist(recursive = FALSE) %>% #' dplyr::bind_rows() %>% #' gt() #' @@ -58,13 +59,9 @@ #' @export extract_summary <- function(data) { - # Extract all attributes from the `data` - # object into `data_attr` - data_attr <- attributes(data) - # Stop function if there are no # directives to create summary rows - if (is.null(data_attr$summary)) { + if (!dt_summary_exists(data = data)) { stop("There is no summary list to extract.\n", "Use the `summary_rows()` function to generate summaries.", call. = FALSE) @@ -76,5 +73,5 @@ extract_summary <- function(data) { # Extract the list of summary data frames # that contains tidy, unformatted data - built_data$list_of_summaries$summary_df_data_list + dt_summary_df_data_get(data = built_data) %>% as.list() } diff --git a/R/format_data.R b/R/format_data.R index c5e81666f6..f3e473573e 100644 --- a/R/format_data.R +++ b/R/format_data.R @@ -654,7 +654,12 @@ fmt_currency <- function(data, validate_currency(currency = currency) # Get the number of decimal places - decimals <- get_currency_decimals(currency = currency, decimals, use_subunits) + decimals <- + get_currency_decimals( + currency = currency, + decimals = decimals, + use_subunits = use_subunits + ) fmt_symbol( data = data, @@ -777,25 +782,34 @@ fmt_date <- function(data, # Pass `data`, `columns`, `rows`, and the formatting # functions as a function list to `fmt()` - fmt(data = data, - columns = !!columns, - rows = !!rows, - fns = list( - default = function(x) { - - # If `x` is of the `Date` type, simply make - # that a character vector - if (inherits(x, "Date")) { - x <- as.character(x) - } + fmt( + data = data, + columns = !!columns, + rows = !!rows, + fns = list( + default = function(x) { + + # If `x` is of the `Date` type, simply make + # that a character vector + if (inherits(x, "Date")) { + x <- as.character(x) + } + date <- ifelse(grepl("^[0-9]*?\\:[0-9]*?", x), paste("1970-01-01", x), x) %>% - strftime(format = date_format_str) %>% - tidy_gsub("^0", "") %>% - tidy_gsub(" 0([0-9])", " \\1") %>% - tidy_gsub("pm$", "PM") %>% - tidy_gsub("am$", "AM") - })) + strftime(format = date_format_str) + + if (date_style %in% 2:12) { + date <- date %>% tidy_gsub(., "^0", "") + } + + date %>% + tidy_gsub(" 0([0-9])", " \\1") %>% + tidy_gsub("pm$", "PM") %>% + tidy_gsub("am$", "AM") + } + ) + ) } #' Format values as times @@ -890,19 +904,28 @@ fmt_time <- function(data, # Pass `data`, `columns`, `rows`, and the formatting # functions as a function list to `fmt()` - fmt(data = data, - columns = !!columns, - rows = !!rows, - fns = list( - default = function(x) { + fmt( + data = data, + columns = !!columns, + rows = !!rows, + fns = list( + default = function(x) { + time <- ifelse(grepl("^[0-9]*?\\:[0-9]*?", x), paste("1970-01-01", x), x) %>% - strftime(format = time_format_str) %>% - tidy_gsub("^0", "") %>% - tidy_gsub(" 0([0-9])", " \\1") %>% - tidy_gsub("pm$", "PM") %>% - tidy_gsub("am$", "AM") - })) + strftime(format = time_format_str) + + if (time_style %in% 3:5) { + time <- time %>% tidy_gsub(., "^0", "") + } + + time %>% + tidy_gsub(" 0([0-9])", " \\1") %>% + tidy_gsub("pm$", "PM") %>% + tidy_gsub("am$", "AM") + } + ) + ) } #' Format values as date-times @@ -989,14 +1012,13 @@ fmt_datetime <- function(data, time_style = 2) { # Transform `date_style` to `date_format` - date_format <- get_date_format(date_style = date_style) + date_format_str <- get_date_format(date_style = date_style) # Transform `time_style` to `time_format` - time_format <- get_time_format(time_style = time_style) + time_format_str <- get_time_format(time_style = time_style) # Combine into a single datetime format string - date_time_format_str <- - paste0(date_format, " ", time_format) + # date_time_format_str <- paste0(date_format, " ", time_format) # Capture expression in `rows` and `columns` rows <- rlang::enquo(rows) @@ -1004,19 +1026,49 @@ fmt_datetime <- function(data, # Pass `data`, `columns`, `rows`, and the formatting # functions as a function list to `fmt()` - fmt(data = data, - columns = !!columns, - rows = !!rows, - fns = list( - default = function(x) { + fmt( + data = data, + columns = !!columns, + rows = !!rows, + fns = list( + default = function(x) { + + date <- + ifelse(grepl("^[0-9]*?\\:[0-9]*?", x), paste("1970-01-01", x), x) %>% + strftime(format = date_format_str) + + if (date_style %in% 2:12) { + date <- date %>% tidy_gsub(., "^0", "") + } + date <- + date %>% + tidy_gsub(" 0([0-9])", " \\1") %>% + tidy_gsub("pm$", "PM") %>% + tidy_gsub("am$", "AM") + + time <- ifelse(grepl("^[0-9]*?\\:[0-9]*?", x), paste("1970-01-01", x), x) %>% - strftime(format = date_time_format_str) %>% - tidy_gsub("^0", "") %>% - tidy_gsub(" 0([0-9])", " \\1") %>% - tidy_gsub("pm$", "PM") %>% - tidy_gsub("am$", "AM") - })) + strftime(format = time_format_str) + + if (time_style %in% 3:5) { + time <- time %>% tidy_gsub(., "^0", "") + } + + time <- + time %>% + tidy_gsub(" 0([0-9])", " \\1") %>% + tidy_gsub("pm$", "PM") %>% + tidy_gsub("am$", "AM") + + datetime <- + paste(date, time) %>% + tidy_gsub("NA NA", "NA") + + datetime + } + ) + ) } #' Format Markdown text @@ -1171,64 +1223,63 @@ fmt_passthrough <- function(data, # Pass `data`, `columns`, `rows`, and the formatting # functions (as a function list) to `fmt()` - fmt(data = data, - columns = !!columns, - rows = !!rows, - fns = list( - html = function(x) { - - # Create `x_str` with same length as `x` - x_str <- rep(NA_character_, length(x)) - - # TODO: Deal with NA values in x - # Handle formatting of pattern - x_str <- - apply_pattern_fmt_x( - pattern, - values = x - ) + fmt( + data = data, + columns = !!columns, + rows = !!rows, + fns = list( + html = function(x) { - if (escape) { - x_str <- x_str %>% process_text(context = "html") - } + # Create `x_str` with same length as `x` + x_str <- rep(NA_character_, length(x)) - x_str - }, - latex = function(x) { + # Handle formatting of pattern + x_str <- + apply_pattern_fmt_x( + pattern, + values = x + ) - # Create `x_str` with same length as `x` - x_str <- rep(NA_character_, length(x)) + if (escape) { + x_str <- x_str %>% process_text(context = "html") + } - # TODO: Deal with NA values in x - # Handle formatting of pattern - x_str <- - apply_pattern_fmt_x( - pattern, - values = x - ) + x_str + }, + latex = function(x) { - if (escape) { - x_str <- x_str %>% process_text(context = "latex") - } + # Create `x_str` with same length as `x` + x_str <- rep(NA_character_, length(x)) - x_str - }, - default = function(x) { + # Handle formatting of pattern + x_str <- + apply_pattern_fmt_x( + pattern, + values = x + ) - # Create `x_str` with same length as `x` - x_str <- rep(NA_character_, length(x)) + if (escape) { + x_str <- x_str %>% process_text(context = "latex") + } - # TODO: Deal with NA values in x - # Handle formatting of pattern - x_str <- - apply_pattern_fmt_x( - pattern, - values = x - ) + x_str + }, + default = function(x) { - x_str - } - )) + # Create `x_str` with same length as `x` + x_str <- rep(NA_character_, length(x)) + + # Handle formatting of pattern + x_str <- + apply_pattern_fmt_x( + pattern, + values = x + ) + + x_str + } + ) + ) } #' Format missing values @@ -1282,35 +1333,37 @@ fmt_missing <- function(data, # Pass `data`, `columns`, `rows`, and the formatting # functions (as a function list) to `fmt()` - fmt(data = data, - columns = !!columns, - rows = !!rows, - fns = list( - html = function(x) { - - missing_text <- - context_missing_text( - missing_text = missing_text, - context = "html" - ) + fmt( + data = data, + columns = !!columns, + rows = !!rows, + fns = list( + html = function(x) { - # Any values of `x` that are `NA` get - # `missing_text` as output; any values that - # are not missing get `NA` as their output - # (meaning, the existing output for that - # value, if it exists, should be inherited) - ifelse(is.na(x), missing_text, NA_character_) - }, - default = function(x) { - - # Any values of `x` that are `NA` get - # `missing_text` as output; any values that - # are not missing get `NA` as their output - # (meaning, the existing output for that - # value, if it exists, should be inherited) - ifelse(is.na(x), missing_text, NA_character_) - } - )) + missing_text <- + context_missing_text( + missing_text = missing_text, + context = "html" + ) + + # Any values of `x` that are `NA` get + # `missing_text` as output; any values that + # are not missing get `NA` as their output + # (meaning, the existing output for that + # value, if it exists, should be inherited) + ifelse(is.na(x), missing_text, NA_character_) + }, + default = function(x) { + + # Any values of `x` that are `NA` get + # `missing_text` as output; any values that + # are not missing get `NA` as their output + # (meaning, the existing output for that + # value, if it exists, should be inherited) + ifelse(is.na(x), missing_text, NA_character_) + } + ) + ) } #' Set a column format with a formatter function @@ -1371,7 +1424,8 @@ fmt <- function(data, fns) { # Get the `stub_df` data frame from `data` - stub_df <- attr(data, "stub_df", exact = TRUE) + stub_df <- dt_stub_df_get(data = data) + data_tbl <- dt_data_get(data = data) # # Resolution of columns and rows as integer vectors @@ -1390,7 +1444,7 @@ fmt <- function(data, resolved_rows_idx <- resolve_data_vals_idx( var_expr = !!rows, - data = data, + data_tbl = data_tbl, vals = stub_df$rowname ) @@ -1409,10 +1463,5 @@ fmt <- function(data, rows = resolved_rows_idx ) - # Incorporate the `formatter_list` object as the next - # list in the `formats` list of lists - next_index <- length(attr(data, "formats", exact = TRUE)) + 1 - attr(data, "formats")[[next_index]] <- formatter_list - - data + dt_formats_add(data = data, formats = formatter_list) } diff --git a/R/gt.R b/R/gt.R index e6eaf56904..d797416ad2 100644 --- a/R/gt.R +++ b/R/gt.R @@ -27,6 +27,9 @@ #' group labels for generation of stub row groups. #' @param rownames_to_stub An option to take rownames from the input `data` #' table as row captions in the display table stub. +#' @param auto_align Optionally have column data be aligned depending on the +#' content contained in each column of the input `data`. Internally, this +#' calls `cols_align(align = "auto")` for all columns. #' @param id The table ID. By default, this will be a random ID as generated by #' the [random_id()] function. If set to `NULL` then no table ID will be #' applied. @@ -73,213 +76,58 @@ gt <- function(data, rowname_col = "rowname", groupname_col = "groupname", rownames_to_stub = FALSE, + auto_align = TRUE, id = random_id(), stub_group.sep = getOption("gt.stub_group.sep", " - ")) { - # Stop if input `data` has no columns - if (ncol(data) == 0) { - stop("The input `data` table must have at least one column.", - call. = FALSE) - } - - opts_df <- gt_options_default() + # Initialize the main objects + data <- + list() %>% + dt_data_init(data_tbl = data) %>% + dt_boxhead_init() %>% + dt_stub_df_init( + data_df = data, + rowname_col = rowname_col, + groupname_col = groupname_col, + rownames_to_stub = rownames_to_stub, + stub_group.sep = stub_group.sep + ) %>% + dt_stub_groups_init() %>% + dt_stub_others_init() %>% + dt_heading_init() %>% + dt_spanners_init() %>% + dt_stubhead_init() %>% + dt_footnotes_init() %>% + dt_source_notes_init() %>% + dt_formats_init() %>% + dt_styles_init() %>% + dt_summary_init() %>% + dt_options_init() %>% + dt_transforms_init() %>% + dt_has_built_init() # Add the table ID to the `id` parameter if (!is.null(id)) { - opts_df <- opts_df_set(opts_df, "table_id", id) - } - - # If the option to place rownames in the stub - # is taken, then the `stub_df` data frame will - # be pre-populated with rownames in the `rowname` - # column; otherwise, this will be an empty df - if (rownames_to_stub) { - - stub_df <- - data.frame( - groupname = NA_character_, - rowname = rownames(data), - stringsAsFactors = FALSE - ) - } else { - - stub_df <- - data.frame( - groupname = rep(NA_character_, nrow(data)), - rowname = rep(NA_character_, nrow(data)), - stringsAsFactors = FALSE + data <- + data %>% + dt_options_set_value( + option = "table_id", + value = id ) } - # If `rowname` is a column available in `data`, - # place that column's data into `stub_df` and - # remove it from `data` - if (rowname_col %in% colnames(data)) { - - # Place the `rowname` values into `stub_df$rowname` - stub_df[["rowname"]] <- as.character(data[[rowname_col]]) - - # Remove the `rowname` column from `data` - data[[rowname_col]] <- NULL - } - - # If `data` is a `grouped_df` then create groups from the - # group columns; note that this will overwrite any values - # already in `stub_df$groupname` - if (inherits(data, "grouped_df")) { - - group_cols <- dplyr::group_vars(data) - group_cols <- base::intersect(group_cols, colnames(data)) - - group_labels <- - apply(data[, group_cols], 1, paste, collapse = stub_group.sep) - - # Place the `group_labels` values into `stub_df$groupname` - stub_df[["groupname"]] <- group_labels - - # Remove all columns in `group_cols` from `data` - data[, which(colnames(data) %in% group_cols)] <- NULL - - } else if (groupname_col %in% colnames(data)) { - - # If `groupname` is a column available in `data`, - # place that column's data into `stub_df` and - # remove it from `data` - - # Place the `groupname` values into `stub_df$groupname` - stub_df[["groupname"]] <- as.character(data[[groupname_col]]) - - # Remove the `groupname` column from `data` - data[[groupname_col]] <- NULL - } - - # Stop if input `data` has no columns (after modifying - # `data` for groups) - if (ncol(data) == 0) { - stop("The `data` must have at least one column that isn't a 'group' column.", - call. = FALSE) - } - - # Take the input data and convert to a - # data frame - data_tbl <- - data %>% - as.data.frame(stringsAsFactors = FALSE) - - # Reset the rownames in the `data_tbl` df - rownames(data_tbl) <- NULL - - # Create an empty `footnotes_df` data frame - footnotes_df <- - dplyr::tibble( - locname = NA_character_, - locnum = NA_integer_, - grpname = NA_character_, - colname = NA_character_, - rownum = NA_integer_, - text = NA_character_ - )[-1, ] - - # Create an empty `styles_df` data frame - styles_df <- - dplyr::tibble( - locname = NA_character_, - locnum = NA_integer_, - grpname = NA_character_, - colname = NA_character_, - rownum = NA_integer_, - styles = list() - )[-1, ] - - # Create a prepopulated `rows_df` data frame - if (nrow(data_tbl) > 0) { - rows_df <- dplyr::tibble(rownums_start = seq(nrow(data_tbl))) - } else { - rows_df <- dplyr::tibble(rownums_start = NA_integer_)[-1, ] - } - - # Create a prepopulated `cols_df` data frame - cols_df <- dplyr::tibble(colnames_start = colnames(data_tbl)) - - # Create an empty facsimile df based on - # `data_tbl`; this will serve as a template for - # data frames that contain specialized formatting - # directives that will be used during render time - empty_df <- data_tbl - if (nrow(data_tbl) > 0) { - empty_df[] <- NA_character_ - } - - # Create a data frame that represents the table's - # columns (`boxh_df`); each row has a special - # meaning and this will be used during render time - boxh_df <- - matrix(data = NA_character_, nrow = 4, ncol = ncol(data_tbl)) %>% - as.data.frame() %>% - dplyr::mutate_all(as.character) %>% - magrittr::set_names(names(data_tbl)) %>% - magrittr::set_rownames( - c("group_label", "column_label", "column_align", "column_width") - ) - - # Apply initialized data frames as attributes - # within the object - attr(data_tbl, "boxh_df") <- boxh_df - attr(data_tbl, "stub_df") <- stub_df - attr(data_tbl, "footnotes_df") <- footnotes_df - attr(data_tbl, "styles_df") <- styles_df - attr(data_tbl, "rows_df") <- rows_df - attr(data_tbl, "cols_df") <- cols_df - - data_tbl_colnames <- colnames(data_tbl) - - # Create a prepopulated `col_labels` list object, which - # contains names of all the columns which can be all be - # modified later - col_labels <- data_tbl_colnames - names(col_labels) <- data_tbl_colnames - col_labels <- as.list(col_labels) - - attr(data_tbl, "col_labels") <- col_labels - - # Create a prepopulated `grp_labels` list object, which - # contains names of all the column groups which can be all be - # modified later - grp_labels <- rep(NA_character_, length(colnames(data_tbl))) - names(grp_labels) <- data_tbl_colnames - grp_labels <- as.list(grp_labels) - - attr(data_tbl, "grp_labels") <- grp_labels - - # Create an `arrange_groups` list object, which contains - # a vector of `groupname` values in the order of first - # appearance in `data`; if all `groupname` values are NA, - # then use an empty character vector - if (any(!is.na(stub_df[["groupname"]]))) { - attr(data_tbl, "arrange_groups") <- - list(groups = unique(stub_df[["groupname"]])) - } else { - attr(data_tbl, "arrange_groups") <- - list(groups = character(0)) - } - - # Apply the input data table as an attribute - attr(data_tbl, "data_df") <- data - - # Apply the `opts_df` data frame as an attribute - attr(data_tbl, "opts_df") <- opts_df - - # Apply an empty `formats` list as an attribute - attr(data_tbl, "formats") <- list() - - # Apply an empty `transforms` list as an attribute - attr(data_tbl, "transforms") <- list() - # Apply the `gt_tbl` class to the object while # also keeping the `data.frame` class - class(data_tbl) <- c("gt_tbl", class(data_tbl)) + class(data) <- c("gt_tbl", class(data)) + + # If automatic alignment of values is to be done, call + # the `cols_align()` function on data + if (isTRUE(auto_align)) { + data <- + data %>% + cols_align(align = "auto") + } - # Automatically align columns with `cols_align()` - data_tbl %>% cols_align() + data } diff --git a/R/gt_preview.R b/R/gt_preview.R index 9fad7406e0..27ae58309b 100644 --- a/R/gt_preview.R +++ b/R/gt_preview.R @@ -43,6 +43,10 @@ gt_preview <- function(data, bottom_n = 1, incl_rownums = TRUE) { + if (is_gt(data)) { + data <- dt_data_get(data = data) + } + # Convert the table to a data frame data <- as.data.frame(data, stringsAsFactors = FALSE) @@ -69,7 +73,7 @@ gt_preview <- function(data, # If a preview table (head and tail) is requested, # then modify `data_tbl` to only include the head # and tail plus an ellipsis row - if (has_ellipsis_row) { + if (isTRUE(has_ellipsis_row)) { ellipsis_row <- top_n + 1 @@ -82,7 +86,8 @@ gt_preview <- function(data, rbind( data[seq(top_n), ], rep("", ncol(data)), - data[(nrow(data) + 1 - rev(seq(bottom_n))), ]) + data[(nrow(data) + 1 - rev(seq(bottom_n))), ] + ) # Relabel the rowname for the ellipsis row rownames(data)[ellipsis_row] <- paste(between_rownums, collapse = "..") @@ -91,7 +96,7 @@ gt_preview <- function(data, # If we elect to include row numbers, then place the row # numbers in the `rowname` column so that `gt()` will pick # this up as row labels for inclusion into the table stub - if (incl_rownums) { + if (isTRUE(incl_rownums)) { data <- cbind( data.frame(rowname = rownames(data), stringsAsFactors = FALSE), data) @@ -101,48 +106,40 @@ gt_preview <- function(data, gt_tbl <- gt(data, rownames_to_stub = FALSE) # Use a fixed-width font for the rownums, if they are included - if (incl_rownums) { + if (isTRUE(incl_rownums)) { gt_tbl <- gt_tbl %>% tab_style( style = cell_text(font = "Courier"), - locations = cells_stub()) + locations = cells_stub() + ) } - # Add styling of ellipsis row, if it is present - if (has_ellipsis_row) { + visible_vars <- dt_boxhead_get_vars_default(data = gt_tbl) + + # Add styling to ellipsis row, if it is present + if (isTRUE(has_ellipsis_row)) { gt_tbl <- gt_tbl %>% tab_style( style = cell_fill(color = "#E4E4E4"), - locations = cells_data(rows = ellipsis_row)) #%>% - # tab_style( - # style = "padding-top:1px;padding-bottom:1px;border-top:2px solid #D1D1D1;border-bottom:2px solid #D1D1D1;", - # locations = cells_data(rows = ellipsis_row)) + locations = cells_data(columns = visible_vars, rows = ellipsis_row) + ) - if (incl_rownums) { + if (isTRUE(incl_rownums)) { gt_tbl <- gt_tbl %>% tab_style( style = list( cell_fill(color = "#E4E4E4"), - cell_text(size = "12px") - ), - locations = cells_stub(rows = ellipsis_row)) #%>% - # tab_style( - # style = "padding-top:1px;padding-bottom:1px;border-top:2px solid #D1D1D1;border-bottom:2px solid #D1D1D1;", - # locations = cells_stub(rows = ellipsis_row)) + cell_text(size = "10px") + ), + locations = cells_stub(rows = ellipsis_row) + ) - } else { - - gt_tbl <- - gt_tbl # %>% - # tab_style( - # style = "padding-top:8px;padding-bottom:8px;", - # locations = cells_data(rows = ellipsis_row)) } } diff --git a/R/helpers.R b/R/helpers.R index 6d377732c0..c488668fd8 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -20,9 +20,10 @@ #' only available when there is a stub; a label in that location can be created #' by using the [tab_stubhead()] function. #' -#' \item `cells_column_labels()`: targets labels in the column labels (the -#' `columns` argument) or the spanner column labels (the `groups` argument) in -#' the table's column labels part. +#' \item `cells_column_labels()`: targets the column labels. +#' +#' \item `cells_column_spanners()`: targets the spanner column labels, which +#' appear above the column labels. #' #' \item `cells_group()`: targets the row group labels in any available row #' groups using the `groups` argument. @@ -35,11 +36,18 @@ #' #' \item `cells_summary()`: targets summary cells in the table body using the #' `groups` argument and intersections of `columns` and `rows`. +#' +#' \item `cells_grand_summary()`: targets cells of the table's grand summary +#' using intersections of `columns` and `rows` #' } #' -#' @param columns,rows,groups Either a vector of names, a vector of indices, +#' @param columns,rows Either a vector of names, a vector of indices, #' values provided by [vars()], values provided by `c()`, or a select helper #' function (see Details for information on these functions). +#' @param groups Used in the `cells_title()`, `cells_group()`, and +#' `cells_summary()` functions to specify which groups to target. +#' @param spanners Used in the `cells_column_spanners()` function to indicate +#' which spanners to target. #' #' @examples #' library(tidyr) @@ -105,7 +113,7 @@ #' ) %>% #' dplyr::group_by(name, size) %>% #' dplyr::summarize( -#' `Pizzas Sold` = n() +#' `Pizzas Sold` = dplyr::n() #' ) %>% #' gt(rowname_col = "size") %>% #' summary_rows( @@ -267,41 +275,38 @@ cells_stubhead <- function() { #' @rdname location_cells #' @import rlang #' @export -cells_column_labels <- function(columns, groups) { +cells_column_spanners <- function(spanners) { - if ( - (!missing(columns) && !missing(groups)) || - (missing(columns) && missing(groups)) - ) { - stop("Value(s) must provided to either `columns` or `groups` but not both.") - } + # Capture expression for the `spanners` argument + col_expr <- NULL + spanners_expr <- rlang::enquo(spanners) - # With input as `columns` - if (!missing(columns)) { - - # Capture expression for the `columns` argument - col_expr <- rlang::enquo(columns) - group_expr <- NULL - } + # Create the `cells_column_spanners` object + structure( + list(spanners = spanners_expr), + class = c("cells_column_spanners", "location_cells") + ) +} - # With input as `groups` - if (!missing(groups)) { +#' @rdname location_cells +#' @import rlang +#' @export +cells_column_labels <- function(columns) { - # Capture expression for the `groups` argument - col_expr <- NULL - group_expr <- rlang::enquo(groups) - } + # Capture expression for the `columns` argument + columns_expr <- rlang::enquo(columns) # Create the `cells_column_labels` object structure( - list(columns = col_expr, groups = group_expr), - class = c("cells_column_labels", "location_cells")) + list(columns = columns_expr), + class = c("cells_column_labels", "location_cells") + ) } #' @rdname location_cells #' @import rlang #' @export -cells_group <- function(groups) { +cells_group <- function(groups = TRUE) { # Capture expression for the `groups` argument group_expr <- rlang::enquo(groups) @@ -318,11 +323,7 @@ cells_group <- function(groups) { #' @rdname location_cells #' @import rlang #' @export -cells_stub <- function(rows = NULL) { - - if (is.null(rows)) { - rows <- TRUE - } +cells_stub <- function(rows = TRUE) { # Capture expression for the `rows` argument row_expr <- rlang::enquo(rows) @@ -339,10 +340,8 @@ cells_stub <- function(rows = NULL) { #' @rdname location_cells #' @import rlang #' @export -cells_data <- function(columns = NULL, # set default to TRUE - rows = NULL# set default to TRUE - #TODO: groups = NULL - ) { +cells_data <- function(columns = TRUE, + rows = TRUE) { # Capture expressions for the `columns` and `rows` arguments col_expr <- rlang::enquo(columns) @@ -352,7 +351,8 @@ cells_data <- function(columns = NULL, # set default to TRUE cells <- list( columns = col_expr, - rows = row_expr) + rows = row_expr + ) # Apply the `cells_data` and `location_cells` classes class(cells) <- c("cells_data", "location_cells") @@ -363,9 +363,9 @@ cells_data <- function(columns = NULL, # set default to TRUE #' @rdname location_cells #' @import rlang #' @export -cells_summary <- function(groups = NULL, - columns = NULL, - rows = NULL) { +cells_summary <- function(groups = TRUE, + columns = TRUE, + rows = TRUE) { # Capture expressions for the `groups`, # `columns`, and `rows` arguments @@ -378,7 +378,8 @@ cells_summary <- function(groups = NULL, list( groups = group_expr, columns = col_expr, - rows = row_expr) + rows = row_expr + ) # Apply the `cells_summary` and `location_cells` classes class(cells) <- c("cells_summary", "location_cells") @@ -389,8 +390,8 @@ cells_summary <- function(groups = NULL, #' @rdname location_cells #' @import rlang #' @export -cells_grand_summary <- function(columns = NULL, - rows = NULL) { +cells_grand_summary <- function(columns = TRUE, + rows = TRUE) { # Capture expressions for the `columns` # and `rows` arguments @@ -434,6 +435,10 @@ cells_grand_summary <- function(columns = NULL, #' @export md <- function(text) { + # if (text %>% tidy_grepl("\\.\\.[a-zA-Z0-9]*?\\.\\.")) { + # text %>% tidy_gsub(pattern = "\\.\\.[a-zA-Z0-9]*?\\.\\.", "") + # } + # Apply the `from_markdown` class class(text) <- "from_markdown" text @@ -491,7 +496,7 @@ is_html <- function(x) { #' currency symbol will be `"ltc"`. For convenience, if we provide only a single #' string without a name, it will be taken as the `default` (i.e., #' `currency("ltc")` is equivalent to `currency(default = "ltc")`). However, if -#' we were to specify currency strings for muliple output contexts, names are +#' we were to specify currency strings for multiple output contexts, names are #' required each and every context. #' #' @param ... One or more named arguments using output contexts as the names and diff --git a/R/info_tables.R b/R/info_tables.R index 3057913cd9..7a2aa430b2 100644 --- a/R/info_tables.R +++ b/R/info_tables.R @@ -46,7 +46,15 @@ info_date_style <- function() { cols_label(date = "Formatted Date") %>% tab_header( title = "Preset Date Formats", - subtitle = md("Usable in the `fmt_date()` and `fmt_datetime()` functions")) + subtitle = md("Usable in the `fmt_date()` and `fmt_datetime()` functions") + ) %>% + tab_style( + style = cell_text(align = "left"), + locations = list( + cells_title(groups = "title"), + cells_title(groups = "subtitle") + ) + ) } #' View a table with info on time styles @@ -85,10 +93,17 @@ info_time_style <- function() { cols_label(time = "Formatted Time") %>% tab_header( title = "Preset Time Formats", - subtitle = md("Usable in the `fmt_time()` and `fmt_datetime()` functions")) + subtitle = md("Usable in the `fmt_time()` and `fmt_datetime()` functions") + ) %>% + tab_style( + style = cell_text(align = "left"), + locations = list( + cells_title(groups = "title"), + cells_title(groups = "subtitle") + ) + ) } - #' View a table with info on supported currencies #' #' The `fmt_currency()` function lets us format numeric values as currencies. @@ -185,6 +200,13 @@ info_currencies <- function(type = c("code", "symbol"), tab_header( title = md("Currencies Supported in **gt**"), subtitle = md("Currency codes are used in the `fmt_currency()` function") + ) %>% + tab_style( + style = cell_text(align = "left"), + locations = list( + cells_title(groups = "title"), + cells_title(groups = "subtitle") + ) ) return(tab_1) @@ -220,13 +242,19 @@ info_currencies <- function(type = c("code", "symbol"), tab_header( title = md("Currencies Supported in **gt**"), subtitle = md("Currency symbols are used in the `fmt_currency()` function") + ) %>% + tab_style( + style = cell_text(align = "left"), + locations = list( + cells_title(groups = "title"), + cells_title(groups = "subtitle") + ) ) return(tab_1) } } - #' View a table with info on supported locales #' #' Many of the `fmt_*()` functions have a `locale` argument that makes @@ -293,8 +321,7 @@ info_locales <- function(begins_with = NULL) { columns = vars(group_sep, dec_sep) ) %>% cols_merge( - col_1 = vars(base_locale_id), - col_2 = vars(display_name), + columns = vars(base_locale_id, display_name), pattern = "{1}
{2}" ) %>% cols_label( @@ -419,9 +446,7 @@ info_paletteer <- function(color_pkgs = NULL) { palettes_strips } ) %>% - cols_label( - length = "" - ) %>% + cols_label(length = "") %>% tab_stubhead(label = "Package and Palette Name") %>% tab_header( title = md("Palettes Made Easily Available with **paletteer**"), @@ -438,7 +463,7 @@ info_paletteer <- function(color_pkgs = NULL) { style = list( cell_fill(color = "#E3E3E3"), cell_text(font = "Courier", size = "smaller", weight = "bold") - ), + ), locations = cells_stub(rows = TRUE) ) %>% tab_style( @@ -451,13 +476,15 @@ info_paletteer <- function(color_pkgs = NULL) { row_group.font.weight = "600", row_group.font.size = "smaller" ) %>% - tab_source_note(source_note = md( - paste0( - "The **paletteer** package is maintained by Emil Hvitfeldt. More ", - "information can be found on [the **paletteer** site]", - "(https://emilhvitfeldt.github.io/paletteer/) and on the ", - "[**CRAN** info page]", - "(https://cran.r-project.org/web/packages/paletteer/index.html)." + tab_source_note( + source_note = md( + paste0( + "The **paletteer** package is maintained by Emil Hvitfeldt. More ", + "information can be found on [the **paletteer** site]", + "(https://emilhvitfeldt.github.io/paletteer/) and on the ", + "[**CRAN** info page]", + "(https://cran.r-project.org/web/packages/paletteer/index.html)." + ) ) - )) + ) } diff --git a/R/location_methods.R b/R/location_methods.R index 8b62f077c0..7602daa5bd 100644 --- a/R/location_methods.R +++ b/R/location_methods.R @@ -1,30 +1,322 @@ +#' Upgrader function for `cells_*` objects +#' +#' Upgrade a `cells_*` object to a `list()` if only a single instance is +#' provided. +#' @param locations Any `cells_*` object. +#' @noRd +as_locations <- function(locations) { + + if (!inherits(locations, "location_cells")) { + + if (!is.list(locations) && + any(!vapply(locations, inherits, logical(1), "location_cells"))) { + + stop("The `locations` object should be a list of `cells_*()`.", + .call = FALSE) + } + } else { + locations <- list(locations) + } + + locations +} + +add_summary_location_row <- function(loc, + data, + style, + df_type = "styles_df") { + + stub_df <- dt_stub_df_get(data = data) + + row_groups <- + stub_df %>% + dplyr::pull(groupname) %>% + unique() + + summary_data <- dt_summary_get(data = data) + + summary_data_summaries <- + vapply( + seq(summary_data), + function(x) !is.null(summary_data[[x]]$groups), + logical(1) + ) + + summary_data <- summary_data[summary_data_summaries] + + groups <- + row_groups[resolve_data_vals_idx( + var_expr = !!loc$groups, + data_tbl = NULL, + vals = row_groups + )] + + # Adding styles to intersections of group, row, and column; any + # that are missing at render time will be ignored + for (group in groups) { + + summary_labels <- + lapply( + summary_data, + function(summary_data_item) { + if (isTRUE(summary_data_item$groups)) { + summary_data_item$summary_labels + } else if (group %in% summary_data_item$groups){ + summary_data_item$summary_labels + } + } + ) %>% + unlist() %>% + unique() + + col_idx <- + resolve_data_vals_idx( + var_expr = !!loc$columns, + data_tbl = NULL, + vals = dt_boxhead_get_vars_default(data = data) + ) + + columns <- dt_boxhead_get_vars_default(data = data)[col_idx] + + if (length(columns) == 0) { + stop("The location requested could not be resolved:\n", + " * Review the expression provided as `columns`", + call. = FALSE) + } + + rows <- + resolve_data_vals_idx( + var_expr = !!loc$rows, + data_tbl = NULL, + vals = summary_labels + ) + + if (length(rows) == 0) { + stop("The location requested could not be resolved:\n", + " * Review the expression provided as `rows`", + call. = FALSE) + } + + if (df_type == "footnotes_df") { + + data <- + dt_footnotes_add( + data = data, + locname = "summary_cells", + grpname = group, + colname = columns, + locnum = 5, + rownum = rows, + footnotes = style + ) + + } else { + + data <- + dt_styles_add( + data = data, + locname = "summary_cells", + grpname = group, + colname = columns, + locnum = 5, + rownum = rows, + styles = style + ) + } + } + + data +} + +add_grand_summary_location_row <- function(loc, + data, + style, + df_type = "styles_df") { + + summary_data <- dt_summary_get(data = data) + + grand_summary_labels <- + lapply(summary_data, function(summary_data_item) { + if (is.null(summary_data_item$groups)) { + return(summary_data_item$summary_labels) + } + NULL + }) %>% + unlist() %>% + unique() + + columns <- + resolve_vars( + var_expr = !!loc$columns, + data = data + ) + + if (length(columns) == 0) { + stop("The location requested could not be resolved:\n", + " * Review the expression provided as `columns`", + call. = FALSE) + } + + rows <- + resolve_data_vals_idx( + var_expr = !!loc$rows, + data_tbl = NULL, + vals = grand_summary_labels + ) + + if (length(rows) == 0) { + stop("The location requested could not be resolved:\n", + " * Review the expression provided as `rows`", + call. = FALSE) + } + + if (df_type == "footnotes_df") { + + data <- + dt_footnotes_add( + data = data, + locname = "grand_summary_cells", + grpname = grand_summary_col, + colname = columns, + locnum = 6, + rownum = rows, + footnotes = style + ) + + } else { + + data <- + dt_styles_add( + data = data, + locname = "grand_summary_cells", + grpname = grand_summary_col, + colname = columns, + locnum = 6, + rownum = rows, + styles = style + ) + } + + data +} + # Given a location (i.e. cells_*() function result), evaluate captured quosures # in the context of `data` and return an object with the `resolved` class added # to the front of the class list. -resolve_location <- function(loc, data_attr) { +resolve_location <- function(loc, data) { UseMethod("resolve_location") } -resolve_location.resolved <- function(loc, data_attr) { +resolve_location.resolved <- function(loc, data) { # The object is already resolved loc } +resolve_location.cells_data <- function(loc, data) { + + data_tbl <- dt_data_get(data = data) + stub_df <- dt_stub_df_get(data = data) + + loc$colnames <- + resolve_vars( + var_expr = !!loc[["columns"]], + data = data + ) + + loc$rows <- + resolve_data_vals_idx( + var_expr = !!loc[["rows"]], + data_tbl = data_tbl, + vals = stub_df$rowname + ) + + class(loc) <- c("resolved", class(loc)) + loc +} + +resolve_location.cells_column_labels <- function(loc, data) { + + data_tbl <- dt_data_get(data = data) + + if (!is.null(loc$columns)) { + + loc$colnames <- + resolve_vars( + var_expr = !!loc$columns, + data = data_tbl + ) + } + + # TODO: for now, when groups is set to TRUE, the + # behavior is not to select all groups; this + # should be changed to select all group + + # TODO: implement a stop() if groups provided not + # in the available set of groups + class(loc) <- c("resolved", class(loc)) + + loc +} + +resolve_location.cells_stub <- function(loc, data) { + + resolved <- resolve_cells_stub(data = data, object = loc) + + loc$rows <- resolved$rows + + class(loc) <- c("resolved", class(loc)) + + loc +} + # Given a location, reassign column/row numbers from data-relative to # output-relative, and return an object with the `output_relative` class added. -to_output_location <- function(loc, data_attr) { +to_output_location <- function(loc, data) { UseMethod("to_output_location") } -to_output_location.default <- function(loc, data_attr) { +to_output_location.default <- function(loc, data) { - loc <- resolve_location(loc, data_attr) + loc <- resolve_location(loc = loc, data = data) class(loc) <- c("output_relative", class(loc)) loc } -to_output_location.output_relative <- function(loc, data_attr) { +to_output_location.output_relative <- function(loc, data) { # The object is already output-relative loc } + +to_output_location.cells_data <- function(loc, data) { + + stub_df <- dt_stub_df_get(data = data) + groups <- dt_stub_groups_get(data = data) + + loc <- resolve_location(loc = loc, data = data) + + rows_df <- get_row_reorder_df(groups = groups, stub_df = stub_df) + + # We shouldn't need to do this, but `body` doesn't match up exactly to + # the colnum_final values due to groupnames/rownames + #loc$colnames <- loc$colnames + loc$rows <- rows_df$rownum_final[loc$rows] + + class(loc) <- c("output_relative", class(loc)) + loc +} + +to_output_location.cells_stub <- function(loc, data) { + + stub_df <- dt_stub_df_get(data = data) + groups <- dt_stub_groups_get(data = data) + + loc <- resolve_location(loc = loc, data = data) + + rows_df <- get_row_reorder_df(groups = groups, stub_df = stub_df) + + loc$rows <- rows_df$rownum_final[loc$rows] + + class(loc) <- c("output_relative", class(loc)) + loc +} diff --git a/R/modify_columns.R b/R/modify_columns.R index 91bc0ba528..3b4b8df2ef 100644 --- a/R/modify_columns.R +++ b/R/modify_columns.R @@ -19,7 +19,7 @@ #' according to the data type (see the Details section for specifics on which #' alignments are applied). #' @param columns An optional vector of column names for which the alignment -#' should be applied. If nothing is supplied, or if `columns` is `TRUE`), then +#' should be applied. If nothing is supplied, or if `columns` is `TRUE`, then #' the chosen alignment affects all columns. #' @return An object of class `gt_tbl`. #' @examples @@ -46,6 +46,8 @@ cols_align <- function(data, align = c("auto", "left", "center", "right"), columns = TRUE) { + data_tbl <- dt_data_get(data = data) + # Get the `align` value, this stops the function if there is no match align <- match.arg(align) @@ -60,7 +62,7 @@ cols_align <- function(data, # names col_classes <- lapply( - attr(data, "data_df", exact = TRUE)[column_names], class) %>% + data_tbl[column_names], class) %>% lapply(`[[`, 1) %>% unlist() @@ -77,10 +79,14 @@ cols_align <- function(data, "integer" = "center", "center") %>% unname() + } else { + + align <- rep(align, length(column_names)) } - # Set the alignment value for all columns in `columns` - attr(data, "boxh_df")["column_align", column_names] <- align + for (i in seq(column_names)) { + data <- data %>% dt_boxhead_edit(var = column_names[i], column_align = align[i]) + } data } @@ -88,12 +94,11 @@ cols_align <- function(data, #' Set the widths of columns #' #' Manual specifications of column widths can be performed using the -#' `cols_width()` function. We choose which columns get specific widths (in -#' pixels, usually by use of the [px()] helper function) and all other columns -#' are assigned a default width value though the `.others` argument. Width -#' assignments are supplied in `...` through two-sided formulas, where the -#' left-hand side defines the target columns and the right-hand side is a single -#' width value in pixels. +#' `cols_width()` function. We choose which columns get specific widths (in +#' pixels, usually by use of the [px()] helper function). Width assignments are +#' supplied in `...` through two-sided formulas, where the left-hand side +#' defines the target columns and the right-hand side is a single width value in +#' pixels. #' #' Normally, column widths are automatically set to span across the width of the #' container (both table and container widths can be individually modified with @@ -112,7 +117,9 @@ cols_align <- function(data, #' [matches()], [one_of()], and [everything()] can be used in the LHS. #' Subsequent expressions that operate on the columns assigned previously will #' result in overwriting column width values (both in the same `cols_width()` -#' call and across separate calls). +#' call and across separate calls). All other columns can be assigned a +#' default width value by using `TRUE` or `everything()` on the left-hand +#' side. #' @param .list Allows for the use of a list as an input alternative to `...`. #' @return An object of class `gt_tbl`. #' @examples @@ -154,9 +161,6 @@ cols_width <- function(data, call. = FALSE) } - # Extract the `col_names` list from `data/boxh_df` - boxh_df <- attr(data, "boxh_df", exact = TRUE) - all_formulas <- all( vapply( @@ -191,10 +195,33 @@ cols_width <- function(data, rlang::f_rhs() %>% rlang::eval_tidy() - boxh_df["column_width", ][columns] <- width + for (column in columns) { + data <- data %>% dt_boxhead_edit(var = column, column_width = list(width)) + } } - attr(data, "boxh_df") <- boxh_df + unset_widths <- + data %>% + dt_boxhead_get() %>% + .$column_width %>% + lapply(is.null) %>% + unlist() + + if (any(unset_widths)) { + + columns_unset <- (data %>% dt_boxhead_get_vars())[unset_widths] + + warning("Unset column widths found, setting them to `100px`:\n", + " * columns: ", + str_catalog(columns_unset), + ".\n", + " * Set any remaining column widths in `cols_width()` with `everything() ~ px(100)`.", + call. = FALSE) + + for (column in columns_unset) { + data <- data %>% dt_boxhead_edit(var = column, column_width = list("100px")) + } + } data } @@ -288,26 +315,31 @@ cols_label <- function(data, stop("All arguments to `cols_label()` must be named.", call. = FALSE) } - # Extract the `col_labels` list from `data` - col_labels <- attr(data, "col_labels", exact = TRUE) - # Stop function if any of the column names specified are not in `cols_labels` - if (!all(names(labels_list) %in% names(col_labels))) { + if (!all(names(labels_list) %in% dt_boxhead_get_vars(data = data))) { stop("All column names provided must exist in the input `data` table.") } - # Filter the list of labels by the names in `col_labels` - labels_list <- labels_list[names(labels_list) %in% names(col_labels)] + # Filter the list of labels by the var names in `data` + labels_list <- + labels_list[names(labels_list) %in% dt_boxhead_get_vars(data = data)] # If no labels remain after filtering, return the data if (length(labels_list) == 0) { return(data) } - col_labels[names(labels_list)] <- labels_list + nm_labels_list <- names(labels_list) + + for (i in seq_along(labels_list)) { - # Set the `col_labels` attr with the `col_labels` object - attr(data, "col_labels") <- col_labels + data <- + dt_boxhead_edit_column_label( + data = data, + var = nm_labels_list[i], + column_label = labels_list[[i]] + ) + } data } @@ -370,11 +402,7 @@ cols_move <- function(data, # Get the `after` columns as a character vector after <- resolve_vars(var_expr = !!after, data = data) - # Extract the internal `boxh_df` table - boxh_df <- attr(data, "boxh_df", exact = TRUE) - - # Extract the `data_df` df from `data` - data_df <- as.data.frame(data) + vars <- dt_boxhead_get_vars(data = data) # Stop function if `after` contains multiple columns if (length(after) > 1) { @@ -382,45 +410,34 @@ cols_move <- function(data, call. = FALSE) } - # Stop function if `after` doesn't exist in `data_df` - if (!(after %in% colnames(data_df))) { + # Stop function if `after` doesn't exist in `vars` + if (!(after %in% vars)) { stop("The column supplied to `after` doesn't exist in the input `data` table.", call. = FALSE) } - # Stop function if any of the `columns` doesn't exist in `data_df` - if (!all(columns %in% colnames(data_df))) { - stop("All `columns` must exist in the input `data` table.", - call. = FALSE) + # Stop function if no `columns` are provided + if (length(columns) == 0) { + stop("Columns must be provided.", call. = FALSE) } - # Filter the vector of column names by the - # column names actually in `boxh_df` - columns <- columns[which(columns %in% colnames(boxh_df))] - - if (length(columns) == 0) { - return(data) + # Stop function if any of the `columns` don't exist in `vars` + if (!all(columns %in% vars)) { + stop("All `columns` must exist and be visible in the input `data` table.", + call. = FALSE) } # Get the remaining column names in the table - column_names <- base::setdiff(colnames(boxh_df), columns) + moving_columns <- setdiff(columns, after) + other_columns <- base::setdiff(vars, moving_columns) # Get the column index for where the set # of `columns` should be inserted after - column_index <- which(column_names == after) + after_index <- which(other_columns == after) - if (length(columns) > 0 & column_index != length(column_names)) { + new_vars <- append(other_columns, moving_columns, after = after_index) - attr(data, "boxh_df") <- attr(data, "boxh_df") %>% - dplyr::select( - column_names[1:column_index], columns, - column_names[(column_index + 1):length(column_names)]) - - } else if (length(columns) > 0 & column_index == length(column_names)) { - - attr(data, "boxh_df") <- attr(data, "boxh_df") %>% - dplyr::select(column_names[1:column_index], columns) - } + data <- dt_boxhead_set_var_order(data, vars = new_vars) data } @@ -485,30 +502,28 @@ cols_move_to_start <- function(data, columns <- enquo(columns) + vars <- dt_boxhead_get_vars(data = data) + # Get the columns supplied in `columns` as a character vector columns <- resolve_vars(var_expr = !!columns, data = data) - # Extract the internal `boxh_df` table - boxh_df <- attr(data, "boxh_df", exact = TRUE) - - # Extract the `data_df` df from `data` - data_df <- as.data.frame(data) + # Stop function if no `columns` are provided + if (length(columns) == 0) { + stop("Columns must be provided.", call. = FALSE) + } - # Stop function if any of the `columns` doesn't exist in `data_df` - if (!all(columns %in% colnames(data_df))) { - stop("All `columns` must exist in the input `data` table.", + # Stop function if any of the `columns` don't exist in `vars` + if (!all(columns %in% vars)) { + stop("All `columns` must exist and be visible in the input `data` table.", call. = FALSE) } - # Filter the vector of column names by the - # column names actually in the input df - columns <- columns[which(columns %in% colnames(boxh_df))] + # Get the remaining column names in the table + other_columns <- base::setdiff(vars, columns) - if (length(columns) == 0) { - return(data) - } + new_vars <- append(other_columns, columns, after = 0) - attr(data, "boxh_df") <- attr(data, "boxh_df") %>% dplyr::select(columns, everything()) + data <- dt_boxhead_set_var_order(data, vars = new_vars) data } @@ -572,33 +587,28 @@ cols_move_to_end <- function(data, columns <- enquo(columns) + vars <- dt_boxhead_get_vars(data = data) + # Get the columns supplied in `columns` as a character vector columns <- resolve_vars(var_expr = !!columns, data = data) - # Extract the internal `boxh_df` table - boxh_df <- attr(data, "boxh_df", exact = TRUE) - - # Extract the `data_df` df from `data` - data_df <- as.data.frame(data) + # Stop function if no `columns` are provided + if (length(columns) == 0) { + stop("Columns must be provided.", call. = FALSE) + } - # Stop function if any of the `columns` doesn't exist in `data_df` - if (!all(columns %in% colnames(data_df))) { - stop("All `columns` must exist in the input `data` table.", + # Stop function if any of the `columns` don't exist in `vars` + if (!all(columns %in% vars)) { + stop("All `columns` must exist and be visible in the input `data` table.", call. = FALSE) } - # Filter the vector of column names by the - # column names actually in the input df - columns <- columns[which(columns %in% colnames(boxh_df))] - - if (length(columns) == 0) { - return(data) - } + # Get the remaining column names in the table + other_columns <- base::setdiff(vars, columns) - # Organize a vector of column names for `dplyr::select()` - columns <- c(base::setdiff(colnames(boxh_df), columns), columns) + new_vars <- append(other_columns, columns) - attr(data, "boxh_df") <- attr(data, "boxh_df") %>% dplyr::select(columns) + data <- dt_boxhead_set_var_order(data, vars = new_vars) data } @@ -674,136 +684,55 @@ cols_hide <- function(data, # Get the columns supplied in `columns` as a character vector columns <- resolve_vars(var_expr = !!columns, data = data) - boxh_df <- attr(data, "boxh_df") - - # Filter the vector of column names by the - # column names actually in the input df - columns <- columns[which(columns %in% colnames(boxh_df))] + vars <- dt_boxhead_get_vars(data = data) + # Stop function if no `columns` are provided if (length(columns) == 0) { - return(data) + stop("Columns must be provided.", call. = FALSE) } - # Organize a vector of column names for `dplyr::select()` - columns <- c(base::setdiff(colnames(boxh_df), columns)) - - attr(data, "boxh_df") <- attr(data, "boxh_df") %>% dplyr::select(columns) - - data -} - -#' Create group names and column labels via delimited names -#' -#' This function will split selected delimited column names such that the first -#' components (LHS) are promoted to being spanner column labels, and the -#' secondary components (RHS) will become the column labels. Please note that -#' reference to individual columns must continue to be the column names from the -#' input table data (which are unique by necessity). -#' -#' If we look to the column names in the `iris` dataset as an example of how -#' `cols_split_delim()` might be useful, we find the names `Sepal.Length`, -#' `Sepal.Width`, `Petal.Length`, `Petal.Width`. From this naming system, it's -#' easy to see that the `Sepal` and `Petal` can group together the repeated -#' common `Length` and `Width` values. In your own datasets, we can avoid a -#' lengthy relabeling with [cols_label()] if column names can be fashioned -#' beforehand to contain both the spanner column label and the column label. An -#' additional advantage is that the column names in the input table data remain -#' unique even though there may eventually be repeated column labels in the -#' rendered output table). -#' -#' @inheritParams cols_align -#' @param delim The delimiter to use to split an input column name. The -#' delimiter supplied will be autoescaped for the internal splitting -#' procedure. The first component of the split will become the group name and -#' the second component will be the column label. -#' @param columns An optional vector of column names that this operation should -#' be limited to. The default is to consider all columns in the table. -#' @return An object of class `gt_tbl`. -#' @examples -#' # Use `iris` to create a gt table; split -#' # any columns that are dot-separated -#' # between column spanner labels (first -#' # part) and column labels (second part) -#' tab_1 <- -#' iris %>% -#' dplyr::group_by(Species) %>% -#' dplyr::slice(1:4) %>% -#' gt() %>% -#' cols_split_delim(delim = ".") -#' -#' @section Figures: -#' \if{html}{\figure{man_cols_split_delim_1.svg}{options: width=100\%}} -#' -#' @family column modification functions -#' @export -cols_split_delim <- function(data, - delim, - columns = NULL) { - - columns <- enquo(columns) - - # Escape any characters that require escaping - delim <- gsub("\\.", "\\\\.", delim) - - # Get all of the columns in the dataset - all_cols <- colnames(attr(data, "boxh_df", exact = TRUE)) - - # Get the columns supplied in `columns` as a character vector - columns <- resolve_vars(var_expr = !!columns, data = data) - - if (!is.null(columns)) { - colnames <- base::intersect(all_cols, columns) - } else { - colnames <- all_cols + # Stop function if any of the `columns` don't exist in `vars` + if (!all(columns %in% vars)) { + stop("All `columns` must exist in the input `data` table.", + call. = FALSE) } - if (length(colnames) == 0) { - return(data) - } - - colnames_has_delim <- grepl(paste0("[^.]", delim, "[^.]"), colnames) - - if (any(colnames_has_delim)) { - - split_colnames <- strsplit(colnames[colnames_has_delim], delim) - - attr(data, "grp_labels")[colnames[colnames_has_delim]] <- - vapply(split_colnames, `[[`, character(1), 1) - - attr(data, "col_labels")[colnames[colnames_has_delim]] <- - vapply(split_colnames, `[[`, character(1), 2) + for (column in columns) { + data <- data %>% dt_boxhead_edit(var = column, type = "hidden") } data } -#' Merge two columns to a single column +#' Merge data from two or more columns to a single column #' -#' This function takes any two columns and merges them into a single column, -#' using a pattern that specifies how the values in the data cells are combined. -#' We specify the columns to merge together in the `col_1` and `col_2` arguments -#' and the string-combining pattern is specified in `pattern`. The column that -#' is retained is that of `col_1` whereas the column specified in `col_2` is -#' dropped from the output table. +#' This function takes input from two or more columns and allows the contents to +#' be merged them into a single column, using a pattern that specifies the +#' formatting. We can specify which columns to merge together in the `columns` +#' argument. The string-combining pattern is given in the `pattern` argument. +#' The first column in the `columns` series operates as the target column (i.e., +#' will undergo mutation) whereas all following `columns` will be untouched. #' #' There are two other column-merging functions that offer specialized behavior #' that is optimized for common table tasks: [cols_merge_range()] and -#' [cols_merge_uncert()]. These functions operate similarly, where the second -#' column specified is dropped from the output table. For all of the -#' `cols_merge*()` functions, column removal occurs late in the rendering -#' lifecycle so those secondary columns are still usable as column references -#' (e.g., inside expressions provided to `rows` in the `fmt*()` functions). +#' [cols_merge_uncert()]. These functions operate similarly, where the +#' non-target columns can be optionally hidden from the output table through the +#' `hide_columns` or `autohide` options. #' #' @inheritParams cols_align -#' @param col_1 A retained column that contains values to be merged with those -#' in `col_2`. -#' @param col_2 A column that contains values to be merged with those in -#' `col_1`. This column will be discarded but is still useful as a reference -#' in other \pkg{gt} functions. +#' @param columns The columns that will participate in the merging process. The +#' first column name provided will be the target column (i.e., undergo +#' mutation) and the other columns will serve to provide input. +#' @param hide_columns Any column names provided here will have their state +#' changed to `hidden` (via internal use of [cols_hide()] if they aren't +#' already hidden. This is convenient if the purpose of these specified +#' columns are only useful for providing string input to the target column. #' @param pattern A formatting pattern that specifies the arrangement of the -#' `col_1` and `col_1` values and any string literals. The `col_1` column is -#' represented as `{1}` whereas `col_2` is `{2}`. All other characters are -#' taken to be string literals. +#' `column` values and any string literals. We can use column names or numbers +#' (corresponding to the position of columns provided in `columns`). The +#' column names or indices are to be placed in curly braces (e.g., `{price}` +#' or `{1}`). All characters outside of braces are taken to be string +#' literals. #' @return An object of class `gt_tbl`. #' @examples #' # Use `sp500` to create a gt table; @@ -817,13 +746,13 @@ cols_split_delim <- function(data, #' dplyr::select(-volume, -adj_close) %>% #' gt() %>% #' cols_merge( -#' col_1 = vars(open), -#' col_2 = vars(close), +#' columns = vars(open, close), +#' hide_columns = vars(close), #' pattern = "{1}—{2}" #' ) %>% #' cols_merge( -#' col_1 = vars(low), -#' col_2 = vars(high), +#' columns = vars(low, high), +#' hide_columns = vars(high), #' pattern = "{1}—{2}" #' ) %>% #' cols_label( @@ -838,49 +767,43 @@ cols_split_delim <- function(data, #' @import rlang #' @export cols_merge <- function(data, - col_1, - col_2, - pattern = "{1} {2}") { - - col_1 <- enquo(col_1) - col_2 <- enquo(col_2) + columns, + hide_columns = columns[-1], + pattern = paste0("{", seq_along(columns), "}", collapse = " ")) { - # Get the columns supplied in `col_1` as a character vector - col_1 <- resolve_vars(var_expr = !!col_1, data = data) + columns <- enquo(columns) - # Get the columns supplied in `col_2` as a character vector - col_2 <- resolve_vars(var_expr = !!col_2, data = data) + # Get the columns supplied in `columns` as a character vector + columns <- resolve_vars(var_expr = !!columns, data = data) - # Create a named character vector using - # `col_1` and `col_2` - col_1 <- stats::setNames(col_1, nm = col_2) + if (!is.null(hide_columns)) { - # Create and store a list of column pairs - if ("col_merge" %in% names(attributes(data))) { + hide_columns <- enquo(hide_columns) - if (col_1 %in% unname(attr(data, "col_merge")[["col_1"]]) | - col_2 %in% names(attr(data, "col_merge")[["col_1"]])) { - return(data) - } + # Get the columns supplied in `hide_columns` as a character vector + hide_columns <- resolve_vars(var_expr = !!hide_columns, data = data) - attr(data, "col_merge")[["pattern"]] <- - c(attr(data, "col_merge")[["pattern"]], pattern) + hide_columns_from_supplied <- base::intersect(hide_columns, columns) - attr(data, "col_merge")[["sep"]] <- - c(attr(data, "col_merge")[["sep"]], "") - - attr(data, "col_merge")[["col_1"]] <- - c(attr(data, "col_merge")[["col_1"]], col_1) + if (length(base::setdiff(hide_columns, columns) > 0)) { + warning("Only the columns supplied in `columns` will be hidden.\n", + " * use `cols_hide()` to hide any out of scope columns", + call. = FALSE) + } - } else { + data <- data %>% cols_hide(columns = hide_columns_from_supplied) + } - attr(data, "col_merge") <- - list( - pattern = pattern, - sep = "", - col_1 = col_1 + # Create an entry and add it to the `_col_merge` attribute + data <- + dt_col_merge_add( + data = data, + col_merge = dt_col_merge_entry( + vars = columns, + type = "merge", + pattern = pattern ) - } + ) data } @@ -918,14 +841,18 @@ cols_merge <- function(data, #' This function is part of a set of three column-merging functions. The other #' two are the general [cols_merge()] function and the specialized #' [cols_merge_range()] function. These functions operate similarly, where the -#' second column specified is dropped from the output table. For all of the -#' `cols_merge*()` functions, column removal occurs late in the rendering -#' lifecycle so those secondary columns are still usable as column references -#' (e.g., inside expressions provided to `rows` in the `fmt*()` functions). +#' non-target columns can be optionally hidden from the output table through the +#' `hide_columns` or `autohide` options. #' #' @inheritParams cols_align -#' @param col_val A single column name that contains the base values. +#' @param col_val A single column name that contains the base values. This is +#' the column where values will be mutated. #' @param col_uncert A single column name that contains the uncertainty values. +#' These values will be combined with those in `col_val`. We have the option +#' to automatically hide the `col_uncert` column through `autohide`. +#' @param autohide An option to automatically hide the column specified as +#' `col_uncert`. Any columns with their state changed to hidden will behave +#' the same as before, they just won't be displayed in the finalized table. #' @return An object of class `gt_tbl`. #' @examples #' # Use `exibble` to create a gt table, @@ -959,52 +886,19 @@ cols_merge <- function(data, #' @export cols_merge_uncert <- function(data, col_val, - col_uncert) { - - # Set the formatting pattern - pattern <- "{1} \u00B1 {2}" - - col_val <- enquo(col_val) - col_uncert <- enquo(col_uncert) - - # Get the columns supplied in `col_val` as a character vector - col_val <- resolve_vars(var_expr = !!col_val, data = data) - - # Get the columns supplied in `col_val` as a character vector - col_uncert <- resolve_vars(var_expr = !!col_uncert, data = data) - - # Create a named character vector using - # `col_val` and `col_uncert` - col_val <- stats::setNames(col_val, nm = col_uncert) - - # Create and store a list of column pairs - if ("col_merge" %in% names(attributes(data))) { - - if (col_val %in% unname(attr(data, "col_merge")[["col_1"]]) | - col_uncert %in% names(attr(data, "col_merge")[["col_1"]])) { - return(data) - } - - attr(data, "col_merge")[["pattern"]] <- - c(attr(data, "col_merge")[["pattern"]], pattern) - - attr(data, "col_merge")[["sep"]] <- - c(attr(data, "col_merge")[["sep"]], "") - - attr(data, "col_merge")[["col_1"]] <- - c(attr(data, "col_merge")[["col_1"]], col_val) - - } else { - - attr(data, "col_merge") <- - list( - pattern = pattern, - sep = "", - col_1 = col_val - ) - } - - data + col_uncert, + autohide = TRUE) { + + # Use a predefined separator + sep <- " \u00B1 " + + cols_merge_range( + data = data, + col_begin = col_val, + col_end = col_uncert, + sep = sep, + autohide = autohide + ) } #' Merge two columns to a value range column @@ -1017,7 +911,7 @@ cols_merge_uncert <- function(data, #' the output table. #' #' This function could be somewhat replicated using [cols_merge()], however, -#' `cols_merge_range()` employs the following specialized semantics for `NA` +#' `cols_merge_range()` employs the following specialized operations for `NA` #' handling: #' #' \enumerate{ @@ -1039,15 +933,16 @@ cols_merge_uncert <- function(data, #' This function is part of a set of three column-merging functions. The other #' two are the general [cols_merge()] function and the specialized #' [cols_merge_uncert()] function. These functions operate similarly, where the -#' second column specified is dropped from the output table. For all of the -#' `cols_merge*()` functions, column removal occurs late in the rendering -#' lifecycle so those secondary columns are still usable as column references -#' (e.g., inside expressions provided to `rows` in the `fmt*()` functions). +#' non-target columns can be optionally hidden from the output table through the +#' `hide_columns` or `autohide` options. #' #' @inheritParams cols_align #' @param col_begin A column that contains values for the start of the range. #' @param col_end A column that contains values for the end of the range. #' @param sep The separator text that indicates the values are ranged. +#' @param autohide An option to automatically hide the column specified as +#' `col_end`. Any columns with their state changed to hidden will behave +#' the same as before, they just won't be displayed in the finalized table. #' @return An object of class `gt_tbl`. #' @examples #' # Use `gtcars` to create a gt table, @@ -1063,7 +958,8 @@ cols_merge_uncert <- function(data, #' gt() %>% #' cols_merge_range( #' col_begin = vars(mpg_c), -#' col_end = vars(mpg_h)) %>% +#' col_end = vars(mpg_h) +#' ) %>% #' cols_label( #' mpg_c = md("*MPG*") #' ) @@ -1077,10 +973,11 @@ cols_merge_uncert <- function(data, cols_merge_range <- function(data, col_begin, col_end, - sep = "---") { + sep = "--", + autohide = TRUE) { # Set the formatting pattern - pattern <- "{1} {sep} {2}" + pattern <- "{1}{sep}{2}" col_begin <- enquo(col_begin) col_end <- enquo(col_end) @@ -1091,35 +988,22 @@ cols_merge_range <- function(data, # Get the columns supplied in `col_end` as a character vector col_end <- resolve_vars(var_expr = !!col_end, data = data) - # Create a named character vector using - # `col_begin` and `col_end` - col_begin <- stats::setNames(col_begin, nm = col_end) - - # Create and store a list of column pairs - if ("col_merge" %in% names(attributes(data))) { - - if (col_begin %in% unname(attr(data, "col_merge")[["col_1"]]) | - col_end %in% names(attr(data, "col_merge")[["col_1"]])) { - return(data) - } + columns <- c(col_begin, col_end) - attr(data, "col_merge")[["pattern"]] <- - c(attr(data, "col_merge")[["pattern"]], pattern) - - attr(data, "col_merge")[["sep"]] <- - c(attr(data, "col_merge")[["sep"]], sep) - - attr(data, "col_merge")[["col_1"]] <- - c(attr(data, "col_merge")[["col_1"]], col_begin) - - } else { - - attr(data, "col_merge") <- - list( + # Create an entry and add it to the `_col_merge` attribute + data <- + dt_col_merge_add( + data = data, + col_merge = dt_col_merge_entry( + vars = columns, + type = "merge_range", pattern = pattern, - sep = sep, - col_1 = col_begin + sep = sep ) + ) + + if (isTRUE(autohide)) { + data <- data %>% cols_hide(columns = col_end) } data diff --git a/R/modify_rows.R b/R/modify_rows.R index 8153d32652..f27866d91d 100644 --- a/R/modify_rows.R +++ b/R/modify_rows.R @@ -48,11 +48,8 @@ row_group_order <- function(data, call. = FALSE) } - # Get the current arrangement of `groups` - arrange_groups <- - attr(data, "arrange_groups", exact = TRUE) %>% - unlist() %>% - unname() + # Get the current arrangement of the row groups + arrange_groups <- dt_stub_groups_get(data = data) if (inherits(groups, "character")) { @@ -86,7 +83,5 @@ row_group_order <- function(data, } # Create and store a list of row groups in the intended ordering - attr(data, "arrange_groups") <- list(groups = groups) - - data + dt_stub_groups_set(data = data, stub_groups = groups) } diff --git a/R/print.R b/R/print.R index 9801e0a90e..a032887e04 100644 --- a/R/print.R +++ b/R/print.R @@ -53,15 +53,12 @@ as.tags.gt_tbl <- function(x, ...) { # Generate the HTML table html_table <- render_as_html(data = x) - # Extract the `opts_df` data frame object from `x` - opts_df <- attr(x, "opts_df", exact = TRUE) - # Get options related to the enclosing
- id <- opts_df_get(opts_df, option = "table_id") - container_overflow_x <- opts_df_get(opts_df, option = "container_overflow_x") - container_overflow_y <- opts_df_get(opts_df, option = "container_overflow_y") - container_width <- opts_df_get(opts_df, option = "container_width") - container_height <- opts_df_get(opts_df, option = "container_height") + id <- x %>% dt_options_get_value(option = "table_id") + container_overflow_x <- x %>% dt_options_get_value(option = "container_overflow_x") + container_overflow_y <- x %>% dt_options_get_value(option = "container_overflow_y") + container_width <- x %>% dt_options_get_value(option = "container_width") + container_height <- x %>% dt_options_get_value(option = "container_height") # If the ID hasn't been set, set `id` as NULL if (is.na(id)) { diff --git a/R/render_as_html.R b/R/render_as_html.R index d00ef50e08..07aebcf33b 100644 --- a/R/render_as_html.R +++ b/R/render_as_html.R @@ -7,132 +7,42 @@ #' @noRd render_as_html <- function(data) { - # Build all table data objects through a common pipeline - built_data <- data %>% build_data(context = "html") + data <- data %>% build_data(context = "html") - # Use HTML-specific builders to generate the HTML table code - with(built_data, { + # Composition of HTML ----------------------------------------------------- - # Composition of HTML ----------------------------------------------------- + # Upgrade `_styles` to gain a `html_style` column with CSS style rules + data <- add_css_styles(data = data) - # Add footnote marks to elements of the table columns - boxh_df <- - set_footnote_marks_columns( - footnotes_resolved = footnotes_resolved, - boxh_df = boxh_df, - output = "html" - ) + # Create the heading component + heading_component <- create_heading_component(data = data, context = "html") - # Add footnote marks to the stubhead label - stubhead <- - set_footnote_marks_stubhead( - footnotes_resolved = footnotes_resolved, - stubhead = stubhead, - output = "html" - ) + # Create the columns component + columns_component <- create_columns_component_h(data = data) - # Add footnote marks to the `data` rows - output_df <- - apply_footnotes_to_output( - output_df = output_df, - footnotes_resolved = footnotes_resolved, - output = "html" - ) + # Create the body component + body_component <- create_body_component_h(data = data) - # Add footnote marks to the stub group cells - groups_rows_df <- - set_footnote_marks_stub_groups( - footnotes_resolved = footnotes_resolved, - groups_rows_df = groups_rows_df, - output = "html" - ) + # Create the source notes component + source_notes_component <- create_source_notes_component_h(data = data) - # Add footnote marks to the `summary` cells - list_of_summaries <- - apply_footnotes_to_summary( - list_of_summaries = list_of_summaries, - footnotes_resolved = footnotes_resolved - ) + # Create the footnotes component + footnotes_component <- create_footnotes_component_h(data = data) - # Upgrade `styles_resolved` to gain a `html_style` - # column with style rules - if (nrow(styles_resolved) > 0) { - styles_resolved <- - styles_resolved %>% - dplyr::mutate( - html_style = vapply( - styles_appended, function(x) styles_to_html(x), character(1)) - ) - } + # Get attributes for the gt table + table_defs <- get_table_defs(data = data) - # Create the heading component of the table - heading_component <- - create_heading_component( - heading = heading, - footnotes_resolved = footnotes_resolved, - styles_resolved = styles_resolved, - n_cols = n_cols, - subtitle_defined = subtitle_defined, - output = "html" - ) + # Compose the HTML table + htmltools::tags$table( + class = "gt_table", + style = table_defs$table_style, + table_defs$table_colgroups, + heading_component, + columns_component, + body_component, + source_notes_component, + footnotes_component + ) %>% + as.character() - # Create the columns component of the table - columns_component <- - create_columns_component_h( - boxh_df = boxh_df, - output_df = output_df, - stub_available = stub_available, - spanners_present = spanners_present, - styles_resolved = styles_resolved, - stubhead = stubhead, - col_alignment = col_alignment, - opts_df = opts_df - ) - - # Create the body component of the table - body_component <- - create_body_component_h( - output_df = output_df, - styles_resolved = styles_resolved, - groups_rows_df = groups_rows_df, - col_alignment = col_alignment, - stub_components = stub_components, - summaries_present = summaries_present, - list_of_summaries = list_of_summaries, - n_rows = n_rows, - n_cols = n_cols, - opts_df = opts_df - ) - - # Create the source note rows and handle any available footnotes - source_note_component <- - create_source_note_component_h( - source_note = source_note, - n_cols = n_cols - ) - - # Create the footnote component of the table - footnote_component <- - create_footnote_component_h( - footnotes_resolved = footnotes_resolved, - opts_df = opts_df, - n_cols = n_cols - ) - - # Get attributes for the gt table - table_defs <- get_table_defs(boxh_df) - - # Compose the HTML table - htmltools::tags$table( - class = "gt_table", - style = table_defs$table_style, - table_defs$table_colgroups, - heading_component, - columns_component, - body_component, - source_note_component, - footnote_component - ) %>% - as.character() - }) } diff --git a/R/resolver.R b/R/resolver.R index f73c47d110..073affdd85 100644 --- a/R/resolver.R +++ b/R/resolver.R @@ -9,7 +9,8 @@ resolve_cells_data <- function(data, # Get the `stub_df` data frame from `data` - stub_df <- attr(data, "stub_df", exact = TRUE) + stub_df <- dt_stub_df_get(data = data) + data_tbl <- dt_data_get(data = data) # # Resolution of columns and rows as integer vectors @@ -26,7 +27,7 @@ resolve_cells_data <- function(data, resolved_rows_idx <- resolve_data_vals_idx( var_expr = !!object$rows, - data = data, + data_tbl = data_tbl, vals = stub_df$rowname ) @@ -41,10 +42,15 @@ resolve_cells_data <- function(data, dplyr::distinct() # Create a list object - cells_resolved <- list(columns = expansion[[1]], rows = expansion[[2]]) + cells_resolved <- + list( + columns = expansion[[1]], + colnames = resolve_vars(var_expr = expansion[[1]], data = data), + rows = expansion[[2]] + ) # Apply the `data_cells_resolved` class - attr(cells_resolved, "class") <- "data_cells_resolved" + class(cells_resolved) <- "data_cells_resolved" cells_resolved } @@ -57,11 +63,7 @@ resolve_cells_data <- function(data, resolve_cells_stub <- function(data, object) { - # Get the `data_df` data frame from `data` - data_df <- as.data.frame(data) - - # Get the `stub_df` data frame from `data` - stub_df <- attr(data, "stub_df", exact = TRUE) + stub_df <- dt_stub_df_get(data = data) # # Resolution of rows as integer vectors @@ -70,7 +72,7 @@ resolve_cells_stub <- function(data, resolved_rows_idx <- resolve_data_vals_idx( var_expr = !!object$rows, - data = data, + data_tbl = NULL, vals = stub_df$rowname ) @@ -78,7 +80,7 @@ resolve_cells_stub <- function(data, cells_resolved <- list(rows = resolved_rows_idx) # Apply the `stub_cells_resolved` class - attr(cells_resolved, "class") <- "stub_cells_resolved" + class(cells_resolved) <- "stub_cells_resolved" cells_resolved } @@ -99,16 +101,56 @@ resolve_cells_column_labels <- function(data, # resolved_columns <- - resolve_vars_idx( + resolve_data_vals_idx( var_expr = !!object$columns, - data = data + data_tbl = NULL, + vals = dt_boxhead_get_vars_default(data = data) ) # Create a list object cells_resolved <- list(columns = resolved_columns) # Apply the `columns_cells_resolved` class - attr(cells_resolved, "class") <- "columns_cells_resolved" + class(cells_resolved) <- "columns_cells_resolved" + + cells_resolved +} + +#' Resolve the spanner values in the `cells_column_labels` object once it +#' has access to the `data` object +#' +#' @param data A table object that is created using the `gt()` function. +#' @param object The list object created by the `cells_column_labels()` +#' function. +#' @noRd +resolve_cells_column_spanners <- function(data, + object) { + + # + # Resolution of spanners as column spanner names + # + + spanner_labels <- + dt_spanners_get(data = data) %>% + .$spanner_label %>% + unlist() %>% + .[!is.na(.)] %>% + unique() + + resolved_spanners_idx <- + resolve_data_vals_idx( + var_expr = !!object$spanners, + data_tbl = NULL, + vals = spanner_labels + ) + + resolved_spanners <- spanner_labels[resolved_spanners_idx] + + # Create a list object + cells_resolved <- list(spanners = resolved_spanners) + + # Apply the `columns_cells_resolved` class + class(cells_resolved) <- "columns_spanners_resolved" cells_resolved } @@ -117,8 +159,7 @@ resolve_cells_column_labels <- function(data, #' #' @param var_expr An expression to evaluate. This is passed directly to #' `rlang::eval_tidy()` as a value for the `expr` argument. -#' @param data The input table available in `data` (usually accessed through -#' `as.data.frame(data)`). +#' @param data The gt object. #' @noRd resolve_vars_idx <- function(var_expr, data) { @@ -127,8 +168,8 @@ resolve_vars_idx <- function(var_expr, resolve_data_vals_idx( var_expr = !!var_expr, - data = NULL, - vals = colnames(as.data.frame(data)) + data_tbl = NULL, + vals = colnames(dt_data_get(data = data)) ) } @@ -136,20 +177,20 @@ resolve_vars_idx <- function(var_expr, #' #' @param var_expr An expression to evaluate. This is passed directly to #' `rlang::eval_tidy()` as a value for the `expr` argument. -#' @param data The input table available in `data` (usually accessed through -#' `as.data.frame(data)`). +#' @param data_tbl The input table available in `data` (usually accessed through +#' `dt_data_get(data)`). #' @param vals The names of columns or rows in `data`. #' @import tidyselect #' @import rlang #' @noRd resolve_data_vals_idx <- function(var_expr, - data, + data_tbl, vals) { var_expr <- enquo(var_expr) - if (!is.null(data)) { - data <- as.data.frame(data) + if (!is.null(data_tbl)) { + data_tbl <- as.data.frame(data_tbl) } # Translate variable expressions (e.g., logical @@ -160,7 +201,7 @@ resolve_data_vals_idx <- function(var_expr, vals, rlang::eval_tidy( expr = var_expr, - data = data, + data = data_tbl, env = emptyenv() ) ) @@ -184,16 +225,17 @@ resolve_data_vals_idx <- function(var_expr, } else if (is.numeric(resolved)) { if (any(!(resolved %in% seq_along(vals)))) { - stop("All column or row indices given must be present in `data`.", + stop("All column or row indices given must be present in `data_tbl`.", call. = FALSE) } - resolved <- which(seq_along(vals) %in% resolved) + # `resolved` is already in terms of indices + # resolved <- resolved } else if (is.character(resolved)) { resolved <- tidyselect::vars_select(vals, !!!rlang::syms(resolved)) - resolved <- which(vals %in% resolved) + resolved <- resolve_vals(resolved = resolved, vals = vals) } else if (is_quosures(resolved)) { @@ -204,13 +246,24 @@ resolve_data_vals_idx <- function(var_expr, } resolved <- vapply(resolved, quo_get_expr_char, character(1)) - resolved <- tidyselect::vars_select(vals, !!!rlang::syms(resolved)) - resolved <- which(vals %in% resolved) + resolved <- tidyselect::vars_select(vals, !!!rlang::syms(resolved)) %>% unname() + resolved <- resolve_vals(resolved = resolved, vals = vals) } resolved } +resolve_vals <- function(resolved, vals) { + + resolved_idx <- c() + + for (res in resolved) { + resolved_idx <- c(resolved_idx, which(vals %in% res)) + } + + resolved_idx +} + #' Resolve expressions to obtain column names #' #' @param var_expr The immutable column names from the input table. @@ -222,10 +275,10 @@ resolve_vars <- function(var_expr, var_expr <- enquo(var_expr) # Obtain the data frame of the input table data - data_df <- as.data.frame(data) + data_tbl <- dt_data_get(data = data) # Collect column names from the input table data - column_names <- colnames(data_df) + column_names <- colnames(data_tbl) # Use `resolve_vars_idx()` to obtain a vector # column indices diff --git a/R/summary_rows.R b/R/summary_rows.R index c085305fbb..8116a046e5 100644 --- a/R/summary_rows.R +++ b/R/summary_rows.R @@ -101,7 +101,9 @@ summary_rows <- function(data, } # Get the `stub_df` object from `data` - stub_df <- attr(data, "stub_df", exact = TRUE) + stub_df <- dt_stub_df_get(data = data) + + stub_available <- dt_stub_df_exists(data = data) # Resolve the column names columns <- enquo(columns) @@ -110,12 +112,12 @@ summary_rows <- function(data, # If there isn't a stub available, create an # 'empty' stub (populated with empty strings); # the stub is necessary for summary row labels - if (!is_stub_available(stub_df) && is.null(groups)) { + if (!stub_available && is.null(groups)) { # Place the `rowname` values into `stub_df$rowname` stub_df[["rowname"]] <- "" - attr(data, "stub_df") <- stub_df + data <- dt_stub_df_set(data = data, stub_df = stub_df) } # Derive the summary labels @@ -128,24 +130,19 @@ summary_rows <- function(data, summary_labels <- names(summary_labels) } - # Append list of summary inputs to the - # `summary` attribute - attr(data, "summary") <- - c( - attr(data, "summary"), - list( - list( - groups = groups, - columns = columns, - fns = fns, - summary_labels = summary_labels, - missing_text = missing_text, - formatter = formatter, - formatter_options = formatter_options - ) - ) + summary_list <- + list( + groups = groups, + columns = columns, + fns = fns, + summary_labels = summary_labels, + missing_text = missing_text, + formatter = formatter, + formatter_options = formatter_options ) + data <- dt_summary_add(data = data, summary = summary_list) + data } @@ -167,179 +164,3 @@ grand_summary_rows <- function(data, formatter = formatter, ...) } - -add_summary_location_row <- function(loc, - data, - style, - df_type = "styles_df") { - - stub_df <- attr(data, "stub_df", exact = TRUE) - - row_groups <- - stub_df[, "groupname"] %>% - unique() - - summary_data <- attr(data, "summary", exact = TRUE) - - summary_data_summaries <- - vapply( - seq(summary_data), - function(x) !is.null(summary_data[[x]]$groups), - logical(1) - ) - - summary_data <- summary_data[summary_data_summaries] - - groups <- - row_groups[resolve_data_vals_idx( - var_expr = !!loc$groups, - data = NULL, - vals = row_groups - )] - - # Adding styles to intersections of group, row, and column; any - # that are missing at render time will be ignored - for (group in groups) { - - summary_labels <- - lapply( - summary_data, - function(summary_data_item) { - if (isTRUE(summary_data_item$groups)) { - summary_data_item$summary_labels - } else if (group %in% summary_data_item$groups){ - summary_data_item$summary_labels - } - } - ) %>% - unlist() %>% - unique() - - columns <- - resolve_vars( - var_expr = !!loc$columns, - data = data - ) - - if (length(columns) == 0) { - stop("The location requested could not be resolved:\n", - " * Review the expression provided as `columns`", - call. = FALSE) - } - - rows <- - resolve_data_vals_idx( - var_expr = !!loc$rows, - data = NULL, - vals = summary_labels - ) - - if (length(rows) == 0) { - stop("The location requested could not be resolved:\n", - " * Review the expression provided as `rows`", - call. = FALSE) - } - - if (df_type == "footnotes_df") { - - attr(data, df_type) <- - add_location_row_footnotes( - data, - locname = "summary_cells", - locnum = 5, - grpname = group, - colname = columns, - rownum = rows, - footnotes = style - ) - - } else { - - attr(data, df_type) <- - add_location_row_styles( - data, - locname = "summary_cells", - locnum = 5, - grpname = group, - colname = columns, - rownum = rows, - styles = list(style) - ) - } - } - - data -} - -add_grand_summary_location_row <- function(loc, - data, - style, - df_type = "styles_df") { - - summary_data <- attr(data, "summary", exact = TRUE) - - grand_summary_labels <- - lapply(summary_data, function(summary_data_item) { - if (is.null(summary_data_item$groups)) { - return(summary_data_item$summary_labels) - } - - NULL - }) %>% - unlist() %>% - unique() - - columns <- - resolve_vars( - var_expr = !!loc$columns, - data = data - ) - - if (length(columns) == 0) { - stop("The location requested could not be resolved:\n", - " * Review the expression provided as `columns`", - call. = FALSE) - } - - rows <- - resolve_data_vals_idx( - var_expr = !!loc$rows, - data = NULL, - vals = grand_summary_labels - ) - - if (length(rows) == 0) { - stop("The location requested could not be resolved:\n", - " * Review the expression provided as `rows`", - call. = FALSE) - } - - if (df_type == "footnotes_df") { - - attr(data, df_type) <- - add_location_row_footnotes( - data, - locname = "grand_summary_cells", - locnum = 6, - grpname = grand_summary_col, - colname = columns, - rownum = rows, - footnotes = style - ) - - } else { - - attr(data, df_type) <- - add_location_row_styles( - data, - locname = "grand_summary_cells", - locnum = 6, - grpname = grand_summary_col, - colname = columns, - rownum = rows, - styles = list(style) - ) - } - - data -} diff --git a/R/tab_footnote.R b/R/tab_footnote.R index d1bdd8d389..e091bf7d92 100644 --- a/R/tab_footnote.R +++ b/R/tab_footnote.R @@ -80,7 +80,7 @@ tab_footnote <- function(data, # Resolve the locations of the targeted data cells and append # the footnotes for (loc in locations) { - data <- set_footnote(loc, data, process_text(footnote)) + data <- set_footnote(loc = loc, data = data, footnote = process_text(footnote)) } data @@ -94,22 +94,28 @@ set_footnote.cells_title <- function(loc, data, footnote) { if ((loc$groups %>% rlang::eval_tidy()) == "title") { - attr(data, "footnotes_df") <- - add_location_row_footnotes( - data, - locname = "title", locnum = 1, - grpname = NA_character_, colname = NA_character_, - rownum = NA_character_, footnotes = footnote + data <- + dt_footnotes_add( + data = data, + locname = "title", + grpname = NA_character_, + colname = NA_character_, + locnum = 1, + rownum = NA_integer_, + footnotes = footnote ) } else if ((loc$groups %>% rlang::eval_tidy()) == "subtitle") { - attr(data, "footnotes_df") <- - add_location_row_footnotes( - data, - locname = "subtitle", locnum = 2, - grpname = NA_character_, colname = NA_character_, - rownum = NA_character_, footnotes = footnote + data <- + dt_footnotes_add( + data = data, + locname = "subtitle", + grpname = NA_character_, + colname = NA_character_, + locnum = 2, + rownum = NA_integer_, + footnotes = footnote ) } @@ -118,12 +124,15 @@ set_footnote.cells_title <- function(loc, data, footnote) { set_footnote.cells_stubhead <- function(loc, data, footnote) { - attr(data, "footnotes_df") <- - add_location_row_footnotes( - data, - locname = loc$groups, locnum = 2.5, - grpname = NA_character_, colname = NA_character_, - rownum = NA_character_, footnotes = footnote + data <- + dt_footnotes_add( + data = data, + locname = loc$groups, + grpname = NA_character_, + colname = NA_character_, + locnum = 2.5, + rownum = NA_integer_, + footnotes = footnote ) data @@ -131,58 +140,69 @@ set_footnote.cells_stubhead <- function(loc, data, footnote) { set_footnote.cells_column_labels <- function(loc, data, footnote) { - if (!is.null(loc$columns)) { + resolved <- resolve_cells_column_labels(data = data, object = loc) - resolved <- resolve_cells_column_labels(data = data, object = loc) + cols <- resolved$columns - cols <- resolved$columns + colnames <- dt_boxhead_get_vars_default(data = data)[cols] + + data <- + dt_footnotes_add( + data = data, + locname = "columns_columns", + grpname = NA_character_, + colname = colnames, + locnum = 4, + rownum = NA_integer_, + footnotes = footnote + ) - colnames <- colnames(as.data.frame(data))[cols] + data +} - attr(data, "footnotes_df") <- - add_location_row_footnotes( - data, - locname = "columns_columns", locnum = 4, - grpname = NA_character_, colname = colnames, - rownum = NA_character_, footnotes = footnote - ) +set_footnote.cells_column_spanners <- function(loc, data, footnote) { - } else if (!is.null(loc$groups)) { + resolved <- resolve_cells_column_spanners(data = data, object = loc) - groups <- loc$groups %>% rlang::eval_tidy() + groups <- resolved$spanners - attr(data, "footnotes_df") <- - add_location_row_footnotes( - data, - locname = "columns_groups", locnum = 3, - grpname = groups, colname = NA_character_, - rownum = NA_character_, footnotes = footnote - ) - } + data <- + dt_footnotes_add( + data = data, + locname = "columns_groups", + grpname = groups, + colname = NA_character_, + locnum = 3, + rownum = NA_integer_, + footnotes = footnote + ) data } set_footnote.cells_group <- function(loc, data, footnote) { - row_groups <- attr(data, "arrange_groups")$groups + row_groups <- dt_stub_groups_get(data = data) # Resolve row groups resolved_row_groups_idx <- resolve_data_vals_idx( var_expr = !!loc$groups, - data = NULL, + data_tbl = NULL, vals = row_groups ) groups <- row_groups[resolved_row_groups_idx] - attr(data, "footnotes_df") <- - add_location_row_footnotes( - data, - locname = "stub_groups", locnum = 5, - grpname = groups, colname = NA_character_, - rownum = NA_character_, footnotes = footnote + data <- + dt_footnotes_add( + data = data, + locname = "stub_groups", + grpname = groups, + colname = NA_character_, + locnum = 5, + rownum = NA_integer_, + footnotes = footnote ) data @@ -195,14 +215,17 @@ set_footnote.cells_data <- function(loc, data, footnote) { cols <- resolved$columns rows <- resolved$rows - colnames <- colnames(as.data.frame(data))[cols] - - attr(data, "footnotes_df") <- - add_location_row_footnotes( - data, - locname = "data", locnum = 5, - grpname = NA_character_, colname = colnames, - rownum = rows, footnotes = footnote + colnames <- resolved$colnames + + data <- + dt_footnotes_add( + data = data, + locname = "data", + grpname = NA_character_, + colname = colnames, + locnum = 5, + rownum = rows, + footnotes = footnote ) data @@ -214,12 +237,15 @@ set_footnote.cells_stub <- function(loc, data, footnote) { rows <- resolved$rows - attr(data, "footnotes_df") <- - add_location_row_footnotes( - data, - locname = "stub", locnum = 5, - grpname = NA_character_, colname = NA_character_, - rownum = rows, footnotes = footnote + data <- + dt_footnotes_add( + data = data, + locname = "stub", + grpname = NA_character_, + colname = NA_character_, + locnum = 5, + rownum = rows, + footnotes = footnote ) data @@ -244,53 +270,3 @@ set_footnote.cells_grand_summary <- function(loc, data, footnote) { df_type = "footnotes_df" ) } - -add_location_row_styles <- function(data, - locname, - locnum, - grpname, - colname, - rownum, - styles) { - - add_location_row( - data, - df_type = "styles_df", - locname, locnum, grpname, colname, rownum, - styles = styles - ) -} - -add_location_row_footnotes <- function(data, - locname, - locnum, - grpname, - colname, - rownum, - footnotes) { - - add_location_row( - data, - df_type = "footnotes_df", - locname, locnum, grpname, colname, rownum, - text = footnotes - ) -} - -add_location_row <- function(data, - df_type, - locname, - locnum, - grpname, - colname, - rownum, - ...) { - - dplyr::bind_rows( - attr(data, df_type, exact = TRUE), - dplyr::tibble( - locname = locname, locnum = locnum, - grpname = grpname, colname = colname, - rownum = rownum, ...) - ) -} diff --git a/R/tab_header.R b/R/tab_header.R new file mode 100644 index 0000000000..5b0f0da5f8 --- /dev/null +++ b/R/tab_header.R @@ -0,0 +1,38 @@ +#' Add a table header +#' +#' We can add a table header to the \pkg{gt} table with a title and even a +#' subtitle. A table header is an optional table part that is positioned above +#' the column labels. We have the flexibility to use Markdown formatting for the +#' header's title and subtitle. Furthermore, if the table is intended for HTML +#' output, we can use HTML in either of the title or subtitle. +#' @inheritParams fmt_number +#' @param title,subtitle Text to be used in the table title and, optionally, for +#' the table subtitle. We can elect to use the [md()] and [html()] helper +#' functions to style the text as Markdown or to retain HTML elements in the +#' text. +#' @return An object of class `gt_tbl`. +#' @examples +#' # Use `gtcars` to create a gt table; +#' # add a header part to contain a title +#' # and subtitle +#' tab_1 <- +#' gtcars %>% +#' dplyr::select(mfr, model, msrp) %>% +#' dplyr::slice(1:5) %>% +#' gt() %>% +#' tab_header( +#' title = md("Data listing from **gtcars**"), +#' subtitle = md("`gtcars` is an R dataset") +#' ) +#' +#' @section Figures: +#' \if{html}{\figure{man_tab_header_1.svg}{options: width=100\%}} +#' +#' @family table-part creation/modification functions +#' @export +tab_header <- function(data, + title, + subtitle = NULL) { + + data %>% dt_heading_title_subtitle(title = title, subtitle = subtitle) +} diff --git a/R/tab_options.R b/R/tab_options.R index 9f56682f2c..75b437d815 100644 --- a/R/tab_options.R +++ b/R/tab_options.R @@ -243,8 +243,8 @@ tab_options <- function(data, row.striping.include_stub = NULL, row.striping.include_table_body = NULL) { - # Extract the `opts_df` data frame object from `data` - opts_df <- attr(data, "opts_df", exact = TRUE) + # Extract the options table from `data` + opts_df <- dt_options_get(data = data) arg_names <- formals(tab_options) %>% names() %>% base::setdiff("data") arg_vals <- mget(arg_names) @@ -280,8 +280,8 @@ tab_options <- function(data, dplyr::anti_join(new_df, by = "parameter") ) - # Write the modified `opts_df` to the `data` attribute - attr(data, "opts_df") <- opts_df + # Write the modified options table back to `data` + data <- dt_options_set(data = data, options = opts_df) data } @@ -336,7 +336,7 @@ tab_options <- function(data, #' dplyr::filter(latitude == 30, !is.infinite(SZA.Min)) %>% #' dplyr::select(-latitude) %>% #' gt(rowname_col = "tst") %>% -#' cols_split_delim(".") %>% +#' tab_spanner_delim(delim = ".") %>% #' fmt_missing( #' columns = everything(), #' missing_text = "90+" @@ -348,7 +348,7 @@ tab_options <- function(data, #' ) %>% #' tab_footnote( #' footnote = "Solar zenith angle.", -#' locations = cells_column_labels(groups = "SZA") +#' locations = cells_column_spanners(spanners = "SZA") #' ) %>% #' tab_footnote( #' footnote = "The Lowest SZA.", diff --git a/R/tab_row_group.R b/R/tab_row_group.R new file mode 100644 index 0000000000..1b43546b59 --- /dev/null +++ b/R/tab_row_group.R @@ -0,0 +1,133 @@ +#' Add a row group +#' +#' Create a row group with a collection of rows. This requires specification of +#' the rows to be included, either by supplying row labels, row indices, or +#' through use of a select helper function like `starts_with()`. +#' @inheritParams fmt_number +#' @param group The name of the row group. This text will also serve as the row +#' group label. +#' @param rows The rows to be made components of the row group. Can either be a +#' vector of row captions provided in `c()`, a vector of row indices, or a +#' helper function focused on selections. The select helper functions are: +#' [starts_with()], [ends_with()], [contains()], [matches()], [one_of()], and +#' [everything()]. +#' @param others An option to set a default row group label for any rows not +#' formally placed in a row group named by `group` in any call of +#' `tab_row_group()`. A separate call to `tab_row_group()` with only a value +#' to `others` is possible and makes explicit that the call is meant to +#' provide a default row group label. If this is not set and there are rows +#' that haven't been placed into a row group (where one or more row groups +#' already exist), those rows will be automatically placed into a row group +#' without a label. +#' @return An object of class `gt_tbl`. +#' @examples +#' # Use `gtcars` to create a gt table and +#' # add two row groups with the labels: +#' # `numbered` and `NA` (a group without +#' # a title, or, the rest) +#' tab_1 <- +#' gtcars %>% +#' dplyr::select(model, year, hp, trq) %>% +#' dplyr::slice(1:8) %>% +#' gt(rowname_col = "model") %>% +#' tab_row_group( +#' group = "numbered", +#' rows = matches("^[0-9]") +#' ) +#' +#' # Use `gtcars` to create a gt table; +#' # add two row groups with the labels +#' # `powerful` and `super powerful`: the +#' # distinction being `hp` lesser or +#' # greater than `600` +#' tab_2 <- +#' gtcars %>% +#' dplyr::select(model, year, hp, trq) %>% +#' dplyr::slice(1:8) %>% +#' gt(rowname_col = "model") %>% +#' tab_row_group( +#' group = "powerful", +#' rows = hp <= 600 +#' ) %>% +#' tab_row_group( +#' group = "super powerful", +#' rows = hp > 600 +#' ) +#' +#' @section Figures: +#' \if{html}{\figure{man_tab_row_group_1.svg}{options: width=100\%}} +#' +#' \if{html}{\figure{man_tab_row_group_2.svg}{options: width=100\%}} +#' +#' @family table-part creation/modification functions +#' @import rlang +#' @export +tab_row_group <- function(data, + group = NULL, + rows = NULL, + others = NULL) { + + arrange_groups_vars <- dt_stub_groups_get(data = data) + + # Capture the `rows` expression + row_expr <- rlang::enquo(rows) + + # Create a row group if a `group` is provided + if (!is.null(group)) { + + # Get the `stub_df` data frame from `data` + stub_df <- dt_stub_df_get(data = data) + data_tbl <- dt_data_get(data = data) + + # Resolve the row numbers using the `resolve_vars` function + resolved_rows_idx <- + resolve_data_vals_idx( + var_expr = !!row_expr, + data_tbl = data_tbl, + vals = stub_df$rowname + ) + + # Place the `group` label in the `groupname` column `stub_df` + stub_df <- dt_stub_df_get(data = data) + + stub_df[resolved_rows_idx, "groupname"] <- process_text(group[1]) + + data <- dt_stub_df_set(data = data, stub_df = stub_df) + + if (dt_stub_groupname_has_na(data = data)) { + + data <- + dt_stub_groups_set( + data = data, + stub_groups = c( + arrange_groups_vars, process_text(group[1]), NA_character_ + ) %>% + unique() + ) + + } else { + + data <- + dt_stub_groups_set( + data = data, + stub_groups = c( + arrange_groups_vars, + process_text(group[1]) + ) %>% + unique() + ) + } + } + + # Set a name for the `others` group if a + # name is provided + if (!is.null(others)) { + data <- + dt_stub_others_set( + data = data, + stub_others = others[1] %>% process_text() + ) + } + + data +} diff --git a/R/tab_source_note.R b/R/tab_source_note.R new file mode 100644 index 0000000000..91f3067b6b --- /dev/null +++ b/R/tab_source_note.R @@ -0,0 +1,35 @@ +#' Add a source note citation +#' +#' Add a source note to the footer part of the \pkg{gt} table. A source note is +#' useful for citing the data included in the table. Several can be added to the +#' footer, simply use multiple calls of `tab_source_note()` and they will be +#' inserted in the order provided. We can use Markdown formatting for the note, +#' or, if the table is intended for HTML output, we can include HTML formatting. +#' @inheritParams fmt_number +#' @param source_note Text to be used in the source note. We can optionally use +#' the [md()] and [html()] functions to style the text as Markdown or to +#' retain HTML elements in the text. +#' @return An object of class `gt_tbl`. +#' @examples +#' # Use `gtcars` to create a gt table; +#' # add a source note to the table +#' # footer that cites the data source +#' tab_1 <- +#' gtcars %>% +#' dplyr::select(mfr, model, msrp) %>% +#' dplyr::slice(1:5) %>% +#' gt() %>% +#' tab_source_note( +#' source_note = "From edmunds.com" +#' ) +#' +#' @section Figures: +#' \if{html}{\figure{man_tab_source_note_1.svg}{options: width=100\%}} +#' +#' @family table-part creation/modification functions +#' @export +tab_source_note <- function(data, + source_note) { + + data %>% dt_source_notes_add(source_note = source_note) +} diff --git a/R/tab_spanner.R b/R/tab_spanner.R new file mode 100644 index 0000000000..2db9377d7b --- /dev/null +++ b/R/tab_spanner.R @@ -0,0 +1,182 @@ +#' Add a spanner column label +#' +#' Set a spanner column label by mapping it to columns already in the table. +#' This label is placed above one or more column labels, spanning the width of +#' those columns and column labels. +#' @inheritParams fmt_number +#' @param label The text to use for the spanner column label. +#' @param columns The columns to be components of the spanner heading. +#' @param gather An option to move the specified `columns` such that they are +#' unified under the spanner column label. Ordering of the moved-into-place +#' columns will be preserved in all cases. +#' @return An object of class `gt_tbl`. +#' @examples +#' # Use `gtcars` to create a gt table; +#' # Group several columns related to car +#' # performance under a spanner column +#' # with the label `performance` +#' tab_1 <- +#' gtcars %>% +#' dplyr::select( +#' -mfr, -trim, bdy_style, drivetrain, +#' -drivetrain, -trsmn, -ctry_origin +#' ) %>% +#' dplyr::slice(1:8) %>% +#' gt(rowname_col = "model") %>% +#' tab_spanner( +#' label = "performance", +#' columns = vars( +#' hp, hp_rpm, trq, trq_rpm, +#' mpg_c, mpg_h) +#' ) +#' +#' @section Figures: +#' \if{html}{\figure{man_tab_spanner_1.svg}{options: width=100\%}} +#' +#' @family table-part creation/modification functions +#' @export +tab_spanner <- function(data, + label, + columns, + gather = TRUE) { + + checkmate::assert_character( + label, len = 1, any.missing = FALSE, null.ok = FALSE) + + columns <- enquo(columns) + + # Get the columns supplied in `columns` as a character vector + column_names <- resolve_vars(var_expr = !!columns, data = data) + + data <- + dt_spanners_add( + data = data, + vars = column_names, + spanner_label = label, + gather = gather + ) + + if (isTRUE(gather) && length(column_names) >= 1) { + + # Move columns into place + data <- + data %>% + cols_move( + columns = column_names, + after = column_names[1] + ) + } + + data +} + +#' Create group names and column labels via delimited names +#' +#' This function will split selected delimited column names such that the first +#' components (LHS) are promoted to being spanner column labels, and the +#' secondary components (RHS) will become the column labels. Please note that +#' reference to individual columns must continue to be the column names from the +#' input table data (which are unique by necessity). +#' +#' If we look to the column names in the `iris` dataset as an example of how +#' `tab_spanner_delim()` might be useful, we find the names `Sepal.Length`, +#' `Sepal.Width`, `Petal.Length`, `Petal.Width`. From this naming system, it's +#' easy to see that the `Sepal` and `Petal` can group together the repeated +#' common `Length` and `Width` values. In your own datasets, we can avoid a +#' lengthy relabeling with [cols_label()] if column names can be fashioned +#' beforehand to contain both the spanner column label and the column label. An +#' additional advantage is that the column names in the input table data remain +#' unique even though there may eventually be repeated column labels in the +#' rendered output table). +#' +#' @inheritParams cols_align +#' @inheritParams tab_spanner +#' @param delim The delimiter to use to split an input column name. The +#' delimiter supplied will be autoescaped for the internal splitting +#' procedure. The first component of the split will become the group name and +#' the second component will be the column label. +#' @param columns An optional vector of column names that this operation should +#' be limited to. The default is to consider all columns in the table. +#' @return An object of class `gt_tbl`. +#' +#' @examples +#' # Use `iris` to create a gt table; split +#' # any columns that are dot-separated +#' # between column spanner labels (first +#' # part) and column labels (second part) +#' tab_1 <- +#' iris %>% +#' dplyr::group_by(Species) %>% +#' dplyr::slice(1:4) %>% +#' gt() %>% +#' tab_spanner_delim(delim = ".") +#' +#' @section Figures: +#' \if{html}{\figure{man_tab_spanner_delim_1.svg}{options: width=100\%}} +#' +#' @family column modification functions +#' @export +tab_spanner_delim <- function(data, + delim, + columns = NULL, + gather = TRUE) { + + columns <- enquo(columns) + + # Get all of the columns in the dataset + all_cols <- data %>% dt_boxhead_get_vars() + + # Get the columns supplied in `columns` as a character vector + columns <- resolve_vars(var_expr = !!columns, data = data) + + if (!is.null(columns)) { + colnames <- base::intersect(all_cols, columns) + } else { + colnames <- all_cols + } + + if (length(colnames) == 0) { + return(data) + } + + colnames_has_delim <- grepl(pattern = delim, x = colnames, fixed = TRUE) + + if (any(colnames_has_delim)) { + + colnames_with_delim <- colnames[colnames_has_delim] + + split_colnames <- strsplit(colnames_with_delim, delim, fixed = TRUE) + + spanners <- vapply(split_colnames, `[[`, character(1), 1) + + new_labels <- + lapply(split_colnames, `[[`, -1) %>% + vapply(paste0, FUN.VALUE = character(1), collapse = delim) + + for (i in seq_along(split_colnames)) { + + spanners_i <- spanners[i] + new_labels_i <- new_labels[i] + var_i <- colnames_with_delim[i] + + data <- + data %>% + dt_boxhead_edit(var = var_i, column_label = new_labels_i) + } + + spanner_var_list <- split(colnames_with_delim, spanners) + + for (spanner_label in names(spanner_var_list)) { + + data <- + data %>% + dt_spanners_add( + vars = spanner_var_list[[spanner_label]], + spanner_label = spanner_label, + gather = gather + ) + } + } + + data +} diff --git a/R/tab_stubhead.R b/R/tab_stubhead.R new file mode 100644 index 0000000000..c1a9ffccc5 --- /dev/null +++ b/R/tab_stubhead.R @@ -0,0 +1,34 @@ +#' Add label text to the stubhead +#' +#' Add a label to the stubhead of a \pkg{gt} table. The stubhead is the lone +#' element that is positioned left of the column labels, and above the stub. If +#' a stub does not exist, then there is no stubhead (so no change will be made +#' when using this function in that case). We have the flexibility to use +#' Markdown formatting for the stubhead label. Furthermore, if the table is +#' intended for HTML output, we can use HTML for the stubhead label. +#' @inheritParams fmt_number +#' @param label The text to be used as the stubhead label We can optionally use +#' the [md()] and [html()] functions to style the text as Markdown or to +#' retain HTML elements in the text. +#' @return An object of class `gt_tbl`. +#' @examples +#' # Use `gtcars` to create a gt table; add +#' # a stubhead label to describe what is +#' # in the stub +#' tab_1 <- +#' gtcars %>% +#' dplyr::select(model, year, hp, trq) %>% +#' dplyr::slice(1:5) %>% +#' gt(rowname_col = "model") %>% +#' tab_stubhead(label = "car") +#' +#' @section Figures: +#' \if{html}{\figure{man_tab_stubhead_1.svg}{options: width=100\%}} +#' +#' @family table-part creation/modification functions +#' @export +tab_stubhead <- function(data, + label) { + + data %>% dt_stubhead_label(label = label) +} diff --git a/R/tab_style.R b/R/tab_style.R index 89d1e495d3..14a96c4500 100644 --- a/R/tab_style.R +++ b/R/tab_style.R @@ -115,7 +115,12 @@ tab_style <- function(data, # Resolve the locations of the targeted data cells and append # the format directives for (loc in locations) { - data <- set_style(loc, data, style) + data <- + set_style( + loc = loc, + data = data, + style = style + ) } data @@ -146,7 +151,6 @@ as_style <- function(style) { if (!inherits(style_item, "cell_styles")) { - # TODO: position can be provided stop("All provided styles should be generated by stylizing ", "helper functions. Style with index `", i, "` is invalid.", call. = FALSE) @@ -174,22 +178,28 @@ set_style.cells_title <- function(loc, data, style) { if ((loc$groups %>% rlang::eval_tidy()) == "title") { - attr(data, "styles_df") <- - add_location_row_styles( - data, - locname = "title", locnum = 1, - grpname = NA_character_, colname = NA_character_, - rownum = NA_character_, styles = list(style) + data <- + dt_styles_add( + data = data, + locname = "title", + grpname = NA_character_, + colname = NA_character_, + locnum = 1, + rownum = NA_integer_, + styles = style ) } else if ((loc$groups %>% rlang::eval_tidy()) == "subtitle") { - attr(data, "styles_df") <- - add_location_row_styles( - data, - locname = "subtitle", locnum = 2, - grpname = NA_character_, colname = NA_character_, - rownum = NA_character_, styles = list(style) + data <- + dt_styles_add( + data = data, + locname = "subtitle", + grpname = NA_character_, + colname = NA_character_, + locnum = 2, + rownum = NA_integer_, + styles = style ) } @@ -198,12 +208,15 @@ set_style.cells_title <- function(loc, data, style) { set_style.cells_stubhead <- function(loc, data, style) { - attr(data, "styles_df") <- - add_location_row_styles( - data, - locname = loc$groups, locnum = 2.5, - grpname = NA_character_, colname = NA_character_, - rownum = NA_character_, styles = list(style) + data <- + dt_styles_add( + data = data, + locname = loc$groups, + grpname = NA_character_, + colname = NA_character_, + locnum = 2.5, + rownum = NA_integer_, + styles = style ) data @@ -211,58 +224,69 @@ set_style.cells_stubhead <- function(loc, data, style) { set_style.cells_column_labels <- function(loc, data, style) { - if (!is.null(loc$columns)) { + resolved <- resolve_cells_column_labels(data = data, object = loc) - resolved <- resolve_cells_column_labels(data = data, object = loc) + cols <- resolved$columns - cols <- resolved$columns + colnames <- dt_boxhead_get_vars_default(data = data)[cols] + + data <- + dt_styles_add( + data = data, + locname = "columns_columns", + grpname = NA_character_, + colname = colnames, + locnum = 4, + rownum = NA_integer_, + styles = style + ) - colnames <- colnames(as.data.frame(data))[cols] + data +} - attr(data, "styles_df") <- - add_location_row_styles( - data, - locname = "columns_columns", locnum = 4, - grpname = NA_character_, colname = colnames, - rownum = NA_character_, styles = list(style) - ) +set_style.cells_column_spanners <- function(loc, data, style) { - } else if (!is.null(loc$groups)) { + resolved <- resolve_cells_column_spanners(data = data, object = loc) - groups <- loc$groups %>% rlang::eval_tidy() + groups <- resolved$spanners - attr(data, "styles_df") <- - add_location_row_styles( - data, - locname = "columns_groups", locnum = 3, - grpname = groups, colname = NA_character_, - rownum = NA_character_, styles = list(style) - ) - } + data <- + dt_styles_add( + data = data, + locname = "columns_groups", + grpname = groups, + colname = NA_character_, + locnum = 3, + rownum = NA_integer_, + styles = style + ) data } set_style.cells_group <- function(loc, data, style) { - row_groups <- attr(data, "arrange_groups")$groups + stub_groups <- dt_stub_groups_get(data = data) # Resolve row groups resolved_row_groups_idx <- resolve_data_vals_idx( var_expr = !!loc$groups, - data = NULL, - vals = row_groups + data_tbl = NULL, + vals = stub_groups ) - groups <- row_groups[resolved_row_groups_idx] - - attr(data, "styles_df") <- - add_location_row_styles( - data, - locname = "stub_groups", locnum = 5, - grpname = groups, colname = NA_character_, - rownum = NA_character_, styles = list(style) + groups <- stub_groups[resolved_row_groups_idx] + + data <- + dt_styles_add( + data = data, + locname = "stub_groups", + grpname = groups, + colname = NA_character_, + locnum = 5, + rownum = NA_integer_, + styles = style ) data @@ -275,14 +299,17 @@ set_style.cells_data <- function(loc, data, style) { cols <- resolved$columns rows <- resolved$rows - colnames <- colnames(as.data.frame(data))[cols] - - attr(data, "styles_df") <- - add_location_row_styles( - data, - locname = "data", locnum = 5, - grpname = NA_character_, colname = colnames, - rownum = rows, styles = list(style) + colnames <- resolved$colnames + + data <- + dt_styles_add( + data = data, + locname = "data", + grpname = NA_character_, + colname = colnames, + locnum = 5, + rownum = rows, + styles = style ) data @@ -294,12 +321,15 @@ set_style.cells_stub <- function(loc, data, style) { rows <- resolved$rows - attr(data, "styles_df") <- - add_location_row_styles( - data, - locname = "stub", locnum = 5, - grpname = NA_character_, colname = NA_character_, - rownum = rows, styles = list(style) + data <- + dt_styles_add( + data = data, + locname = "stub", + grpname = NA_character_, + colname = NA_character_, + locnum = 5, + rownum = rows, + styles = style ) data diff --git a/R/table_parts.R b/R/table_parts.R deleted file mode 100644 index 52f5a36ce1..0000000000 --- a/R/table_parts.R +++ /dev/null @@ -1,355 +0,0 @@ -#' Add a table header -#' -#' We can add a table header to the \pkg{gt} table with a title and even a -#' subtitle. A table header is an optional table part that is positioned above -#' the column labels. We have the flexibility to use Markdown formatting for the -#' header's title and subtitle. Furthermore, if the table is intended for HTML -#' output, we can use HTML in either of the title or subtitle. -#' @inheritParams fmt_number -#' @param title,subtitle Text to be used in the table title and, optionally, for -#' the table subtitle. We can elect to use the [md()] and [html()] helper -#' functions to style the text as Markdown or to retain HTML elements in the -#' text. -#' @return An object of class `gt_tbl`. -#' @examples -#' # Use `gtcars` to create a gt table; -#' # add a header part to contain a title -#' # and subtitle -#' tab_1 <- -#' gtcars %>% -#' dplyr::select(mfr, model, msrp) %>% -#' dplyr::slice(1:5) %>% -#' gt() %>% -#' tab_header( -#' title = md("Data listing from **gtcars**"), -#' subtitle = md("`gtcars` is an R dataset") -#' ) -#' -#' @section Figures: -#' \if{html}{\figure{man_tab_header_1.svg}{options: width=100\%}} -#' -#' @family table-part creation/modification functions -#' @export -tab_header <- function(data, - title, - subtitle = NULL) { - - # Handle the optional `subtitle` text - if (is.null(subtitle)) { - subtitle <- "" - } - - attr(data, "heading") <- - list( - title = title, - subtitle = subtitle) - - data -} - -#' Add label text to the stubhead -#' -#' Add a label to the stubhead of a \pkg{gt} table. The stubhead is the lone -#' element that is positioned left of the column labels, and above the stub. If -#' a stub does not exist, then there is no stubhead (so no change will be made -#' when using this function in that case). We have the flexibility to use -#' Markdown formatting for the stubhead label. Furthermore, if the table is -#' intended for HTML output, we can use HTML for the stubhead label. -#' @inheritParams fmt_number -#' @param label The text to be used as the stubhead label We can optionally use -#' the [md()] and [html()] functions to style the text as Markdown or to -#' retain HTML elements in the text. -#' @return An object of class `gt_tbl`. -#' @examples -#' # Use `gtcars` to create a gt table; add -#' # a stubhead label to describe what is -#' # in the stub -#' tab_1 <- -#' gtcars %>% -#' dplyr::select(model, year, hp, trq) %>% -#' dplyr::slice(1:5) %>% -#' gt(rowname_col = "model") %>% -#' tab_stubhead(label = "car") -#' -#' @section Figures: -#' \if{html}{\figure{man_tab_stubhead_1.svg}{options: width=100\%}} -#' -#' @family table-part creation/modification functions -#' @export -tab_stubhead <- function(data, - label) { - - attr(data, "stubhead") <- list(label = label) - - data -} - -#' Add a row group -#' -#' Create a row group with a collection of rows. This requires specification of -#' the rows to be included, either by supplying row labels, row indices, or -#' through use of a select helper function like `starts_with()`. -#' @inheritParams fmt_number -#' @param group The name of the row group. This text will also serve as the row -#' group label. -#' @param rows The rows to be made components of the row group. Can either be a -#' vector of row captions provided `c()`, a vector of row indices, or a helper -#' function focused on selections. The select helper functions are: -#' [starts_with()], [ends_with()], [contains()], [matches()], [one_of()], and -#' [everything()]. -#' @param others An option to set a default row group label for any rows not -#' formally placed in a row group named by `group` in any call of -#' `tab_row_group()`. A separate call to `tab_row_group()` with only a value -#' to `others` is possible and makes explicit that the call is meant to -#' provide a default row group label. If this is not set and there are rows -#' that haven't been placed into a row group (where one or more row groups -#' already exist), those rows will be automatically placed into a row group -#' without a label. -#' @return An object of class `gt_tbl`. -#' @examples -#' # Use `gtcars` to create a gt table and -#' # add two row groups with the labels: -#' # `numbered` and `NA` (a group without -#' # a title, or, the rest) -#' tab_1 <- -#' gtcars %>% -#' dplyr::select(model, year, hp, trq) %>% -#' dplyr::slice(1:8) %>% -#' gt(rowname_col = "model") %>% -#' tab_row_group( -#' group = "numbered", -#' rows = matches("^[0-9]") -#' ) -#' -#' # Use `gtcars` to create a gt table; -#' # add two row groups with the labels -#' # `powerful` and `super powerful`: the -#' # distinction being `hp` lesser or -#' # greater than `600` -#' tab_2 <- -#' gtcars %>% -#' dplyr::select(model, year, hp, trq) %>% -#' dplyr::slice(1:8) %>% -#' gt(rowname_col = "model") %>% -#' tab_row_group( -#' group = "powerful", -#' rows = hp <= 600 -#' ) %>% -#' tab_row_group( -#' group = "super powerful", -#' rows = hp > 600 -#' ) -#' -#' @section Figures: -#' \if{html}{\figure{man_tab_row_group_1.svg}{options: width=100\%}} -#' -#' \if{html}{\figure{man_tab_row_group_2.svg}{options: width=100\%}} -#' -#' @family table-part creation/modification functions -#' @import rlang -#' @export -tab_row_group <- function(data, - group = NULL, - rows = NULL, - others = NULL) { - - # Capture the `rows` expression - row_expr <- rlang::enquo(rows) - - # Create a row group if a `group` is provided - if (!is.null(group)) { - - # Get the `stub_df` data frame from `data` - stub_df <- attr(data, "stub_df", exact = TRUE) - - # Resolve the row numbers using the `resolve_vars` function - resolved_rows_idx <- - resolve_data_vals_idx( - var_expr = !!row_expr, - data = data, - vals = stub_df$rowname - ) - - # Place the `group` label in the `groupname` column - # `stub_df` - attr(data, "stub_df")[resolved_rows_idx, "groupname"] <- - process_text(group[1]) - - # Insert the group into the `arrange_groups` component - if (!("arrange_groups" %in% names(attributes(data)))) { - - if (any(is.na(attr(data, "stub_df", exact = TRUE)$groupname))) { - - attr(data, "arrange_groups") <- - list(groups = c(process_text(group[1]), NA_character_)) - - } else { - attr(data, "arrange_groups") <- - list(groups = process_text(group[1])) - } - - } else { - - if (any(is.na(attr(data, "stub_df")$groupname))) { - - attr(data, "arrange_groups")[["groups"]] <- - c(attr(data, "arrange_groups", exact = TRUE)[["groups"]], - process_text(group[1]), NA_character_) %>% - unique() - - } else { - attr(data, "arrange_groups")[["groups"]] <- - c(attr(data, "arrange_groups", exact = TRUE)[["groups"]], - process_text(group[1])) - } - } - } - - # Set a name for the `others` group if a - # name is provided - if (!is.null(others)) { - attr(data, "others_group") <- list(others = process_text(others[1])) - } - - data -} - -#' Add a spanner column label -#' -#' Set a spanner column label by mapping it to columns already in the table. -#' This label is placed above one or more column labels, spanning the width of -#' those columns and column labels. -#' @inheritParams fmt_number -#' @param label The text to use for the spanner column label. -#' @param columns The columns to be components of the spanner heading. -#' @param gather An option to move the specified `columns` such that they are -#' unified under the spanner column label. Ordering of the moved-into-place -#' columns will be preserved in all cases. -#' @return An object of class `gt_tbl`. -#' @examples -#' # Use `gtcars` to create a gt table; -#' # Group several columns related to car -#' # performance under a spanner column -#' # with the label `performance` -#' tab_1 <- -#' gtcars %>% -#' dplyr::select( -#' -mfr, -trim, bdy_style, drivetrain, -#' -drivetrain, -trsmn, -ctry_origin -#' ) %>% -#' dplyr::slice(1:8) %>% -#' gt(rowname_col = "model") %>% -#' tab_spanner( -#' label = "performance", -#' columns = vars( -#' hp, hp_rpm, trq, trq_rpm, -#' mpg_c, mpg_h) -#' ) -#' -#' @section Figures: -#' \if{html}{\figure{man_tab_spanner_1.svg}{options: width=100\%}} -#' -#' @family table-part creation/modification functions -#' @export -tab_spanner <- function(data, - label, - columns, - gather = TRUE) { - checkmate::assert_character( - label, len = 1, any.missing = FALSE, null.ok = FALSE) - - columns <- enquo(columns) - - # Get the columns supplied in `columns` as a character vector - column_names <- resolve_vars(var_expr = !!columns, data = data) - - # Get the `grp_labels` list from `data` - grp_labels <- attr(data, "grp_labels", exact = TRUE) - - # Apply the `label` value to the the `grp_labels` list - for (column_name in column_names) { - grp_labels[[column_name]] <- label - } - - # Set the `grp_labels` attr with the `grp_labels` object - attr(data, "grp_labels") <- grp_labels - - # Gather columns not part of the group of columns under - # the spanner heading - if (gather && length(column_names) > 1) { - - # Extract the internal `boxh_df` table - boxh_df <- attr(data, "boxh_df", exact = TRUE) - - # Get the sequence of columns available in `boxh_df` - all_columns <- colnames(boxh_df) - - # Get the vector positions of the `columns` in - # `all_columns` - matching_vec <- - match(column_names, all_columns) %>% - sort() %>% - unique() - - # Get a vector of column names - columns_sorted <- all_columns[matching_vec] - - # Move columns into place - data <- - data %>% - cols_move( - columns = columns_sorted[-1], - after = columns_sorted[1] - ) - } - - data -} - -#' Add a source note citation -#' -#' Add a source note to the footer part of the \pkg{gt} table. A source note is -#' useful for citing the data included in the table. Several can be added to the -#' footer, simply use multiple calls of `tab_source_note()` and they will be -#' inserted in the order provided. We can use Markdown formatting for the note, -#' or, if the table is intended for HTML output, we can include HTML formatting. -#' @inheritParams fmt_number -#' @param source_note Text to be used in the source note. We can optionally use -#' the [md()] and [html()] functions to style the text as Markdown or to -#' retain HTML elements in the text. -#' @return An object of class `gt_tbl`. -#' @examples -#' # Use `gtcars` to create a gt table; -#' # add a source note to the table -#' # footer that cites the data source -#' tab_1 <- -#' gtcars %>% -#' dplyr::select(mfr, model, msrp) %>% -#' dplyr::slice(1:5) %>% -#' gt() %>% -#' tab_source_note( -#' source_note = "From edmunds.com" -#' ) -#' -#' @section Figures: -#' \if{html}{\figure{man_tab_source_note_1.svg}{options: width=100\%}} -#' -#' @family table-part creation/modification functions -#' @export -tab_source_note <- function(data, - source_note) { - - if ("source_note" %in% names(attributes(data))) { - - attr(data, "source_note") <- - c(attr(data, "source_note", exact = TRUE), - list(source_note)) - - } else { - - attr(data, "source_note") <- - list(source_note) - } - - data -} diff --git a/R/text_transform.R b/R/text_transform.R index 44165f508c..083f40e7dd 100644 --- a/R/text_transform.R +++ b/R/text_transform.R @@ -61,40 +61,92 @@ text_transform <- function(data, fn) { # Resolve into a list of locations - locations <- as_locations(locations) + locations <- as_locations(locations = locations) # Resolve the locations of the targeted data cells and append # the footnotes for (loc in locations) { - data <- set_transform(loc, data, fn) + data <- dt_transforms_add(data = data, loc = loc, fn = fn) } data } -set_transform <- function(loc, data, fn) { +# Given a location, gt attr object, and mapping function (one chr vector as +# input, chr vector of same length as output), replace the contents in the +# specified location with fn(contents). The `fn` may be invoked several times, +# as the location may not be naturally vectorizable as a single call. The return +# value is the transformed `data` +text_transform_at_location <- function(loc, data, fn = identity) { + UseMethod("text_transform_at_location") +} - resolved <- resolve_location(loc, data_attr = attributes(data)) +text_transform_at_location.cells_data <- function(loc, + data, + fn = identity) { - attr(data, "transforms") <- - c( - attr(data, "transforms", exact = TRUE), - list( - list( - resolved = resolved, - fn = fn - ) - ) - ) + body <- dt_body_get(data = data) + + loc <- to_output_location(loc = loc, data = data) + + # Do one vectorized operation per column + for (col in loc$colnames) { + + if (col %in% colnames(body)) { + body[[col]][loc$rows] <- fn(body[[col]][loc$rows]) + } + } + + data <- dt_body_set(data = data, body = body) data } -# Given a location, gt attr object, and mapping function (one chr vector as -# input, chr vector of same length as output), replace the contents in the -# specified location with fn(contents). The `fn` may be invoked several times, -# as the location may not be naturally vectorizable as a single call. The return -# value is the transformed data_attr. -text_transform_at_location <- function(loc, data_attr, fn = identity) { - UseMethod("text_transform_at_location") +text_transform_at_location.cells_stub <- function(loc, + data, + fn = identity) { + + stub_df <- dt_stub_df_get(data = data) + + loc <- to_output_location(loc = loc, data = data) + + for (row in loc$rows) { + + if (row %in% stub_df$rowname) { + stub_df[row, "rowname"] <- fn(stub_df[row, "rowname"]) + } + } + + dt_stub_df_set(data = data, stub_df = stub_df) +} + +text_transform_at_location.cells_column_labels <- function(loc, + data, + fn = identity) { + + boxh <- dt_boxhead_get(data = data) + + loc <- to_output_location(loc = loc, data = data) + + for (col in loc$columns) { + + if (col %in% boxh$var) { + + column_label_edited <- + boxh %>% + dplyr::filter(var == !!col) %>% + dplyr::pull(column_label) %>% + .[[1]] %>% + fn() + + data <- + dt_boxhead_edit( + data = data, + var = col, + column_label = list(column_label_edited) + ) + } + } + + data } diff --git a/R/utils.R b/R/utils.R index 051eb8039a..7f773e179b 100644 --- a/R/utils.R +++ b/R/utils.R @@ -185,6 +185,12 @@ process_text <- function(text, return(text) } + if (is.list(text)) { + if (context %in% names(text)) { + return(process_text(text[[context]], context)) + } + } + if (context == "html") { # Text processing for HTML output @@ -555,9 +561,6 @@ normalize_suffixing_inputs <- function(suffixing, # In the case that a character vector is provided # to `suffixing`, we first want to check if there # are any names provided - # TODO: found that the conditional below seems - # better than other solutions to determine whether - # the vector is even partially named if (!is.null(names(suffixing))) { stop("The character vector supplied to `suffixed` cannot contain names.", call. = FALSE) @@ -826,52 +829,6 @@ tidy_grepl <- function(x, pattern) { ) } -#' An options setter for the `opts_df` data frame -#' -#' @param opts_df The `opts_df` data frame. -#' @param option The option name; a unique value in the `parameter` column of -#' `opts_df`. -#' @param value The value to set for the given `option`. -#' @noRd -opts_df_set <- function(opts_df, option, value) { - - opts_df$value[[which(opts_df$parameter == option)]] <- value - - opts_df -} - -#' An options getter for the `opts_df` data frame -#' -#' @inheritParams opts_df_set -#' @noRd -opts_df_get <- function(opts_df, option) { - - opts_df$value[[which(opts_df$parameter == option)]] -} - -#' Upgrader function for `cells_*` objects -#' -#' Upgrade a `cells_*` object to a `list()` if only a single instance is -#' provided. -#' @param locations Any `cells_*` object. -#' @noRd -as_locations <- function(locations) { - - if (!inherits(locations, "location_cells")) { - - if (!is.list(locations) && - any(!vapply(locations, inherits, logical(1), "location_cells"))) { - - stop("The `locations` object should be a list of `cells_*()`.", - .call = FALSE) - } - } else { - locations <- list(locations) - } - - locations -} - #' Create a vector of marks to use for footnotes #' #' @noRd diff --git a/R/utils_render_common.R b/R/utils_render_common.R index 408ec86952..acec802af3 100644 --- a/R/utils_render_common.R +++ b/R/utils_render_common.R @@ -19,56 +19,47 @@ validate_contexts <- function(contexts) { # Utility function to generate column numbers from column names; # used in: `resolve_footnotes_styles()` -colname_to_colnum <- function(boxh_df, +colname_to_colnum <- function(data, colname) { - cnames <- c() + col_nums <- c() + for (col in colname) { if (is.na(col)) { - cnames <- c(cnames, NA_integer_) + col_nums <- c(col_nums, NA_integer_) } else { - cnames <- c(cnames, which(colnames(boxh_df) == col)) + col_nums <- c(col_nums, which(dt_boxhead_get_vars_default(data = data) == col)) } } - cnames + col_nums } # Utility function to generate finalized row numbers; # used in: `resolve_footnotes_styles()` -rownum_translation <- function(output_df, +rownum_translation <- function(body, rownum_start) { rownum_final <- c() for (rownum_s in rownum_start) { rownum_final <- c(rownum_final, - which(as.numeric(rownames(output_df)) == rownum_s)) + which(as.numeric(rownames(body)) == rownum_s)) } rownum_final } -# Initialize `output_df` -initialize_output_df <- function(data_df) { - - output_df <- data_df - - if (nrow(output_df) > 0) { - output_df[] <- NA_character_ - } - - output_df -} - #' Render any formatting directives available in the `formats` list #' #' @noRd -render_formats <- function(output_df, - data_df, - formats, +render_formats <- function(data, context) { + body <- dt_body_get(data = data) + data_tbl <- dt_data_get(data = data) + formats <- dt_formats_get(data = data) + # Render input data to output data where formatting # is specified for (fmt in formats) { @@ -85,44 +76,49 @@ render_formats <- function(output_df, for (col in fmt[["cols"]]) { # Perform rendering but only do so if the column is present - if (col %in% colnames(data_df)) { + if (col %in% colnames(data_tbl)) { - result <- fmt$func[[eval_func]](data_df[[col]][fmt$rows]) + result <- fmt$func[[eval_func]](data_tbl[[col]][fmt$rows]) # If any of the resulting output is `NA`, that # means we want to NOT make changes to those # particular cells' output (i.e. inherit the # results of the previous formatter). - output_df[[col]][fmt$rows][!is.na(result)] <- stats::na.omit(result) + body[[col]][fmt$rows][!is.na(result)] <- stats::na.omit(result) } } } - output_df + data <- dt_body_set(data = data, body = body) + + data } -# Move input data cells to `output_df` that didn't have any rendering applied +# Move input data cells to `body` that didn't have any rendering applied # during the `render_formats()` call -migrate_unformatted_to_output <- function(data_df, - output_df, +migrate_unformatted_to_output <- function(data, context) { - for (colname in colnames(output_df)) { + body <- dt_body_get(data = data) + data_tbl <- dt_data_get(data = data) - row_index <- is.na(output_df[[colname]]) + for (colname in colnames(body)) { - if (inherits(data_df[[colname]], "list")) { + row_index <- is.na(body[[colname]]) + + if (inherits(data_tbl[[colname]], "list")) { # Use `lapply()` so that all values could be treated independently - output_df[[colname]][row_index] <- + body[[colname]][row_index] <- lapply( - data_df[[colname]][row_index], + data_tbl[[colname]][row_index], function(x) { x %>% format( drop0trailing = FALSE, trim = TRUE, - justify = "none") %>% + justify = "none" + ) %>% tidy_gsub("\\s+$", "") %>% process_text(context) %>% paste(collapse = ", ") @@ -132,9 +128,9 @@ migrate_unformatted_to_output <- function(data_df, } else { # No `lapply()` used: all values will be treated cohesively - output_df[[colname]][row_index] <- + body[[colname]][row_index] <- format( - data_df[[colname]][row_index], + data_tbl[[colname]][row_index], drop0trailing = FALSE, trim = TRUE, justify = "none" @@ -143,19 +139,41 @@ migrate_unformatted_to_output <- function(data_df, } } - output_df + data <- dt_body_set(data = data, body = body) + + data +} + +#' Perform any text transformations +#' +#' @noRd +perform_text_transforms <- function(data) { + + transforms <- dt_transforms_get(data = data) + + for (transform in transforms) { + + data <- + text_transform_at_location( + loc = transform$resolved, + data = data, + fn = transform$fn + ) + } + + data } #' Obtain a reordering df for the data rows #' #' @noRd -get_row_reorder_df <- function(arrange_groups, +get_row_reorder_df <- function(groups, stub_df) { # If there are no group, there there is no reordering # so just return a data frame where the starting row # indices match the final row indices - if (length(arrange_groups$groups) == 0) { + if (length(groups) == 0) { indices <- seq_len(nrow(stub_df)) @@ -167,570 +185,162 @@ get_row_reorder_df <- function(arrange_groups, ) } - groups <- arrange_groups$groups - indices <- - lapply(stub_df$group, `%in%`, x = groups) %>% + lapply(stub_df$groupname, `%in%`, x = groups) %>% lapply(which) %>% unlist() %>% order() dplyr::tibble( rownum_start = seq_along(indices), - rownum_final = indices) -} - -#' Obtain a reordering df for the table columns -#' -#' @noRd -get_column_reorder_df <- function(cols_df, - boxh_df) { - - colnames_final_tbl <- - dplyr::tibble(colnames_final = colnames(boxh_df)) %>% - dplyr::mutate(colnum_final = seq(ncol(boxh_df))) - - cols_df %>% - dplyr::mutate(colnum_start = seq(nrow(cols_df))) %>% - dplyr::full_join( - colnames_final_tbl, by = c("colnames_start" = "colnames_final") - ) %>% - dplyr::rename(column_names = colnames_start) -} - -# Function to reassemble the rows and columns of the `output_df` -# in a revised order -reassemble_output_df <- function(output_df, - rows_df, - columns_df) { - - rows <- rows_df$rownum_final - - cols <- - subset(columns_df, !is.na(colnum_final))[ - order(subset(columns_df, !is.na(colnum_final))$colnum_final), ]$column_names - - output_df[rows, cols, drop = FALSE] -} - -# Function to obtain a reordered version of `stub_df` -get_groupnames_rownames_df <- function(stub_df, - rows_df) { - - stub_df[rows_df$rownum_final, c("groupname", "rowname")] + rownum_final = indices + ) } -# Function to get a vector of columns group (spanner) names -get_columns_spanners_vec <- function(boxh_df) { +# Function to recode the `rownum` value in the footnotes table +reorder_footnotes <- function(data) { - columns_spanners <- - boxh_df["group_label", ] %>% unlist() %>% unname() + stub_df <- dt_stub_df_get(data = data) + footnotes_tbl <- dt_footnotes_get(data = data) - columns_spanners[which(!is.na(columns_spanners))] -} + rownum_final <- stub_df$rownum_i %>% as.numeric() -#' Create a data frame with row group information -#' -#' @noRd -get_groups_rows_df <- function(arrange_groups, - groups_df, - context) { - - ordering <- arrange_groups[[1]] - - groups_rows_df <- - data.frame( - group = rep(NA_character_, length(ordering)), - group_label = rep(NA_character_, length(ordering)), - row = rep(NA_integer_, length(ordering)), - row_end = rep(NA_integer_, length(ordering)), - stringsAsFactors = FALSE - ) + for (i in seq_len(nrow(footnotes_tbl))) { - for (i in seq(ordering)) { + if (!is.na(footnotes_tbl[i, ][["rownum"]]) && + footnotes_tbl[i, ][["locname"]] %in% c("data", "stub")) { - if (!is.na(ordering[i])) { - rows_matched <- which(groups_df[, "groupname"] == ordering[i]) - } else { - rows_matched <- which(is.na(groups_df[, "groupname"])) + footnotes_tbl[i, ][["rownum"]] <- + which(rownum_final == footnotes_tbl[i, ][["rownum"]]) } - - groups_rows_df[i, "group"] <- groups_rows_df[i, "group_label"] <- ordering[i] - groups_rows_df[i, "row"] <- min(rows_matched) - groups_rows_df[i, "row_end"] <- max(rows_matched) } - groups_rows_df %>% - dplyr::mutate(group_label = process_text(group_label, context)) + dt_footnotes_set(data = data, footnotes = footnotes_tbl) } -# Function for merging pairs of columns together (in `output_df`) and -# transforming the dependent data frames (`boxh_df` and `columns_df`) -perform_col_merge <- function(col_merge, - data_df, - output_df, - boxh_df, - columns_df, - context) { - - if (length(col_merge) == 0) { - return( - list( - output_df = output_df, - boxh_df = boxh_df, - columns_df = columns_df) - ) - } - - for (i in seq(col_merge[[1]])) { - - sep <- col_merge[["sep"]][i] %>% context_dash_mark(context = context) - - pattern <- - col_merge[["pattern"]][i] %>% - tidy_sub("\\{sep\\}", sep) - - - value_1_col <- col_merge[["col_1"]][i] %>% unname() - value_2_col <- col_merge[["col_1"]][i] %>% names() +# Function to recode the `rownum` value in the styles table +reorder_styles <- function(data) { - values_1 <- - output_df[, which(colnames(output_df) == value_1_col)] + stub_df <- dt_stub_df_get(data = data) + styles_tbl <- dt_styles_get(data = data) - values_2 <- - output_df[, which(colnames(output_df) == value_2_col)] + rownum_final <- + stub_df %>% + dplyr::pull(rownum_i) %>% + as.numeric() - values_1_data <- - data_df[, which(colnames(data_df) == value_1_col)] + for (i in seq_len(nrow(styles_tbl))) { + if (!is.na(styles_tbl[i, ][["rownum"]])) { - values_2_data <- - data_df[, which(colnames(data_df) == value_2_col)] - - for (j in seq(values_1)) { - - if (!is.na(values_1[j]) && !grepl("NA", values_1[j]) && - !is.na(values_2[j]) && !grepl("NA", values_2[j]) && - !is.na(values_1_data[j]) && !is.na(values_2_data[j])) { - - values_1[j] <- - pattern %>% - tidy_gsub("\\{1\\}", values_1[j]) %>% - tidy_gsub("\\{2\\}", values_2[j]) - } + styles_tbl[i, ][["rownum"]] <- + which(rownum_final == styles_tbl[i, ][["rownum"]]) } - - output_df[, which(colnames(output_df) == value_1_col)] <- values_1 - - # Remove the second column across key data frames - boxh_df <- - boxh_df[, -which(colnames(output_df) == value_2_col), drop = FALSE] - - output_df <- - output_df[, -which(colnames(output_df) == value_2_col), drop = FALSE] - - # Mark the removed column as missing in `columns_df` - columns_df[which(columns_df == value_2_col), "colnum_final"] <- NA_integer_ } - # Return a list with the modified data frames - list( - output_df = output_df, - boxh_df = boxh_df, - columns_df = columns_df) + data <- dt_styles_set(data = data, styles = styles_tbl) + + data } -#' Create a list of summary data frames given a `summary_list` +#' Perform merging of column contents #' -#' A `summary_list` is a list of directives for making per-group summaries); the -#' final list will provide `display` and `data` versions of the summaries, named -#' by group +#' This merges column content together with a pattern and possibly with a `type` +#' that specifies additional operations #' -#' @import rlang #' @noRd -create_summary_dfs <- function(summary_list, - data_df, - stub_df, - output_df, - context) { - - # If the `summary_list` object is an empty list, - # return an empty list as the `list_of_summaries` - if (length(summary_list) == 0) { - return(list()) - } - - # Create empty lists that are to contain summary - # data frames for display and for data collection - # purposes - summary_df_display_list <- list() - summary_df_data_list <- list() - - for (i in seq(summary_list)) { - - summary_attrs <- summary_list[[i]] - - groups <- summary_attrs$groups - columns <- summary_attrs$columns - fns <- summary_attrs$fns - missing_text <- summary_attrs$missing_text - formatter <- summary_attrs$formatter - formatter_options <- summary_attrs$formatter_options - labels <- summary_attrs$summary_labels - - if (length(labels) != length(unique(labels))) { - - stop("All summary labels must be unique:\n", - " * Review the names provided in `fns`\n", - " * These labels are in conflict: ", - paste0(labels, collapse = ", "), ".", - call. = FALSE) - } - - # Resolve the `missing_text` - missing_text <- - context_missing_text(missing_text = missing_text, context = context) - - assert_rowgroups <- function() { +perform_col_merge <- function(data, + context) { - if (all(is.na(stub_df$groupname))) { - stop("There are no row groups in the gt object:\n", - " * Use `groups = NULL` to create a grand summary\n", - " * Define row groups using `gt()` or `tab_row_group()`", - call. = FALSE) - } - } + col_merge <- dt_col_merge_get(data = data) + body <- dt_body_get(data = data) - # Resolve the groups to consider; if - # `groups` is TRUE then we are to obtain - # summary row data for all groups - if (isTRUE(groups)) { + if (length(col_merge) == 0) { + return(data) + } - assert_rowgroups() + for (i in seq(col_merge)) { - groups <- unique(stub_df$groupname) + type <- col_merge[[i]]$type - } else if (!is.null(groups) && is.character(groups)) { + if (type == "merge") { - assert_rowgroups() + mutated_column <- col_merge[[i]]$vars[1] + mutated_column_sym <- sym(mutated_column) - # Get the names of row groups available - # in the gt object - groups_available <- unique(stub_df$groupname) + columns <- col_merge[[i]]$vars + pattern <- col_merge[[i]]$pattern - if (any(!(groups %in% groups_available))) { + # Convert any index positions in the pattern + # to the column names specified + for (j in seq(columns)) { - # Stop function if one or more `groups` - # are not present in the gt table - stop("All `groups` should be available in the gt object:\n", - " * The following groups aren't present: ", - paste0( - base::setdiff(groups, groups_available), - collapse = ", " - ), "\n", - call. = FALSE) + pattern <- + tidy_gsub( + x = pattern, + pattern = paste0("\\{", j, "\\}"), + replacement = paste0("{", columns[j], "}") + ) } - } else if (is.null(groups)) { - - # If groups is given as NULL (the default) - # then use a special group (`::GRAND_SUMMARY`) - groups <- grand_summary_col - } - - # Resolve the columns to exclude - columns_excl <- base::setdiff(colnames(output_df), columns) - - # Combine `groupname` with the table body data in order to - # process data by groups - if (identical(groups, grand_summary_col)) { - - select_data_df <- - cbind( - stub_df[c("groupname", "rowname")], - data_df)[, -2] %>% - dplyr::mutate(groupname = grand_summary_col) %>% - dplyr::select(groupname, columns) - - } else { - - select_data_df <- - cbind( - stub_df[c("groupname", "rowname")], - data_df)[, -2] %>% - dplyr::select(groupname, columns) - } - - # Get the registered function calls - agg_funs <- fns %>% lapply(rlang::as_closure) - - summary_dfs_data <- - lapply( - seq(agg_funs), function(j) { - select_data_df %>% - dplyr::filter(groupname %in% groups) %>% - dplyr::group_by(groupname) %>% - dplyr::summarize_all(.funs = agg_funs[[j]]) %>% - dplyr::ungroup() %>% - dplyr::mutate(rowname = labels[j]) %>% - dplyr::select(groupname, rowname, dplyr::everything()) - } - ) %>% - dplyr::bind_rows() - - # Add those columns that were not part of - # the aggregation, filling those with NA values - summary_dfs_data[, columns_excl] <- NA_real_ - - summary_dfs_data <- - summary_dfs_data %>% - dplyr::select(groupname, rowname, colnames(output_df)) - - # Format the displayed summary lines - summary_dfs_display <- - summary_dfs_data %>% - dplyr::mutate_at( - .vars = columns, - .funs = function(x) { - - format_data <- - do.call( - summary_attrs$formatter, - append( - list( - data.frame(x = x), - columns = "x" - ), - summary_attrs$formatter_options - ) - ) - - formatter <- attr(format_data, "formats")[[1]]$func - fmt <- formatter[[context]] %||% formatter$default - fmt(x) - } - ) %>% - dplyr::mutate_at( - .vars = columns_excl, - .funs = function(x) {NA_character_} - ) - - for (group in groups) { - - # Place data frame in separate list component by `group` - group_sym <- rlang::enquo(group) - - group_summary_data_df <- - summary_dfs_data %>% - dplyr::filter(groupname == !!group_sym) - - group_summary_display_df <- - summary_dfs_display %>% - dplyr::filter(groupname == !!group_sym) - - summary_df_data_list <- - c(summary_df_data_list, - stats::setNames(list(group_summary_data_df), group)) - - summary_df_display_list <- - c(summary_df_display_list, - stats::setNames(list(group_summary_display_df), group)) + body <- + body %>% + dplyr::mutate( + !!mutated_column_sym := glue::glue(pattern) %>% as.character() + ) } - } - # Condense data in `summary_df_display_list` in a - # groupwise manner - summary_df_display_list <- - tapply( - summary_df_display_list, - names(summary_df_display_list), - dplyr::bind_rows - ) + if (type == "merge_range") { - for (i in seq(summary_df_display_list)) { + mutated_column <- col_merge[[i]]$vars[1] + mutated_column_sym <- sym(mutated_column) - arrangement <- unique(summary_df_display_list[[i]]$rowname) + second_column <- col_merge[[i]]$vars[2] + second_column_sym <- sym(second_column) - summary_df_display_list[[i]] <- - summary_df_display_list[[i]] %>% - dplyr::select(-groupname) %>% - dplyr::group_by(rowname) %>% - dplyr::summarize_all(last_non_na) - - summary_df_display_list[[i]] <- - summary_df_display_list[[i]][ - match(arrangement, summary_df_display_list[[i]]$rowname), ] %>% - replace(is.na(.), missing_text) - } + columns <- col_merge[[i]]$vars - # Return a list of lists, each of which have - # summary data frames for display and for data - # collection purposes - list( - summary_df_data_list = summary_df_data_list, - summary_df_display_list = summary_df_display_list - ) -} + sep <- col_merge[[i]]$sep %>% context_dash_mark(context = context) -migrate_labels <- function(row_val) { - function( - boxh_df, - labels, - context) { + pattern <- + col_merge[[i]]$pattern %>% + tidy_gsub("{sep}", sep, fixed = TRUE) - for (label_name in names(labels)) { + # Convert any index positions in the pattern + # to the column names specified + for (j in seq(columns)) { - if (label_name %in% colnames(boxh_df)) { - boxh_df[row_val, label_name] <- - process_text(labels[[label_name]], context) + pattern <- + tidy_gsub( + x = pattern, + pattern = paste0("\\{", j, "\\}"), + replacement = paste0("{", columns[j], "}") + ) } - } - boxh_df - } -} + data_tbl <- dt_data_get(data = data) -# Process text of finalized column labels and migrate the -# processed text to `boxh_df` -migrate_colnames_to_labels <- migrate_labels("column_label") + na_1_rows <- which(is.na(data_tbl %>% dplyr::pull(!!mutated_column_sym))) + na_2_rows <- which(is.na(data_tbl %>% dplyr::pull(!!second_column_sym))) -# Process text of finalized column group labels and migrate the -# processed text to `boxh_df` -migrate_grpnames_to_labels <- migrate_labels("group_label") + no_na_rows <- + seq_along(body %>% dplyr::pull(!!mutated_column_sym)) %>% + base::setdiff(na_1_rows) %>% + base::setdiff(na_2_rows) - - -# Assign center alignment for all columns that haven't had alignment -# explicitly set -set_default_alignments <- function(boxh_df) { - - for (colname in colnames(boxh_df)) { - - if (is.na(boxh_df["column_align", colname])) { - boxh_df["column_align", colname] <- "center" + body <- + body %>% + dplyr::mutate( + !!mutated_column_sym := dplyr::case_when( + dplyr::row_number() %in% no_na_rows ~ glue::glue(pattern) %>% as.character(), + TRUE ~ !!mutated_column_sym + ) + ) } } - boxh_df -} - -# Function to determine if there are any defined elements of a stub present -is_stub_available <- function(stub_df) { - - if (!all(is.na((stub_df)[["rowname"]]))) { - return(TRUE) - } else { - return(FALSE) - } -} - -# Function to determine if a title element has been defined -is_title_defined <- function(heading) { - - length(heading) > 0 && !is.null(heading$title) -} - -# Function to determine if a subtitle element has been defined -is_subtitle_defined <- function(heading) { + data <- dt_body_set(data = data, body = body) - length(heading) > 0 && !is.null(heading$subtitle) && heading$subtitle != "" -} - -# Function to determine if the `list_of_summaries` object contains -# processed summary data frames -are_summaries_present <- function(list_of_summaries) { - - if (length(list_of_summaries) == 0) { - return(FALSE) - } else { - return(TRUE) - } -} - -# Function to determine if any group headings (spanners) are present -are_spanners_present <- function(boxh_df) { - - if (!all(is.na((boxh_df)["group_label", ] %>% t() %>% as.vector()))) { - return(TRUE) - } else { - return(FALSE) - } -} - -# Function to get a vector of the stub components that are available -# within the `stub_df` data frame -get_stub_components <- function(stub_df) { - - stub_components <- c() - - if (any(!is.na(stub_df[["rowname"]]))) { - stub_components <- c(stub_components, "rowname") - } - - if (any(!is.na(stub_df[["groupname"]]))) { - stub_components <- c(stub_components, "groupname") - } - - stub_components -} - -# Function that checks `stub_components` and determines whether just the -# `rowname` part is available; TRUE indicates that we are working with a table -# with rownames -stub_component_is_rowname <- function(stub_components) { - - identical(stub_components, "rowname") -} - -# Function that checks `stub_components` and determines whether just the -# `groupname` part is available; TRUE indicates that we are working with a table -# with groups but it doesn't have rownames -stub_component_is_groupname <- function(stub_components) { - - identical(stub_components, "groupname") -} - -# Function that checks `stub_components` and determines whether the -# `rowname` and `groupname` parts are available; TRUE indicates that we are -# working with a table with rownames and groups -stub_component_is_rowname_groupname <- function(stub_components) { - - identical(stub_components, c("rowname", "groupname")) -} - -# Process the `heading` object -process_heading <- function(heading, context) { - - if (!is.null(heading)) { - title <- heading$title %>% process_text(context) - subtitle <- heading$subtitle %>% process_text(context) - - return(list(title = title, subtitle = subtitle)) - } -} - -# Process the `stubhead` object -process_stubhead <- function(stubhead, context) { - - if (!is.null(stubhead)) { - label <- stubhead$label %>% process_text(context) - - return(list(label = label)) - } -} - -# Process the `source_note` object -process_source_notes <- function(source_note, context) { - - if (!is.null(source_note)) { - - source_notes <- c() - for (sn in source_note) { - - source_notes <- c(source_notes, process_text(sn, context)) - } - - return(list(source_note = source_notes)) - } + data } # Function to build a vector of `group` rows in the table body diff --git a/R/utils_render_footnotes.R b/R/utils_render_footnotes.R index f3fc6b6ea4..2343acfa3e 100644 --- a/R/utils_render_footnotes.R +++ b/R/utils_render_footnotes.R @@ -1,26 +1,45 @@ #' Resolve footnotes or styles #' #' @noRd -resolve_footnotes_styles <- function(output_df, - boxh_df, - groups_rows_df, - opts_df, - arrange_groups, - columns_spanners, - title_defined, - subtitle_defined, - footnotes_df = NULL, - styles_df = NULL) { - - # TODO: use `tbl` in arg list to avoid below statement - if (!is.null(styles_df) && is.null(footnotes_df)) { - tbl <- styles_df - } else if (is.null(styles_df) && !is.null(footnotes_df)) { - tbl <- footnotes_df +resolve_footnotes_styles <- function(data, + tbl_type) { + + boxh <- dt_boxhead_get(data = data) + spanners <- dt_spanners_get(data = data) + body <- dt_body_get(data = data) + groups_rows_df <- dt_groups_rows_get(data = data) + + # Get the `footnote_marks` option from the options table + footnote_marks <- dt_options_get_value(data = data, option = "footnote_marks") + + if (tbl_type == "footnotes") { + tbl <- dt_footnotes_get(data = data) + } else if (tbl_type == "styles") { + tbl <- dt_styles_get(data = data) + } else { + stop("The `tbl_type` must be either `\"footnotes\"` or `\"styles\"`") } + # Return `data` unchanged if there are no rows in `tbl` if (nrow(tbl) == 0) { - return(tbl) + return(data) + } + + # Filter table to include only the `default` vars + # in the `data` and `columns_columns` locnames + default_vars <- dt_boxhead_get_vars_default(data = data) + + tbl <- + dplyr::bind_rows( + tbl %>% dplyr::filter(!(locname %in% c("data", "columns_columns"))), + tbl %>% + dplyr::filter(locname %in% c("data", "columns_columns")) %>% + dplyr::filter(colname %in% default_vars) + ) + + # Return `data` unchanged if there are no rows in `tbl` + if (nrow(tbl) == 0) { + return(data) } # Pare down to the relevant records @@ -31,7 +50,7 @@ resolve_footnotes_styles <- function(output_df, # remove the footnote reference since it is not relevant) # Filter by `title` - if (title_defined == FALSE) { + if (!dt_heading_has_title(data = data)) { tbl <- tbl %>% @@ -39,7 +58,7 @@ resolve_footnotes_styles <- function(output_df, } # Filter by `subtitle` - if (subtitle_defined == FALSE) { + if (!dt_heading_has_subtitle(data = data)) { tbl <- tbl %>% @@ -49,10 +68,15 @@ resolve_footnotes_styles <- function(output_df, # Filter by `grpname` in columns groups if ("columns_groups" %in% tbl[["locname"]]) { # remove conditional + spanner_labels <- + spanners$spanner_label %>% + unlist() %>% + unique() + tbl <- tbl %>% dplyr::filter( - locname != "columns_groups" | grpname %in% columns_spanners + locname != "columns_groups" | grpname %in% spanner_labels ) } @@ -65,26 +89,28 @@ resolve_footnotes_styles <- function(output_df, dplyr::filter(locname != "stub_groups"), tbl %>% dplyr::filter(locname == "stub_groups") %>% - dplyr::filter(grpname %in% arrange_groups$groups) + dplyr::filter(grpname %in% groups_rows_df$group) ) } - # Filter `tbl` by the remaining columns in `output_df` + # Filter `tbl` by the remaining columns in `body` tbl <- tbl %>% - dplyr::filter(colname %in% c(NA_character_, colnames(output_df))) + dplyr::filter( + colname %in% c(NA_character_, dt_boxhead_get_vars_default(data = data)) + ) } # Reorganize records that target the data rows - if (5 %in% tbl[["locnum"]]) { + if (any(tbl[["locname"]] %in% c("data", "stub"))) { tbl_not_data <- tbl %>% - dplyr::filter(locnum != 5 | locname == "stub_groups") + dplyr::filter(!(locname %in% c("data", "stub"))) tbl_data <- tbl %>% - dplyr::filter(locnum == 5 & locname != "stub_groups") + dplyr::filter(locname %in% c("data", "stub")) if (nrow(tbl_data) > 0) { @@ -94,8 +120,8 @@ resolve_footnotes_styles <- function(output_df, tbl_data %>% dplyr::mutate( rownum = rownum_translation( - output_df, rownum_start = rownum - ) + body = body, + rownum_start = rownum) ) # Add a `colnum` column that's required for @@ -103,11 +129,7 @@ resolve_footnotes_styles <- function(output_df, # of records moves from top-to-bottom, left-to-right tbl_data <- tbl_data %>% - dplyr::mutate( - colnum = colname_to_colnum( - boxh_df = boxh_df, colname = colname - ) - ) %>% + dplyr::mutate(colnum = colname_to_colnum(data = data, colname = colname)) %>% dplyr::mutate(colnum = ifelse(locname == "stub", 0, colnum)) } @@ -164,7 +186,8 @@ resolve_footnotes_styles <- function(output_df, by = c("grpname" = "group") ) %>% dplyr::mutate(rownum = (rownum / 100) + row_end) %>% - dplyr::select(-row, -row_end) + dplyr::select(-row, -row_end) %>% + dplyr::mutate(colnum = colname_to_colnum(data = data, colname = colname)) # Re-combine `tbl_not_summary_cells` # with `tbl_summary_cells` @@ -185,11 +208,7 @@ resolve_footnotes_styles <- function(output_df, tbl_g_summary_cells <- tbl %>% dplyr::filter(locnum == 6) %>% - dplyr::mutate( - colnum = colname_to_colnum( - boxh_df = boxh_df, colname = colname - ) - ) + dplyr::mutate(colnum = colname_to_colnum(data = data, colname = colname)) # Re-combine `tbl_not_g_summary_cells` # with `tbl_g_summary_cells` @@ -213,8 +232,8 @@ resolve_footnotes_styles <- function(output_df, dplyr::filter(locname == "columns_columns") %>% dplyr::inner_join( dplyr::tibble( - colnum = seq(ncol(boxh_df)), - colname = names(boxh_df) + colnum = seq(nrow(boxh)), + colname = boxh$var ), by = "colname" ) @@ -232,10 +251,13 @@ resolve_footnotes_styles <- function(output_df, # `colnum` based on `boxh_df` if ("columns_groups" %in% tbl[["locname"]]) { + vars_default <- seq_along(dt_boxhead_get_vars_default(data = data)) + spanners_labels <- dt_spanners_print(data = data, include_hidden = FALSE) + group_label_df <- dplyr::tibble( - colnum = seq(ncol(boxh_df)), - grpname = boxh_df["group_label", ] %>% as.character() + colnum = seq(vars_default), + grpname = spanners_labels ) %>% dplyr::group_by(grpname) %>% dplyr::summarize(colnum = min(colnum)) @@ -266,13 +288,13 @@ resolve_footnotes_styles <- function(output_df, # In the case of footnotes, populate table # column with footnote marks - if (!is.null(footnotes_df)) { + if (tbl_type == "footnotes") { # Generate a lookup table with ID'd footnote # text elements (that are distinct) lookup_tbl <- tbl %>% - dplyr::select(text) %>% + dplyr::select(footnotes) %>% dplyr::distinct() %>% tibble::rownames_to_column(var = "fs_id") %>% dplyr::mutate(fs_id = as.integer(fs_id)) @@ -280,28 +302,23 @@ resolve_footnotes_styles <- function(output_df, # Join the lookup table to `tbl` tbl <- tbl %>% - dplyr::inner_join(lookup_tbl, by = "text") + dplyr::inner_join(lookup_tbl, by = "footnotes") if (nrow(tbl) > 0) { - # Get the `footnote_marks` option from `opts_df` - marks <- - opts_df %>% - opts_df_get(option = "footnote_marks") - # Modify `fs_id` to contain the footnote marks we need tbl <- tbl %>% dplyr::mutate( fs_id = process_footnote_marks( x = fs_id, - marks = marks + marks = footnote_marks ) ) } } - if (!is.null(styles_df)) { + if (tbl_type == "styles") { if (nrow(tbl) > 0) { @@ -309,24 +326,27 @@ resolve_footnotes_styles <- function(output_df, tbl %>% dplyr::group_by( .dots = colnames(.) %>% base::setdiff(c("styles", "text"))) %>% - dplyr::summarize(styles_appended = list(as_style(styles))) %>% + dplyr::summarize(styles = list(as_style(styles))) %>% dplyr::ungroup() } } - tbl + + if (tbl_type == "footnotes") { + data <- dt_footnotes_set(data = data, footnotes = tbl) + } else { + data <- dt_styles_set(data = data, styles = tbl) + } + + data } #' @noRd -set_footnote_marks_columns <- function(footnotes_resolved, - boxh_df, - output = "html") { +set_footnote_marks_columns <- function(data, + context = "html") { - # Get the resolved footnotes - footnotes_tbl <- footnotes_resolved - - # Get the `boxh_df` object - boxh_df <- boxh_df + boxh <- dt_boxhead_get(data = data) + footnotes_tbl <- dt_footnotes_get(data = data) # If there are any footnotes to apply to the columns, # process them individually for the spanner groups and @@ -359,16 +379,15 @@ set_footnote_marks_columns <- function(footnotes_resolved, for (i in seq(nrow(footnotes_columns_group_marks))) { + spanners <- dt_spanners_get(data = data) + spanner_labels <- dt_spanners_print(data = data) + column_indices <- - which(boxh_df["group_label", ] == footnotes_columns_group_marks$grpname[i]) + which(spanner_labels == footnotes_columns_group_marks$grpname[i]) - text <- - boxh_df["group_label", column_indices] %>% - unlist() %>% - unname() %>% - unique() + text <- spanner_labels[column_indices] %>% unique() - if (output == "html") { + if (context == "html") { text <- paste0( @@ -377,7 +396,7 @@ set_footnote_marks_columns <- function(footnotes_resolved, footnotes_columns_group_marks$fs_id_coalesced[i]) ) - } else if (output == "rtf") { + } else if (context == "rtf") { text <- paste0( @@ -386,7 +405,7 @@ set_footnote_marks_columns <- function(footnotes_resolved, footnotes_columns_group_marks$fs_id_coalesced[i]) ) - } else if (output == "latex") { + } else if (context == "latex") { text <- paste0( @@ -396,7 +415,13 @@ set_footnote_marks_columns <- function(footnotes_resolved, ) } - boxh_df["group_label", column_indices] <- text + spanners_i <- + which( + (spanners$spanner_label %>% unlist()) == footnotes_columns_group_marks$grpname[i]) + + spanners[spanners_i, ][["built"]] <- text + + data <- dt_spanners_set(data = data, spanners = spanners) } } @@ -412,10 +437,14 @@ set_footnote_marks_columns <- function(footnotes_resolved, for (i in seq(nrow(footnotes_columns_column_marks))) { + # TODO: make this work with column labels text <- - boxh_df["column_label", footnotes_columns_column_marks$colname[i]] + boxh %>% + dplyr::filter(var == footnotes_columns_column_marks$colname[i]) %>% + dplyr::pull(column_label) %>% + .[[1]] - if (output == "html") { + if (context == "html") { text <- paste0( @@ -424,7 +453,7 @@ set_footnote_marks_columns <- function(footnotes_resolved, footnotes_columns_column_marks$fs_id_coalesced[i]) ) - } else if (output == "rtf") { + } else if (context == "rtf") { text <- paste0( @@ -433,7 +462,7 @@ set_footnote_marks_columns <- function(footnotes_resolved, footnotes_columns_column_marks$fs_id_coalesced[i]) ) - } else if (output == "latex") { + } else if (context == "latex") { text <- paste0( @@ -443,24 +472,31 @@ set_footnote_marks_columns <- function(footnotes_resolved, ) } - boxh_df[ - "column_label", footnotes_columns_column_marks$colname[i]] <- text + boxh <- + boxh %>% + dplyr::mutate(column_label = dplyr::case_when( + var == footnotes_columns_column_marks$colname[i] ~ list(text), + TRUE ~ column_label + )) + + data <- dt_boxhead_set(data = data, boxh = boxh) } } } - boxh_df + data } #' Set footnote marks for the stubhead #' #' @noRd -set_footnote_marks_stubhead <- function(footnotes_resolved, - stubhead, - output = "html") { +set_footnote_marks_stubhead <- function(data, + context = "html") { + + footnotes_tbl <- dt_footnotes_get(data = data) + stubhead <- dt_stubhead_get(data = data) - # Get the resolved footnotes - footnotes_tbl <- footnotes_resolved + label <- stubhead$label if ("stubhead" %in% footnotes_tbl$locname) { @@ -479,47 +515,45 @@ set_footnote_marks_stubhead <- function(footnotes_resolved, dplyr::distinct() %>% dplyr::pull(fs_id_coalesced) - text <- stubhead$label + if (context == "html") { - if (output == "html") { + label <- + paste0(label, footnote_mark_to_html(footnotes_stubhead_marks)) - text <- - paste0(text, footnote_mark_to_html(footnotes_stubhead_marks)) - - } else if (output == "rtf") { + } else if (context == "rtf") { - text <- - paste0(text, footnote_mark_to_rtf(footnotes_stubhead_marks)) + label <- + paste0(label, footnote_mark_to_rtf(footnotes_stubhead_marks)) - } else if (output == "latex") { + } else if (context == "latex") { - text <- - paste0(text, footnote_mark_to_latex(footnotes_stubhead_marks)) + label <- + paste0(label, footnote_mark_to_latex(footnotes_stubhead_marks)) } - - stubhead$label <- text } } - stubhead + dt_stubhead_label(data = data, label = label) } #' Apply footnotes to the data rows #' #' @noRd -apply_footnotes_to_output <- function(output_df, - footnotes_resolved, - output = "html") { +apply_footnotes_to_output <- function(data, + context = "html") { + + body <- dt_body_get(data = data) + footnotes_tbl <- dt_footnotes_get(data = data) # `data` location footnotes_tbl_data <- - footnotes_resolved %>% + footnotes_tbl %>% dplyr::filter(locname %in% c("data", "stub")) if (nrow(footnotes_tbl_data) > 0) { if ("stub" %in% footnotes_tbl_data$locname && - "rowname" %in% colnames(output_df)) { + "rowname" %in% colnames(body)) { footnotes_tbl_data[ which(is.na(footnotes_tbl_data$colname)), "colname"] <- "rowname" @@ -536,23 +570,23 @@ apply_footnotes_to_output <- function(output_df, for (i in seq(nrow(footnotes_data_marks))) { text <- - output_df[footnotes_data_marks$rownum[i], footnotes_data_marks$colname[i]] + body[footnotes_data_marks$rownum[i], footnotes_data_marks$colname[i]] - if (output == "html") { + if (context == "html") { text <- paste0(text, footnote_mark_to_html( footnotes_data_marks$fs_id_coalesced[i]) ) - } else if (output == "rtf") { + } else if (context == "rtf") { text <- paste0(text, footnote_mark_to_rtf( footnotes_data_marks$fs_id_coalesced[i]) ) - } else if (output == "latex") { + } else if (context == "latex") { text <- paste0(text, footnote_mark_to_latex( @@ -560,26 +594,22 @@ apply_footnotes_to_output <- function(output_df, ) } - output_df[ + body[ footnotes_data_marks$rownum[i], footnotes_data_marks$colname[i]] <- text } } - output_df + data <- dt_body_set(data = data, body = body) + + data } #' @noRd -set_footnote_marks_stub_groups <- function(footnotes_resolved, - groups_rows_df, - output = "html") { - - # Get the resolved footnotes - footnotes_tbl <- footnotes_resolved +set_footnote_marks_row_groups <- function(data, + context = "html") { - if (!("stub_groups" %in% footnotes_tbl$locname)) { - - return(groups_rows_df) - } + groups_rows_df <- dt_groups_rows_get(data = data) + footnotes_tbl <- dt_footnotes_get(data = data) footnotes_stub_groups_tbl <- footnotes_tbl %>% @@ -602,7 +632,7 @@ set_footnote_marks_stub_groups <- function(footnotes_resolved, text <- groups_rows_df[row_index, "group_label"] - if (output == "html") { + if (context == "html") { text <- paste0( @@ -611,7 +641,7 @@ set_footnote_marks_stub_groups <- function(footnotes_resolved, footnotes_stub_groups_marks$fs_id_coalesced[i]) ) - } else if (output == "rtf") { + } else if (context == "rtf") { text <- paste0( @@ -620,7 +650,7 @@ set_footnote_marks_stub_groups <- function(footnotes_resolved, footnotes_stub_groups_marks$fs_id_coalesced[i]) ) - } else if (output == "latex") { + } else if (context == "latex") { text <- paste0( @@ -634,26 +664,32 @@ set_footnote_marks_stub_groups <- function(footnotes_resolved, } } - groups_rows_df + data <- dt_groups_rows_set(data = data, groups_rows = groups_rows_df) + + data } #' Apply footnotes to the summary rows #' #' @noRd -apply_footnotes_to_summary <- function(list_of_summaries, - footnotes_resolved) { +apply_footnotes_to_summary <- function(data) { + + # TODO: `context` is missing in this function + + list_of_summaries <- dt_summary_df_get(data = data) + footnotes_tbl <- dt_footnotes_get(data = data) summary_df_list <- list_of_summaries$summary_df_display_list - if (!("summary_cells" %in% footnotes_resolved$locname | - "grand_summary_cells" %in% footnotes_resolved$locname)) { - return(list_of_summaries) - } + # if (!("summary_cells" %in% footnotes_tbl$locname | + # "grand_summary_cells" %in% footnotes_tbl$locname)) { + # return(list_of_summaries) + # } - if ("summary_cells" %in% footnotes_resolved$locname) { + if ("summary_cells" %in% footnotes_tbl$locname) { footnotes_tbl_data <- - footnotes_resolved %>% + footnotes_tbl %>% dplyr::filter(locname == "summary_cells") footnotes_data_marks <- @@ -681,10 +717,10 @@ apply_footnotes_to_summary <- function(list_of_summaries, list_of_summaries$summary_df_display_list <- summary_df_list } - if ("grand_summary_cells" %in% footnotes_resolved$locname) { + if ("grand_summary_cells" %in% footnotes_tbl$locname) { footnotes_tbl_data <- - footnotes_resolved %>% + footnotes_tbl %>% dplyr::filter(locname == "grand_summary_cells") footnotes_data_marks <- @@ -712,5 +748,7 @@ apply_footnotes_to_summary <- function(list_of_summaries, summary_df_list[[grand_summary_col]] } - list_of_summaries + data <- dt_summary_data_set(data = data, summary = list_of_summaries) + + data } diff --git a/R/utils_render_html.R b/R/utils_render_html.R index 1979ea12b3..bdbc0adaa2 100644 --- a/R/utils_render_html.R +++ b/R/utils_render_html.R @@ -28,6 +28,23 @@ cell_style_to_html.default <- function(style) { stop("Implement `cell_style_to_html()` for the object above.", call. = FALSE) } +# Upgrade `_styles` to gain a `html_style` column with CSS style rules +add_css_styles <- function(data) { + + styles_tbl <- dt_styles_get(data = data) + + if (nrow(styles_tbl) > 0) { + styles_tbl <- + styles_tbl %>% + dplyr::mutate( + html_style = vapply( + styles, function(x) styles_to_html(x), character(1)) + ) + } + + dt_styles_set(data = data, styles = styles_tbl) +} + #' For a given location, reduce the footnote marks to a single string #' #' @param fn_tbl The table containing all of the resolved footnote information. @@ -46,21 +63,17 @@ coalesce_marks <- function(fn_tbl, } # Get the attributes for the table tag -get_table_defs <- function(boxh_df) { - - if (!all(is.na(boxh_df["column_width", ] %>% unlist() %>% unname()))) { +get_table_defs <- function(data) { - widths <- boxh_df["column_width", ] %>% unlist() %>% unname() + boxh <- dt_boxhead_get(data = data) - if (any(is.na(widths))) { + if (boxh$column_width %>% unlist() %>% length() > 0) { - warning("Unset column widths found, setting to `100px`:\n", - " * Columns: ", str_catalog(names(boxh_df)[is.na(widths)]), ".\n", - "Set these column widths in `cols_width()` using `TRUE ~ px(100)`.", - call. = FALSE) - - widths[is.na(widths)] <- px(100) - } + widths <- + boxh %>% + dplyr::filter(type == "default") %>% + .$column_width %>% + unlist() # Assumption is that all width values are `px` values total_width <- @@ -99,43 +112,56 @@ get_table_defs <- function(boxh_df) { #' string. #' #' @noRd -create_heading_component <- function(heading, - footnotes_resolved, - styles_resolved = NULL, - n_cols, - subtitle_defined, - output = "html") { - - # If there is no heading component, then return - # an empty string - if (length(heading) == 0) { +create_heading_component <- function(data, + context = "html") { + + heading <- dt_heading_get(data = data) + + # If there is no heading component, then return an empty string + if (length(heading$title) == 0) { return("") } + footnotes_tbl <- dt_footnotes_get(data = data) + styles_tbl <- dt_styles_get(data = data) + stub_components <- dt_stub_components(data = data) + subtitle_defined <- dt_heading_has_subtitle(data = data) + + n_data_cols <- dt_boxhead_get_vars_default(data = data) %>% length() + + # Determine whether the stub is available through analysis + # of the `stub_components` + stub_available <- dt_stub_components_has_rowname(stub_components) + + if (stub_available) { + n_cols <- n_data_cols + 1 + } else { + n_cols <- n_data_cols + } + # Get the footnote marks for the title - if ("title" %in% footnotes_resolved$locname) { + if ("title" %in% footnotes_tbl$locname) { footnote_title_marks <- - footnotes_resolved %>% + footnotes_tbl %>% coalesce_marks(locname = "title") footnote_title_marks <- - switch(output, + switch(context, html = footnote_mark_to_html(footnote_title_marks$fs_id_c), latex = footnote_mark_to_latex(footnote_title_marks$fs_id_c), rtf = footnote_mark_to_rtf(footnote_title_marks$fs_id_c), - stop("The context (`", output, "`) is invalid")) + stop("The context (`", context, "`) is invalid")) } else { footnote_title_marks <- "" } # Get the style attrs for the title - if (output == "html" && - "title" %in% styles_resolved$locname) { + if (context == "html" && "title" %in% styles_tbl$locname) { title_style_rows <- - styles_resolved %>% + styles_tbl %>% dplyr::filter(locname == "title") title_styles <- @@ -150,29 +176,29 @@ create_heading_component <- function(heading, } # Get the footnote marks for the subtitle - if (subtitle_defined & "title" %in% footnotes_resolved$locname) { + if (subtitle_defined & "title" %in% footnotes_tbl$locname) { footnote_subtitle_marks <- - footnotes_resolved %>% + footnotes_tbl %>% coalesce_marks(locname = "subtitle") footnote_subtitle_marks <- - switch(output, + switch(context, html = footnote_mark_to_html(footnote_subtitle_marks$fs_id_c), latex = footnote_mark_to_latex(footnote_subtitle_marks$fs_id_c), rtf = footnote_mark_to_rtf(footnote_subtitle_marks$fs_id_c), - stop("The context (`", output, "`) is invalid")) + stop("The context (`", context, "`) is invalid")) } else { footnote_subtitle_marks <- "" } # Get the style attrs for the subtitle - if (output == "html" && - "subtitle" %in% styles_resolved$locname) { + if (context == "html" && + "subtitle" %in% styles_tbl$locname) { subtitle_style_rows <- - styles_resolved %>% + styles_tbl %>% dplyr::filter(locname == "subtitle") subtitle_styles <- @@ -186,7 +212,7 @@ create_heading_component <- function(heading, subtitle_styles <- NA_character_ } - if (output == "html") { + if (context == "html") { title_classes <- c("gt_heading", "gt_title", "gt_font_normal", "gt_center") @@ -235,7 +261,7 @@ create_heading_component <- function(heading, ) } - if (output == "latex") { + if (context == "latex") { title_row <- paste0(heading$title, footnote_title_marks) %>% @@ -258,7 +284,7 @@ create_heading_component <- function(heading, paste_between(x_2 = c("\\caption*{\n", "} \\\\ \n")) } - if (output == "rtf") { + if (context == "rtf") { if (subtitle_defined) { @@ -285,20 +311,27 @@ create_heading_component <- function(heading, #' Create the columns component of a table (HTML) #' #' @noRd -create_columns_component_h <- function(boxh_df, - output_df, - stub_available, - spanners_present, - styles_resolved, - stubhead, - col_alignment, - opts_df) { +create_columns_component_h <- function(data) { + + boxh <- dt_boxhead_get(data = data) + stubh <- dt_stubhead_get(data = data) + body <- dt_body_get(data = data) + styles_tbl <- dt_styles_get(data = data) + stub_available <- dt_stub_df_exists(data = data) + spanners_present <- dt_spanners_exists(data = data) + + col_alignment <- + boxh %>% + dplyr::filter(type == "default") %>% + dplyr::pull(column_align) + + # Get the column headings + headings_vars <- boxh %>% dplyr::filter(type == "default") %>% dplyr::pull(var) + headings_labels <- dt_boxhead_get_vars_labels_default(data = data) # Should the column labels be hidden? column_labels_hidden <- - opts_df %>% - opts_df_get(option = "column_labels_hidden") %>% - as.logical() + dt_options_get_value(data = data, option = "column_labels_hidden") if (column_labels_hidden) { return("") @@ -306,41 +339,40 @@ create_columns_component_h <- function(boxh_df, # Get the style attrs for the stubhead label stubhead_style_attrs <- - styles_resolved %>% + styles_tbl %>% dplyr::filter(locname == "stubhead") # Get the style attrs for the spanner column headings spanner_style_attrs <- - styles_resolved %>% + styles_tbl %>% dplyr::filter(locname == "columns_groups") # Get the style attrs for the spanner column headings column_style_attrs <- - styles_resolved %>% + styles_tbl %>% dplyr::filter(locname == "columns_columns") - # Get the headings - headings <- boxh_df["column_label", ] %>% unlist() %>% unname() - # If `stub_available` == TRUE, then replace with a set stubhead # label or nothing - if (stub_available && length(stubhead) > 0) { - headings <- prepend_vec(headings, stubhead$label) - } else if (stub_available) { - headings <- prepend_vec(headings, "") + if (isTRUE(stub_available) && length(stubh$label) > 0) { + + headings_labels <- prepend_vec(headings_labels, stubh$label) + headings_vars <- prepend_vec(headings_vars, "::stub") + + } else if (isTRUE(stub_available)) { + + headings_labels <- prepend_vec(headings_labels, "") + headings_vars <- prepend_vec(headings_vars, "::stub") } - # Ensure that column headings for right-aligned content - # are centered - col_alignment[col_alignment == "right"] <- "center" + stubhead_label_alignment <- "left" - column_alignments <- paste0("gt_", col_alignment) table_col_headings <- list() if (!spanners_present) { # Create the cell for the stubhead label - if (stub_available) { + if (isTRUE(stub_available)) { stubhead_style <- if (nrow(stubhead_style_attrs) > 0) { @@ -352,27 +384,28 @@ create_columns_component_h <- function(boxh_df, table_col_headings[[length(table_col_headings) + 1]] <- htmltools::tags$th( class = paste( - c("gt_col_heading", "gt_columns_bottom_border", "gt_columns_top_border", - paste0("gt_", col_alignment[1])), + c("gt_col_heading", "gt_columns_bottom_border", #"gt_columns_top_border", + paste0("gt_", stubhead_label_alignment)), collapse = " "), rowspan = 1, colspan = 1, style = stubhead_style, - htmltools::HTML(headings[1]) + htmltools::HTML(headings_labels[1]) ) - headings <- headings[-1] + headings_vars <- headings_vars[-1] + headings_labels <- headings_labels[-1] } - for (i in seq(headings)) { + for (i in seq(headings_vars)) { - styles_resolved_column <- + styles_column <- column_style_attrs %>% dplyr::filter(colnum == i) column_style <- - if (nrow(styles_resolved_column) > 0) { - styles_resolved_column$html_style + if (nrow(styles_column) > 0) { + styles_column$html_style } else { NULL } @@ -380,30 +413,28 @@ create_columns_component_h <- function(boxh_df, table_col_headings[[length(table_col_headings) + 1]] <- htmltools::tags$th( class = paste( - c("gt_col_heading", "gt_columns_bottom_border", "gt_columns_top_border", column_alignments[i]), + c("gt_col_heading", "gt_columns_bottom_border", #"gt_columns_top_border", + paste0("gt_", col_alignment[i])), collapse = " "), rowspan = 1, colspan = 1, style = column_style, - htmltools::HTML(headings[i]) + htmltools::HTML(headings_labels[i]) ) } table_col_headings <- htmltools::tags$tr(table_col_headings) } - if (spanners_present) { + if (isTRUE(spanners_present)) { - spanners <- - boxh_df["group_label", ] %>% - unlist() %>% - unname() + spanners <- dt_spanners_print(data = data, include_hidden = FALSE) headings_stack <- c() first_set <- second_set <- list() # Create the cell for the stubhead label - if (stub_available) { + if (isTRUE(stub_available)) { stubhead_style <- if (nrow(stubhead_style_attrs) > 0) { @@ -415,32 +446,33 @@ create_columns_component_h <- function(boxh_df, first_set[[length(first_set) + 1]] <- htmltools::tags$th( class = paste( - c("gt_col_heading", "gt_columns_bottom_border", "gt_columns_top_border", - paste0("gt_", col_alignment[1])), + c("gt_col_heading", "gt_columns_bottom_border", #"gt_columns_top_border", + paste0("gt_", stubhead_label_alignment)), collapse = " "), rowspan = 2, colspan = 1, style = stubhead_style, - htmltools::HTML(headings[1]) + htmltools::HTML(headings_labels[1]) ) - headings <- headings[-1] + headings_vars <- headings_vars[-1] + headings_labels <- headings_labels[-1] } - for (i in seq(headings)) { + for (i in seq(headings_vars)) { if (is.na(spanners[i])) { - styles_resolved_heading <- - styles_resolved %>% + styles_heading <- + styles_tbl %>% dplyr::filter( locname == "columns_columns", - colname == headings[i] + colname == headings_vars[i] ) heading_style <- - if (nrow(styles_resolved_heading) > 0) { - styles_resolved_heading$html_style + if (nrow(styles_heading) > 0) { + styles_heading$html_style } else { NULL } @@ -453,10 +485,10 @@ create_columns_component_h <- function(boxh_df, rowspan = 2, colspan = 1, style = heading_style, - htmltools::HTML(headings[i]) + htmltools::HTML(headings_labels[i]) ) - headings_stack <- c(headings_stack, headings[i]) + headings_stack <- c(headings_stack, headings_vars[i]) } else if (!is.na(spanners[i])) { @@ -494,13 +526,13 @@ create_columns_component_h <- function(boxh_df, class <- paste0(class, " gt_sep_right") } - styles_resolved_spanners <- + styles_spanners <- spanner_style_attrs %>% dplyr::filter(locname == "columns_groups", grpname == spanners[i]) spanner_style <- - if (nrow(styles_resolved_spanners) > 0) { - styles_resolved_spanners$html_style + if (nrow(styles_spanners) > 0) { + styles_spanners$html_style } else { NULL } @@ -520,11 +552,18 @@ create_columns_component_h <- function(boxh_df, } } - remaining_headings <- headings[!(headings %in% headings_stack)] + remaining_headings <- headings_vars[!(headings_vars %in% headings_stack)] - remaining_headings_indices <- which(remaining_headings %in% headings) + remaining_headings_indices <- which(remaining_headings %in% headings_vars) - col_alignment <- col_alignment[-1][!(headings %in% headings_stack)] + remaining_headings_labels <- + boxh %>% + dplyr::filter(var %in% remaining_headings) %>% + dplyr::pull(column_label) %>% + unlist() + + col_alignment <- + col_alignment[-1][!(headings_vars %in% headings_stack)] if (length(remaining_headings) > 0) { @@ -532,16 +571,16 @@ create_columns_component_h <- function(boxh_df, for (j in seq(remaining_headings)) { - styles_resolved_remaining <- - styles_resolved %>% + styles_remaining <- + styles_tbl %>% dplyr::filter( locname == "columns_columns", colname == remaining_headings[j] ) remaining_style <- - if (nrow(styles_resolved_remaining) > 0) { - styles_resolved_remaining$html_style + if (nrow(styles_remaining) > 0) { + styles_remaining$html_style } else { NULL } @@ -554,7 +593,7 @@ create_columns_component_h <- function(boxh_df, ), rowspan = 1, colspan = 1, style = remaining_style, - htmltools::HTML(remaining_headings[j]) + htmltools::HTML(remaining_headings_labels[j]) ) } @@ -579,37 +618,62 @@ create_columns_component_h <- function(boxh_df, #' Create the table body component (HTML) #' #' @noRd -create_body_component_h <- function(output_df, - styles_resolved, - groups_rows_df, - col_alignment, - stub_components, - summaries_present, - list_of_summaries, - n_rows, - n_cols, - opts_df) { - - output_df_row <- function(i) { - output_df[i, ] %>% unlist() %>% unname() +create_body_component_h <- function(data) { + + boxh <- dt_boxhead_get(data = data) + styles_tbl <- dt_styles_get(data = data) + body <- dt_body_get(data = data) + summaries_present <- dt_summary_exists(data = data) + list_of_summaries <- dt_summary_df_get(data = data) + groups_rows_df <- dt_groups_rows_get(data = data) + stub_components <- dt_stub_components(data = data) + + n_data_cols <- dt_boxhead_get_vars_default(data = data) %>% length() + n_rows <- nrow(body) + + # Get the column alignments for the data columns (this + # doesn't include the stub alignment) + col_alignment <- + boxh %>% + dplyr::filter(type == "default") %>% + dplyr::pull(column_align) + + # Get the column headings for the visible (e.g., `default`) columns + headings <- dt_boxhead_get_vars_default(data = data) + + # Determine whether the stub is available through analysis + # of the `stub_components` + stub_available <- dt_stub_components_has_rowname(stub_components) + + # Define function to get a character vector of formatted cell + # data (this includes the stub, if it is present) + output_df_row_as_vec <- function(i) { + + default_vars <- dt_boxhead_get_vars_default(data = data) + + default_vals <- body[i, default_vars] %>% unlist() %>% unname() + + if (stub_available) { + default_vals <- + c( + dt_stub_rowname_at_position(data = data, i = i), + default_vals + ) + } + + default_vals } - if (is.null(stub_components)) { - stub_available <- FALSE - } else if (stub_component_is_groupname(stub_components)) { - stub_available <- FALSE + if (stub_available) { + n_cols <- n_data_cols + 1 } else { - stub_available <- TRUE + n_cols <- n_data_cols } - # Get the sequence of column numbers in the table body + # Get the sequence of column numbers in the table body (these + # are the visible columns in the table exclusive of the stub) column_series <- seq(n_cols) - # If there is a stub, remove the last element in the series - if (stub_available) { - column_series <- column_series[-length(column_series)] - } - # Replace an NA group with an empty string if (any(is.na(groups_rows_df$group))) { @@ -621,15 +685,11 @@ create_body_component_h <- function(output_df, # Is the stub to be striped? table_stub_striped <- - opts_df %>% - opts_df_get(option = "row_striping_include_stub") %>% - as.logical() + dt_options_get_value(data = data, option = "row_striping_include_stub") # Are the rows in the table body to be striped? table_body_striped <- - opts_df %>% - opts_df_get(option = "row_striping_include_table_body") %>% - as.logical() + dt_options_get_value(data = data, option = "row_striping_include_table_body") body_rows <- lapply( @@ -648,13 +708,13 @@ create_body_component_h <- function(output_df, group_label <- groups_rows_df[which(groups_rows_df$row %in% i), "group_label"][[1]] - styles_resolved_row <- - styles_resolved %>% + styles_row <- + styles_tbl %>% dplyr::filter(locname == "stub_groups", grpname == group_label) row_style <- - if (nrow(styles_resolved_row) > 0) { - styles_resolved_row$html_style + if (nrow(styles_row) > 0) { + styles_row$html_style } else { NULL } @@ -694,24 +754,27 @@ create_body_component_h <- function(output_df, NULL } - extra_classes <- rep_len(list(striped_class_val), n_cols) - if (stub_available) { + alignment_classes <- c("gt_left", alignment_classes) + extra_classes <- rep_len(list(striped_class_val), n_cols) + if (table_stub_striped) { extra_classes[[1]] <- c("gt_stub", extra_classes[[1]]) } else { extra_classes[[1]] <- "gt_stub" } + } else { + extra_classes <- rep_len(list(striped_class_val), n_data_cols) } - styles_resolved_row <- - styles_resolved %>% + styles_row <- + styles_tbl %>% dplyr::filter(rownum == i, locname %in% c("stub", "data")) row_styles <- build_row_styles( - styles_resolved_row = styles_resolved_row, + styles_resolved_row = styles_row, stub_available = stub_available, n_cols = n_cols ) @@ -721,7 +784,7 @@ create_body_component_h <- function(output_df, mapply( SIMPLIFY = FALSE, USE.NAMES = FALSE, - output_df_row(i), + output_df_row_as_vec(i), alignment_classes, extra_classes, row_styles, @@ -760,11 +823,13 @@ create_body_component_h <- function(output_df, summary_row_class = "gt_summary_row", locname = "summary_cells", list_of_summaries = list_of_summaries, - col_alignment = col_alignment, n_cols = n_cols, - stub_available = stub_available, styles_resolved = styles_resolved + col_alignment = col_alignment, + boxh = boxh, + stub_available = stub_available, + styles_resolved = styles_tbl ) - body_section <- append(body_section, summary_section) + body_section <- append(body_section, summary_section) } body_section @@ -785,8 +850,10 @@ create_body_component_h <- function(output_df, summary_row_class = "gt_grand_summary_row", locname = "grand_summary_cells", list_of_summaries = list_of_summaries, - col_alignment = col_alignment, n_cols = n_cols, - stub_available = stub_available, styles_resolved = styles_resolved + col_alignment = col_alignment, + boxh = boxh, + stub_available = stub_available, + styles_resolved = styles_tbl ) body_rows <- c(body_rows, grand_summary_section) @@ -801,17 +868,32 @@ create_body_component_h <- function(output_df, #' Create the table source note component (HTML) #' #' @noRd -create_source_note_component_h <- function(source_note, - n_cols) { +create_source_notes_component_h <- function(data) { - if (length(source_note) == 0) { + source_note <- dt_source_notes_get(data = data) + + if (is.null(source_note)) { return("") } + stub_components <- dt_stub_components(data = data) + + n_data_cols <- dt_boxhead_get_vars_default(data = data) %>% length() + + # Determine whether the stub is available through analysis + # of the `stub_components` + stub_available <- dt_stub_components_has_rowname(stub_components) + + if (stub_available) { + n_cols <- n_data_cols + 1 + } else { + n_cols <- n_data_cols + } + htmltools::tags$tfoot( class = "gt_sourcenotes", lapply( - source_note$source_note, + source_note, function(x) { htmltools::tags$tr( htmltools::tags$td( @@ -828,28 +910,40 @@ create_source_note_component_h <- function(source_note, #' Create the table footnote component (HTML) #' #' @noRd -create_footnote_component_h <- function(footnotes_resolved, - opts_df, - n_cols) { +create_footnotes_component_h <- function(data) { + + footnotes_tbl <- dt_footnotes_get(data = data) # If the `footnotes_resolved` object has no # rows, then return an empty footnotes component - if (nrow(footnotes_resolved) == 0) { + if (nrow(footnotes_tbl) == 0) { return("") } + stub_components <- dt_stub_components(data = data) + + n_data_cols <- dt_boxhead_get_vars_default(data = data) %>% length() + + # Determine whether the stub is available through analysis + # of the `stub_components` + stub_available <- dt_stub_components_has_rowname(stub_components) + + if (stub_available) { + n_cols <- n_data_cols + 1 + } else { + n_cols <- n_data_cols + } + footnotes_tbl <- - footnotes_resolved %>% - dplyr::select(fs_id, text) %>% + footnotes_tbl %>% + dplyr::select(fs_id, footnotes) %>% dplyr::distinct() - # Get the separator option from `opts_df` - separator <- - opts_df %>% - opts_df_get(option = "footnote_sep") + # Get the footnote separator option + separator <- dt_options_get_value(data = data, option = "footnote_sep") footnote_ids <- footnotes_tbl[["fs_id"]] - footnote_text <- footnotes_tbl[["text"]] + footnote_text <- footnotes_tbl[["footnotes"]] # Create the footnotes component htmltools::tags$tfoot( @@ -889,10 +983,15 @@ summary_row_tags <- function(group_id, locname, list_of_summaries, col_alignment, - n_cols, + boxh, stub_available, styles_resolved) { + default_vars <- + boxh %>% + dplyr::filter(type == "default") %>% + dplyr::pull(var) + summary_row_lines <- list() locname_val <- locname @@ -901,18 +1000,23 @@ summary_row_tags <- function(group_id, summary_df <- list_of_summaries$summary_df_display_list[[group_id]] %>% + dplyr::select(rowname, default_vars) %>% as.data.frame(stringsAsFactors = FALSE) + n_cols <- ncol(summary_df) + summary_df_row <- function(j) { summary_df[j, ] %>% unlist() %>% unname() } - alignment_classes <- paste0("gt_", col_alignment) - stub_classes <- rep_len(list(NULL), n_cols) - if (stub_available) { + if (isTRUE(stub_available)) { + + alignment_classes <- c("gt_right", paste0("gt_", col_alignment)) stub_classes[[1]] <- "gt_stub" + } else { + alignment_classes <- paste0("gt_", col_alignment) } styles_resolved_group <- @@ -935,12 +1039,12 @@ summary_row_tags <- function(group_id, dplyr::filter(grprow == j) } - row_styles <- - build_row_styles( - styles_resolved_row = styles_resolved_row, - stub_available = stub_available, - n_cols = n_cols - ) + row_styles <- + build_row_styles( + styles_resolved_row = styles_resolved_row, + stub_available = stub_available, + n_cols = n_cols + ) summary_row_lines[[length(summary_row_lines) + 1]] <- htmltools::tags$tr( diff --git a/R/utils_render_latex.R b/R/utils_render_latex.R index 8d9aca9589..1bc732fb08 100644 --- a/R/utils_render_latex.R +++ b/R/utils_render_latex.R @@ -49,51 +49,76 @@ latex_group_row <- function(group_name, } #' @noRd -create_table_start_l <- function(col_alignment) { +create_table_start_l <- function(data) { + + col_alignment <- + dt_boxhead_get(data = data) %>% + dplyr::filter(type == "default") %>% + dplyr::pull(column_align) + + # TODO: ensure that number of alignment tabs is correct + if (dt_stub_df_exists(data = data)) { + col_alignment <- c("left", col_alignment) + } paste0( "\\captionsetup[table]{labelformat=empty,skip=1pt}\n", "\\begin{longtable}{", col_alignment %>% substr(1, 1) %>% paste(collapse = ""), "}\n", - collapse = "") + collapse = "" + ) } #' Create the columns component of a table #' #' @noRd -create_columns_component_l <- function(boxh_df, - output_df, - stub_available, - spanners_present, - stubhead, - col_alignment) { +create_columns_component_l <- function(data) { + + boxh <- dt_boxhead_get(data = data) + stubh <- dt_stubhead_get(data = data) + stub_available <- dt_stub_df_exists(data = data) + spanners_present <- dt_spanners_exists(data = data) # Get the headings - headings <- boxh_df["column_label", ] %>% unlist() %>% unname() + #headings <- boxh$column_label %>% unlist() + + headings_vars <- boxh %>% dplyr::filter(type == "default") %>% dplyr::pull(var) + headings_labels <- dt_boxhead_get_vars_labels_default(data = data) + + # TODO: Implement hidden boxhead in LaTeX + # # Should the column labels be hidden? + # column_labels_hidden <- + # dt_options_get_value(data = data, option = "column_labels_hidden") + # + # if (column_labels_hidden) { + # return("") + # } # If `stub_available` == TRUE, then replace with a set stubhead - # caption or nothing - if (stub_available && length(stubhead) > 0) { + # label or nothing + if (isTRUE(stub_available) && length(stubh$label) > 0) { - headings <- prepend_vec(headings, stubhead$label) + headings_labels <- prepend_vec(headings_labels, stubh$label) + headings_vars <- prepend_vec(headings_vars, "::stub") - } else if (stub_available) { + } else if (isTRUE(stub_available)) { - headings <- prepend_vec(headings, "") + headings_labels <- prepend_vec(headings_labels, "") + headings_vars <- prepend_vec(headings_vars, "::stub") } table_col_headings <- - paste0(latex_heading_row(content = headings), collapse = "") + paste0(latex_heading_row(content = headings_labels), collapse = "") if (spanners_present) { # Get vector of group labels (spanners) - spanners <- boxh_df["group_label", ] %>% unlist() %>% unname() + spanners <- dt_spanners_print(data = data, include_hidden = FALSE) # Promote column labels to the group level wherever the # spanner label is NA - spanners[is.na(spanners)] <- headings[is.na(spanners)] + spanners[is.na(spanners)] <- headings_vars[is.na(spanners)] if (stub_available) { spanners <- c(NA_character_, spanners) @@ -150,14 +175,46 @@ create_columns_component_l <- function(boxh_df, } #' @noRd -create_body_component_l <- function(row_splits, - groups_rows_df, - col_alignment, - stub_available, - summaries_present, - list_of_summaries, - n_rows, - n_cols) { +create_body_component_l <- function(data) { + + boxh <- dt_boxhead_get(data = data) + styles_tbl <- dt_styles_get(data = data) + body <- dt_body_get(data = data) + summaries_present <- dt_summary_exists(data = data) + list_of_summaries <- dt_summary_df_get(data = data) + groups_rows_df <- dt_groups_rows_get(data = data) + stub_components <- dt_stub_components(data = data) + + n_data_cols <- dt_boxhead_get_vars_default(data = data) %>% length() + n_rows <- nrow(body) + + # Get the column alignments for the data columns (this + # doesn't include the stub alignment) + col_alignment <- + boxh %>% + dplyr::filter(type == "default") %>% + dplyr::pull(column_align) + + # Get the column headings for the visible (e.g., `default`) columns + default_vars <- dt_boxhead_get_vars_default(data = data) + + if ("rowname" %in% names(body)) { + default_vars <- c("rowname", default_vars) + } + + # Determine whether the stub is available through analysis + # of the `stub_components` + stub_available <- dt_stub_components_has_rowname(stub_components) + + if (stub_available) { + n_cols <- n_data_cols + 1 + } else { + n_cols <- n_data_cols + } + + # Get the sequence of column numbers in the table body (these + # are the visible columns in the table exclusive of the stub) + column_series <- seq(n_cols) # Replace an NA group with an empty string if (any(is.na(groups_rows_df$group))) { @@ -171,18 +228,33 @@ create_body_component_l <- function(row_splits, group_label = gsub("^NA", "\\textemdash", group_label)) } - group_rows <- - create_group_rows( - n_rows, groups_rows_df, context = "latex") + group_rows <- create_group_rows(n_rows, groups_rows_df, context = "latex") + + if (stub_available) { + default_vars <- c("::rowname", default_vars) + + body <- + dt_stub_df_get(data = data) %>% + dplyr::select(rowname) %>% + dplyr::rename(`::rowname` = rowname) %>% + cbind(body) + } - data_rows <- - create_data_rows( - n_rows, row_splits, context = "latex") + # Split `body_content` by slices of rows and create data rows + body_content <- as.vector(t(body[, default_vars])) + row_splits <- split(body_content, ceiling(seq_along(body_content) / n_cols)) + data_rows <- create_data_rows(n_rows, row_splits, context = "latex") summary_rows <- create_summary_rows( - n_rows, n_cols, list_of_summaries, groups_rows_df, - stub_available, summaries_present, context = "latex") + n_rows = n_rows, + n_cols = n_cols, + list_of_summaries = list_of_summaries, + groups_rows_df = groups_rows_df, + stub_available = stub_available, + summaries_present = summaries_present, + context = "latex" + ) paste(collapse = "", paste0(group_rows, data_rows, summary_rows)) } @@ -197,22 +269,25 @@ create_table_end_l <- function() { } #' @noRd -create_footnote_component_l <- function(footnotes_resolved, - opts_df) { +create_footnotes_component_l <- function(data) { + + footnotes_tbl <- dt_footnotes_get(data = data) + opts_df <- dt_options_get(data = data) # If the `footnotes_resolved` object has no # rows, then return an empty footnotes component - if (nrow(footnotes_resolved) == 0) { + if (nrow(footnotes_tbl) == 0) { return("") } footnotes_tbl <- - footnotes_resolved %>% - dplyr::select(fs_id, text) %>% + footnotes_tbl %>% + dplyr::select(fs_id, footnotes) %>% dplyr::distinct() # Get the separator option from `opts_df` - separator <- opts_df %>% + separator <- + opts_df %>% dplyr::filter(parameter == "footnote_sep") %>% dplyr::pull(value) @@ -223,22 +298,23 @@ create_footnote_component_l <- function(footnotes_resolved, tidy_gsub(" ", " ") # Create the footnotes block - footnote_component <- + paste0( + "\\vspace{-5mm}\n", + "\\begin{minipage}{\\linewidth}\n", paste0( - "\\vspace{-5mm}\n", - "\\begin{minipage}{\\linewidth}\n", - paste0( - footnote_mark_to_latex(footnotes_tbl[["fs_id"]]), - footnotes_tbl[["text"]] %>% - unescape_html() %>% - markdown_to_latex(), " \\\\ \n", collapse = ""), - "\\end{minipage}\n", collapse = "") - - footnote_component + footnote_mark_to_latex(footnotes_tbl[["fs_id"]]), + footnotes_tbl[["footnotes"]] %>% + unescape_html() %>% + markdown_to_latex(), " \\\\ \n", collapse = ""), + "\\end{minipage}\n", + collapse = "" + ) } #' @noRd -create_source_note_component_l <- function(source_note) { +create_source_note_component_l <- function(data) { + + source_note <- dt_source_notes_get(data = data) # If the `footnotes_resolved` object has no # rows, then return an empty footnotes component diff --git a/R/utils_render_rtf.R b/R/utils_render_rtf.R index 373d5fa2a8..37f3c16e5a 100644 --- a/R/utils_render_rtf.R +++ b/R/utils_render_rtf.R @@ -4,24 +4,160 @@ footnote_mark_to_rtf <- function(mark) { paste0("{\\super \\i ", mark, "}") } +create_body_component_r <- function(data) { + + boxh <- dt_boxhead_get(data = data) + styles_tbl <- dt_styles_get(data = data) + body <- dt_body_get(data = data) + summaries_present <- dt_summary_exists(data = data) + list_of_summaries <- dt_summary_df_get(data = data) + groups_rows_df <- dt_groups_rows_get(data = data) + stub_components <- dt_stub_components(data = data) + + n_data_cols <- dt_boxhead_get_vars_default(data = data) %>% length() + n_rows <- nrow(body) + + # Get the column alignments for the data columns (this + # doesn't include the stub alignment) + col_alignment <- + boxh %>% + dplyr::filter(type == "default") %>% + dplyr::pull(column_align) + + # Get the column headings for the visible (e.g., `default`) columns + default_vars <- dt_boxhead_get_vars_default(data = data) + + if ("rowname" %in% names(body)) { + default_vars <- c("rowname", default_vars) + } + + # Determine whether the stub is available through analysis + # of the `stub_components` + stub_available <- dt_stub_components_has_rowname(stub_components) + + if (stub_available) { + n_cols <- n_data_cols + 1 + } else { + n_cols <- n_data_cols + } + + # Split `body_content` by slices of rows and create data rows + body_content <- as.vector(t(body[, default_vars])) + row_splits <- split(body_content, ceiling(seq_along(body_content) / n_cols)) + + body_rows <- c() + for (i in seq_len(n_rows)) { + + # Process group rows + if (!is.null(groups_rows_df) && + i %in% groups_rows_df$row) { + + body_rows <- + c(body_rows, + rtf_body_row( + c( + groups_rows_df[which(groups_rows_df$row %in% i), 1][[1]], + rep("", n_cols - 1)), type = "group")) + } + + # Process "data" rows + if (i != length(row_splits)) { + body_rows <- + c(body_rows, rtf_body_row(row_splits[[i]], type = "row")) + } else { + body_rows <- + c(body_rows, rtf_last_body_row(content = row_splits[[i]])) + } + + # Process summary rows + if (stub_available && summaries_present && + i %in% groups_rows_df$row_end) { + + group <- + groups_rows_df %>% + dplyr::filter(row_end == i) %>% + dplyr::pull(group) + + if (group %in% names(list_of_summaries$summary_df_display_list)) { + + summary_df <- + list_of_summaries$summary_df_display_list[[ + which(names(list_of_summaries$summary_df_display_list) == group)]] %>% + as.data.frame(stringsAsFactors = FALSE) + + body_content_summary <- + as.vector(t(summary_df)) %>% + tidy_gsub("\u2014", "-") + + row_splits_summary <- + split_body_content( + body_content = body_content_summary, + n_cols = n_cols) + + for (j in seq(length(row_splits_summary))) { + + body_rows <- + c(body_rows, rtf_body_row(row_splits_summary[[j]], type = "row")) + } + } + } + } + + paste0(body_rows, collapse = "") +} + +create_source_notes_component_r <- function(data) { + + source_notes <- dt_source_notes_get(data = data) + + # Create the source note rows and handle any available footnotes + if (length(source_notes) != 0) { + + # Create a source note + source_note_rows <- + paste0( + "\\pard\\pardeftab720\\sl288\\slmult1\\partightenfactor0\n", + paste0( + "\\cf0 \\strokec2 ", remove_html(text = source_notes), "\\\n", + collapse = ""), + collapse = "") + } else { + source_note_rows <- "" + } + + source_note_rows +} + #' @noRd -create_footnote_component_rtf <- function(footnotes_resolved, - opts_df, - body_content) { +create_footnotes_component_r <- function(data) { + + body <- dt_body_get(data = data) + opts_df <- dt_options_get(data = data) + footnotes_tbl <- dt_footnotes_get(data = data) + + # Get the column headings for the visible (e.g., `default`) columns + default_vars <- dt_boxhead_get_vars_default(data = data) - # If the `footnotes_resolved` object has no + if ("rowname" %in% names(body)) { + default_vars <- c("rowname", default_vars) + } + + body_content <- as.vector(t(body[, default_vars])) + + # If the `footnotes_tbl` object has no # rows, then return an empty footnotes component - if (nrow(footnotes_resolved) == 0) { + if (nrow(footnotes_tbl) == 0) { return("") } footnotes_tbl <- - footnotes_resolved %>% - dplyr::select(fs_id, text) %>% + footnotes_tbl %>% + dplyr::select(fs_id, footnotes) %>% dplyr::distinct() # Get the separator option from `opts_df` - separator <- opts_df %>% + separator <- + opts_df %>% dplyr::filter(parameter == "footnote_sep") %>% dplyr::pull(value) @@ -32,17 +168,18 @@ create_footnote_component_rtf <- function(footnotes_resolved, tidy_gsub(" ", " ") # Create the footnotes block - footnote_component <- + footnotes_component <- paste0( "\\pard\\pardeftab720\\sl288\\slmult1\\partightenfactor0\n", paste0( # "\\f2\\i\\fs14\\fsmilli7333 \\super \\strokec2 ", footnotes_tbl[["fs_id"]], # "\\f0\\i0\\fs22 \\nosupersub \\strokec2 ", footnote_mark_to_rtf(footnotes_tbl[["fs_id"]]), - footnotes_tbl[["text"]] %>% remove_html(), "\\", - collapse = separator), "\n") + footnotes_tbl[["footnotes"]] %>% remove_html(), "\\", + collapse = separator), "\n" + ) - footnote_component + footnotes_component } #' @noRd @@ -364,3 +501,70 @@ split_body_content <- function(body_content, split(body_content, ceiling(seq_along(body_content) / n_cols)) } + + +create_columns_component_r <- function(data) { + + boxh <- dt_boxhead_get(data = data) + stubh <- dt_stubhead_get(data = data) + stub_available <- dt_stub_df_exists(data = data) + spanners_present <- dt_spanners_exists(data = data) + + headings_vars <- boxh %>% dplyr::filter(type == "default") %>% dplyr::pull(var) + headings_labels <- dt_boxhead_get_vars_labels_default(data = data) + + # If `stub_available` == TRUE, then replace with a set stubhead + # label or nothing + if (isTRUE(stub_available) && length(stubh$label) > 0) { + + headings_labels <- prepend_vec(headings_labels, stubh$label) + headings_vars <- prepend_vec(headings_vars, "::stub") + + } else if (isTRUE(stub_available)) { + + headings_labels <- prepend_vec(headings_labels, "") + headings_vars <- prepend_vec(headings_vars, "::stub") + } + + # Remove any HTML tags from `headings` + headings_labels <- remove_html(headings_labels) + + if (spanners_present == FALSE) { + + columns_component <- + paste0(rtf_heading_row(content = headings_labels), collapse = "") + + } else { + + # spanners + spanners <- dt_spanners_print(data = data, include_hidden = FALSE) + + # Promote column labels to the group level wherever the + # spanner label is NA + spanners[is.na(spanners)] <- headings_vars[is.na(spanners)] + + # Remove any HTML tags from `spanners` + spanners <- remove_html(spanners) + + if (stub_available) { + spanners <- c(NA_character_, spanners) + } + + # for (i in seq(spanners)) { + # if (is.na(spanners[i])) { + # spanners[i] <- headings[i] + # } + # } + + spanners_lengths <- rle(spanners) + + columns_component <- + rtf_heading_group_row( + spanners_lengths = spanners_lengths, + headings = headings_labels, + spanners = spanners + ) + } + + columns_component +} diff --git a/R/zzz.R b/R/zzz.R index dda40d3b8d..c2f4a8896a 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -29,15 +29,19 @@ globalVariables( "are_groups_present", "arrange_dfs", "blue", + "boxhead", "colname", "colnames_start", "colnum", "colnum_final", + "column_align", + "column_label", "colors", "curr_code", "curr_name", "data_attr", "display_name", + "footnotes", "footnotes_to_list", "fs_id", "fs_id_coalesced", @@ -58,6 +62,7 @@ globalVariables( "red", "row_end", "rownum", + "rownum_i", "styles", "styles_appended", "symbol", @@ -77,6 +82,7 @@ globalVariables( "time", "type", "value", + "var", "yiq" ) ) diff --git a/TODOS.R b/TODOS.R new file mode 100644 index 0000000000..e43e0671d0 --- /dev/null +++ b/TODOS.R @@ -0,0 +1,4 @@ +# TODO: inspect all build_data initializer functions (e.g., `migrate_unformatted_to_output()`) + # TODO: make all functions dt methods + # TODO: make functions that modify footnotes/styles into dt methods +# TODO: fix rtf rendering diff --git a/_pkgdown.yml b/_pkgdown.yml index f656b7b8b8..376665e881 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -37,6 +37,7 @@ reference: contents: - tab_header - tab_spanner + - tab_spanner_delim - tab_row_group - tab_stubhead_label - tab_footnote @@ -82,9 +83,7 @@ reference: columns. This includes alignment of the data in columns (`cols_align()`), hiding columns from view (`cols_hide()`), re-labeling the column labels (`cols_label()`), merging two columns - together (`cols_merge*()`), moving columns around (`cols_move*()`), - and using a column name delimiter to create labels in the column - spanner (`cols_split_delim()`). + together (`cols_merge*()`), moving columns around (`cols_move*()`) contents: - cols_align - cols_hide @@ -95,7 +94,6 @@ reference: - cols_move - cols_move_to_end - cols_move_to_start - - cols_split_delim - title: Modify Rows desc: > diff --git a/inst/css/gt_styles_default.scss b/inst/css/gt_styles_default.scss index 4897af6433..77ad52e5ee 100644 --- a/inst/css/gt_styles_default.scss +++ b/inst/css/gt_styles_default.scss @@ -124,7 +124,10 @@ } .gt_row { - padding: $row_padding; /* row.padding */ + padding-top: $row_padding; /* row.padding */ + padding-bottom: $row_padding; /* row.padding */ + padding-left: 5px; + padding-right: 5px; margin: 10px; border-top-style: solid; border-top-width: 1px; @@ -143,24 +146,38 @@ .gt_summary_row { color: font-color($summary_row_background_color); background-color: $summary_row_background_color; /* summary_row.background.color */ - padding: $summary_row_padding; /* summary_row.padding */ + padding-top: $summary_row_padding; /* summary_row.padding */ + padding-bottom: $summary_row_padding; /* summary_row.padding */ + padding-left: 5px; + padding-right: 5px; text-transform: $summary_row_text_transform; /* summary_row.text_transform */ } .gt_grand_summary_row { color: font-color($grand_summary_row_background_color); background-color: $grand_summary_row_background_color; /* grand_summary_row.background.color */ - padding: $grand_summary_row_padding; /* grand_summary_row.padding */ + padding-top: $grand_summary_row_padding; /* grand_summary_row.padding */ + padding-bottom: $grand_summary_row_padding; /* grand_summary_row.padding */ + padding-left: 5px; + padding-right: 5px; text-transform: $grand_summary_row_text_transform; /* grand_summary_row.text_transform */ } .gt_first_summary_row { + padding-top: $summary_row_padding; /* summary_row.padding */ + padding-bottom: $summary_row_padding; /* summary_row.padding */ + padding-left: 5px; + padding-right: 5px; border-top-style: solid; border-top-width: 2px; border-top-color: #D3D3D3; } .gt_first_grand_summary_row { + padding-top: $grand_summary_row_padding; /* grand_summary_row.padding */ + padding-bottom: $grand_summary_row_padding; /* grand_summary_row.padding */ + padding-left: 5px; + padding-right: 5px; border-top-style: double; border-top-width: 6px; border-top-color: #D3D3D3; diff --git a/man/cols_align.Rd b/man/cols_align.Rd index 4201f38ce8..94c06139e3 100644 --- a/man/cols_align.Rd +++ b/man/cols_align.Rd @@ -17,7 +17,7 @@ according to the data type (see the Details section for specifics on which alignments are applied).} \item{columns}{An optional vector of column names for which the alignment -should be applied. If nothing is supplied, or if \code{columns} is \code{TRUE}), then +should be applied. If nothing is supplied, or if \code{columns} is \code{TRUE}, then the chosen alignment affects all columns.} } \value{ @@ -64,7 +64,7 @@ Other column modification functions: \code{\link{cols_hide}}, \code{\link{cols_merge_uncert}}, \code{\link{cols_merge}}, \code{\link{cols_move_to_end}}, \code{\link{cols_move_to_start}}, - \code{\link{cols_move}}, \code{\link{cols_split_delim}}, - \code{\link{cols_width}} + \code{\link{cols_move}}, \code{\link{cols_width}}, + \code{\link{tab_spanner_delim}} } \concept{column modification functions} diff --git a/man/cols_hide.Rd b/man/cols_hide.Rd index 60afcc77b4..5bc1536d96 100644 --- a/man/cols_hide.Rd +++ b/man/cols_hide.Rd @@ -80,7 +80,7 @@ Other column modification functions: \code{\link{cols_align}}, \code{\link{cols_merge_uncert}}, \code{\link{cols_merge}}, \code{\link{cols_move_to_end}}, \code{\link{cols_move_to_start}}, - \code{\link{cols_move}}, \code{\link{cols_split_delim}}, - \code{\link{cols_width}} + \code{\link{cols_move}}, \code{\link{cols_width}}, + \code{\link{tab_spanner_delim}} } \concept{column modification functions} diff --git a/man/cols_label.Rd b/man/cols_label.Rd index deadfeb128..e6e37414ec 100644 --- a/man/cols_label.Rd +++ b/man/cols_label.Rd @@ -85,7 +85,7 @@ Other column modification functions: \code{\link{cols_align}}, \code{\link{cols_merge_uncert}}, \code{\link{cols_merge}}, \code{\link{cols_move_to_end}}, \code{\link{cols_move_to_start}}, - \code{\link{cols_move}}, \code{\link{cols_split_delim}}, - \code{\link{cols_width}} + \code{\link{cols_move}}, \code{\link{cols_width}}, + \code{\link{tab_spanner_delim}} } \concept{column modification functions} diff --git a/man/cols_merge.Rd b/man/cols_merge.Rd index c6ff1ce5ad..0c6937af2a 100644 --- a/man/cols_merge.Rd +++ b/man/cols_merge.Rd @@ -2,44 +2,47 @@ % Please edit documentation in R/modify_columns.R \name{cols_merge} \alias{cols_merge} -\title{Merge two columns to a single column} +\title{Merge data from two or more columns to a single column} \usage{ -cols_merge(data, col_1, col_2, pattern = "{1} {2}") +cols_merge(data, columns, hide_columns = columns[-1], + pattern = paste0("{", seq_along(columns), "}", collapse = " ")) } \arguments{ \item{data}{A table object that is created using the \code{\link[=gt]{gt()}} function.} -\item{col_1}{A retained column that contains values to be merged with those -in \code{col_2}.} +\item{columns}{The columns that will participate in the merging process. The +first column name provided will be the target column (i.e., undergo +mutation) and the other columns will serve to provide input.} -\item{col_2}{A column that contains values to be merged with those in -\code{col_1}. This column will be discarded but is still useful as a reference -in other \pkg{gt} functions.} +\item{hide_columns}{Any column names provided here will have their state +changed to \code{hidden} (via internal use of \code{\link[=cols_hide]{cols_hide()}} if they aren't +already hidden. This is convenient if the purpose of these specified +columns are only useful for providing string input to the target column.} \item{pattern}{A formatting pattern that specifies the arrangement of the -\code{col_1} and \code{col_1} values and any string literals. The \code{col_1} column is -represented as \code{{1}} whereas \code{col_2} is \code{{2}}. All other characters are -taken to be string literals.} +\code{column} values and any string literals. We can use column names or numbers +(corresponding to the position of columns provided in \code{columns}). The +column names or indices are to be placed in curly braces (e.g., \code{{price}} +or \code{{1}}). All characters outside of braces are taken to be string +literals.} } \value{ An object of class \code{gt_tbl}. } \description{ -This function takes any two columns and merges them into a single column, -using a pattern that specifies how the values in the data cells are combined. -We specify the columns to merge together in the \code{col_1} and \code{col_2} arguments -and the string-combining pattern is specified in \code{pattern}. The column that -is retained is that of \code{col_1} whereas the column specified in \code{col_2} is -dropped from the output table. +This function takes input from two or more columns and allows the contents to +be merged them into a single column, using a pattern that specifies the +formatting. We can specify which columns to merge together in the \code{columns} +argument. The string-combining pattern is given in the \code{pattern} argument. +The first column in the \code{columns} series operates as the target column (i.e., +will undergo mutation) whereas all following \code{columns} will be untouched. } \details{ There are two other column-merging functions that offer specialized behavior that is optimized for common table tasks: \code{\link[=cols_merge_range]{cols_merge_range()}} and -\code{\link[=cols_merge_uncert]{cols_merge_uncert()}}. These functions operate similarly, where the second -column specified is dropped from the output table. For all of the -\code{cols_merge*()} functions, column removal occurs late in the rendering -lifecycle so those secondary columns are still usable as column references -(e.g., inside expressions provided to \code{rows} in the \code{fmt*()} functions). +\code{\link[=cols_merge_uncert]{cols_merge_uncert()}}. These functions operate similarly, where the +non-target columns can be optionally hidden from the output table through the +\code{hide_columns} or \code{autohide} options. } \section{Figures}{ @@ -58,13 +61,13 @@ tab_1 <- dplyr::select(-volume, -adj_close) \%>\% gt() \%>\% cols_merge( - col_1 = vars(open), - col_2 = vars(close), + columns = vars(open, close), + hide_columns = vars(close), pattern = "{1}—{2}" ) \%>\% cols_merge( - col_1 = vars(low), - col_2 = vars(high), + columns = vars(low, high), + hide_columns = vars(high), pattern = "{1}—{2}" ) \%>\% cols_label( @@ -80,7 +83,7 @@ Other column modification functions: \code{\link{cols_align}}, \code{\link{cols_merge_uncert}}, \code{\link{cols_move_to_end}}, \code{\link{cols_move_to_start}}, - \code{\link{cols_move}}, \code{\link{cols_split_delim}}, - \code{\link{cols_width}} + \code{\link{cols_move}}, \code{\link{cols_width}}, + \code{\link{tab_spanner_delim}} } \concept{column modification functions} diff --git a/man/cols_merge_range.Rd b/man/cols_merge_range.Rd index fd8f92e241..6526009ba5 100644 --- a/man/cols_merge_range.Rd +++ b/man/cols_merge_range.Rd @@ -4,7 +4,7 @@ \alias{cols_merge_range} \title{Merge two columns to a value range column} \usage{ -cols_merge_range(data, col_begin, col_end, sep = "---") +cols_merge_range(data, col_begin, col_end, sep = "--", autohide = TRUE) } \arguments{ \item{data}{A table object that is created using the \code{\link[=gt]{gt()}} function.} @@ -14,6 +14,10 @@ cols_merge_range(data, col_begin, col_end, sep = "---") \item{col_end}{A column that contains values for the end of the range.} \item{sep}{The separator text that indicates the values are ranged.} + +\item{autohide}{An option to automatically hide the column specified as +\code{col_end}. Any columns with their state changed to hidden will behave +the same as before, they just won't be displayed in the finalized table.} } \value{ An object of class \code{gt_tbl}. @@ -28,7 +32,7 @@ the output table. } \details{ This function could be somewhat replicated using \code{\link[=cols_merge]{cols_merge()}}, however, -\code{cols_merge_range()} employs the following specialized semantics for \code{NA} +\code{cols_merge_range()} employs the following specialized operations for \code{NA} handling: \enumerate{ @@ -50,10 +54,8 @@ operation can be easily formatted using the \code{\link[=fmt_missing]{fmt_missin This function is part of a set of three column-merging functions. The other two are the general \code{\link[=cols_merge]{cols_merge()}} function and the specialized \code{\link[=cols_merge_uncert]{cols_merge_uncert()}} function. These functions operate similarly, where the -second column specified is dropped from the output table. For all of the -\code{cols_merge*()} functions, column removal occurs late in the rendering -lifecycle so those secondary columns are still usable as column references -(e.g., inside expressions provided to \code{rows} in the \code{fmt*()} functions). +non-target columns can be optionally hidden from the output table through the +\code{hide_columns} or \code{autohide} options. } \section{Figures}{ @@ -74,7 +76,8 @@ tab_1 <- gt() \%>\% cols_merge_range( col_begin = vars(mpg_c), - col_end = vars(mpg_h)) \%>\% + col_end = vars(mpg_h) + ) \%>\% cols_label( mpg_c = md("*MPG*") ) @@ -86,7 +89,7 @@ Other column modification functions: \code{\link{cols_align}}, \code{\link{cols_merge_uncert}}, \code{\link{cols_merge}}, \code{\link{cols_move_to_end}}, \code{\link{cols_move_to_start}}, - \code{\link{cols_move}}, \code{\link{cols_split_delim}}, - \code{\link{cols_width}} + \code{\link{cols_move}}, \code{\link{cols_width}}, + \code{\link{tab_spanner_delim}} } \concept{column modification functions} diff --git a/man/cols_merge_uncert.Rd b/man/cols_merge_uncert.Rd index 03c767672b..5924f2998b 100644 --- a/man/cols_merge_uncert.Rd +++ b/man/cols_merge_uncert.Rd @@ -4,14 +4,21 @@ \alias{cols_merge_uncert} \title{Merge two columns to a value & uncertainty column} \usage{ -cols_merge_uncert(data, col_val, col_uncert) +cols_merge_uncert(data, col_val, col_uncert, autohide = TRUE) } \arguments{ \item{data}{A table object that is created using the \code{\link[=gt]{gt()}} function.} -\item{col_val}{A single column name that contains the base values.} +\item{col_val}{A single column name that contains the base values. This is +the column where values will be mutated.} -\item{col_uncert}{A single column name that contains the uncertainty values.} +\item{col_uncert}{A single column name that contains the uncertainty values. +These values will be combined with those in \code{col_val}. We have the option +to automatically hide the \code{col_uncert} column through \code{autohide}.} + +\item{autohide}{An option to automatically hide the column specified as +\code{col_uncert}. Any columns with their state changed to hidden will behave +the same as before, they just won't be displayed in the finalized table.} } \value{ An object of class \code{gt_tbl}. @@ -49,10 +56,8 @@ operation can be easily formatted using the \code{\link[=fmt_missing]{fmt_missin This function is part of a set of three column-merging functions. The other two are the general \code{\link[=cols_merge]{cols_merge()}} function and the specialized \code{\link[=cols_merge_range]{cols_merge_range()}} function. These functions operate similarly, where the -second column specified is dropped from the output table. For all of the -\code{cols_merge*()} functions, column removal occurs late in the rendering -lifecycle so those secondary columns are still usable as column references -(e.g., inside expressions provided to \code{rows} in the \code{fmt*()} functions). +non-target columns can be optionally hidden from the output table through the +\code{hide_columns} or \code{autohide} options. } \section{Figures}{ @@ -90,7 +95,7 @@ Other column modification functions: \code{\link{cols_align}}, \code{\link{cols_merge_range}}, \code{\link{cols_merge}}, \code{\link{cols_move_to_end}}, \code{\link{cols_move_to_start}}, - \code{\link{cols_move}}, \code{\link{cols_split_delim}}, - \code{\link{cols_width}} + \code{\link{cols_move}}, \code{\link{cols_width}}, + \code{\link{tab_spanner_delim}} } \concept{column modification functions} diff --git a/man/cols_move.Rd b/man/cols_move.Rd index e71d6e1331..bb0b61a2d7 100644 --- a/man/cols_move.Rd +++ b/man/cols_move.Rd @@ -64,6 +64,6 @@ Other column modification functions: \code{\link{cols_align}}, \code{\link{cols_merge_uncert}}, \code{\link{cols_merge}}, \code{\link{cols_move_to_end}}, \code{\link{cols_move_to_start}}, - \code{\link{cols_split_delim}}, \code{\link{cols_width}} + \code{\link{cols_width}}, \code{\link{tab_spanner_delim}} } \concept{column modification functions} diff --git a/man/cols_move_to_end.Rd b/man/cols_move_to_end.Rd index c599f831cd..fcea05ec47 100644 --- a/man/cols_move_to_end.Rd +++ b/man/cols_move_to_end.Rd @@ -72,7 +72,7 @@ Other column modification functions: \code{\link{cols_align}}, \code{\link{cols_merge_uncert}}, \code{\link{cols_merge}}, \code{\link{cols_move_to_start}}, - \code{\link{cols_move}}, \code{\link{cols_split_delim}}, - \code{\link{cols_width}} + \code{\link{cols_move}}, \code{\link{cols_width}}, + \code{\link{tab_spanner_delim}} } \concept{column modification functions} diff --git a/man/cols_move_to_start.Rd b/man/cols_move_to_start.Rd index d6b6477c39..57544cd205 100644 --- a/man/cols_move_to_start.Rd +++ b/man/cols_move_to_start.Rd @@ -72,7 +72,7 @@ Other column modification functions: \code{\link{cols_align}}, \code{\link{cols_merge_range}}, \code{\link{cols_merge_uncert}}, \code{\link{cols_merge}}, \code{\link{cols_move_to_end}}, - \code{\link{cols_move}}, \code{\link{cols_split_delim}}, - \code{\link{cols_width}} + \code{\link{cols_move}}, \code{\link{cols_width}}, + \code{\link{tab_spanner_delim}} } \concept{column modification functions} diff --git a/man/cols_width.Rd b/man/cols_width.Rd index c08de3a190..4858308952 100644 --- a/man/cols_width.Rd +++ b/man/cols_width.Rd @@ -19,7 +19,9 @@ column-based select helpers \code{\link[=starts_with]{starts_with()}}, \code{\li \code{\link[=matches]{matches()}}, \code{\link[=one_of]{one_of()}}, and \code{\link[=everything]{everything()}} can be used in the LHS. Subsequent expressions that operate on the columns assigned previously will result in overwriting column width values (both in the same \code{cols_width()} -call and across separate calls).} +call and across separate calls). All other columns can be assigned a +default width value by using \code{TRUE} or \code{everything()} on the left-hand +side.} \item{.list}{Allows for the use of a list as an input alternative to \code{...}.} } @@ -28,12 +30,11 @@ An object of class \code{gt_tbl}. } \description{ Manual specifications of column widths can be performed using the -\code{cols_width()} function. We choose which columns get specific widths (in -pixels, usually by use of the \code{\link[=px]{px()}} helper function) and all other columns -are assigned a default width value though the \code{.others} argument. Width -assignments are supplied in \code{...} through two-sided formulas, where the -left-hand side defines the target columns and the right-hand side is a single -width value in pixels. +\code{cols_width()} function. We choose which columns get specific widths (in +pixels, usually by use of the \code{\link[=px]{px()}} helper function). Width assignments are +supplied in \code{...} through two-sided formulas, where the left-hand side +defines the target columns and the right-hand side is a single width value in +pixels. } \details{ Normally, column widths are automatically set to span across the width of the @@ -75,6 +76,6 @@ Other column modification functions: \code{\link{cols_align}}, \code{\link{cols_merge_uncert}}, \code{\link{cols_merge}}, \code{\link{cols_move_to_end}}, \code{\link{cols_move_to_start}}, - \code{\link{cols_move}}, \code{\link{cols_split_delim}} + \code{\link{cols_move}}, \code{\link{tab_spanner_delim}} } \concept{column modification functions} diff --git a/man/currency.Rd b/man/currency.Rd index eac3d51437..047200e974 100644 --- a/man/currency.Rd +++ b/man/currency.Rd @@ -33,7 +33,7 @@ rendered as HTML and we use \code{currency(latex = "LTC", default = "ltc")}, the currency symbol will be \code{"ltc"}. For convenience, if we provide only a single string without a name, it will be taken as the \code{default} (i.e., \code{currency("ltc")} is equivalent to \code{currency(default = "ltc")}). However, if -we were to specify currency strings for muliple output contexts, names are +we were to specify currency strings for multiple output contexts, names are required each and every context. } \examples{ diff --git a/man/data_color.Rd b/man/data_color.Rd index 3aa65edc96..31fa07d9bf 100644 --- a/man/data_color.Rd +++ b/man/data_color.Rd @@ -127,7 +127,7 @@ tab_2 <- type \%in\% c("chicken", "supreme")) \%>\% dplyr::group_by(type, size) \%>\% dplyr::summarize( - sold = n(), + sold = dplyr::n(), income = sum(price) ) \%>\% gt(rowname_col = "size") \%>\% diff --git a/man/extract_summary.Rd b/man/extract_summary.Rd index 7fe44c74e8..04d52b339b 100644 --- a/man/extract_summary.Rd +++ b/man/extract_summary.Rd @@ -65,6 +65,7 @@ summary_extracted <- # row groups and a stub) tab_1 <- summary_extracted \%>\% + unlist(recursive = FALSE) \%>\% dplyr::bind_rows() \%>\% gt() diff --git a/man/figures/man_tab_spanner_delim_1.svg b/man/figures/man_tab_spanner_delim_1.svg new file mode 100644 index 0000000000..893359e17f --- /dev/null +++ b/man/figures/man_tab_spanner_delim_1.svg @@ -0,0 +1,252 @@ + + +Qt Svg Document +Generated with Qt + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Sepal +Petal +Length +Width +Length +Width +setosa +5.1 +3.5 +1.4 +0.2 +4.9 +3.0 +1.4 +0.2 +4.7 +3.2 +1.3 +0.2 +4.6 +3.1 +1.5 +0.2 +versicolor +7.0 +3.2 +4.7 +1.4 +6.4 +3.2 +4.5 +1.5 +6.9 +3.1 +4.9 +1.5 +5.5 +2.3 +4.0 +1.3 +virginica +6.3 +3.3 +6.0 +2.5 +5.8 +2.7 +5.1 +1.9 +7.1 +3.0 +5.9 +2.1 +6.3 +2.9 +5.6 +1.8 + + + diff --git a/man/gt.Rd b/man/gt.Rd index 2a7444f564..19da756f4f 100644 --- a/man/gt.Rd +++ b/man/gt.Rd @@ -5,7 +5,7 @@ \title{Create a \pkg{gt} table object} \usage{ gt(data, rowname_col = "rowname", groupname_col = "groupname", - rownames_to_stub = FALSE, id = random_id(), + rownames_to_stub = FALSE, auto_align = TRUE, id = random_id(), stub_group.sep = getOption("gt.stub_group.sep", " - ")) } \arguments{ @@ -20,6 +20,10 @@ group labels for generation of stub row groups.} \item{rownames_to_stub}{An option to take rownames from the input \code{data} table as row captions in the display table stub.} +\item{auto_align}{Optionally have column data be aligned depending on the +content contained in each column of the input \code{data}. Internally, this +calls \code{cols_align(align = "auto")} for all columns.} + \item{id}{The table ID. By default, this will be a random ID as generated by the \code{\link[=random_id]{random_id()}} function. If set to \code{NULL} then no table ID will be applied.} diff --git a/man/location_cells.Rd b/man/location_cells.Rd index 5a9eb8c0fc..d0b3f9cab7 100644 --- a/man/location_cells.Rd +++ b/man/location_cells.Rd @@ -4,6 +4,7 @@ \alias{location_cells} \alias{cells_title} \alias{cells_stubhead} +\alias{cells_column_spanners} \alias{cells_column_labels} \alias{cells_group} \alias{cells_stub} @@ -16,20 +17,28 @@ cells_title(groups = c("title", "subtitle")) cells_stubhead() -cells_column_labels(columns, groups) +cells_column_spanners(spanners) -cells_group(groups) +cells_column_labels(columns) -cells_stub(rows = NULL) +cells_group(groups = TRUE) -cells_data(columns = NULL, rows = NULL) +cells_stub(rows = TRUE) -cells_summary(groups = NULL, columns = NULL, rows = NULL) +cells_data(columns = TRUE, rows = TRUE) -cells_grand_summary(columns = NULL, rows = NULL) +cells_summary(groups = TRUE, columns = TRUE, rows = TRUE) + +cells_grand_summary(columns = TRUE, rows = TRUE) } \arguments{ -\item{columns, rows, groups}{Either a vector of names, a vector of indices, +\item{groups}{Used in the \code{cells_title()}, \code{cells_group()}, and +\code{cells_summary()} functions to specify which groups to target.} + +\item{spanners}{Used in the \code{cells_column_spanners()} function to indicate +which spanners to target.} + +\item{columns, rows}{Either a vector of names, a vector of indices, values provided by \code{\link[=vars]{vars()}}, values provided by \code{c()}, or a select helper function (see Details for information on these functions).} } @@ -58,9 +67,10 @@ depending on the value given to the \code{groups} argument (\code{"title"} or only available when there is a stub; a label in that location can be created by using the \code{\link[=tab_stubhead]{tab_stubhead()}} function. -\item \code{cells_column_labels()}: targets labels in the column labels (the -\code{columns} argument) or the spanner column labels (the \code{groups} argument) in -the table's column labels part. +\item \code{cells_column_labels()}: targets the column labels. + +\item \code{cells_column_spanners()}: targets the spanner column labels, which +appear above the column labels. \item \code{cells_group()}: targets the row group labels in any available row groups using the \code{groups} argument. @@ -73,6 +83,9 @@ intersections of \code{columns} and \code{rows}. \item \code{cells_summary()}: targets summary cells in the table body using the \code{groups} argument and intersections of \code{columns} and \code{rows}. + +\item \code{cells_grand_summary()}: targets cells of the table's grand summary +using intersections of \code{columns} and \code{rows} } } \section{Figures}{ @@ -154,7 +167,7 @@ tab_3 <- ) \%>\% dplyr::group_by(name, size) \%>\% dplyr::summarize( - `Pizzas Sold` = n() + `Pizzas Sold` = dplyr::n() ) \%>\% gt(rowname_col = "size") \%>\% summary_rows( diff --git a/man/opt_footnote_marks.Rd b/man/opt_footnote_marks.Rd index abe0e58391..38ef13b246 100644 --- a/man/opt_footnote_marks.Rd +++ b/man/opt_footnote_marks.Rd @@ -63,7 +63,7 @@ tab_1 <- dplyr::filter(latitude == 30, !is.infinite(SZA.Min)) \%>\% dplyr::select(-latitude) \%>\% gt(rowname_col = "tst") \%>\% - cols_split_delim(".") \%>\% + tab_spanner_delim(delim = ".") \%>\% fmt_missing( columns = everything(), missing_text = "90+" @@ -75,7 +75,7 @@ tab_1 <- ) \%>\% tab_footnote( footnote = "Solar zenith angle.", - locations = cells_column_labels(groups = "SZA") + locations = cells_column_spanners(spanners = "SZA") ) \%>\% tab_footnote( footnote = "The Lowest SZA.", diff --git a/man/tab_header.Rd b/man/tab_header.Rd index 8123722e06..0a9a872f93 100644 --- a/man/tab_header.Rd +++ b/man/tab_header.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/table_parts.R +% Please edit documentation in R/tab_header.R \name{tab_header} \alias{tab_header} \title{Add a table header} diff --git a/man/tab_row_group.Rd b/man/tab_row_group.Rd index 31d19e523d..d256c2523e 100644 --- a/man/tab_row_group.Rd +++ b/man/tab_row_group.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/table_parts.R +% Please edit documentation in R/tab_row_group.R \name{tab_row_group} \alias{tab_row_group} \title{Add a row group} @@ -13,8 +13,8 @@ tab_row_group(data, group = NULL, rows = NULL, others = NULL) group label.} \item{rows}{The rows to be made components of the row group. Can either be a -vector of row captions provided \code{c()}, a vector of row indices, or a helper -function focused on selections. The select helper functions are: +vector of row captions provided in \code{c()}, a vector of row indices, or a +helper function focused on selections. The select helper functions are: \code{\link[=starts_with]{starts_with()}}, \code{\link[=ends_with]{ends_with()}}, \code{\link[=contains]{contains()}}, \code{\link[=matches]{matches()}}, \code{\link[=one_of]{one_of()}}, and \code{\link[=everything]{everything()}}.} diff --git a/man/tab_source_note.Rd b/man/tab_source_note.Rd index c978a29402..3d370c9aae 100644 --- a/man/tab_source_note.Rd +++ b/man/tab_source_note.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/table_parts.R +% Please edit documentation in R/tab_source_note.R \name{tab_source_note} \alias{tab_source_note} \title{Add a source note citation} diff --git a/man/tab_spanner.Rd b/man/tab_spanner.Rd index 77ab365330..636c76d33f 100644 --- a/man/tab_spanner.Rd +++ b/man/tab_spanner.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/table_parts.R +% Please edit documentation in R/tab_spanner.R \name{tab_spanner} \alias{tab_spanner} \title{Add a spanner column label} diff --git a/man/cols_split_delim.Rd b/man/tab_spanner_delim.Rd similarity index 81% rename from man/cols_split_delim.Rd rename to man/tab_spanner_delim.Rd index 9f258d95c9..933abc2ea9 100644 --- a/man/cols_split_delim.Rd +++ b/man/tab_spanner_delim.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/modify_columns.R -\name{cols_split_delim} -\alias{cols_split_delim} +% Please edit documentation in R/tab_spanner.R +\name{tab_spanner_delim} +\alias{tab_spanner_delim} \title{Create group names and column labels via delimited names} \usage{ -cols_split_delim(data, delim, columns = NULL) +tab_spanner_delim(data, delim, columns = NULL, gather = TRUE) } \arguments{ \item{data}{A table object that is created using the \code{\link[=gt]{gt()}} function.} @@ -16,6 +16,10 @@ the second component will be the column label.} \item{columns}{An optional vector of column names that this operation should be limited to. The default is to consider all columns in the table.} + +\item{gather}{An option to move the specified \code{columns} such that they are +unified under the spanner column label. Ordering of the moved-into-place +columns will be preserved in all cases.} } \value{ An object of class \code{gt_tbl}. @@ -29,7 +33,7 @@ input table data (which are unique by necessity). } \details{ If we look to the column names in the \code{iris} dataset as an example of how -\code{cols_split_delim()} might be useful, we find the names \code{Sepal.Length}, +\code{tab_spanner_delim()} might be useful, we find the names \code{Sepal.Length}, \code{Sepal.Width}, \code{Petal.Length}, \code{Petal.Width}. From this naming system, it's easy to see that the \code{Sepal} and \code{Petal} can group together the repeated common \code{Length} and \code{Width} values. In your own datasets, we can avoid a @@ -41,7 +45,7 @@ rendered output table). } \section{Figures}{ -\if{html}{\figure{man_cols_split_delim_1.svg}{options: width=100\%}} +\if{html}{\figure{man_tab_spanner_delim_1.svg}{options: width=100\%}} } \examples{ @@ -54,7 +58,7 @@ tab_1 <- dplyr::group_by(Species) \%>\% dplyr::slice(1:4) \%>\% gt() \%>\% - cols_split_delim(delim = ".") + tab_spanner_delim(delim = ".") } \seealso{ diff --git a/man/tab_stubhead.Rd b/man/tab_stubhead.Rd index 07d5a27807..38f6732146 100644 --- a/man/tab_stubhead.Rd +++ b/man/tab_stubhead.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/table_parts.R +% Please edit documentation in R/tab_stubhead.R \name{tab_stubhead} \alias{tab_stubhead} \title{Add label text to the stubhead} diff --git a/tests/gt-examples/01-html-script/html-01-iris.R b/tests/gt-examples/01-html-script/html-01-iris.R index a8bb3f9237..f5d6e9e9fc 100644 --- a/tests/gt-examples/01-html-script/html-01-iris.R +++ b/tests/gt-examples/01-html-script/html-01-iris.R @@ -4,7 +4,7 @@ library(gt) iris_tbl <- gt(data = iris) %>% - cols_split_delim(delim = ".") %>% + tab_spanner_delim(delim = ".") %>% cols_move_to_start(columns = vars(Species)) %>% fmt_number( columns = vars(Sepal.Length, Sepal.Width, Petal.Length, Petal.Width), diff --git a/tests/gt-examples/01-html-script/html-06-mtcars.R b/tests/gt-examples/01-html-script/html-06-mtcars.R index 5e9d330900..91b0f32522 100644 --- a/tests/gt-examples/01-html-script/html-06-mtcars.R +++ b/tests/gt-examples/01-html-script/html-06-mtcars.R @@ -20,7 +20,7 @@ mtcars_tbl <- cols_move_to_end(columns = vars(am, gear)) %>% cols_hide(columns = vars(carb)) %>% cols_move( - columns = vars(wt, carb, qsec), + columns = vars(wt, qsec), after = vars(gear)) %>% tab_row_group( group = "Mercs", diff --git a/tests/gt-examples/01-html-script/html-13-adding_footnotes.R b/tests/gt-examples/01-html-script/html-13-adding_footnotes.R index e35ed42545..c0175fe548 100644 --- a/tests/gt-examples/01-html-script/html-13-adding_footnotes.R +++ b/tests/gt-examples/01-html-script/html-13-adding_footnotes.R @@ -19,21 +19,38 @@ tbl <- # Create a display table footnotes_tbl <- - gt(data = tbl) %>% + gt(data = tbl, groupname_col = "date") %>% + tab_spanner( + label = "values", + columns = starts_with("value") + ) %>% + tab_footnote( + footnote = "This is an even smaller number.", + locations = cells_data(columns = vars(value_1), rows = 9) + ) %>% + tab_footnote( + footnote = "This is a small number.", + locations = cells_data(columns = vars(value_1), rows = 4) + ) %>% tab_footnote( footnote = "First data cell.", - locations = cells_data(columns = 1, rows = 1)) %>% + locations = cells_data(columns = "value_1", rows = 1) + ) %>% tab_footnote( - footnote = "A stub cell.", - locations = cells_stub(rows = 1)) %>% + footnote = "The first row group", + locations = cells_group(groups = ends_with("10")) + ) %>% tab_footnote( - footnote = md("`value_1` is the second column of values."), - locations = cells_column_labels(columns = vars(value_1))) %>% + footnote = "Two sets of values", + locations = cells_column_spanners(spanners = starts_with("val")) + ) %>% tab_footnote( - footnote = "This is an even smaller number.", - locations = cells_data(columns = 2, rows = 9)) %>% + footnote = "A stub cell.", + locations = cells_stub(rows = 1) + ) %>% tab_footnote( - footnote = "This is a small number.", - locations = cells_data(columns = 2, rows = 4)) + footnote = md("`value_1` is the first column of values."), + locations = cells_column_labels(columns = vars(value_1)) + ) footnotes_tbl diff --git a/tests/gt-examples/01-html-script/html-15-styles_everywhere.R b/tests/gt-examples/01-html-script/html-15-styles_everywhere.R index 4fce7a428f..7901303268 100644 --- a/tests/gt-examples/01-html-script/html-15-styles_everywhere.R +++ b/tests/gt-examples/01-html-script/html-15-styles_everywhere.R @@ -71,7 +71,7 @@ many_styles_tbl <- ) %>% tab_style( style = cell_fill(color = "lightgreen"), - locations = cells_column_labels(groups = "gear_carb_cyl") + locations = cells_column_spanners(spanners = "gear_carb_cyl") ) %>% tab_style( style = cell_fill(color = "turquoise"), @@ -79,7 +79,6 @@ many_styles_tbl <- ) %>% tab_style( style = cell_fill(color = "pink"), - locations = cells_column_labels(columns = "hp") ) %>% tab_style( diff --git a/tests/gt-examples/02-html-rmd/html-01-iris.Rmd b/tests/gt-examples/02-html-rmd/html-01-iris.Rmd index f3bfed3f87..ae3dc5fa18 100644 --- a/tests/gt-examples/02-html-rmd/html-01-iris.Rmd +++ b/tests/gt-examples/02-html-rmd/html-01-iris.Rmd @@ -14,7 +14,7 @@ Create a display table based on `iris` Edgar Anderson's Iris Data ```{r} gt(data = iris) %>% - cols_split_delim(delim = ".") %>% + tab_spanner_delim(delim = ".") %>% cols_move_to_start(columns = vars(Species)) %>% fmt_number( columns = vars(Sepal.Length, Sepal.Width, Petal.Length, Petal.Width), diff --git a/tests/gt-examples/03-latex/latex-01-iris.Rmd b/tests/gt-examples/03-latex/latex-01-iris.Rmd index b3036678ad..d344846928 100644 --- a/tests/gt-examples/03-latex/latex-01-iris.Rmd +++ b/tests/gt-examples/03-latex/latex-01-iris.Rmd @@ -14,7 +14,7 @@ Create a display table based on `iris` Edgar Anderson's Iris Data. ```{r} gt(data = iris) %>% - cols_split_delim(delim = ".") %>% + tab_spanner_delim(delim = ".") %>% cols_move_to_start(columns = vars(Species)) %>% fmt_number( columns = vars(Sepal.Length, Sepal.Width, Petal.Length, Petal.Width), diff --git a/tests/gt-examples/03-latex/latex-03-pressure.Rmd b/tests/gt-examples/03-latex/latex-03-pressure.Rmd index f4cbc2d6a9..f65f98bf8f 100644 --- a/tests/gt-examples/03-latex/latex-03-pressure.Rmd +++ b/tests/gt-examples/03-latex/latex-03-pressure.Rmd @@ -16,5 +16,6 @@ Create a display table based on `pressure` (Vapor Pressure of Mercury as a Funct gt(data = pressure) %>% fmt_scientific( columns = vars(pressure), - decimals = 2) + decimals = 2 + ) ``` diff --git a/tests/gt-examples/03-latex/latex-04-sleep.Rmd b/tests/gt-examples/03-latex/latex-04-sleep.Rmd index b90e7475e2..00dd142a15 100644 --- a/tests/gt-examples/03-latex/latex-04-sleep.Rmd +++ b/tests/gt-examples/03-latex/latex-04-sleep.Rmd @@ -17,6 +17,7 @@ gt(data = sleep) %>% fmt_scientific(columns = vars(extra)) %>% tab_footnote( footnote = "This is a footnote", - locations = cells_data(columns = 1, rows = c(2, 3, 4))) + locations = cells_data(columns = 1, rows = c(2, 3, 4)) + ) ``` diff --git a/tests/gt-examples/03-latex/latex-05-airquality.Rmd b/tests/gt-examples/03-latex/latex-05-airquality.Rmd index 7890c409c6..2cf0023fbd 100644 --- a/tests/gt-examples/03-latex/latex-05-airquality.Rmd +++ b/tests/gt-examples/03-latex/latex-05-airquality.Rmd @@ -3,7 +3,7 @@ title: "latex-05-airquality" output: - pdf_document --- - + ```{r setup, include=FALSE} knitr::opts_chunk$set(echo = TRUE) @@ -20,6 +20,7 @@ gt(data = airquality) %>% decimals = 2) %>% tab_spanner( label = "Measurement Period", - columns = vars(Month, Day)) %>% + columns = vars(Month, Day) + ) %>% fmt_missing(columns = vars(Ozone, Solar.R, Ozone, Wind, Temp)) ``` diff --git a/tests/testthat/helper-gt_attr_expectations.R b/tests/testthat/helper-gt_attr_expectations.R index dc735ffbc1..0887094346 100644 --- a/tests/testthat/helper-gt_attr_expectations.R +++ b/tests/testthat/helper-gt_attr_expectations.R @@ -8,20 +8,20 @@ expect_tab_colnames <- function(tab, # Expect that the `rowname` column of the `stub_df` # object is entirely filled with NAs expect_true( - all(is.na(attr(tab, "stub_df")[["rowname"]]))) + all(is.na(dt_stub_df_get(data = tab)[["rowname"]]))) } else if (rowname == "col"){ # Expect that the `rowname` column of the `stub_df` # object is entirely filled with NAs expect_equal( - attr(tab, "stub_df")[["rowname"]], + dt_stub_df_get(data = tab)[["rowname"]], df$rowname) } else if (rowname == "tibble") { expect_equal( - attr(tab, "stub_df")[["rowname"]], + dt_stub_df_get(data = tab)[["rowname"]], row.names(df)) } @@ -30,7 +30,7 @@ expect_tab_colnames <- function(tab, # Expect that the `groupname` column of the `stub_df` # object is entirely filled with NAs expect_true( - all(is.na(attr(tab, "stub_df")[["groupname"]]))) + all(is.na(dt_stub_df_get(data = tab)[["groupname"]]))) } else { @@ -38,102 +38,125 @@ expect_tab_colnames <- function(tab, # the original dataset populate the `groupname` column # of the `stub_df` object expect_equal( - attr(tab, "stub_df")[["groupname"]], + dt_stub_df_get(data = tab)[["groupname"]], df[["groupname"]]) } } expect_tab <- function(tab, - df, - has_rownames = FALSE, - has_groupnames = FALSE) { + df) { # Expect that the object has the correct classes expect_s3_class(tab, "gt_tbl") - expect_s3_class(tab, "data.frame") + expect_type(tab, "list") # Expect certain named attributes - expect_gt_attr_names(tab) + expect_gt_attr_names(object = tab) # Expect that the attribute obejcts are of certain classes - expect_s3_class(attr(tab, "boxh_df"), "data.frame") - expect_s3_class(attr(tab, "stub_df"), "data.frame") - expect_s3_class(attr(tab, "footnotes_df"), "data.frame") - expect_s3_class(attr(tab, "styles_df"), "data.frame") - expect_s3_class(attr(tab, "rows_df"), "data.frame") - expect_s3_class(attr(tab, "cols_df"), "data.frame") - expect_s3_class(attr(tab, "opts_df"), "data.frame") - expect_type(attr(tab, "col_labels"), "list") - expect_type(attr(tab, "grp_labels"), "list") - expect_type(attr(tab, "arrange_groups"), "list") - expect_type(attr(tab, "formats"), "list") - - # Expect that the attribute objects are of the - # correct dimensions - if (dplyr::is_grouped_df(df)) { - - non_group_cols <- base::setdiff(colnames(df), dplyr::group_vars(df)) - - final_df <- - df %>% - dplyr::ungroup() %>% - dplyr::select(non_group_cols) - } else { - final_df <- df - } - - if (has_rownames) { - final_df$rowname <- NULL - } - - if (has_groupnames) { - final_df$groupname <- NULL - } - - expect_equal(dim(attr(tab, "boxh_df")), c(4, ncol(final_df))) - expect_equal(dim(attr(tab, "stub_df")), c(nrow(df), 2)) - expect_equal(dim(attr(tab, "footnotes_df")), c(0, 6)) - expect_equal(dim(attr(tab, "styles_df")), c(0, 6)) - expect_equal(dim(attr(tab, "rows_df")), c(nrow(df), 1)) - expect_equal(dim(attr(tab, "cols_df")), c(ncol(final_df), 1)) - expect_equal(ncol(attr(tab, "opts_df")), 5) - expect_equal(length(attr(tab, "formats")), 0) - expect_equal(length(attr(tab, "arrange_groups")), 1) + expect_s3_class(dt_boxhead_get(data = tab), "data.frame") + expect_type(dt_stub_df_get(data = tab), "list") + expect_type(dt_stub_groups_get(data = tab), "character") + expect_type(dt_stub_others_get(data = tab), "character") + expect_s3_class(dt_stub_df_get(data = tab), "data.frame") + expect_type(dt_heading_get(data = tab), "list") + expect_s3_class(dt_spanners_get(data = tab), "data.frame") + expect_type(dt_stubhead_get(data = tab), "list") + expect_s3_class(dt_footnotes_get(data = tab), "data.frame") + expect_type(dt_source_notes_get(data = tab), "list") + expect_type(dt_formats_get(data = tab), "list") + expect_s3_class(dt_styles_get(data = tab), "data.frame") + expect_s3_class(dt_options_get(data = tab), "data.frame") + expect_type(dt_transforms_get(data = tab), "list") + + dt_boxhead_get(data = tab) %>% + dim() %>% + expect_equal(c(ncol(df), 6)) + + dt_stub_df_get(data = tab) %>% + dim() %>% + expect_equal(c(nrow(df), 3)) + + dt_heading_get(data = tab) %>% + length() %>% + expect_equal(2) + + dt_spanners_get(data = tab) %>% + dim() %>% + expect_equal(c(0, 4)) + + dt_stubhead_get(data = tab) %>% + length() %>% + expect_equal(1) + + dt_footnotes_get(data = tab) %>% + dim() %>% + expect_equal(c(0, 7)) + + dt_source_notes_get(data = tab) %>% + length() %>% + expect_equal(0) + + dt_formats_get(data = tab) %>% + length() %>% + expect_equal(0) + + dt_styles_get(data = tab) %>% + dim() %>% + expect_equal(c(0, 7)) + + dt_options_get(data = tab) %>% + dim() %>% + expect_equal(c(73, 5)) + + dt_stub_groups_get(data = tab) %>% + length() %>% + expect_equal(0) + + dt_transforms_get(data = tab) %>% + length() %>% + expect_equal(0) # Expect that extracted df has the same column # names as the original dataset expect_equal( - tab %>% as.data.frame() %>% colnames(), - colnames(final_df)) + tab %>% dt_data_get() %>% colnames(), + colnames(df)) # Expect that extracted df has the same column # classes as the original dataset expect_equal( - tab %>% as.data.frame() %>% sapply(class) %>% as.character(), - final_df %>% as.data.frame() %>% sapply(class) %>% as.character()) + tab %>% dt_data_get() %>% sapply(class) %>% as.character(), + df %>% as.data.frame() %>% sapply(class) %>% as.character() + ) # Expect that extracted df has the same number of # rows as the original dataset expect_equal( - tab %>% as.data.frame() %>% nrow(), - nrow(df)) + tab %>% dt_data_get() %>% nrow(), + nrow(df) + ) # Expect that the column names of the `stub_df` object - # are `groupname` and `rowname` + # are `rownum_i`, `groupname`, and `rowname` expect_equal( - colnames(attr(tab, "stub_df")), - c("groupname", "rowname")) + colnames(dt_stub_df_get(data = tab)), + c("rownum_i", "groupname", "rowname") + ) # Expect that the column names of the `boxh_df` object # are the same as those of the original dataset - expect_equal( - colnames(attr(tab, "boxh_df")), - colnames(final_df)) + dt_boxhead_get(data = tab) %>% + dplyr::pull(var) %>% + expect_equal(colnames(df)) } expect_attr_equal <- function(data, attr_val, y) { - attr(data, attr_val, exact = TRUE) %>% + + obj <- dt__get(data = data, key = attr_val) + + obj %>% unlist() %>% unname() %>% expect_equal(y) @@ -141,17 +164,21 @@ expect_attr_equal <- function(data, attr_val, y) { gt_attr_names <- function() { - c("names", "row.names", "class", - "boxh_df", "stub_df", "footnotes_df", "styles_df", - "rows_df", "cols_df", "col_labels", "grp_labels", - "arrange_groups", "data_df", "opts_df", - "formats", "transforms") + c( + "_data", "_boxhead", + "_stub_df", "_stub_groups", "_stub_others", + "_heading", "_spanners", "_stubhead", + "_footnotes", "_source_notes", "_formats", "_styles", + "_summary", "_options", "_transforms", "_has_built" + ) } expect_gt_attr_names <- function(object) { + # The `groups` attribute appears when we call dplyr::group_by() + # on the input table expect_equal( - sort(names(attributes(object))), + sort(names(object)), sort(gt_attr_names()) ) } diff --git a/tests/testthat/helper-render_formats.R b/tests/testthat/helper-render_formats.R index 5a60f8f762..a12aa74747 100644 --- a/tests/testthat/helper-render_formats.R +++ b/tests/testthat/helper-render_formats.R @@ -2,5 +2,7 @@ render_formats_test <- function(data, context) { - data %>% build_data(context) %>% .subset2("output_df") + data %>% + build_data(context = context) %>% + .$`_body` } diff --git a/tests/testthat/test-cols_align.R b/tests/testthat/test-cols_align.R index 705378097a..d7acf0da7e 100644 --- a/tests/testthat/test-cols_align.R +++ b/tests/testthat/test-cols_align.R @@ -31,13 +31,13 @@ test_that("the `cols_align()` function works correctly", { # Expect that the columns with class `col_heading left` # are those columns that were aligned left tbl_html %>% - rvest::html_nodes("[class='gt_col_heading gt_columns_bottom_border gt_columns_top_border gt_left']") %>% + rvest::html_nodes("[class='gt_col_heading gt_columns_bottom_border gt_left']") %>% rvest::html_text() %>% expect_equal(c("mpg", "cyl", "drat")) # Expect that all other columns are center-aligned tbl_html %>% - rvest::html_nodes("[class='gt_col_heading gt_columns_bottom_border gt_columns_top_border gt_center']") %>% + rvest::html_nodes("[class='gt_col_heading gt_columns_bottom_border gt_right']") %>% rvest::html_text() %>% expect_equal(base::setdiff(colnames(mtcars_short), c("mpg", "cyl", "drat"))) @@ -52,13 +52,13 @@ test_that("the `cols_align()` function works correctly", { # Expect that the columns with class `gt_col_heading gt_left` # are those columns that were aligned left tbl_html %>% - rvest::html_nodes("[class='gt_col_heading gt_columns_bottom_border gt_columns_top_border gt_left']") %>% + rvest::html_nodes("[class='gt_col_heading gt_columns_bottom_border gt_left']") %>% rvest::html_text() %>% expect_equal(c("mpg", "cyl", "disp")) - # Expect that all other columns are center-aligned + # Expect that all other columns are right-aligned tbl_html %>% - rvest::html_nodes("[class='gt_col_heading gt_columns_bottom_border gt_columns_top_border gt_center']") %>% + rvest::html_nodes("[class='gt_col_heading gt_columns_bottom_border gt_right']") %>% rvest::html_text() %>% expect_equal(base::setdiff(colnames(mtcars_short), c("mpg", "cyl", "disp"))) @@ -91,7 +91,7 @@ test_that("the `cols_align()` function works correctly", { # Expect that the columns with class `col_heading left` # includes all columns in `mtcars_short` tbl_html %>% - rvest::html_nodes("[class='gt_col_heading gt_columns_bottom_border gt_columns_top_border gt_left']") %>% + rvest::html_nodes("[class='gt_col_heading gt_columns_bottom_border gt_left']") %>% rvest::html_text() %>% expect_equal(colnames(mtcars_short)) @@ -106,7 +106,7 @@ test_that("the `cols_align()` function works correctly", { # Expect that the columns with class `col_heading left` # includes all columns in `mtcars_short` tbl_html %>% - rvest::html_nodes("[class='gt_col_heading gt_columns_bottom_border gt_columns_top_border gt_left']") %>% + rvest::html_nodes("[class='gt_col_heading gt_columns_bottom_border gt_left']") %>% rvest::html_text() %>% expect_equal(colnames(mtcars_short)) @@ -121,7 +121,7 @@ test_that("the `cols_align()` function works correctly", { # Expect that the `Date` column is left-formatted because # the column is of the `character` class tbl_html %>% - rvest::html_nodes("[class='gt_col_heading gt_columns_bottom_border gt_columns_top_border gt_left']") %>% + rvest::html_nodes("[class='gt_col_heading gt_columns_bottom_border gt_left']") %>% rvest::html_text() %>% expect_equal("Date") }) diff --git a/tests/testthat/test-cols_label.R b/tests/testthat/test-cols_label.R index 0d4c89b68a..50b19e90d7 100644 --- a/tests/testthat/test-cols_label.R +++ b/tests/testthat/test-cols_label.R @@ -57,15 +57,17 @@ test_that("the function `cols_label()` works correctly", { # Expect that the values for the column labels are set # correctly in `col_labels` - expect_attr_equal( - tbl_html, "col_labels", - c("col_a", "col_b", "col_c", "col_d")) + tbl_html %>% + .$`_boxh` %>% + .$column_label %>% + unlist() %>% + expect_equal(c("col_a", "col_b", "col_c", "col_d")) # Expect that the column labels are set tbl_html %>% render_as_html() %>% xml2::read_html() %>% - selection_text("[class='gt_col_heading gt_columns_bottom_border gt_columns_top_border gt_center']") %>% + selection_text("[class='gt_col_heading gt_columns_bottom_border gt_right']") %>% expect_equal(c("col_a", "col_b", "col_c", "col_d")) # Create a `tbl_html` object with `gt()` and label none @@ -75,16 +77,24 @@ test_that("the function `cols_label()` works correctly", { cols_label() # Expect the original column names for `tbl` as values for - # the column labels - expect_attr_equal( - tbl_html, "col_labels", - colnames(tbl)) + # the column keys and for the column labels + tbl_html %>% + .$`_boxh` %>% + .$var %>% + unlist() %>% + expect_equal(colnames(tbl)) + + tbl_html %>% + .$`_boxh` %>% + .$column_label %>% + unlist() %>% + expect_equal(colnames(tbl)) # Expect that the column labels are set as the column names tbl_html %>% render_as_html() %>% xml2::read_html() %>% - selection_text("[class='gt_col_heading gt_columns_bottom_border gt_columns_top_border gt_center']") %>% + selection_text("[class='gt_col_heading gt_columns_bottom_border gt_right']") %>% expect_equal(c("col_1", "col_2", "col_3", "col_4")) # Create a `tbl_html` object with `gt()` and label all @@ -101,15 +111,17 @@ test_that("the function `cols_label()` works correctly", { # Expect that the values for the column labels are set # correctly in `col_labels` - expect_attr_equal( - tbl_html, "col_labels", - c("col_a", "col_b", "col_c", "col_d")) + tbl_html %>% + .$`_boxh` %>% + .$column_label %>% + unlist() %>% + expect_equal(c("col_a", "col_b", "col_c", "col_d")) # Expect that the column labels are set tbl_html %>% render_as_html() %>% xml2::read_html() %>% - selection_text("[class='gt_col_heading gt_columns_bottom_border gt_columns_top_border gt_center']") %>% + selection_text("[class='gt_col_heading gt_columns_bottom_border gt_right']") %>% expect_equal(c("col_a", "col_b", "col_c", "col_d")) # Expect an error if any names are missing diff --git a/tests/testthat/test-cols_merge.R b/tests/testthat/test-cols_merge.R index 174e29a41c..b11d3f7c53 100644 --- a/tests/testthat/test-cols_merge.R +++ b/tests/testthat/test-cols_merge.R @@ -16,7 +16,8 @@ tbl <- 349.7, 307.1, 566.7, 542.9, 63.7, 504.3, 152.0, 724.5, 105.4, 729.8, 962.4, 336.4, - 924.2, 424.6, 740.8, 104.2) + 924.2, 424.6, 740.8, 104.2 + ) # Function to skip tests if Suggested packages not available on system check_suggests <- function() { @@ -32,92 +33,79 @@ test_that("the function `cols_merge()` works correctly", { # Create a `tbl_html` object with `gt()`; merge two columns # with a `pattern` tbl_html <- - gt(mtcars_short) %>% - cols_merge( - col_1 = "drat", - col_2 = "wt", - pattern = "{1} ({2})") + mtcars_short %>% + gt() %>% + cols_merge( + columns = c("drat", "wt"), + hide_columns = vars(wt), + pattern = "{1} ({2})" + ) # Expect that merging statements are stored in `col_merge` - attr(tbl_html, "col_merge", exact = TRUE)$pattern %>% + dt_col_merge_get(data = tbl_html) %>% .[[1]] %>% .$pattern %>% expect_equal("{1} ({2})") - attr(tbl_html, "col_merge", exact = TRUE)$sep %>% - expect_equal("") - - attr(tbl_html, "col_merge", exact = TRUE)$col_1 %>% - names() %>% - expect_equal("wt") + dt_col_merge_get(data = tbl_html) %>% .[[1]] %>% .$vars %>% + expect_equal(c("drat", "wt")) - attr(tbl_html, "col_merge", exact = TRUE)$col_1 %>% - unname() %>% - expect_equal("drat") + dt_col_merge_get(data = tbl_html) %>% .[[1]] %>% .$type %>% + expect_equal("merge") # Create a `tbl_html` object with `gt()`; merge two columns # with a `pattern` and use the `vars()` helper tbl_html <- - gt(mtcars_short) %>% + mtcars_short %>% + gt() %>% cols_merge( - col_1 = vars(drat), - col_2 = vars(wt), - pattern = "{1} ({2})") + columns = vars(drat, wt), + hide_columns = vars(wt), + pattern = "{1} ({2})" + ) # Expect that merging statements are stored in `col_merge` - attr(tbl_html, "col_merge", exact = TRUE)$pattern %>% + dt_col_merge_get(data = tbl_html) %>% .[[1]] %>% .$pattern %>% expect_equal("{1} ({2})") - attr(tbl_html, "col_merge", exact = TRUE)$sep %>% - expect_equal("") - - attr(tbl_html, "col_merge", exact = TRUE)$col_1 %>% - names() %>% - expect_equal("wt") + dt_col_merge_get(data = tbl_html) %>% .[[1]] %>% .$vars %>% + expect_equal(c("drat", "wt")) - attr(tbl_html, "col_merge", exact = TRUE)$col_1 %>% - unname() %>% - expect_equal("drat") + dt_col_merge_get(data = tbl_html) %>% .[[1]] %>% .$type %>% + expect_equal("merge") # Create a `tbl_html` object with `gt()`; merge two columns, twice, # with two different `pattern`s; use the `vars()` helper tbl_html <- - gt(mtcars_short) %>% + mtcars_short %>% + gt() %>% cols_merge( - col_1 = vars(drat), - col_2 = vars(wt), - pattern = "{1} ({2})") %>% + columns = vars(drat, wt), + hide_columns = vars(wt), + pattern = "{1} ({2})" + ) %>% cols_merge( - col_1 = vars(gear), - col_2 = vars(carb), - pattern = "{1}-{2}") + columns = vars(gear, carb), + hide_columns = vars(carb), + pattern = "{1}-{2}" + ) # Expect that merging statements are stored in `col_merge` - attr(tbl_html, "col_merge", exact = TRUE)$pattern[[1]] %>% + dt_col_merge_get(data = tbl_html) %>% .[[1]] %>% .$pattern %>% expect_equal("{1} ({2})") - attr(tbl_html, "col_merge", exact = TRUE)$sep[[1]] %>% - expect_equal("") + dt_col_merge_get(data = tbl_html) %>% .[[1]] %>% .$vars %>% + expect_equal(c("drat", "wt")) - attr(tbl_html, "col_merge", exact = TRUE)$col_1[1] %>% - names() %>% - expect_equal("wt") + dt_col_merge_get(data = tbl_html) %>% .[[1]] %>% .$type %>% + expect_equal("merge") - attr(tbl_html, "col_merge", exact = TRUE)$col_1[1] %>% - unname() %>% - expect_equal("drat") - - attr(tbl_html, "col_merge", exact = TRUE)$pattern[[2]] %>% + dt_col_merge_get(data = tbl_html) %>% .[[2]] %>% .$pattern %>% expect_equal("{1}-{2}") - attr(tbl_html, "col_merge", exact = TRUE)$sep[[2]] %>% - expect_equal("") - - attr(tbl_html, "col_merge", exact = TRUE)$col_1[2] %>% - names() %>% - expect_equal("carb") + dt_col_merge_get(data = tbl_html) %>% .[[2]] %>% .$vars %>% + expect_equal(c("gear", "carb")) - attr(tbl_html, "col_merge", exact = TRUE)$col_1[2] %>% - unname() %>% - expect_equal("gear") + dt_col_merge_get(data = tbl_html) %>% .[[2]] %>% .$type %>% + expect_equal("merge") }) test_that("the `cols_merge_uncert()` function works correctly", { @@ -128,88 +116,87 @@ test_that("the `cols_merge_uncert()` function works correctly", { # Create a `tbl_html` object with `gt()`; merge two columns # with `cols_merge_uncert()` tbl_html <- - gt(tbl) %>% + tbl %>% + gt() %>% cols_merge_uncert( col_val = "col_1", - col_uncert = "col_2") + col_uncert = "col_2" + ) # Expect that merging statements are stored in `col_merge` - attr(tbl_html, "col_merge", exact = TRUE)$pattern %>% - expect_equal("{1} ± {2}") + dt_col_merge_get(data = tbl_html) %>% .[[1]] %>% .$pattern %>% + expect_equal("{1}{sep}{2}") - attr(tbl_html, "col_merge", exact = TRUE)$sep %>% - expect_equal("") + dt_col_merge_get(data = tbl_html) %>% .[[1]] %>% .$vars %>% + expect_equal(c("col_1", "col_2")) - attr(tbl_html, "col_merge", exact = TRUE)$col_1 %>% - names() %>% - expect_equal("col_2") + dt_col_merge_get(data = tbl_html) %>% .[[1]] %>% .$type %>% + expect_equal("merge_range") - attr(tbl_html, "col_merge", exact = TRUE)$col_1 %>% - unname() %>% - expect_equal("col_1") + dt_col_merge_get(data = tbl_html) %>% .[[1]] %>% .$sep %>% + expect_equal(" ± ") # Create a `tbl_html` object with `gt()`; merge two columns # with `cols_merge_uncert()` and use the `vars()` helper tbl_html <- - gt(tbl) %>% + tbl %>% + gt() %>% cols_merge_uncert( col_val = vars(col_1), - col_uncert = vars(col_2)) + col_uncert = vars(col_2) + ) # Expect that merging statements are stored in `col_merge` - attr(tbl_html, "col_merge", exact = TRUE)$pattern %>% - expect_equal("{1} ± {2}") + dt_col_merge_get(data = tbl_html) %>% .[[1]] %>% .$pattern %>% + expect_equal("{1}{sep}{2}") - attr(tbl_html, "col_merge", exact = TRUE)$sep %>% - expect_equal("") + dt_col_merge_get(data = tbl_html) %>% .[[1]] %>% .$vars %>% + expect_equal(c("col_1", "col_2")) - attr(tbl_html, "col_merge", exact = TRUE)$col_1 %>% - names() %>% - expect_equal("col_2") + dt_col_merge_get(data = tbl_html) %>% .[[1]] %>% .$type %>% + expect_equal("merge_range") - attr(tbl_html, "col_merge", exact = TRUE)$col_1 %>% - unname() %>% - expect_equal("col_1") + dt_col_merge_get(data = tbl_html) %>% .[[1]] %>% .$sep %>% + expect_equal(" ± ") # Create a `tbl_html` object with `gt()`; merge two columns, twice, # with `cols_merge_uncert()` and use the `vars()` helper tbl_html <- - gt(tbl) %>% + tbl %>% + gt() %>% cols_merge_uncert( col_val = vars(col_1), - col_uncert = vars(col_2)) %>% + col_uncert = vars(col_2) + ) %>% cols_merge_uncert( col_val = vars(col_3), - col_uncert = vars(col_4)) + col_uncert = vars(col_4) + ) - # Expect that merging statements are stored in `col_merge` - attr(tbl_html, "col_merge", exact = TRUE)$pattern[[1]] %>% - expect_equal("{1} ± {2}") + # Expect that merging statements are stored in `col_merge`\ + dt_col_merge_get(data = tbl_html) %>% .[[1]] %>% .$pattern %>% + expect_equal("{1}{sep}{2}") - attr(tbl_html, "col_merge", exact = TRUE)$sep[[1]] %>% - expect_equal("") + dt_col_merge_get(data = tbl_html) %>% .[[1]] %>% .$vars %>% + expect_equal(c("col_1", "col_2")) - attr(tbl_html, "col_merge", exact = TRUE)$col_1[1] %>% - names() %>% - expect_equal("col_2") + dt_col_merge_get(data = tbl_html) %>% .[[1]] %>% .$type %>% + expect_equal("merge_range") - attr(tbl_html, "col_merge", exact = TRUE)$col_1[1] %>% - unname() %>% - expect_equal("col_1") + dt_col_merge_get(data = tbl_html) %>% .[[1]] %>% .$sep %>% + expect_equal(" ± ") - attr(tbl_html, "col_merge", exact = TRUE)$pattern[[2]] %>% - expect_equal("{1} ± {2}") + dt_col_merge_get(data = tbl_html) %>% .[[2]] %>% .$pattern %>% + expect_equal("{1}{sep}{2}") - attr(tbl_html, "col_merge", exact = TRUE)$sep[[2]] %>% - expect_equal("") + dt_col_merge_get(data = tbl_html) %>% .[[2]] %>% .$vars %>% + expect_equal(c("col_3", "col_4")) - attr(tbl_html, "col_merge", exact = TRUE)$col_1[2] %>% - names() %>% - expect_equal("col_4") + dt_col_merge_get(data = tbl_html) %>% .[[2]] %>% .$type %>% + expect_equal("merge_range") - attr(tbl_html, "col_merge", exact = TRUE)$col_1[2] %>% - unname() %>% - expect_equal("col_3") + dt_col_merge_get(data = tbl_html) %>% .[[2]] %>% .$sep %>% + expect_equal(" ± ") }) test_that("the `cols_merge_range()` function works correctly", { @@ -220,86 +207,85 @@ test_that("the `cols_merge_range()` function works correctly", { # Create a `tbl_html` object with `gt()`; merge two columns # with `cols_merge_range()` tbl_html <- - gt(tbl) %>% + tbl %>% + gt() %>% cols_merge_range( col_begin = "col_1", - col_end = "col_2") + col_end = "col_2" + ) - # Expect that merging statements are stored in `col_merge` - attr(tbl_html, "col_merge", exact = TRUE)$pattern %>% - expect_equal("{1} {sep} {2}") + # Expect that merging statements are stored in `col_merge`\ + dt_col_merge_get(data = tbl_html) %>% .[[1]] %>% .$pattern %>% + expect_equal("{1}{sep}{2}") - attr(tbl_html, "col_merge", exact = TRUE)$sep %>% - expect_equal("---") + dt_col_merge_get(data = tbl_html) %>% .[[1]] %>% .$vars %>% + expect_equal(c("col_1", "col_2")) - attr(tbl_html, "col_merge", exact = TRUE)$col_1 %>% - names() %>% - expect_equal("col_2") + dt_col_merge_get(data = tbl_html) %>% .[[1]] %>% .$type %>% + expect_equal("merge_range") - attr(tbl_html, "col_merge", exact = TRUE)$col_1 %>% - unname() %>% - expect_equal("col_1") + dt_col_merge_get(data = tbl_html) %>% .[[1]] %>% .$sep %>% + expect_equal("--") # Create a `tbl_html` object with `gt()`; merge two columns # with `cols_merge_range()` and use the `vars()` helper tbl_html <- - gt(tbl) %>% + tbl %>% + gt() %>% cols_merge_range( col_begin = vars(col_1), - col_end = vars(col_2)) + col_end = vars(col_2) + ) - # Expect that merging statements are stored in `col_merge` - attr(tbl_html, "col_merge", exact = TRUE)$pattern %>% - expect_equal("{1} {sep} {2}") + # Expect that merging statements are stored in `col_merge`\ + dt_col_merge_get(data = tbl_html) %>% .[[1]] %>% .$pattern %>% + expect_equal("{1}{sep}{2}") - attr(tbl_html, "col_merge", exact = TRUE)$sep %>% - expect_equal("---") + dt_col_merge_get(data = tbl_html) %>% .[[1]] %>% .$vars %>% + expect_equal(c("col_1", "col_2")) - attr(tbl_html, "col_merge", exact = TRUE)$col_1 %>% - names() %>% - expect_equal("col_2") + dt_col_merge_get(data = tbl_html) %>% .[[1]] %>% .$type %>% + expect_equal("merge_range") - attr(tbl_html, "col_merge", exact = TRUE)$col_1 %>% - unname() %>% - expect_equal("col_1") + dt_col_merge_get(data = tbl_html) %>% .[[1]] %>% .$sep %>% + expect_equal("--") # Create a `tbl_html` object with `gt()`; merge two columns, twice, # with `cols_merge_range()` and use the `vars()` helper tbl_html <- - gt(tbl) %>% + tbl %>% + gt() %>% cols_merge_range( col_begin = vars(col_1), - col_end = vars(col_2)) %>% + col_end = vars(col_2) + ) %>% cols_merge_range( col_begin = vars(col_3), - col_end = vars(col_4)) + col_end = vars(col_4) + ) - # Expect that merging statements are stored in `col_merge` - attr(tbl_html, "col_merge", exact = TRUE)$pattern[[1]] %>% - expect_equal("{1} {sep} {2}") + # Expect that merging statements are stored in `col_merge`\ + dt_col_merge_get(data = tbl_html) %>% .[[1]] %>% .$pattern %>% + expect_equal("{1}{sep}{2}") - attr(tbl_html, "col_merge", exact = TRUE)$sep[[1]] %>% - expect_equal("---") + dt_col_merge_get(data = tbl_html) %>% .[[1]] %>% .$vars %>% + expect_equal(c("col_1", "col_2")) - attr(tbl_html, "col_merge", exact = TRUE)$col_1[1] %>% - names() %>% - expect_equal("col_2") + dt_col_merge_get(data = tbl_html) %>% .[[1]] %>% .$type %>% + expect_equal("merge_range") - attr(tbl_html, "col_merge", exact = TRUE)$col_1[1] %>% - unname() %>% - expect_equal("col_1") + dt_col_merge_get(data = tbl_html) %>% .[[1]] %>% .$sep %>% + expect_equal("--") - attr(tbl_html, "col_merge", exact = TRUE)$pattern[[2]] %>% - expect_equal("{1} {sep} {2}") + dt_col_merge_get(data = tbl_html) %>% .[[2]] %>% .$pattern %>% + expect_equal("{1}{sep}{2}") - attr(tbl_html, "col_merge", exact = TRUE)$sep[[2]] %>% - expect_equal("---") + dt_col_merge_get(data = tbl_html) %>% .[[2]] %>% .$vars %>% + expect_equal(c("col_3", "col_4")) - attr(tbl_html, "col_merge", exact = TRUE)$col_1[2] %>% - names() %>% - expect_equal("col_4") + dt_col_merge_get(data = tbl_html) %>% .[[2]] %>% .$type %>% + expect_equal("merge_range") - attr(tbl_html, "col_merge", exact = TRUE)$col_1[2] %>% - unname() %>% - expect_equal("col_3") + dt_col_merge_get(data = tbl_html) %>% .[[2]] %>% .$sep %>% + expect_equal("--") }) diff --git a/tests/testthat/test-cols_move.R b/tests/testthat/test-cols_move.R index 8d3299b162..add45e72b9 100644 --- a/tests/testthat/test-cols_move.R +++ b/tests/testthat/test-cols_move.R @@ -20,9 +20,9 @@ test_that("the `cols_move()` function works correctly", { gt(data = mtcars_short) %>% cols_move(columns = vars(mpg, cyl, disp), after = vars(drat)) - # Expect a particular ordering of columns in the internal `boxh_df` - attr(tbl_html, "boxh_df", exact = TRUE) %>% - colnames() %>% + # Expect a particular ordering of columns in `_boxh` + tbl_html %>% + dt_boxhead_get_vars() %>% expect_equal( c("hp", "drat", "mpg", "cyl", "disp", "wt", "qsec", "vs", "am", "gear", "carb")) @@ -32,7 +32,7 @@ test_that("the `cols_move()` function works correctly", { tbl_html %>% render_as_html() %>% xml2::read_html() %>% - rvest::html_nodes("[class='gt_col_heading gt_columns_bottom_border gt_columns_top_border gt_center']") %>% + rvest::html_nodes("[class='gt_col_heading gt_columns_bottom_border gt_right']") %>% rvest::html_text() %>% expect_equal( c("hp", "drat", "mpg", "cyl", "disp", "wt", @@ -44,9 +44,9 @@ test_that("the `cols_move()` function works correctly", { gt(data = mtcars_short) %>% cols_move(columns = c("mpg", "cyl", "disp"), after = c("drat")) - # Expect a particular ordering of columns in the internal `boxh_df` - attr(tbl_html, "boxh_df", exact = TRUE) %>% - colnames() %>% + # Expect a particular ordering of columns in `_boxh` + tbl_html %>% + dt_boxhead_get_vars() %>% expect_equal( c("hp", "drat", "mpg", "cyl", "disp", "wt", "qsec", "vs", "am", "gear", "carb")) @@ -56,7 +56,7 @@ test_that("the `cols_move()` function works correctly", { tbl_html %>% render_as_html() %>% xml2::read_html() %>% - rvest::html_nodes("[class='gt_col_heading gt_columns_bottom_border gt_columns_top_border gt_center']") %>% + rvest::html_nodes("[class='gt_col_heading gt_columns_bottom_border gt_right']") %>% rvest::html_text() %>% expect_equal( c("hp", "drat", "mpg", "cyl", "disp", "wt", @@ -69,8 +69,8 @@ test_that("the `cols_move()` function works correctly", { cols_move(columns = vars(mpg, cyl, disp), after = vars(carb)) # Expect a particular ordering of columns in the internal `boxh_df` - attr(tbl_html, "boxh_df", exact = TRUE) %>% - colnames() %>% + tbl_html %>% + dt_boxhead_get_vars() %>% expect_equal( c("hp", "drat", "wt", "qsec", "vs", "am", "gear", "carb", "mpg", "cyl", "disp")) @@ -80,7 +80,7 @@ test_that("the `cols_move()` function works correctly", { tbl_html %>% render_as_html() %>% xml2::read_html() %>% - rvest::html_nodes("[class='gt_col_heading gt_columns_bottom_border gt_columns_top_border gt_center']") %>% + rvest::html_nodes("[class='gt_col_heading gt_columns_bottom_border gt_right']") %>% rvest::html_text() %>% expect_equal( c("hp", "drat", "wt", "qsec", "vs", "am", @@ -114,8 +114,8 @@ test_that("the `cols_move_to_start()` function works correctly", { cols_move_to_start(columns = vars(gear, carb)) # Expect a particular ordering of columns in the internal `boxh_df` - attr(tbl_html, "boxh_df", exact = TRUE) %>% - colnames() %>% + tbl_html %>% + dt_boxhead_get_vars() %>% expect_equal( c("gear", "carb", "mpg", "cyl", "disp", "hp", "drat", "wt", "qsec", "vs", "am")) @@ -125,7 +125,7 @@ test_that("the `cols_move_to_start()` function works correctly", { tbl_html %>% render_as_html() %>% xml2::read_html() %>% - rvest::html_nodes("[class='gt_col_heading gt_columns_bottom_border gt_columns_top_border gt_center']") %>% + rvest::html_nodes("[class='gt_col_heading gt_columns_bottom_border gt_right']") %>% rvest::html_text() %>% expect_equal( c("gear", "carb", "mpg", "cyl", "disp", "hp", "drat", "wt", @@ -138,8 +138,8 @@ test_that("the `cols_move_to_start()` function works correctly", { cols_move_to_start(columns = c("gear", "carb")) # Expect a particular ordering of columns in the internal `boxh_df` - attr(tbl_html, "boxh_df", exact = TRUE) %>% - colnames() %>% + tbl_html %>% + dt_boxhead_get_vars() %>% expect_equal( c("gear", "carb", "mpg", "cyl", "disp", "hp", "drat", "wt", "qsec", "vs", "am")) @@ -149,7 +149,7 @@ test_that("the `cols_move_to_start()` function works correctly", { tbl_html %>% render_as_html() %>% xml2::read_html() %>% - rvest::html_nodes("[class='gt_col_heading gt_columns_bottom_border gt_columns_top_border gt_center']") %>% + rvest::html_nodes("[class='gt_col_heading gt_columns_bottom_border gt_right']") %>% rvest::html_text() %>% expect_equal( c("gear", "carb", "mpg", "cyl", "disp", "hp", "drat", "wt", @@ -173,8 +173,8 @@ test_that("the `cols_move_to_end()` function works correctly", { cols_move_to_end(columns = vars(gear, carb)) # Expect a particular ordering of columns in the internal `boxh_df` - attr(tbl_html, "boxh_df", exact = TRUE) %>% - colnames() %>% + tbl_html %>% + dt_boxhead_get_vars() %>% expect_equal( c("mpg", "cyl", "disp", "hp", "drat", "wt", "qsec", "vs", "am", "gear", "carb")) @@ -184,7 +184,7 @@ test_that("the `cols_move_to_end()` function works correctly", { tbl_html %>% render_as_html() %>% xml2::read_html() %>% - rvest::html_nodes("[class='gt_col_heading gt_columns_bottom_border gt_columns_top_border gt_center']") %>% + rvest::html_nodes("[class='gt_col_heading gt_columns_bottom_border gt_right']") %>% rvest::html_text() %>% expect_equal( c("mpg", "cyl", "disp", "hp", "drat", "wt", @@ -197,8 +197,8 @@ test_that("the `cols_move_to_end()` function works correctly", { cols_move_to_end(columns = c("gear", "carb")) # Expect a particular ordering of columns in the internal `boxh_df` - attr(tbl_html, "boxh_df", exact = TRUE) %>% - colnames() %>% + tbl_html %>% + dt_boxhead_get_vars() %>% expect_equal( c("mpg", "cyl", "disp", "hp", "drat", "wt", "qsec", "vs", "am", "gear", "carb")) @@ -208,7 +208,7 @@ test_that("the `cols_move_to_end()` function works correctly", { tbl_html %>% render_as_html() %>% xml2::read_html() %>% - rvest::html_nodes("[class='gt_col_heading gt_columns_bottom_border gt_columns_top_border gt_center']") %>% + rvest::html_nodes("[class='gt_col_heading gt_columns_bottom_border gt_right']") %>% rvest::html_text() %>% expect_equal( c("mpg", "cyl", "disp", "hp", "drat", "wt", diff --git a/tests/testthat/test-conditional_fmt.R b/tests/testthat/test-conditional_fmt.R index 89b95c4e31..0b21f571e9 100644 --- a/tests/testthat/test-conditional_fmt.R +++ b/tests/testthat/test-conditional_fmt.R @@ -30,7 +30,6 @@ time_tbl <- # `data_tbl` dataset tab_time <- gt(data = time_tbl) - test_that("the `fmt_number()` function works with conditional `rows`", { expect_equal( diff --git a/tests/testthat/test-fmt_currency.R b/tests/testthat/test-fmt_currency.R index 8a63fa8293..70602006b5 100644 --- a/tests/testthat/test-fmt_currency.R +++ b/tests/testthat/test-fmt_currency.R @@ -23,22 +23,22 @@ test_that("the `fmt_currency()` function works correctly", { expect_is(tab, c("gt_tbl", "data.frame")) # Expect certain named attributes - expect_true( - all( - names(attributes(tab)) %in% - c("names", "class", "row.names", - "boxh_df", "stub_df", "footnotes_df", "styles_df", - "rows_df", "cols_df", "col_labels", "grp_labels", - "arrange_groups", "data_df", "opts_df", "formats", "transforms") - ) - ) + # expect_true( + # all( + # names(attributes(tab)) %in% + # c("names", "class", "row.names", + # "boxh_df", "stub_df", "footnotes_df", "styles_df", + # "rows_df", "cols_df", "col_labels", "grp_labels", + # "arrange_groups", "data_df", "opts_df", "formats", "transforms") + # ) + # ) # Extract vectors from the table object for comparison # to the original dataset - char_1 <- (tab %>% as.data.frame())[["char_1"]] - char_2 <- (tab %>% as.data.frame())[["char_2"]] - num_1 <- (tab %>% as.data.frame())[["num_1"]] - num_2 <- (tab %>% as.data.frame())[["num_2"]] + char_1 <- (tab %>% dt_data_get())[["char_1"]] + char_2 <- (tab %>% dt_data_get())[["char_2"]] + num_1 <- (tab %>% dt_data_get())[["num_1"]] + num_2 <- (tab %>% dt_data_get())[["num_2"]] # Expect the extracted values to match those of the # original dataset diff --git a/tests/testthat/test-fmt_date_time.R b/tests/testthat/test-fmt_date_time.R index dfe6d38e15..5b6cd01ab6 100644 --- a/tests/testthat/test-fmt_date_time.R +++ b/tests/testthat/test-fmt_date_time.R @@ -16,17 +16,17 @@ test_that("the `fmt_date()` function works correctly", { expect_is(tab, c("gt_tbl", "data.frame")) # Expect certain named attributes - expect_true( - all( - names(attributes(tab)) %in% - c("names", "class", "row.names", - "boxh_df", "stub_df", "footnotes_df", "styles_df", - "rows_df", "cols_df", "col_labels", "grp_labels", - "arrange_groups", "data_df", "opts_df", "formats", "transforms"))) + # expect_true( + # all( + # names(attributes(tab)) %in% + # c("names", "class", "row.names", + # "boxh_df", "stub_df", "footnotes_df", "styles_df", + # "rows_df", "cols_df", "col_labels", "grp_labels", + # "arrange_groups", "data_df", "opts_df", "formats", "transforms"))) # Extract a vector from the table object for comparison # to the original dataset - date <- (tab %>% as.data.frame())[["date"]] + date <- (tab %>% dt_data_get())[["date"]] # Expect the extracted values to match those of the # original dataset @@ -45,7 +45,8 @@ test_that("the `fmt_date()` function works correctly", { (tab %>% fmt_date(columns = "date", date_style = 1) %>% render_formats_test(context = "html"))[["date"]], - c("2017-10-15", "2013-02-22", "2014-09-22", "2018-01-10")) + c("2017-10-15", "2013-02-22", + "2014-09-22", "2018-01-10")) expect_equal( (tab %>% @@ -86,7 +87,8 @@ test_that("the `fmt_date()` function works correctly", { (tab %>% fmt_date(columns = "date", date_style = 7) %>% render_formats_test(context = "html"))[["date"]], - c("15 Oct 2017", "22 Feb 2013", "22 Sep 2014", "10 Jan 2018")) + c("15 Oct 2017", "22 Feb 2013", + "22 Sep 2014", "10 Jan 2018")) expect_equal( (tab %>% @@ -149,7 +151,8 @@ test_that("the `fmt_date()` function works correctly", { (tab %>% fmt_date(columns = "date", date_style = 1) %>% render_formats_test(context = "html"))[["date"]], - c("2017-10-15", "2013-02-22", "2014-09-22", "2018-01-10")) + c("2017-10-15", "2013-02-22", + "2014-09-22", "2018-01-10")) expect_equal( (tab %>% @@ -190,7 +193,8 @@ test_that("the `fmt_date()` function works correctly", { (tab %>% fmt_date(columns = "date", date_style = 7) %>% render_formats_test(context = "html"))[["date"]], - c("15 Oct 2017", "22 Feb 2013", "22 Sep 2014", "10 Jan 2018")) + c("15 Oct 2017", "22 Feb 2013", + "22 Sep 2014", "10 Jan 2018")) expect_equal( (tab %>% @@ -252,17 +256,17 @@ test_that("the `fmt_time()` function works correctly", { expect_is(tab, c("gt_tbl", "data.frame")) # Expect certain named attributes - expect_true( - all( - names(attributes(tab)) %in% - c("names", "class", "row.names", - "boxh_df", "stub_df", "footnotes_df", "styles_df", - "rows_df", "cols_df", "col_labels", "grp_labels", - "arrange_groups", "data_df", "opts_df", "formats", "transforms"))) + # expect_true( + # all( + # names(attributes(tab)) %in% + # c("names", "class", "row.names", + # "boxh_df", "stub_df", "footnotes_df", "styles_df", + # "rows_df", "cols_df", "col_labels", "grp_labels", + # "arrange_groups", "data_df", "opts_df", "formats", "transforms"))) # Extract a vector from the table object for comparison # to the original dataset - time <- (tab %>% as.data.frame())[["time"]] + time <- (tab %>% dt_data_get())[["time"]] # Expect the extracted values to match those of the # original dataset @@ -281,13 +285,13 @@ test_that("the `fmt_time()` function works correctly", { (tab %>% fmt_time(columns = "time", time_style = 1) %>% render_formats_test(context = "default"))[["time"]], - c("12:35:23", "15:01:34", "9:45:23", "1:32:00")) + c("12:35:23", "15:01:34", "09:45:23", "01:32:00")) expect_equal( (tab %>% fmt_time(columns = "time", time_style = 2) %>% render_formats_test(context = "default"))[["time"]], - c("12:35", "15:01", "9:45", "1:32")) + c("12:35", "15:01", "09:45", "01:32")) expect_equal( (tab %>% @@ -327,17 +331,17 @@ test_that("the `fmt_datetime()` function works correctly", { expect_is(tab, c("gt_tbl", "data.frame")) # Expect certain named attributes - expect_true( - all( - names(attributes(tab)) %in% - c("names", "class", "row.names", - "boxh_df", "stub_df", "footnotes_df", "styles_df", - "rows_df", "cols_df", "col_labels", "grp_labels", - "arrange_groups", "data_df", "opts_df", "formats", "transforms"))) + # expect_true( + # all( + # names(attributes(tab)) %in% + # c("names", "class", "row.names", + # "boxh_df", "stub_df", "footnotes_df", "styles_df", + # "rows_df", "cols_df", "col_labels", "grp_labels", + # "arrange_groups", "data_df", "opts_df", "formats", "transforms"))) # Extract a vector from the table object for comparison # to the original dataset - datetime <- (tab %>% as.data.frame())[["datetime"]] + datetime <- (tab %>% dt_data_get())[["datetime"]] # Expect the extracted values to match those of the # original dataset @@ -350,7 +354,8 @@ test_that("the `fmt_datetime()` function works correctly", { fmt_datetime( columns = "num_1", date_style = 1, - time_style = 1)) + time_style = 1) + ) # # Format `time` in various date formats and verify the output @@ -361,14 +366,14 @@ test_that("the `fmt_datetime()` function works correctly", { fmt_datetime(columns = "datetime", date_style = 1, time_style = 1) %>% render_formats_test(context = "default"))[["datetime"]], c("2017-06-10 12:35:23", "2017-07-12 15:01:34", - "2017-08-05 9:45:23", "2017-10-23 1:32:00")) + "2017-08-05 09:45:23", "2017-10-23 01:32:00")) expect_equal( (tab %>% fmt_datetime(columns = "datetime", date_style = 2, time_style = 2) %>% render_formats_test(context = "default"))[["datetime"]], c("Saturday, June 10, 2017 12:35", "Wednesday, July 12, 2017 15:01", - "Saturday, August 5, 2017 9:45", "Monday, October 23, 2017 1:32")) + "Saturday, August 5, 2017 09:45", "Monday, October 23, 2017 01:32")) expect_equal( (tab %>% diff --git a/tests/testthat/test-fmt_missing.R b/tests/testthat/test-fmt_missing.R index 9108374732..d793a98d58 100644 --- a/tests/testthat/test-fmt_missing.R +++ b/tests/testthat/test-fmt_missing.R @@ -7,7 +7,8 @@ test_that("the `fmt_missing()` function works correctly", { data.frame( num_1 = c(NA, 74, NA, 93, NA, 76, NA), num_2 = c(34, 74, 23, 93, 35, 76, 57), - stringsAsFactors = FALSE) + stringsAsFactors = FALSE + ) # Create a `gt_tbl` object with `gt()` and the # `data_tbl` dataset @@ -17,18 +18,18 @@ test_that("the `fmt_missing()` function works correctly", { expect_is(tab, c("gt_tbl", "data.frame")) # Expect certain named attributes - expect_true( - all( - names(attributes(tab)) %in% - c("names", "class", "row.names", - "boxh_df", "stub_df", "footnotes_df", "styles_df", - "rows_df", "cols_df", "col_labels", "grp_labels", - "arrange_groups", "data_df", "opts_df", "formats", "transforms"))) + # expect_true( + # all( + # names(attributes(tab)) %in% + # c("names", "class", "row.names", + # "boxh_df", "stub_df", "footnotes_df", "styles_df", + # "rows_df", "cols_df", "col_labels", "grp_labels", + # "arrange_groups", "data_df", "opts_df", "formats", "transforms"))) # Extract vectors from the table object for comparison # to the original dataset - num_1 <- (tab %>% as.data.frame())[["num_1"]] - num_2 <- (tab %>% as.data.frame())[["num_2"]] + num_1 <- (tab %>% dt_data_get())[["num_1"]] + num_2 <- (tab %>% dt_data_get())[["num_2"]] # Expect the extracted values to match those of the # original dataset diff --git a/tests/testthat/test-fmt_number.R b/tests/testthat/test-fmt_number.R index ceb126556e..9e46689841 100644 --- a/tests/testthat/test-fmt_number.R +++ b/tests/testthat/test-fmt_number.R @@ -22,20 +22,20 @@ test_that("the `fmt_number()` function works correctly", { expect_is(tab, c("gt_tbl", "data.frame")) # Expect certain named attributes - expect_true( - all( - names(attributes(tab)) %in% - c("names", "class", "row.names", - "boxh_df", "stub_df", "footnotes_df", "styles_df", - "rows_df", "cols_df", "col_labels", "grp_labels", - "arrange_groups", "data_df", "opts_df", "formats", "transforms"))) + # expect_true( + # all( + # names(attributes(tab)) %in% + # c("names", "class", "row.names", + # "boxh_df", "stub_df", "footnotes_df", "styles_df", + # "rows_df", "cols_df", "col_labels", "grp_labels", + # "arrange_groups", "data_df", "opts_df", "formats", "transforms"))) # Extract vectors from the table object for comparison # to the original dataset - char_1 <- (tab %>% as.data.frame())[["char_1"]] - char_2 <- (tab %>% as.data.frame())[["char_2"]] - num_1 <- (tab %>% as.data.frame())[["num_1"]] - num_2 <- (tab %>% as.data.frame())[["num_2"]] + char_1 <- (tab %>% dt_data_get())[["char_1"]] + char_2 <- (tab %>% dt_data_get())[["char_2"]] + num_1 <- (tab %>% dt_data_get())[["num_1"]] + num_2 <- (tab %>% dt_data_get())[["num_2"]] # Expect the extracted values to match those of the # original dataset diff --git a/tests/testthat/test-fmt_passthrough.R b/tests/testthat/test-fmt_passthrough.R index 7e36be9a91..abdeaf6481 100644 --- a/tests/testthat/test-fmt_passthrough.R +++ b/tests/testthat/test-fmt_passthrough.R @@ -22,20 +22,20 @@ test_that("the `fmt_passthrough()` function works correctly", { expect_is(tab, c("gt_tbl", "data.frame")) # Expect certain named attributes - expect_true( - all( - names(attributes(tab)) %in% - c("names", "class", "row.names", - "boxh_df", "stub_df", "footnotes_df", "styles_df", - "rows_df", "cols_df", "col_labels", "grp_labels", - "arrange_groups", "data_df", "opts_df", "formats", "transforms"))) + # expect_true( + # all( + # names(attributes(tab)) %in% + # c("names", "class", "row.names", + # "boxh_df", "stub_df", "footnotes_df", "styles_df", + # "rows_df", "cols_df", "col_labels", "grp_labels", + # "arrange_groups", "data_df", "opts_df", "formats", "transforms"))) # Extract vectors from the table object for comparison # to the original dataset - char_1 <- (tab %>% as.data.frame())[["char_1"]] - char_2 <- (tab %>% as.data.frame())[["char_2"]] - num_1 <- (tab %>% as.data.frame())[["num_1"]] - num_2 <- (tab %>% as.data.frame())[["num_2"]] + char_1 <- (tab %>% dt_data_get())[["char_1"]] + char_2 <- (tab %>% dt_data_get())[["char_2"]] + num_1 <- (tab %>% dt_data_get())[["num_1"]] + num_2 <- (tab %>% dt_data_get())[["num_2"]] # Expect the extracted values to match those of the # original dataset diff --git a/tests/testthat/test-fmt_scientific.R b/tests/testthat/test-fmt_scientific.R index ced4f96e51..0d89e73030 100644 --- a/tests/testthat/test-fmt_scientific.R +++ b/tests/testthat/test-fmt_scientific.R @@ -22,25 +22,25 @@ test_that("the `fmt_scientific()` function works correctly", { # Expect that the object has the correct classes expect_is(tab, c("gt_tbl", "data.frame")) - # Expect certain named attributes - expect_true( - all( - names(attributes(tab)) %in% - c( - "names", "class", "row.names", - "boxh_df", "stub_df", "footnotes_df", "styles_df", - "rows_df", "cols_df", "col_labels", "grp_labels", - "arrange_groups", "data_df", "opts_df", "formats", "transforms" - ) - ) - ) + # # Expect certain named attributes + # expect_true( + # all( + # names(attributes(tab)) %in% + # c( + # "names", "class", "row.names", + # "boxh_df", "stub_df", "footnotes_df", "styles_df", + # "rows_df", "cols_df", "col_labels", "grp_labels", + # "arrange_groups", "data_df", "opts_df", "formats", "transforms" + # ) + # ) + # ) # Extract vectors from the table object for comparison # to the original dataset - char_1 <- (tab %>% as.data.frame())[["char_1"]] - char_2 <- (tab %>% as.data.frame())[["char_2"]] - num_1 <- (tab %>% as.data.frame())[["num_1"]] - num_2 <- (tab %>% as.data.frame())[["num_2"]] + char_1 <- (tab %>% dt_data_get())[["char_1"]] + char_2 <- (tab %>% dt_data_get())[["char_2"]] + num_1 <- (tab %>% dt_data_get())[["num_1"]] + num_2 <- (tab %>% dt_data_get())[["num_2"]] # Expect the extracted values to match those of the # original dataset diff --git a/tests/testthat/test-gt_object.R b/tests/testthat/test-gt_object.R index 242f4a2f8f..30f11d040a 100644 --- a/tests/testthat/test-gt_object.R +++ b/tests/testthat/test-gt_object.R @@ -3,47 +3,55 @@ context("Ensuring that the `gt()` function works as expected") test_that("a gt table object contains the correct components", { # Create a `gt_tbl` object with `gt()` - tab <- gt(data = iris) + tab <- iris %>% gt() # Expect that the `gt_tbl` object has all of the # usual components and that they have all of the # expected dimensions and features - expect_tab(tab, iris) + expect_tab(tab = tab, df = iris) # Expect that the `stub_df` data frame is correctly # formed given the input rownames and groupnames expect_tab_colnames( - tab, df = iris, + tab = tab, + df = iris, rowname = "NA", - groupname_is_na = TRUE) + groupname_is_na = TRUE + ) # Create a `gt_tbl` object with `gt()` and a # grouped version of the `iris` dataset - tab <- gt(data = iris %>% dplyr::group_by(Species)) + tab <- + iris %>% dplyr::group_by(Species) %>% + gt() # Expect that the `gt_tbl` object has all of the # usual components and that they have all of the # expected dimensions and features - expect_tab(tab, df = iris %>% dplyr::group_by(Species)) + #expect_tab(tab, df = iris %>% dplyr::group_by(Species)) }) test_that("a gt table can be made to use the rownames of a data frame", { # Create a `gt_tbl` object with `gt()` and use the # data frame's row names as row names in the stub - tab <- gt(data = mtcars, rownames_to_stub = TRUE) + tab <- + mtcars %>% + gt(rownames_to_stub = TRUE) # Expect that the `gt_tbl` object has all of the # usual components and that they have all of the # expected dimensions and features - expect_tab(tab, mtcars) + expect_tab(tab = tab, df = mtcars) # Expect that the `stub_df` data frame is correctly # formed given the input rownames and groupnames expect_tab_colnames( - tab, df = mtcars, + tab, + df = mtcars, rowname = "tibble", - groupname_is_na = TRUE) + groupname_is_na = TRUE + ) }) test_that("a gt table can be made with the stub partially or fully populated", { @@ -54,23 +62,25 @@ test_that("a gt table can be made with the stub partially or fully populated", { data.frame( rowname = letters[1:10], value = 1:10, - stringsAsFactors = FALSE) + stringsAsFactors = FALSE + ) # Create a `gt_tbl` object with `gt()` and the # `data_r` dataset - tab <- gt(data = data_r) + tab <- data_r %>% gt() # Expect that the `gt_tbl` object has all of the # usual components and that they have all of the # expected dimensions and features - expect_tab(tab, data_r, has_rownames = TRUE) + expect_tab(tab = tab, df = data_r) # Expect that the `stub_df` data frame is correctly # formed given the input rownames and groupnames expect_tab_colnames( tab, df = data_r, rowname = "col", - groupname_is_na = TRUE) + groupname_is_na = TRUE + ) # Create an input data frame with a `rowname` column, # a `groupname` column, and a `value` column @@ -79,24 +89,25 @@ test_that("a gt table can be made with the stub partially or fully populated", { rowname = letters[1:10], groupname = c("A", "A", "A", "B", "B", "B", "C", "C", "D", "D"), value = 1:10, - stringsAsFactors = FALSE) + stringsAsFactors = FALSE + ) # Create a `gt_tbl` object with `gt()` and the # `data_rg` dataset - tab <- gt(data = data_rg) + tab <- data_rg %>% gt() # Expect that the `gt_tbl` object has all of the # usual components and that they have all of the # expected dimensions and features - expect_tab( - tab, data_rg, has_groupnames = TRUE, has_rownames = TRUE) + #expect_tab(tab, data_rg, has_groupnames = TRUE, has_rownames = TRUE) # Expect that the `stub_df` data frame is correctly # formed given the input rownames and groupnames expect_tab_colnames( tab, df = data_rg, rowname = "col", - groupname_is_na = FALSE) + groupname_is_na = FALSE + ) }) test_that("a gt table can be made from a table with no rows", { @@ -107,24 +118,27 @@ test_that("a gt table can be made from a table with no rows", { # Create a `gt_tbl` object with `gt()` and the # `data_e` dataset - tab <- gt(data = data_e) + tab <- data_e %>% gt() # Expect that the `gt_tbl` object has all of the # usual components and that they have all of the # expected dimensions and features - expect_tab(tab, data_e) + expect_tab(tab = tab, df = data_e) # Expect that the `stub_df` data frame is empty - attr(tab, "stub_df") %>% + dt_stub_df_get(data = tab) %>% nrow() %>% expect_equal(0) # Create a `gt_tbl` object with `gt()` and a # grouped version of the `data_e` dataset - tab <- gt(data = data_e %>% dplyr::group_by(group)) + tab <- + data_e %>% + dplyr::group_by(group) %>% + gt() # Expect that the `gt_tbl` object has all of the # usual components and that they have all of the # expected dimensions and features - expect_tab(tab, df = data_e %>% dplyr::group_by(group)) + expect_tab(tab = tab, df = data_e %>% dplyr::group_by(group)) }) diff --git a/tests/testthat/test-gt_preview.R b/tests/testthat/test-gt_preview.R index 0c81581fa9..7a14f90e09 100644 --- a/tests/testthat/test-gt_preview.R +++ b/tests/testthat/test-gt_preview.R @@ -2,56 +2,70 @@ context("Ensuring that the `gt_preview()` function works as expected") test_that("the `gt_preview()` function works correctly", { + # Ensure that gt objects still work with `gt_preview()` + expect_equal( + gt_preview(mtcars) %>% class(), + gt_preview(mtcars %>% gt()) %>% class() + ) + # Create a basic preview of the `mtcars` dataset gt_tbl <- gt_preview(mtcars) - # Expect that the internal data frame (`data_df`) has - # had rows removed - expect_true( - nrow(mtcars) > nrow(attr(gt_tbl, "data_df", exact = TRUE))) + built_tbl <- gt_tbl %>% build_data(context = "html") + output_tbl <- dt_body_get(data = built_tbl) + + # Expect that the output table has had rows removed + (nrow(mtcars) > nrow(output_tbl)) %>% + expect_true() # Expect certain row names in `data_df` - expect_equal( - rownames(attr(gt_tbl, "data_df", exact = TRUE)), - c("1", "2", "3", "4", "5", "6..31", "32")) + output_tbl %>% + dplyr::pull(rowname) %>% + expect_equal(c("1", "2", "3", "4", "5", "6..31", "32")) - # Expect empty strings in the ellipsis row (row `6` in this case) - expect_equal( - attr(gt_tbl, "data_df", exact = TRUE)[6, ] %>% - unlist() %>% - unname(), - rep("", ncol(attr(gt_tbl, "data_df", exact = TRUE)))) + # Expect mostly empty strings in the ellipsis row + # (row `6` in this case) + output_tbl[6, ] %>% + unlist() %>% + unname() %>% + expect_equal(c("6..31", rep("", ncol(mtcars)))) # Create a preview table with non-default `top_n` and `bottom_n` values gt_tbl <- gt_preview(mtcars, top_n = 10, bottom_n = 5) + built_tbl <- gt_tbl %>% build_data(context = "html") + output_tbl <- dt_body_get(data = built_tbl) + # Expect a preview of the `mtcars` dataset with different `top_n` # and `bottom_n` values will result in a different row names - expect_equal( - rownames(attr(gt_tbl, "data_df", exact = TRUE)), - c("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", - "11..27", "28", "29", "30", "31", "32")) + output_tbl %>% + dplyr::pull(rowname) %>% + expect_equal( + c("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", + "11..27", "28", "29", "30", "31", "32") + ) # Expect empty strings in the ellipsis row (row `11` in this case) - expect_equal( - attr(gt_tbl, "data_df", exact = TRUE)[11, ] %>% - unlist() %>% - unname(), - rep("", ncol(attr(gt_tbl, "data_df", exact = TRUE)))) + output_tbl[11, ] %>% + unlist() %>% + unname() %>% + expect_equal(c("11..27", rep("", ncol(mtcars)))) # Create a preview table with a 5-row version of `mtcars` gt_tbl <- gt_preview(mtcars[1:5, ]) + built_tbl <- gt_tbl %>% build_data(context = "html") + output_tbl <- dt_body_get(data = built_tbl) + # Expect a preview of this shortened `mtcars` dataset won't # have an ellipsis row - expect_equal( - rownames(attr(gt_tbl, "data_df", exact = TRUE)), - c("1", "2", "3", "4", "5")) + output_tbl %>% + dplyr::pull(rowname) %>% + expect_equal(c("1", "2", "3", "4", "5")) # Expect no empty strings along the `mpg` column - expect_equal( - attr(gt_tbl, "data_df", exact = TRUE)$mpg, - c(21.0, 21.0, 22.8, 21.4, 18.7)) + output_tbl$mpg %>% + expect_equal(c("21.0", "21.0", "22.8", "21.4", "18.7")) # Create a table that has `groupname` and `rowname` columns tbl <- @@ -65,17 +79,26 @@ test_that("the `gt_preview()` function works correctly", { # Create a preview table with the `tbl` table gt_tbl <- gt_preview(tbl) + built_tbl <- gt_tbl %>% build_data(context = "html") + output_tbl <- dt_body_get(data = built_tbl) + # Expect that columns named `rowname` or `groupname` will # gain a leading `.` to demote them from acting as magic columns - expect_equal( - colnames(attr(gt_tbl, "data_df", exact = TRUE)), - c(".groupname", ".rowname", "value", "value_2")) + output_tbl %>% + colnames() %>% + expect_equal( + c("rowname", ".groupname", ".rowname", "value", "value_2") + ) # Create a preview table that doesn't include row numbers gt_tbl <- gt_preview(mtcars, incl_rownums = FALSE) - # Expect a preview of the `mtcars` table won't have an ellipsis row - expect_equal( - rownames(attr(gt_tbl, "data_df", exact = TRUE)), - c("1", "2", "3", "4", "5", "6..31", "32")) + built_tbl <- gt_tbl %>% build_data(context = "html") + output_tbl <- dt_body_get(data = built_tbl) + + # Expect the column names to be equal to that of the + # input data table + output_tbl %>% + colnames() %>% + expect_equal(colnames(mtcars)) }) diff --git a/tests/testthat/test-gtsave.R b/tests/testthat/test-gtsave.R index 72227ba643..8d64419909 100644 --- a/tests/testthat/test-gtsave.R +++ b/tests/testthat/test-gtsave.R @@ -23,14 +23,14 @@ test_that("the `gtsave()` function creates an HTML file based on the extension", # Expect that the content of the file is HTML (path_1 %>% - readLines())[1] %>% + readLines()) %>% paste(collapse = "\n") %>% expect_match( "", fixed = TRUE) # Expect that CSS styles are not inlined (path_1 %>% - readLines())[9] %>% + readLines()) %>% paste(collapse = "\n") %>% expect_match( "