Repository: jthomasmock/gtExtras Branch: master Commit: 00150a480096 Files: 185 Total size: 502.5 KB Directory structure: gitextract_a09k_ywq/ ├── .Rbuildignore ├── .github/ │ ├── .gitignore │ ├── ISSUE_TEMPLATE/ │ │ ├── bug.md │ │ ├── feature.md │ │ └── question.md │ └── workflows/ │ ├── R-CMD-check.yaml │ └── pkgdown.yaml ├── .gitignore ├── DESCRIPTION ├── LICENSE ├── LICENSE.md ├── NAMESPACE ├── NEWS.md ├── R/ │ ├── fmt_pad_num.R │ ├── fmt_pct_extra.R │ ├── fmt_symbol_first.R │ ├── fontawesome-icons.R │ ├── generate_df.R │ ├── get_row_index.R │ ├── gt-bar-html.R │ ├── gtExtras-package.R │ ├── gt_add_divider.R │ ├── gt_alert_icon.R │ ├── gt_color_box.R │ ├── gt_color_rows.R │ ├── gt_dot_bar.R │ ├── gt_dt__.R │ ├── gt_dt_data.R │ ├── gt_duplicate_column.R │ ├── gt_highlight_cols.R │ ├── gt_highlight_rows.R │ ├── gt_hulk_color.R │ ├── gt_image_multi_rows.R │ ├── gt_image_rows.R │ ├── gt_img_circle.R │ ├── gt_index.R │ ├── gt_pct_bar.R │ ├── gt_plt_bar.R │ ├── gt_plt_bullet.R │ ├── gt_plt_conf_int.R │ ├── gt_plt_dist.R │ ├── gt_plt_dumbbell.R │ ├── gt_plt_percentile_dot.R │ ├── gt_plt_point.R │ ├── gt_plt_sparkline.R │ ├── gt_reprex_image.R │ ├── gt_resolver.R │ ├── gt_summary_table.R │ ├── gt_text_img.R │ ├── gt_theme_538.R │ ├── gt_theme_dark.R │ ├── gt_theme_dot_matrix.R │ ├── gt_theme_espn.R │ ├── gt_theme_excel.R │ ├── gt_theme_guardian.R │ ├── gt_theme_nytimes.R │ ├── gt_theme_pff.R │ ├── gt_vendor.R │ ├── gt_win_loss.R │ ├── gtsave_extra.R │ ├── html-helpers.R │ ├── icon_fun.R │ ├── img_header.R │ ├── last_row_id.R │ ├── merge_and_stack.R │ ├── pad_fn.R │ ├── reexports.R │ ├── sysdata.rda │ ├── tab_style_by_grp.R │ ├── two-column-layouts.R │ └── utils.R ├── README.Rmd ├── README.md ├── _pkgdown.yml ├── codecov.yml ├── cran-comments.md ├── data-raw/ │ ├── x06-css-colors.R │ └── zz_process_datasets_ext.R ├── man/ │ ├── add_badge_color.Rd │ ├── add_pcttile_plot.Rd │ ├── add_point_plot.Rd │ ├── add_text_img.Rd │ ├── create_sum_table.Rd │ ├── fa_icon_repeat.Rd │ ├── fmt_pad_num.Rd │ ├── fmt_pct_extra.Rd │ ├── fmt_symbol_first.Rd │ ├── generate_df.Rd │ ├── get_row_index.Rd │ ├── gtExtras-package.Rd │ ├── gt_add_divider.Rd │ ├── gt_alert_icon.Rd │ ├── gt_badge.Rd │ ├── gt_color_box.Rd │ ├── gt_color_rows.Rd │ ├── gt_double_table.Rd │ ├── gt_duplicate_column.Rd │ ├── gt_fa_rank_change.Rd │ ├── gt_fa_rating.Rd │ ├── gt_highlight_cols.Rd │ ├── gt_highlight_rows.Rd │ ├── gt_hulk_col_numeric.Rd │ ├── gt_hyperlink.Rd │ ├── gt_img_border.Rd │ ├── gt_img_circle.Rd │ ├── gt_img_multi_rows.Rd │ ├── gt_img_rows.Rd │ ├── gt_index.Rd │ ├── gt_label_details.Rd │ ├── gt_merge_stack.Rd │ ├── gt_merge_stack_color.Rd │ ├── gt_plt_bar.Rd │ ├── gt_plt_bar_pct.Rd │ ├── gt_plt_bar_stack.Rd │ ├── gt_plt_bullet.Rd │ ├── gt_plt_conf_int.Rd │ ├── gt_plt_dist.Rd │ ├── gt_plt_dot.Rd │ ├── gt_plt_dumbbell.Rd │ ├── gt_plt_percentile.Rd │ ├── gt_plt_point.Rd │ ├── gt_plt_sparkline.Rd │ ├── gt_plt_summary.Rd │ ├── gt_plt_winloss.Rd │ ├── gt_reprex_image.Rd │ ├── gt_theme_538.Rd │ ├── gt_theme_dark.Rd │ ├── gt_theme_dot_matrix.Rd │ ├── gt_theme_espn.Rd │ ├── gt_theme_excel.Rd │ ├── gt_theme_guardian.Rd │ ├── gt_theme_nytimes.Rd │ ├── gt_theme_pff.Rd │ ├── gt_two_column_layout.Rd │ ├── gtsave_extra.Rd │ ├── img_header.Rd │ ├── last_row_id.Rd │ ├── n_decimals.Rd │ ├── pad_fn.Rd │ ├── plot_data.Rd │ ├── reexports.Rd │ ├── tab_style_by_grp.Rd │ └── with_tooltip.Rd ├── tests/ │ ├── testthat/ │ │ ├── helper.R │ │ ├── test-fmt_pad_num.R │ │ ├── test-fmt_pct_extra.R │ │ ├── test-fmt_symbol_first.R │ │ ├── test-fontawesome-icons.R │ │ ├── test-generate_df.R │ │ ├── test-gt-bar-html.R │ │ ├── test-gt_add_divider.R │ │ ├── test-gt_color_box.R │ │ ├── test-gt_color_rows.R │ │ ├── test-gt_dot_bar.R │ │ ├── test-gt_duplicate_column.R │ │ ├── test-gt_highlight_cols.R │ │ ├── test-gt_highlight_rows.R │ │ ├── test-gt_hulk_color.R │ │ ├── test-gt_image_multi_rows.R │ │ ├── test-gt_image_rows.R │ │ ├── test-gt_img_circle.R │ │ ├── test-gt_index.R │ │ ├── test-gt_pct_bar.R │ │ ├── test-gt_plt_bar.R │ │ ├── test-gt_plt_bullet.R │ │ ├── test-gt_plt_conf_int.R │ │ ├── test-gt_plt_dist.R │ │ ├── test-gt_plt_percentile_dot.R │ │ ├── test-gt_plt_point.R │ │ ├── test-gt_plt_sparkline.R │ │ ├── test-gt_summary_table.R │ │ ├── test-gt_text_img.R │ │ ├── test-gt_win_loss.R │ │ ├── test-gtsave_extra.R │ │ ├── test-html-helpers.R │ │ ├── test-icon_fun.R │ │ ├── test-img_header.R │ │ ├── test-merge_and_stack.R │ │ ├── test-tab_style_by_grp.R │ │ ├── test-two-column-layouts.R │ │ ├── test-utils.R │ │ └── test_test-gt_pct_bar.R │ └── testthat.R └── vignettes/ ├── .gitignore └── articles/ └── plotting-with-gtExtras.Rmd ================================================ FILE CONTENTS ================================================ ================================================ FILE: .Rbuildignore ================================================ ^.*\.Rproj$ ^\.Rproj\.user$ ^README\.Rmd$ ^LICENSE\.md$ ^doc$ ^docs$ ^images$ ^Meta$ ^codecov\.yml$ ^_pkgdown\.yaml$ ^.covrignore$ ^_pkgdown\.yml$ ^pkgdown$ ^\.github$ ^vignettes/articles$ ^cran-comments\.md$ ^CRAN-SUBMISSION$ ^meta_fns$ ^data-raw$ ^revdep$ ================================================ FILE: .github/.gitignore ================================================ *.html ================================================ FILE: .github/ISSUE_TEMPLATE/bug.md ================================================ --- name: Bug about: Something is wrong with gtExtras. title: '' labels: 'Type: ☹︎ Bug' assignees: jthomasmock --- ## Prework * [ ] If there is [already a relevant issue](https://github.com/jthomasmock/gtExtras/issues), whether open or closed, comment on the existing thread instead of posting a new issue. * [ ] Post a [minimal reproducible example](https://www.tidyverse.org/help/) so the maintainer can troubleshoot the problems you identify. A reproducible example is: * **Runnable**: post enough R code and data so any onlooker can create the error on their own computer. * **Minimal**: reduce runtime wherever possible and remove complicated details that are irrelevant to the issue at hand. * **Readable**: format your code according to the [tidyverse style guide](https://style.tidyverse.org/). ## Description Describe the bug clearly and concisely. ## Reproducible example * [ ] Post a [minimal reproducible example](https://www.tidyverse.org/help/) so the maintainer can troubleshoot the problems you identify. A reproducible example is: * [ ] **Runnable**: post enough R code and data so any onlooker can create the error on their own computer. * [ ] **Minimal**: reduce runtime wherever possible and remove complicated details that are irrelevant to the issue at hand. * [ ] **Readable**: format your code according to the [tidyverse style guide](https://style.tidyverse.org/). ## Expected result What should have happened? Please be as specific as possible. ## Session info End the reproducible example with a call to `sessionInfo()` in the same session (e.g. `reprex(session_info = TRUE)`) and include the output. ================================================ FILE: .github/ISSUE_TEMPLATE/feature.md ================================================ --- name: New feature about: Suggest a new feature. title: '' labels: 'Type: ★ Enhancement' assignees: jthomasmock --- ## Prework - [ ] Search for duplicates among the [existing issues](https://github.com/jthomasmock/gtExtras/issues) (both open and closed). ## Proposal Describe the new feature clearly and concisely. If applicable, write a minimal example in R code or pseudo-code to show input, usage, and desired output. To help us read any code you include (optional) please try to follow the [tidyverse style guide](https://style.tidyverse.org/). The `style_text()` and `style_file()` functions from the [`styler`](https://github.com/r-lib/styler) package make it easier. ================================================ FILE: .github/ISSUE_TEMPLATE/question.md ================================================ --- name: Question about: Ask a question. title: '' labels: 'Type: ⁇ Question' assignees: '' --- ## Prework * [ ] If there is [already a relevant issue](https://github.com/jthomasmock/gtExtras/issues), whether open or closed, comment on the existing thread instead of posting a new issue. * [ ] For any problems you identify, a [minimal reproducible example](https://www.tidyverse.org/help/) so the maintainer can troubleshoot. A reproducible example is: * **Runnable**: post enough R code and data so any onlooker can create the error on their own computer. * **Minimal**: reduce runtime wherever possible and remove complicated details that are irrelevant to the issue at hand. * **Readable**: format your code according to the [tidyverse style guide](https://style.tidyverse.org/). ## Question What would you like to know? ## Reproducible example * [ ] For any problems you identify, post a [minimal reproducible example](https://www.tidyverse.org/help/) so the maintainer can troubleshoot. A reproducible example is: * [ ] **Runnable**: post enough R code and data so any onlooker can create the error on their own computer. * [ ] **Minimal**: reduce runtime wherever possible and remove complicated details that are irrelevant to the issue at hand. * [ ] **Readable**: format your code according to the [tidyverse style guide](https://style.tidyverse.org/). ================================================ FILE: .github/workflows/R-CMD-check.yaml ================================================ # Workflow derived from https://github.com/r-lib/actions/tree/master/examples # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help on: push: branches: [main, master] pull_request: branches: [main, master] name: R-CMD-check jobs: R-CMD-check: runs-on: ${{ matrix.config.os }} name: ${{ matrix.config.os }} (${{ matrix.config.r }}) strategy: fail-fast: false matrix: config: - {os: macos-latest, r: 'release'} - {os: windows-latest, r: 'release'} - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} - {os: ubuntu-latest, r: 'release'} - {os: ubuntu-latest, r: 'oldrel-1'} env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} R_KEEP_PKG_SOURCE: yes steps: - uses: actions/checkout@v2 - uses: r-lib/actions/setup-pandoc@v2 - uses: r-lib/actions/setup-r@v2 with: r-version: ${{ matrix.config.r }} http-user-agent: ${{ matrix.config.http-user-agent }} use-public-rspm: true - uses: r-lib/actions/setup-r-dependencies@v2 with: extra-packages: rcmdcheck - uses: r-lib/actions/check-r-package@v2 ================================================ FILE: .github/workflows/pkgdown.yaml ================================================ # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help on: push: branches: [main, master] pull_request: branches: [main, master] release: types: [published] workflow_dispatch: name: pkgdown jobs: pkgdown: runs-on: ubuntu-latest # Only restrict concurrency for non-PR jobs concurrency: group: pkgdown-${{ github.event_name != 'pull_request' || github.run_id }} env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} steps: - uses: actions/checkout@v2 - uses: r-lib/actions/setup-pandoc@v2 - uses: r-lib/actions/setup-r@v2 with: use-public-rspm: true - uses: r-lib/actions/setup-r-dependencies@v2 with: extra-packages: any::pkgdown, local::. needs: website - name: Build site run: pkgdown::build_site_github_pages(new_process = FALSE, install = FALSE) shell: Rscript {0} - name: Deploy to GitHub pages 🚀 if: github.event_name != 'pull_request' uses: JamesIves/github-pages-deploy-action@4.1.4 with: clean: false branch: gh-pages folder: docs ================================================ FILE: .gitignore ================================================ .Rproj.user .covrignore .Rhistory .RData .Ruserdata .Rdata .httr-oauth .DS_Store gtExtras.Rproj inst/doc /doc/ /Meta/ docs CRAN-SUBMISSION /meta_fns/ /revdep/ .env logs/ __pycache__/ ================================================ FILE: DESCRIPTION ================================================ Type: Package Package: gtExtras Title: Extending 'gt' for Beautiful HTML Tables Version: 0.6.2 Authors@R: c( person("Thomas", "Mock", , "j.thomasmock@gmail.com", role = c("aut", "cre", "cph")), person("Daniel D.", "Sjoberg", , "danield.sjoberg@gmail.com", role = "ctb", comment = c(ORCID = "0000-0003-0862-2018")) ) Description: Provides additional functions for creating beautiful tables with 'gt'. The functions are generally wrappers around boilerplate or adding opinionated niche capabilities and helpers functions. License: MIT + file LICENSE URL: https://github.com/jthomasmock/gtExtras, https://jthomasmock.github.io/gtExtras/ BugReports: https://github.com/jthomasmock/gtExtras/issues Depends: R (>= 3.6.0), gt (>= 1.0.0) Imports: commonmark, dplyr (>= 1.0.9), fontawesome (>= 0.4.0), ggplot2 (>= 3.4.0), glue (>= 1.6.1), htmltools (>= 0.5.3), paletteer (>= 1.4.0), rlang (>= 1.0.4), scales (>= 1.2.0), knitr (>= 1.35), cli (>= 3.6.0) Suggests: base64enc (>= 0.1-3), bitops (>= 1.0.6), covr, fs (>= 1.5.2), hms, magrittr (>= 1.5), rvest (>= 1.0.3), sass (>= 0.1.1), stringr (>= 1.3.1), svglite (>= 2.1.0), testthat (>= 3.0.0), tibble (>= 3.0.0), tidyr (>= 1.0.0), tidyselect (>= 1.0.0), webshot2 (>= 0.1.0), xml2 (>= 1.3.3), lifecycle (>= 1.0.0) Encoding: UTF-8 Roxygen: list(markdown = TRUE) RoxygenNote: 7.3.3 Config/testthat/edition: 3 Config/testthat/parallel: true ================================================ FILE: LICENSE ================================================ YEAR: 2022 COPYRIGHT HOLDER: Thomas Mock ================================================ FILE: LICENSE.md ================================================ # MIT License Copyright (c) 2022 Thomas Mock Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ================================================ FILE: NAMESPACE ================================================ # Generated by roxygen2: do not edit by hand export("%>%") export(add_text_img) export(all_of) export(any_of) export(contains) export(create_sum_table) export(ends_with) export(everything) export(fmt_pad_num) export(fmt_pct_extra) export(fmt_symbol_first) export(generate_df) export(get_row_index) export(gt_add_divider) export(gt_alert_icon) export(gt_badge) export(gt_color_box) export(gt_color_rows) export(gt_double_table) export(gt_duplicate_column) export(gt_fa_rank_change) export(gt_fa_rating) export(gt_highlight_cols) export(gt_highlight_rows) export(gt_hulk_col_numeric) export(gt_hyperlink) export(gt_img_border) export(gt_img_circle) export(gt_img_multi_rows) export(gt_img_rows) export(gt_index) export(gt_label_details) export(gt_merge_stack) export(gt_merge_stack_color) export(gt_plt_bar) export(gt_plt_bar_pct) export(gt_plt_bar_stack) export(gt_plt_bullet) export(gt_plt_conf_int) export(gt_plt_dist) export(gt_plt_dot) export(gt_plt_dumbbell) export(gt_plt_percentile) export(gt_plt_point) export(gt_plt_sparkline) export(gt_plt_summary) export(gt_plt_winloss) export(gt_reprex_image) export(gt_theme_538) export(gt_theme_dark) export(gt_theme_dot_matrix) export(gt_theme_espn) export(gt_theme_excel) export(gt_theme_guardian) export(gt_theme_nytimes) export(gt_theme_pff) export(gt_two_column_layout) export(gtsave_extra) export(img_header) export(last_col) export(matches) export(mutate) export(n_decimals) export(num_range) export(one_of) export(pad_fn) export(select) export(starts_with) export(tab_style_by_grp) export(vars) export(with_tooltip) import(dplyr) import(ggplot2) import(glue) import(gt) import(htmltools) import(paletteer) import(rlang) import(scales) importFrom(dplyr,"%>%") importFrom(dplyr,all_of) importFrom(dplyr,any_of) importFrom(dplyr,contains) importFrom(dplyr,ends_with) importFrom(dplyr,everything) importFrom(dplyr,last_col) importFrom(dplyr,matches) importFrom(dplyr,mutate) importFrom(dplyr,num_range) importFrom(dplyr,one_of) importFrom(dplyr,select) importFrom(dplyr,starts_with) importFrom(dplyr,vars) importFrom(fontawesome,fa) importFrom(graphics,hist) importFrom(gt,"%>%") importFrom(htmltools,div) importFrom(knitr,include_graphics) importFrom(paletteer,paletteer_d) importFrom(scales,col_numeric) importFrom(scales,cut_long_scale) importFrom(scales,expand_range) importFrom(scales,label_date) importFrom(scales,label_number) importFrom(scales,seq_gradient_pal) importFrom(stats,IQR) importFrom(stats,median) importFrom(stats,na.omit) importFrom(stats,sd) importFrom(utils,capture.output) importFrom(utils,packageVersion) ================================================ FILE: NEWS.md ================================================ # gtExtras 0.6.1 * Resolve issues with ggplot2 v4 # gtExtras 0.6.0 * Handle interquartile range of zero in `gt_plt_summary()` - [#104](https://github.com/jthomasmock/gtExtras/issues/104) * Experimentally handle multiple types of plots in `gt_plt_dist()` - [#102](https://github.com/jthomasmock/gtExtras/issues/102) * Resolve issues with `gt_plt_summary()` - [#148](https://github.com/jthomasmock/gtExtras/issues/148) and [146](https://github.com/jthomasmock/gtExtras/issues/146) * Address test issues with svglite - [#147](https://github.com/jthomasmock/gtExtras/issues/147) * Remove deprecated fontawesome functions `gt_fa_repeats()`, and `gt_fa_column()` in favor of `gt` native functions. * Address CRAN issues # gtExtras 0.5.0 * Refactor NA handling in `gt_fa_` functions - thanks to @areckenrode via [#78](https://github.com/jthomasmock/gtExtras/issues/78) * Allow for all negative values in `gt_plt_bar()` - thanks to @paspvik via [#75](https://github.com/jthomasmock/gtExtras/pull/75) * Respect max and negative range of target and column values in `gt_plt_bullet()` - thanks to @zdenall via [#79](https://github.com/jthomasmock/gtExtras/issues/79) * Improve `gt_theme_538()` to better align with FiveThirtyEight style, namely improved font choices ("Cairo") * Address NAs properly in `gt_fa_rank_change()` - thanks to @moodymudskipper via [#80](https://github.com/jthomasmock/gtExtras/issues/80) * Refactor `fmt_symbol_first()` to work correctly with any font, not just monospace fonts. * Add an experimental `gt_render_reprex()` thanks to @mrcaseb suggestion on Twitter * Allow for entire NA columns in `gt_plt_bar()` and `gt_plt_bar_pct()` - [#86](https://github.com/jthomasmock/gtExtras/issues/86) * Accommodate small values in `gt_plt_bullet()` - [#87](https://github.com/jthomasmock/gtExtras/issues/87) * Address some small bugs #94 and #95 * Add an expandable tag to `gt_plt_summary()` * Add a labelling feature to `gt_plt_bar_pct()` - thanks to @andreweatherman and [PR](https://github.com/jthomasmock/gtExtras/pull/100) # gtExtras 0.4.5 * Refactor many functions to account for upstream changes in `gt` v0.8.0 * Add a `palette_col` argument to `gt_plt_bullet()` to accept a named column of palette colors as present in the data. Fixed #72 * Fix internals of `gt_theme_pff()` to use `table.font.size` inside `tab_options()` rather than `tab_style()`. Fixed #74 * Fix a few instances of `geom_line()` and `geom_v/hline()` that were throwing warnings for `ggplot2` v3.4.0 * Refactor internals of `fmt_pad_num` to align with @mrcaseb implementation * Refactor many functions that use lines with size parameter, to avoid ggplot2 v.3.4.0 deprecation warnings (affects `gt_plt_bar`, `gt_pct_bar`, `gt_plt_dist`, `gt_plt_conf_int`, `gt_plt_percentile_dot`, `gt_plt_point`, `gt_plt_sparkline`, `gt_win_loss`) # gtExtras 0.4.3 * Modify internals of `gt_fa_column()` to accept factors with levels not present in the data, ignoring unneeded levels. Thank you to @mikedolanfliss for the suggestion. * Add `gt_merge_stack_color()` to create a merge/stack with background color - per @mrcaseb and issue #71 * Add `gt_alert_icon()` to create a colored circle based on the range of values in the column. * Fix a CRAN extra check # gtExtras 0.4.2 * Rebuild docs with latest `roxygen2` to fix HTML documentation issues on CRAN * Add `gt_img_multi_rows()` courtesy of Ryan Timpe per [#63](https://github.com/jthomasmock/gtExtras/pull/63) * Add "alt" argument to `man_get_image_tag()` helper - solves CRAN HTML issues for missing alt-text * Use alt-text on `gt_plt_summary()` and `gt_plt_winloss()` # gtExtras 0.4.1 * Add explicit height argument to `gt_fa_column()` * Add `get_row_index()` to assist in applying styles to specific rows visually * Refactor `last_row_id()` to use `get_row_index()` internally. * Refactor `gt_index()` to respect multiple groups - closes [Issue #58](https://github.com/jthomasmock/gtExtras/issues/58) - thanks @jmbarbone ! * Refactor `tab_style_by_grp()` to respect multiple groups * Add NA handling to `gt_plt_conf_int()` - closes [#52](https://github.com/jthomasmock/gtExtras/issues/52) * Update readme content to reflect latest documentation * Remove `use_paletteer` argument from documentation (inline operation in function) * Convert ` ` to ` ` in `fmt_symbol_first()` and `fmt_pad_num()`, convert tests to match * Update documentation for `gt_img_circle()` * Add `gt_theme_pff()` for Pro Football Focus style tables * Add a `"pff"` palette option to `gt_color_box()` * Add new arguments to `gt_merge_stack()` per [issue 53](https://github.com/jthomasmock/gtExtras/issues/53) * Bulk update of examples sections and updated images * Remove background color from label in `gt_plt_conf_int()` - closes [#54](https://github.com/jthomasmock/gtExtras/issues/54) * Add `gt_index()` to internals of `gt_merge_stack()` to prevent incorrect arrangement when grouping data - closes [issue #55](https://github.com/jthomasmock/gtExtras/issues/55) * Corrected `gt_plt_sparkline()` where in some cases inline plots weren't respecting shared limits. # gtExtras 0.4.0 * Prep for and submit initial CRAN release :fingers-crossed: # gtExtras 0.3.9 * Renamed colors arg in `gt_merge_stack()` to be 'palette' * Renamed colors arg in `gt_plt_bullet()` to be 'palette' * Renamed pal arg in `gt_plt_sparkline()` to be 'palette' # gtExtras 0.3.8 * Renamed `colors` argument in `gt_win_loss()` to `palette` * Added NA handling to all `fontawesome::fa()` functions, ie `gt_fa_rank_change()`, `gt_fa_repeats()`, `gt_fa_column()` * Add missing data handling to more plotting functions * Refactor testing to use `webshot2::webshot()` over `webshot::webshot()` * Remove `gt_sparkline()` - functions separated into `gt_plt_sparkline()` and `gt_plt_dist()` # gtExtras 0.3.7 * Added basic support in `gt_plt_summary()` for dates/times. * Updated tests for `gt_plt_summary()` to include dates/times # gtExtras 0.3.6 * Remove `use_paletteer` arg from `gt_color_rows()` in favor of a hopefully more user friendly detection of `::` * Convert `gt_color_rows()` 'type' argument to 'pal_type' to prevent an edge-case where a column named type conflicts with the `paletteer` "type" argument per [issue #50](https://github.com/jthomasmock/gtExtras/issues/50) # gtExtras 0.3.4 * Add initial version of a `gt_plt_summary()` function, as inspired by the [Observable/SummaryTable function](https://observablehq.com/@observablehq/summary-table). * `gt_sparkline()` will be removed soon now that `bstfun`/`gtsummary` are no longer depending on it. `gt_plt_dist()` and `gt_plt_sparkline()` will be the new preferred and enhanced versions of `gt_sparkline()`. * Add tests for `gt_plt_summary()` # gtExtras 0.3.3 * Add `webshot2` as a dependency now that it's on CRAN! # gtExtras 0.3.2 * Remove `scales::scales_label_si()` in favor of `scales::label_number(scale_cut = cut_scale_short())` as the previous function was deprecated. Thanks to [@mrcaseb](https://github.com/mrcaseb) for pointing out in [Issue 48](https://github.com/jthomasmock/gtExtras/issues/48) # gtExtras 0.3 * Add [Daniel Sjoberg](https://github.com/ddsjoberg) as a contributor in honor of their major assistance with preparation towards CRAN * Move past 0.2 release into a "next stop CRAN"... hopefully * Vendor additional unexported functions from `{gt}` with attribution # gtExtras 0.2.7 * Bring in `webshot2` as a remote dependency suggest and minor changes to clean up some R checks, thanks to a PR from the great [Daniel Sjoberg](https://github.com/jthomasmock/gtExtras/pull/43). * Correct an internal bug in `gt_plt_dist()` which was failing for plotting integers. # gtExtras 0.2.6 * Exchange `webshot` for `webshot2` to enhance capabilities. Note that `webshot2` is GitHub only, install via: `remotes::install_github("rstudio/webshot2")`. This solves [issue #42](https://github.com/jthomasmock/gtExtras/issues/42). # gtExtras 0.2.5 * Updated `gt_theme_guardian()` to work with zero-length tables per [Issue 41](https://github.com/jthomasmock/gtExtras/issues/41) # gtExtras 0.2.4 * Added a `NEWS.md` file to track changes to the package. ## Bug Fixes prior to 0.2.4 * Use `gt_index` to prevent incorrect ordering of rows with `gt_plt_bar_pct()` per StackOverflow report * Remove `keep_column` argument for `gt_plt_bullet`, this functionality is able to be achieved with `gt_duplicate_column()` upstream. This also solves naming confusion as seen in [issue 37](https://github.com/jthomasmock/gtExtras/issues/37) ================================================ FILE: R/fmt_pad_num.R ================================================ #' Format numeric columns to align at decimal point without trailing zeroes #' #' @description #' This function removes repeating trailing zeroes and adds blank white space #' to align at the decimal point. #' #' @param gt_object An existing gt table object of class `gt_tbl` #' @param columns The columns to format. Can either be a series of column names provided in `c()`, a vector of column indices, or a helper function focused on selections. The select helper functions are: `starts_with()`, `ends_with()`, `contains()`, `matches()`, `one_of()`, `num_range()`, and `everything()`. #' @param nsmall The max number of decimal places to round at/display #' @param sep A character for the separator, typically `"."` or `","` #' @param pad0 A logical, indicating whether to pad the values with trailing zeros. #' @return An object of class `gt_tbl`. #' @export #' @seealso [gtExtras::pad_fn()] #' @examples #' library(gt) #' padded_tab <- data.frame(numbers = c(1.2345, 12.345, 123.45, 1234.5, 12345)) %>% #' gt() %>% #' fmt_pad_num(columns = numbers, nsmall = 4) #' @section Figures: #' \if{html}{\figure{fmt_pad_num.png}{options: style="width:500px;"}} #' #' @family Utilities #' @section Function ID: #' 2-2 fmt_pad_num <- function(gt_object, columns, sep = ".", nsmall = 2, pad0 = FALSE) { stopifnot("Table must be of class 'gt_tbl'" = "gt_tbl" %in% class(gt_object)) gt_object %>% gt::fmt( columns = {{ columns }}, fns = function(x) { padded_vals <- pad_fn(x, nsmall = nsmall, pad0 = pad0) split_vals <- strsplit(x = padded_vals, split = sep, fixed = TRUE) max_int <- max(nchar(split_vals[[1]])) max_dec <- max(nchar(split_vals[[2]])) create_spans <- function(vals) { int_prefix <- vals[[1]] dec_suffix <- ifelse(length(vals) == 2, vals[[2]], "") html_string <- glue::glue( '
{int_prefix} ', "{sep}", ' {dec_suffix}
' ) } lapply(split_vals, create_spans) } ) } ================================================ FILE: R/fmt_pct_extra.R ================================================ #' Convert to percent and show less than 1% as <1% in grey #' #' @param gt_object An existing gt table #' @param columns The columns to affect #' @param ... Additional argument passed to `scales::label_percent()` #' @param scale A number to multiply values by, defaults to 1 #' #' @return a gt table #' @export #' #' @examples #' library(gt) #' pct_tab <- dplyr::tibble(x = c(.001, .05, .008, .1, .2, .5, .9)) %>% #' gt::gt() %>% #' fmt_pct_extra(x, scale = 100, accuracy = .1) #' @family Utilities fmt_pct_extra <- function(gt_object, columns, ..., scale = 1) { gt_object %>% text_transform( locations = cells_body(columns = {{ columns }}), fn = function(x) { x <- as.double(x) x <- scales::label_percent(..., scale = scale)(x) sapply(x, function(xy) { xz <- gsub(x = xy, "%", "") %>% as.double() if (xz >= 1) { xy } else { gt::html("<1%") } }) } ) %>% cols_align("right", columns = {{ columns }}) } ================================================ FILE: R/fmt_symbol_first.R ================================================ #' Aligning first-row text only #' @description #' This is an experimental function that allows you to apply a suffix/symbol #' to only the first row of a table, and maintain the alignment with whitespace #' in the remaining rows. #' @param gt_object An existing gt table object of class `gt_tbl` #' @param column columns to apply color to with tidyeval #' @param symbol The HTML code or raw character string of the symbol being inserted, optionally #' @param suffix a suffix to add, optionally #' @param decimals the number of decimal places to round to #' @param last_row_n Defining the last row to apply this to. The function will attempt to guess the proper length, but you can always hardcode a specific length. #' @param symbol_first TRUE/FALSE - symbol before after suffix. #' @param scale_by A numeric value to multiply the values by. Useful for scaling percentages from 0 to 1 to 0 to 100. #' @param gfont A string passed to `gt::google_font()` - Existing Google Monospaced fonts are available at: [fonts.google.com](https://fonts.google.com/?category=Monospace&preview.text=0123456789&preview.text_type=custom) #' @return An object of class `gt_tbl`. #' @export #' @examples #' library(gt) #' fmted_tab <- gtcars %>% #' head() %>% #' dplyr::select(mfr, year, bdy_style, mpg_h, hp) %>% #' dplyr::mutate(mpg_h = rnorm(n = dplyr::n(), mean = 22, sd = 1)) %>% #' gt::gt() %>% #' gt::opt_table_lines() %>% #' fmt_symbol_first(column = mfr, symbol = "$", last_row_n = 6) %>% #' fmt_symbol_first(column = year, suffix = "%") %>% #' fmt_symbol_first(column = mpg_h, symbol = "%", decimals = 1) %>% #' fmt_symbol_first(hp, symbol = "°", suffix = "F", symbol_first = TRUE) #' #' @section Figures: #' \if{html}{\figure{gt_fmt_first.png}{options: style="width:500px;"}} #' #' @family Utilities #' @section Function ID: #' 2-1 fmt_symbol_first <- function( gt_object, column = NULL, # column of interest to apply to symbol = NULL, # symbol to add, optionally suffix = "", # suffix to add, optionally decimals = NULL, # number of decimal places to round to last_row_n = NULL, # what's the last row in data? symbol_first = FALSE, # symbol before or after suffix?, scale_by = NULL, # scaling value for things like percentages gfont = NULL # Google font option ) { stopifnot("Table must be of class 'gt_tbl'" = "gt_tbl" %in% class(gt_object)) # Test and error out if mandatory columns are missing stopifnot("`symbol_first` argument must be a logical" = is.logical(symbol_first)) # stopifnot("`last_row_n` argument must be specified and numeric" = is.numeric(last_row_n)) stopifnot("Input must be a gt table" = "gt_tbl" %in% class(gt_object)) decimals <- decimals # needs to type convert to double to play nicely with decimals and rounding # as it's converted to character by gt::text_transform add_to_first <- function(x, suff = suffix, symb = symbol) { if (!is.null(decimals) && !is.null(scale_by)) { # if decimal not null, convert to double x <- suppressWarnings(as.double(x) * scale_by) fmt_val <- format(x = x, nsmall = decimals, digits = decimals) } else if (!is.null(decimals) && is.null(scale_by)) { # if decimal not null, convert to double x <- suppressWarnings(as.double(x)) fmt_val <- format(x = x, nsmall = decimals, digits = decimals) } else if (is.null(decimals) && is.null(scale_by)) { fmt_val <- x } # combine the value, passed suffix, symbol -> html if (isTRUE(symbol_first)) { paste0(fmt_val, symb, suff) %>% gt::html() } else { paste0(fmt_val, suff, symb) %>% gt::html() } } # TODO remove in future? # # repeat non-breaking space for combined length of suffix + symbol # # logic is based on is a NULL passed or not # if (!is.null(symbol) | !identical(as.character(symbol), character(0))) { # suffix <- ifelse(identical(as.character(suffix), character(0)), "", suffix) # length_nbsp <- c(" ", rep(" ", nchar(suffix))) %>% # paste0(collapse = "") # } else { # suffix <- ifelse(identical(as.character(suffix), character(0)), "", suffix) # length_nbsp <- rep(" ", nchar(suffix)) %>% # paste0(collapse = "") # } # affect rows OTHER than the first row add_to_remainder <- function( x#, # TODO remove in future? # length = length_nbsp ) { if (!is.null(decimals) && !is.null(scale_by)) { # if decimal not null, convert to double x <- suppressWarnings(as.double(x) * scale_by) # then round and format ALL to force specific decimals fmt_val <- format(x = x, nsmall = decimals, digits = decimals) } else if (!is.null(decimals) && is.null(scale_by)) { # if decimal not null, convert to double x <- suppressWarnings(as.double(x)) # then round and format ALL to force specific decimals fmt_val <- format(x = x, nsmall = decimals, digits = decimals) } else if (is.null(decimals) && is.null(scale_by)) { fmt_val <- x } paste0( fmt_val, "", symbol, suffix,"" ) %>% lapply(FUN = gt::html) } # default to nrows in input data if (is.null(last_row_n)) { last_row_n <- nrow(gt_object[["_data"]]) } else { last_row_n <- last_row_n } # pass gt object # align right to make sure the spacing is meaningful tab_out <- gt_object %>% cols_align(align = "right", columns = c({{ column }})) %>% # transform first rows text_transform( locations = cells_body(c({{ column }}), rows = 1), fn = add_to_first ) %>% # transform remaining rows text_transform( locations = cells_body(c({{ column }}), rows = 2:last_row_n), fn = add_to_remainder ) if(!is.null(gfont)){ tab_out <- tab_out %>% # convert to mono-font for column of interest tab_style( style = cell_text(font = google_font(gfont)), locations = cells_body(columns = c({{ column }})) ) } tab_out } ================================================ FILE: R/fontawesome-icons.R ================================================ # #' Repeat `{fontawesome}` icons based on an integer. # #' @description # #' `r lifecycle::badge("deprecated")` # #' This function was deprecated because `gt` now has it's own robust `gt::fmt_icon()` function. # #' # #' The `gt_fa_repeats` function takes an existing `gt_tbl` object and # #' adds specific `fontawesome` to the cells. The icons are repeated according to the # #' integer that the column contains. # #' # #' @param gt_object An existing gt table object of class `gt_tbl` # #' @param column The column wherein the integers should be replaced with `{fontawesome}` icons. # #' @param name A character string indicating the name of the "`fontawesome` icon. # #' @param ... Additional arguments passed to `fontawesome::fa()` # #' @param palette Name of palette as a string. Must be either length of 1 or a vector of valid color names/hex values of equal length to the unique levels of the column (ie if there are 4 names, there need to be 4x colors). # #' @param align Character string indicating alignment of the column, defaults to "left" # #' @param direction The direction of the `paletteer` palette, should be either `-1` for reversed or the default of `1` for the existing direction. # #' @return An object of class `gt_tbl`. # #' @export # #' @section Examples: # #' ```r # #' library(gt) # #' mtcars[1:5, 1:4] %>% # #' gt() %>% # #' gt_fa_repeats(cyl, name = "car") # #' ``` # #' @section Figures: # #' \if{html}{\figure{fa-cars.png}{options: width:500px}} # #' # #' @family Utilities # #' @section Function ID: # #' 2-8 # gt_fa_repeats <- function(gt_object, column, name = NULL, ..., # palette = NULL, align = "left", # direction = 1) { # stopifnot("Table must be of class 'gt_tbl'" = "gt_tbl" %in% class(gt_object)) # lifecycle::deprecate_warn("0.5.1", "gt_fa_repeats()", "gt::fmt_icon()") # text_transform( # gt_object, # locations = cells_body(columns = {{ column }}), # fn = function(x) { # int_conv <- suppressWarnings(as.integer(x)) # int_x <- int_conv[!is.na(int_conv)] # if (is.null(palette) && length(unique(int_x)) >= 8) { # stop("Please add your own palette that is equal to the number of unique counts", call. = FALSE) # } # if (is.null(palette)) { # pal_filler <- rev(c( # "#CC79A7", "#D55E00", "#0072B2", # "#F0E442", "#009E73", "#56B4E9", # "#E69F00", "#000000" # ))[seq_along(unique(int_x))] # } else if (length(palette) == 1) { # pal_filler <- palette %>% rep(length(unique(int_x))) # } else { # pal_filler <- palette # } # lapply(X = int_conv, FUN = function(xy) { # # handle missing values # if (is_blank(xy) || is.na(xy)) { # return(gt::html(" ")) # } # fct_x <- factor(xy, levels = unique(int_x), labels = pal_filler) %>% # as.character() # fct_lvl <- suppressWarnings(unique(x[!is.na(as.integer(x))])) # stopifnot("The length of the unique elements must match the palette length" = length(fct_lvl) == length(pal_filler)) # fa_repeats <- fontawesome::fa(name, ..., fill = fct_x, height = "20px", a11y = "sem") %>% # as.character() %>% # rep(., xy) %>% # gt::html() # label <- paste(xy, name) # htmltools::div( # title = label, "aria-label" = label, role = "img", # list(fa_repeats) # ) # }) # } # ) %>% # cols_align(align = align, columns = {{ column }}) # } # #' Add `{fontawesome}` icons inside a `{gt}` column. # #' @description # #' `r lifecycle::badge("deprecated")` # #' This function was deprecated because `gt` now has it's own robust `gt::fmt_icon()` function. # #' # #' The `gt_fa_column` function takes an existing `gt_tbl` object and # #' adds specific `fontawesome` icons based on what the names in the column are. # #' The icons are colored according to a palette that the user supplies, either # #' a vector of valid colors/hex colors of length equal to the unique levels. # #' # #' @param gt_object An existing gt table object of class `gt_tbl` # #' @param column The column wherein the character strings should be replaced with their corresponding `{fontawesome}` icons. # #' @param ... Additional arguments passed to `fontawesome::fa()` # #' @param palette Name of palette as a string. Must be either length of 1 or a vector of valid color names/hex values of equal length to the unique levels of the column (ie if there are 4 names, there need to be 4x colors). Note that if you would like to specify a specific color to match a specific icon, you can also use a named vector like: `c("angle-double-up" = "#009E73", "angle-double-down" = "#D55E00","sort" = "#000000")` # #' @param align Character string indicating alignment of the column, defaults to "left" # #' @param direction The direction of the `paletteer` palette, should be either `-1` for reversed or the default of `1` for the existing direction. # #' @param height A character string indicating the height of the icon, defaults to "20px" # #' @return An object of class `gt_tbl`. # #' @export # #' @section Examples: # #' ```r # #' library(gt) # #' fa_cars <- mtcars %>% # #' head() %>% # #' dplyr::select(cyl, mpg, am, gear) %>% # #' dplyr::mutate(man = ifelse(am == 1, "gear", "gears")) %>% # #' gt() %>% # #' gt_fa_column(man) # #' ``` # #' @section Figures: # #' \if{html}{\figure{fa-column-cars.png}{options: width:500px}} # #' # #' @family Utilities # #' @section Function ID: # #' 2-15 # gt_fa_column <- function(gt_object, column, ..., palette = NULL, # align = "left", direction = 1, height = "20px") { # stopifnot("Table must be of class 'gt_tbl'" = "gt_tbl" %in% class(gt_object)) # lifecycle::deprecate_warn("0.5.1", "gt_fa_column()", "gt::fmt_icon()") # text_transform( # gt_object, # locations = cells_body(columns = {{ column }}), # fn = function(x) { # if (is.null(palette)) { # # if no palette use categorical colorblind palette # pal_filler <- c( # "#000000", "#E69F00", "#56B4E9", "#009E73", # "#F0E442", "#0072B2", "#D55E00", "#CC79A7" # )[seq_along(unique(x[!(x %in% c("", "NA", NA))]))] # # if single color, then repeat to match length # } else if (length(palette) == 1) { # pal_filler <- palette %>% rep(length(unique(x))) # } else if (all(unique(x) %in% names(palette))) { # pal_no_missing <- x[!x %in% c("", "NA", NA, "NULL", NULL)] # # palette is superset of values, # # so reduce palette to just what's needed # pal_filler <- palette[unique(pal_no_missing)] # } else { # # palette is the palette # pal_filler <- palette # } # # pass arguments into anonymous function # lapply(X = x, FUN = function(xy) { # if (xy %in% c("", "NA", NA, NULL, "NULL")) { # return(gt::html(" ")) # } # # drop missing levels # x <- x[!(x %in% c("", "NA", NA, NULL, "NULL"))] # fct_lvl <- unique(x) # # TODO revisit if a useful check, since I'm dropping missing vals # # stopifnot( # # "The length of the unique elements must match the palette length" = # # length(fct_lvl) == length(as.vector(na.omit(pal_filler))) # # ) # if (!is.null(names(pal_filler))) { # fct_x <- factor(xy, levels = names(pal_filler), labels = pal_filler) %>% # as.character() # } else { # fct_x <- factor(xy, levels = fct_lvl, labels = pal_filler) %>% # as.character() # } # # conditional to return blanks if the passed element # # is missing, NA, NULL, or blank # if (!nzchar(xy) || is_blank(xy)) { # gt::html(" ") # } else { # my_fa <- list( # fontawesome::fa(xy, ..., # fill = fct_x, # height = height, a11y = "sem" # ) %>% gt::html() # ) # htmltools::div( # title = xy, "aria-label" = xy, role = "img", # my_fa, style = "padding:0px" # ) # } # }) # } # ) %>% # cols_align(align = align, columns = {{ column }}) # } #' Add rating "stars" to a gt column #' #' @param gt_object An existing gt table object of class `gt_tbl` #' @param column The column wherein the numeric values should be replaced with their corresponding `{fontawesome}` icons. #' @param max_rating The max number of icons to add, these will be added in grey to indicate "missing" #' @param ... Additional arguments passed to `fontawesome::fa()` #' @param color The color of the icon, accepts named colors (`"orange"`) or hex strings. #' @param icon The icon name, passed to `fontawesome::fa()` #' #' @return An object of class `gt_tbl`. #' @export #' #' @section Examples: #' ```r #' library(gt) #' set.seed(37) #' rating_table <- mtcars %>% #' dplyr::select(mpg:wt) %>% #' dplyr::slice(1:5) %>% #' dplyr::mutate(rating = sample(1:5, size = 5, TRUE)) %>% #' gt() %>% #' gt_fa_rating(rating, icon = "r-project") #' ``` #' @section Figures: #' \if{html}{\figure{fa-stars.png}{options: style="width:500px;"}} #' #' @family Utilities #' @section Function ID: #' 2-16 gt_fa_rating <- function( gt_object, column, max_rating = 5, ..., color = "orange", icon = "star" ) { stopifnot("Table must be of class 'gt_tbl'" = "gt_tbl" %in% class(gt_object)) text_transform( gt_object, locations = cells_body(columns = {{ column }}), fn = function(x) { # convert the raw text to numeric num_x <- suppressWarnings(as.numeric(x)) lapply(X = num_x, FUN = function(rating) { # handle missing values & return a blank space if missing if (is_blank(rating) || rating %in% c(NA, "NA", "")) { return(gt::html(" ")) } # adapted from: glin.github.io/reactable/articles/cookbook/cookbook.html#rating-stars rounded_rating <- floor(rating + 0.5) # always round up stars <- lapply(seq_len(max_rating), function(i) { if (i <= rounded_rating) { fontawesome::fa(icon, fill = color, height = "20px", a11y = "sem") } else { fontawesome::fa(icon, fill = "grey", height = "20px", a11y = "sem") } }) label <- sprintf("%s out of %s", rating, max_rating) div_out <- htmltools::div( title = label, "aria-label" = label, role = "img", stars, style = "padding:0px" ) # need to convert from text to html as.character(div_out) %>% gt::html() }) } ) %>% cols_align(align = "left", columns = {{ column }}) } #' Add rank change indicators to a gt table #' @description Takes an existing `gt` table and converts a column of integers #' into various types of up/down arrows. Note that you need to specify a palette #' of three colors, in the order of up, neutral, down. Defaults to green, grey, #' purple. There are 6 supported `fa_type`, representing various arrows. #' Note that you can use `font_color = 'match'` to match the palette across #' arrows and text. `show_text = FALSE` will remove the text from the column, #' resulting only in colored arrows. #' @param gt_object An existing `gt` table object #' @param column The single column that you would like to convert to rank change indicators. #' @param palette A character vector of length 3. Colors can be represented as hex values or named colors. Colors should be in the order of up-arrow, no-change, down-arrow, defaults to green, grey, purple. #' @param fa_type The name of the Fontawesome icon, limited to 5 types of various arrows, one of `c("angles", "arrow", "turn", "chevron", "caret")` #' @param font_color A string, indicating the color of the font, can also be returned as `'match'` to match the font color to the arrow palette. #' @param show_text A logical indicating whether to show/hide the values in the column. #' @return a `gt` table #' @export #' #' @section Examples: #' ```r #' rank_table <- dplyr::tibble(x = c(1:3, -1, -2, -5, 0)) %>% #' gt::gt() %>% #' gt_fa_rank_change(x, font_color = "match") #' ``` #' @section Figures: #' \if{html}{\figure{fa_rank_change.png}{options: style="width:500px;"}} #' #' @family Utilities gt_fa_rank_change <- function( gt_object, column, palette = c("#1b7837", "lightgrey", "#762a83"), fa_type = c("angles", "arrow", "turn", "chevron", "caret"), font_color = "black", show_text = TRUE ) { vals <- gt_index(gt_object, {{ column }}) stopifnot("Column must be integers" = is.integer(as.integer(vals))) stopifnot( "Palette must be length 3, in order of increase, no change, decrease" = length( palette ) == 3 ) stopifnot( 'fa_type must be one of "angles", "arrow", "turn", "chevron", "caret"' = fa_type %in% c("angles", "arrow", "turn", "chevron", "caret") ) # internal function # could possibly pull out to standalone function fa_rank_chg <- function(fa_name, color, font_color, text) { if (font_color == "match") { font_color <- color } if (is_blank(text) || is_blank(fa_name)) { return(gt::html("--")) } else if (!nzchar(text) & !is_blank(text)) { fa_height <- "20px" } else if (nzchar(text) & !is_blank(text)) { fa_height <- "12px" } # fill the Fontawesome call my_fa <- list( fontawesome::fa( name = fa_name, fill = color, height = fa_height, a11y = "sem" ) %>% gt::html() ) # hardcode some HTML/CSS styling htmltools::div( "aria-label" = text, role = "img", htmltools::div(my_fa, style = "float: left;margin-right:1px;"), htmltools::div(text, style = "float:right;"), style = glue::glue( "padding:0px;display:inline;color:{font_color};font-weight:bold;font-size:12px;" ) ) %>% as.character() %>% gt::html() } gt_object %>% text_transform( locations = cells_body({{ column }}), fn = function(x) { vals <- gt_index(gt_object, {{ column }}) color_vals <- dplyr::case_when( vals > 0 ~ palette[1], vals == 0 ~ palette[2], vals < 0 ~ palette[3], TRUE ~ palette[2] ) if (fa_type[1] == "level") { fa_vals <- dplyr::case_when( vals > 0 ~ "level-up-alt", vals < 0 ~ "level-down-alt", vals == 0 ~ "equals", TRUE ~ "question" ) } else { fa_vals <- dplyr::case_when( vals > 0 ~ paste0(fa_type[1], "-up"), vals == 0 ~ "equals", vals < 0 ~ paste0(fa_type[1], "-down") ) } if (isFALSE(show_text)) { vals <- "" } mapply( fa_rank_chg, fa_vals, color_vals, font_color, vals, SIMPLIFY = FALSE ) } ) } ================================================ FILE: R/generate_df.R ================================================ #' Generate pseudorandom dataframes with specific parameters #' @description This function is a small utility to create a specific length dataframe #' with a set number of groups, specific mean/sd per group. Note that the total length #' of the dataframe will be `n` * `n_grps`. #' @param n An integer indicating the number of rows per group, default to `10` #' @param n_grps An integer indicating the number of rows per group, defaults to `1` #' @param mean A number indicating the mean of the randomly generated values, must be a vector of equal length to the `n_grps` #' @param sd A number indicating the standard deviation of the randomly generated values, must be a vector of equal length to the `n_grps` #' @param with_seed A seed to make the randomization reproducible #' @return a tibble/dataframe #' @export #' #' @examples #' library(dplyr) #' generate_df( #' 100L, #' n_grps = 5, #' mean = seq(10, 50, length.out = 5) #' ) %>% #' group_by(grp) %>% #' summarise( #' mean = mean(values), # mean is approx mean #' sd = sd(values), # sd is approx sd #' n = n(), # each grp is of length n #' # showing that the sd default of mean/10 works #' `mean/sd` = round(mean / sd, 1) #' ) #' @family Utilities #' @section Function ID: #' 2-19 generate_df <- function(n = 10L, n_grps = 1L, mean = c(10), sd = mean / 10, with_seed = NULL) { # If a seed is specified, then use it, otherwise ignore if (!is.null(with_seed)) { set.seed(with_seed) } stopifnot("'n' must be an integer of length 1, ie '10', not 'c(10, 20)'" = length(n) == 1) stopifnot("'n' must be an integer" = all.equal(n, as.integer(n))) stopifnot("'n_grps' must be an integer" = all.equal(n_grps, as.integer(n_grps))) stopifnot("'n_grps' must be equal to the number of values in 'mean'" = length(mean) == n_grps) stopifnot("'n_grps' must be equal to the number of values in 'sd'" = length(sd) == n_grps) stopifnot("Number of values in 'sd' must be equal to number of values in 'mean'" = length(mean) == length(sd)) # pad the values with repeated zeros pad_length <- paste0("%0", nchar(n), "d") random_int <- sample(1:n, replace = TRUE) padded_int <- sprintf(pad_length, random_int) my_rnorm <- function(n, mean, sd) { stats::rnorm(n = n, mean = mean, sd = sd) } # create a df with combined random letters and integers dplyr::tibble( row_id = 1:(n * n_grps), id = paste0(sample(LETTERS, n * n_grps, replace = TRUE), padded_int), grp = sprintf("grp-%s", 1:n_grps) %>% rep(each = n), values = mapply(my_rnorm, n, mean, sd) %>% as.vector() ) } ================================================ FILE: R/get_row_index.R ================================================ #' Get underlying row index for gt tables #' @description Provides underlying row index for grouped or ungrouped #' `gt` tables. In some cases the visual representation of specific rows is #' inconsistent with the "row number" so this function provides the final #' output index for subsetting or targetting rows. #' @param gt_object an existing gt table #' #' @return a vector of row indices #' @export #' #' @section Examples: #' #' ### Create a helper function #' #' This helper functions lets us be a bit more efficient when showing the row #' numbers/colors. #' #' ```r #' library(gt) #' #' row_sty <- function(tab, row){ #' #' OkabeIto <- c("#E69F00", "#56B4E9", "#009E73", "#F0E442", #' "#0072B2", "#D55E00", "#CC79A7", "#999999") #' tab %>% #' tab_style( #' cell_fill(color = OkabeIto[row]), #' locations = cells_body(rows = row) #' ) #' } #' ``` #' #' ### Randomize the data #' #' We will randomly sample the data to get it in a specific order. #' #' ```r #' set.seed(37) #' df <- mtcars %>% #' dplyr::group_by(cyl) %>% #' dplyr::slice_sample(n = 2) %>% #' dplyr::ungroup() %>% #' dplyr::slice_sample(n = 6) %>% #' dplyr::mutate(row_id = dplyr::row_number(), .before = 1) #' #' #> df #' #> A tibble: 6 × 12 #' #> row_id mpg cyl disp hp drat wt qsec vs am gear carb #' #> #' #> 1 10.4 8 472 205 2.93 5.25 18.0 0 0 3 4 #' #> 2 18.1 6 225 105 2.76 3.46 20.2 1 0 3 1 #' #> 3 21.4 6 258 110 3.08 3.22 19.4 1 0 3 1 #' #> 4 13.3 8 350 245 3.73 3.84 15.4 0 0 3 4 #' #> 5 33.9 4 71.1 65 4.22 1.84 19.9 1 1 4 1 #' #> 6 22.8 4 108 93 3.85 2.32 18.6 1 1 4 1 #' ``` #' ### Ungrouped data #' #' Ungrouped data works just fine, and the row indices are identical between #' the visual representation and the output. #' ```r #' gt(df) %>% #' row_sty(1) %>% #' row_sty(3) %>% #' row_sty(5) #' ``` #' \if{html}{\figure{ungrouped-tab.png}{options: style="width:500px;"}} #' ### Grouped data #' #' However, for grouped data, the row indices are representative of the underlying #' data before grouping, leading to some potential confusion. #' ```r #' tab2 <- gt(df, groupname_col = "cyl") #' #' tab2 %>% #' row_sty(1) %>% ## actually row 1 #' row_sty(3) %>% ## actually row 5 #' row_sty(5) ## actually row 2 #' ``` #' \if{html}{\figure{grouped-tab.png}{options: style="width:500px;"}} #' #' The `get_row_index()` function gives ability to create an index of the final #' output, so you can reference specific rows by number. #' #' ```r #' tab_index <- get_row_index(tab2) #' #' tab2 %>% #' row_sty(4) %>% ## wrong row, actually row 6 visually #' row_sty(tab_index[4]) ## correct row, actually row 4 #' ``` #' \if{html}{\figure{grouped-tab-row4.png}{options: style="width:500px;"}} #' ```r #' tab2 %>% #' row_sty(tab_index[1]) %>% #' row_sty(tab_index[3]) %>% #' row_sty(tab_index[5]) #' ``` #' \if{html}{\figure{grouped-tab-index.png}{options: style="width:500px;"}} #' get_row_index <- function(gt_object) { is_gt_stop(gt_object) # find group_index subset_log <- gt_object[["_boxhead"]][["type"]] == "row_group" ## subset vars by vector grp_names <- gt_object[["_boxhead"]][["var"]][subset_log] ## create a list of symbols if (length(grp_names) >= 1) { grp_col <- rlang::syms(grp_names) # ordered levels of the row groups gt_row_grps <- gt_object[["_row_groups"]] # pull the ordered row numbers grp_vec_ord <- gt_object[["_stub_df"]] %>% dplyr::mutate(group_id = factor(group_id, levels = gt_row_grps)) %>% dplyr::arrange(group_id) %>% dplyr::pull(rownum_i) # get the actual row id of the data for gt to target row_ids <- gt_object[["_data"]] %>% dplyr::mutate(row_id = dplyr::row_number()) %>% dplyr::slice(grp_vec_ord) %>% dplyr::pull(row_id) } else { row_ids <- nrow(gt_object[["_data"]]) } row_ids } ================================================ FILE: R/gt-bar-html.R ================================================ #' Add HTML-based bar plots into rows of a `gt` table #' @description #' The `gt_plt_bar_pct` function takes an existing `gt_tbl` object and #' adds horizontal barplots via native HTML. Note that values #' default to being normalized to the percent of the maximum observed value #' in the specified column. You can turn this off if the values already #' represent a percentage value representing 0-100. #' #' @param gt_object An existing gt table object of class `gt_tbl` #' @param column The column wherein the bar plot should replace existing data. #' @param height A number representing the vertical height of the plot in pixels. Defaults to 16 px. #' @param width A number representing the horizontal width of the plot in pixels. Defaults to 100 px. Importantly, this interacts with the label_cutoff argument, so if you want to change the cutoff, you may need to adjust the width as well. #' @param fill A character representing the fill for the bar, defaults to purple. Accepts a named color (eg 'purple') or a hex color. #' @param background A character representing the background filling out the 100% mark of the bar, defaults to light grey. Accepts a named color (eg 'white') or a hex color. #' @param scaled `TRUE`/`FALSE` logical indicating if the value is already scaled to a percent of max (`TRUE`) or if it needs to be scaled (`FALSE`). Defaults to `FALSE`, meaning the value will be divided by the max value in that column and then multiplied by 100. #' @param labels `TRUE`/`FALSE` logical representing if labels should be plotted. Defaults to `FALSE`, meaning that no value labels will be plotted. #' @param label_cutoff A number, 0 to 1, representing where to set the inside/outside label boundary. Defaults to 0.40 (40%) of the column's maximum value. If the value in that row is less than the cutoff, the label will be placed outside the bar, otherwise it will be placed within the bar. This interacts with the overall width of the bar, so if you are not happy with the placement of the labels you may try adjusting the `width` argument as well. #' @param decimals A number representing how many decimal places to be used in label rounding. Defaults to 1. #' @param font_style A character representing the font style of the labels. Accepts one of 'bold' (default), 'italic', or 'normal'. #' @param font_size A character representing the font size of the labels. Defaults to '10px'. #' @return An object of class `gt_tbl`. #' @export #' @section Examples: #' ```r #' library(gt) #' #' base_tab <- dplyr::tibble(x = seq(1, 100, length.out = 6)) %>% #' dplyr::mutate( #' x_unscaled = x, #' x_scaled = x / max(x) * 100 #' ) %>% #' gt() #' #' base_tab %>% #' gt_plt_bar_pct( #' column = x_unscaled, #' scaled = TRUE, #' fill = "forestgreen" #' ) %>% #' gt_plt_bar_pct( #' column = x_scaled, #' scaled = FALSE, #' labels = TRUE #' ) #' ``` #' @section Figures: #' \if{html}{\figure{gt_bar_plot.png}{options: width:500px}} #' #' @family Plotting #' @section Function ID: #' 3-5 gt_plt_bar_pct <- function( gt_object, column, height = 16, width = 100, fill = "purple", background = "#e1e1e1", scaled = FALSE, labels = FALSE, label_cutoff = 0.40, decimals = 1, font_style = "bold", font_size = "10px" ) { stopifnot( `'gt_object' must be a 'gt_tbl', have you accidentally passed raw data?` = "gt_tbl" %in% class(gt_object) ) stopifnot( 'label_cutoff must be a number between 0 and 1' = dplyr::between( label_cutoff, 0, 1 ) ) # ensure font_style is one of the accepted values stopifnot( '`font_style` argument must be "bold", "normal", or "italic"' = font_style %in% c("bold", "normal", "italic") ) all_cols <- gt_index(gt_object, column = {{ column }}, as_vector = FALSE) data_in <- all_cols %>% select({{ column }}) %>% pull() col_name <- all_cols %>% select({{ column }}) %>% names() # create a formula for cols_width col_to_widen <- rlang::new_formula(col_name, px(width)) bar_plt_html <- function(xy) { if (length(na.omit(xy)) == 0) { max_x <- 0 } else { max_x <- max(as.double(xy), na.rm = TRUE) } bar <- lapply(data_in, function(x) { scaled_value <- if (isFALSE(scaled)) { x / max_x * 100 } else { x } if (labels) { # adjust values for labeling // scale_label label_values <- if (scaled) { x } else { x / max_x * 100 } # create label string to print out // add % sign if requested label <- glue::glue("{round(label_values, decimals)}%") if (x < (label_cutoff * max_x)) { css_styles <- paste0( "background:", fill, ";", "width:", scaled_value, "%;", "height:", height, "px;", "display:flex;", "align-items:center;", "justify-content:center;", "color:", ideal_fgnd_color(background), ";", "font-weight:", font_style, ";", "font-size:", font_size, ";", "position:relative;" ) span_styles <- paste0( "color:", ideal_fgnd_color(background), ";", "position:absolute;", "left:0%;", "margin-left:", scaled_value * width / 100, "px;", "font-weight:", font_style, ";", "font-size:", font_size, ";" ) glue::glue( "
", "{label}
" ) } else { css_styles <- paste0( "background:", fill, ";", "width:", scaled_value, "%;", "height:", height, "px;", "display:flex;", "align-items:center;", "justify-content:flex-start;", "position:relative;" ) span_styles <- paste0( "color:", ideal_fgnd_color(fill), ";", "position:absolute;", "left:0px;", "margin-left:5px;", "font-weight:", font_style, ";", "font-size:", font_size, ";" ) glue::glue( "
", "{label}
" ) } } else if (!is.na(x)) { glue::glue( "
" # no labels added ) } else if (is.na(x)) { "
" # no labels added } }) chart <- lapply(bar, function(bar) { glue::glue( "
{bar}
" ) }) chart } # silence NAs messing with rownum_i quiet <- function(x) { sink(tempfile()) on.exit(sink()) invisible(force(x)) } quiet( gt_object %>% cols_width(col_to_widen) %>% text_transform( locations = cells_body(columns = {{ column }}), fn = quiet(bar_plt_html) ) %>% cols_align(align = "left", columns = {{ column }}) ) } ================================================ FILE: R/gtExtras-package.R ================================================ #' @keywords internal #' @import dplyr glue ggplot2 gt htmltools paletteer rlang scales #' @importFrom fontawesome fa "_PACKAGE" utils::globalVariables( c( ".", "df", "x1", "x2", "y", "var", "type", "text", "cmark_rules", "rtf_wrap", "Var1", "rtf_escape_unicode", "value", "median", "sd", "name", "Mean", "SD", "n_missing", "name", "vals", "x", "z_r_group_rows", "group_id", "rownum_i", "group_id", "gt_row_grps", "row_id", "DUPE_COLUMN_PLT", "parameter" ) ) ## usethis namespace: start ## usethis namespace: end NULL ================================================ FILE: R/gt_add_divider.R ================================================ #' Add a dividing border to an existing `gt` table. #' @description #' The `gt_add_divider` function takes an existing `gt_tbl` object and #' adds borders or dividers to specific columns. #' @param gt_object An existing gt table object of class `gt_tbl` #' @param columns Specific columns to apply color to, accepts either `tidyeval` colum names or columns by position. #' @param sides The border sides to be modified. Options include `"left"`, `"right"`, `"top"`, and `"bottom"`. For all borders surrounding the selected cells, we can use the `"all"`` option. #' @param color,style,weight The border color, style, and weight. The `color` can be defined with a color name or with a hexadecimal color code. The default `color` value is `"#00FFFFFF"` (black). The `style` can be one of either `"solid"` (the default), `"dashed"`, or `"dotted"`. The `weight` of the border lines is to be given in pixel values (the `px()` helper function is useful for this. The default value for `weight` is `"1px"`. #' @param include_labels A logical, either `TRUE` or `FALSE` indicating whether to also add dividers through the column labels. #' @return An object of class `gt_tbl`. #' @export #' @section Examples: #' ```r #' library(gt) #' basic_divider <- head(mtcars) %>% #' gt() %>% #' gt_add_divider(columns = "cyl", style = "dashed") #' ``` #' @section Figures: #' \if{html}{\figure{add-divider.png}{options: style="width:500px;"}} #' #' @family Utilities #' @section Function ID: #' 2-11 gt_add_divider <- function(gt_object, columns, sides = "right", color = "grey", style = "solid", weight = px(2), include_labels = TRUE) { stopifnot("Table must be of class 'gt_tbl'" = "gt_tbl" %in% class(gt_object)) if (isTRUE(include_labels)) { gt_object %>% tab_style( style = cell_borders( sides = sides, style = style, color = color, weight = weight ), locations = list( cells_body(columns = {{ columns }}), cells_column_labels(columns = {{ columns }}) ) ) } else { gt_object %>% tab_style( style = cell_borders( sides = sides, style = style, color = color, weight = weight ), locations = cells_body(columns = {{ columns }}) ) } } ================================================ FILE: R/gt_alert_icon.R ================================================ #' Insert an alert icon to a specific column #' #' @param gt_object An existing gt table object of class `gt_tbl` #' @param column The column wherein the numeric values should be replaced with circular alert icons. #' @param palette The colours or colour function that values will be mapped to. Can be a character vector (eg `c("white", "red")` or hex colors) or a named palette from the `{paletteer}` package in the `package::palette_name` structure. #' @param height A character string indicating the height in pixels, like "10px" #' @param direction The direction of the `paletteer` palette, should be either `-1` for reversed or the default of `1` for the existing direction. #' @param domain The possible values that can be mapped. This should be a simple numeric range (e.g. `c(0, 100)`) #' @param align Character string indicating alignment of the column, defaults to "left" #' @param v_pad A numeric value indicating the vertical padding, defaults to -5 to aid in centering within the vertical space. #' @importFrom scales col_numeric #' @importFrom paletteer paletteer_d #' @import gt glue #' @importFrom htmltools div #' @importFrom fontawesome fa #' @return a gt table #' @export #' #' @section Examples: #' #' ```r #' head(mtcars) %>% #' dplyr::mutate(warn = ifelse(mpg >= 21, 1, 0), .before = mpg) %>% #' gt::gt() %>% #' gt_alert_icon(warn) #' ``` #' \if{html}{\figure{man/figures/gt_alert_icon-binary.png}{options: style="width:500px;"}} gt_alert_icon <- function(gt_object, column, palette = c("#a962b6", "#f1f1f1", "#378e38"), domain = NULL, height = "10px", direction = 1, align = "center", v_pad = -5) { stopifnot("Table must be of class 'gt_tbl'" = "gt_tbl" %in% class(gt_object)) stopifnot("align must be one of 'center', 'left', or 'right'" = align %in% c("center", "left", "right")) if (is.null(domain)) { message( "Domain not specified, defaulting to observed range within each specified column. Silence this message by setting domain argument." ) } text_transform( gt_object, locations = cells_body(columns = {{ column }}), fn = function(x) { scaled_colors <- scales::col_numeric( palette = if (grepl(x = palette[1], pattern = "::")) { paletteer::paletteer_d( palette = palette, direction = direction, type = "continuous" ) %>% as.character() } else { if (direction == -1) { rev(palette) } else { palette } }, domain = domain )(as.double(x)) Map( function(fill, ht) { htmltools::div( fontawesome::fa("circle", fill = fill, height = ht), style = glue::glue("margin-top: {v_pad}px; top: 50%;") ) }, scaled_colors, height ) } ) %>% gt::cols_align(align = align, columns = {{ column }}) } ================================================ FILE: R/gt_color_box.R ================================================ #' @title Add a small color box relative to the cell value. #' @description Create `PFF`-style colorboxes in a `gt` table. #' Note that rather than using `gt::fmt_` functions on this column, you can send #' numeric formatting arguments via `...`. All arguments should be named #' and are passed to `scales::label_number()`. #' #' @param gt_object An existing gt table object of class `gt_tbl` #' @param columns The columns wherein changes to cell data colors should occur. #' @param palette The colours or colour function that values will be mapped to. Can be a character vector (eg `c("white", "red")` or hex colors) or a named palette from the `{paletteer}` package in the `package::palette_name` structure. Note that `'pff'` will fill in a blue -> green -> yellow -> orange -> red palette. #' @param domain The possible values that can be mapped. This should be a simple numeric range (e.g. `c(0, 100)`) #' @param width The width of the entire coloring area in pixels. #' @param ... Additional arguments passed to `scales::label_number()`, primarily used to format the numbers inside the color box #' @param font_weight A string indicating the font weight, defaults to `"bold"`, change to `"normal"` for default weight. #' @return An object of class `gt_tbl`. #' @export #' #' @section Examples: #' ```r #' library(gt) #' test_data <- dplyr::tibble(x = letters[1:10], #' y = seq(100, 10, by = -10), #' z = seq(10, 100, by = 10)) #' color_box_tab <- test_data %>% #' gt() %>% #' gt_color_box(columns = y, domain = 0:100, palette = "ggsci::blue_material") %>% #' gt_color_box(columns = z, domain = 0:100, #' palette = c("purple", "lightgrey", "green")) #' ``` #' @section Figures: #' \if{html}{\figure{color_box.png}{options: style="width:500px;"}} #' #' @family Colors #' @section Function ID: #' 4-3 gt_color_box <- function(gt_object, columns, palette = NULL, ..., domain = NULL, width = 70, font_weight = "bold") { stopifnot("Table must be of class 'gt_tbl'" = "gt_tbl" %in% class(gt_object)) color_boxes <- function(x) { stopifnot("Error: 'domain' must be specified." = !is.null(domain)) if (length(palette) == 1) { if (grepl(x = palette, pattern = "::", fixed = TRUE)) { palette <- paletteer::paletteer_d( palette = palette ) %>% as.character() } else { palette <- palette } } else if (is.null(palette)) { palette <- c( "#762a83", "#af8dc3", "#e7d4e8", "#f7f7f7", "#d9f0d3", "#7fbf7b", "#1b7837" ) } else { palette <- palette } if (palette[1] == "pff") palette <- c("#cd2624", "#fd9701", "#ffd000", "#3bae24", "#0c5ea0") colors <- scales::col_numeric(palette = palette, domain = domain)(x) background_col <- scales::alpha(colors, alpha = 0.2) div( div( style = paste0( glue::glue( "height: 20px;width:{width}px; background-color: {background_col};" ), "border-radius:5px;)" ), div( style = paste0( glue::glue("height: 13px;width: 13px;background-color: {colors};"), "display: inline-block;border-radius:4px;float:left;", "position:relative;top:17%;left:6%;" # top 12%-15% ) ), div( scales::label_number(...)(x), style = paste0( glue::glue("display: inline-block;float:right;line-height:20px; font-weight: {font_weight};"), "padding: 0px 2.5px;" ) ) ) ) %>% as.character() %>% html() } text_transform( gt_object, locations = cells_body({{ columns }}), fn = function(x) { x <- as.double(x) lapply(x, color_boxes) } ) } ================================================ FILE: R/gt_color_rows.R ================================================ #' Add scaled colors according to numeric values or categories/factors #' @description #' The `gt_color_rows` function takes an existing `gt_tbl` object and #' applies pre-existing palettes from the `{paletteer}` package or custom #' palettes defined by the user. This function is a custom wrapper around #' `gt::data_color()`, and uses some of the boilerplate code. Basic use #' is simpler than `data_color()`. #' #' @param gt_object An existing gt table object of class `gt_tbl` #' @param columns The columns wherein changes to cell data colors should occur. #' @param pal_type A string indicating the palette type (one of `c("discrete", "continuous")`) #' @param ... Additional arguments passed to `scales::col_numeric()` #' @inheritParams scales::col_numeric #' @inheritParams paletteer::paletteer_d #' @return An object of class `gt_tbl`. #' @export #' @section Examples: #' ```r #' library(gt) #' # basic use #' basic_use <- mtcars %>% #' head(15) %>% #' gt() %>% #' gt_color_rows(mpg:disp) #' # change palette to one that paletteer recognizes #' change_pal <- mtcars %>% #' head(15) %>% #' gt() %>% #' gt_color_rows(mpg:disp, palette = "ggsci::blue_material") #' # change palette to raw values #' vector_pal <- mtcars %>% #' head(15) %>% #' gt() %>% #' gt_color_rows( #' mpg:disp, palette = c("white", "green")) #' # could also use palette = c("#ffffff", "##00FF00") #' #' # use discrete instead of continuous palette #' discrete_pal <- mtcars %>% #' head(15) %>% #' gt() %>% #' gt_color_rows( #' cyl, pal_type = "discrete", #' palette = "ggthemes::colorblind", domain = range(mtcars$cyl) #' ) #' # use discrete and manually define range #' range_pal <- mtcars %>% #' dplyr::select(gear, mpg:hp) %>% #' head(15) %>% #' gt() %>% #' gt_color_rows( #' gear, pal_type = "discrete", direction = -1, #' palette = "colorblindr::OkabeIto_black", domain = c(3,4,5)) #' ``` #' @section Figures: #' \if{html}{\figure{basic-pal.png}{options: style="width:500px;"}} #' #' \if{html}{\figure{blue-pal.png}{options: style="width:500px;"}} #' #' \if{html}{\figure{custom-pal.png}{options: style="width:500px;"}} #' #' \if{html}{\figure{discrete-pal.png}{options: style="width:500px;"}} #' #' @family Colors #' @section Function ID: #' 4-2 gt_color_rows <- function(gt_object, columns, palette = "ggsci::red_material", direction = 1, domain = NULL, pal_type = c("discrete", "continuous"), ...) { stopifnot("Table must be of class 'gt_tbl'" = "gt_tbl" %in% class(gt_object)) if (is.null(domain)) { warning( "Domain not specified, defaulting to observed range within each specified column.", call. = FALSE ) } gt_object %>% data_color( columns = {{ columns }}, fn = scales::col_numeric( palette = if (grepl(x = palette[1], pattern = "::")) { paletteer::paletteer_d( palette = palette, direction = direction, type = pal_type ) %>% as.character() } else { if (direction == -1) { rev(palette) } else { palette } }, ..., domain = domain ) ) } ================================================ FILE: R/gt_dot_bar.R ================================================ #' @title Add a color dot and thin bar chart to a table #' @description This function takes a data column and a categorical column and #' adds a colored dot and a colored dot to the categorical column. You can supply #' a specific palette or a palette from the `{paletteer}` package. #' @param gt_object An existing gt table object of class `gt_tbl` #' @param column The column which supplies values to create the inline bar plot #' @param category_column The category column, where a colored dot and bar will be added #' @param palette The colors or color function that values will be mapped to. Can be a character vector (eg `c("white", "red")` or hex colors) or a named palette from the `{paletteer}` package. #' @param max_value A single numeric value indicating the max value, if left as `NULL` then the range of the `column` values will be used #' @import gt #' @return a `gt_tbl` #' @export #' @section Examples: #' ```r #' library(gt) #' dot_bar_tab <- mtcars %>% #' head() %>% #' dplyr::mutate(cars = sapply(strsplit(rownames(.)," "), `[`, 1)) %>% #' dplyr::select(cars, mpg, disp) %>% #' gt() %>% #' gt_plt_dot(disp, cars, palette = "ggthemes::fivethirtyeight") %>% #' cols_width(cars ~ px(125)) #' ``` #' @section Figures: #' \if{html}{\figure{gt_dot_bar.png}{options: style="width:500px;"}} #' #' @family Themes gt_plt_dot <- function(gt_object, column, category_column, palette = NULL, max_value = NULL) { stopifnot("Table must be of class 'gt_tbl'" = "gt_tbl" %in% class(gt_object)) # segment data with bare string column name cat_data_in <- gt_index(gt_object, {{ category_column }}) cat_levels <- unique(cat_data_in) data_in <- gt_index(gt_object, {{ column }}) total_max <- max(data_in, na.rm = TRUE) if (length(palette) == 1) { if (grepl(x = palette, pattern = "::", fixed = TRUE)) { palette <- paletteer::paletteer_d( palette = palette ) %>% as.character() } else { palette <- palette %>% rep(length(cat_levels)) } } else if (is.null(palette)) { palette <- c( "#762a83", "#af8dc3", "#e7d4e8", "#f7f7f7", "#d9f0d3", "#7fbf7b", "#1b7837" ) } else { palette <- palette } bar_chart <- function(value, fill = "red") { max_x <- if (is.null(max_value)) { max(as.double(data_in), na.rm = TRUE) } else { max_value } bar <- lapply(value, function(x) { scaled_value <- as.double(x) / max_x * 100 glue::glue( "
" ) }) chart <- lapply(bar, function(bar) { glue::glue( "
{bar}
" ) %>% as.character() %>% gt::html() }) chart } color_dots <- function(x) { if (x %in% c("NA", "NULL")) { return("
") } split_cols <- strsplit(x, "^split^", fixed = TRUE) %>% unlist() category_label <- split_cols[1] val_x <- split_cols[2] colors <- scales::col_factor( palette = palette, domain = NULL, levels = cat_levels )(category_label) htmltools::div( htmltools::div( category_label, style = paste0( "display:inline-block;float:left;", "margin-right:0px;" ), htmltools::div( style = paste0( glue::glue("height: 0.7em;width: 0.7em;background-color: {colors};"), "border-radius: 50%;margin-top:4px;display:inline-block;", "float:left;margin-right:2px;" ) ), htmltools::div( style = paste0( "display: inline-block;float:right;line-height:20px;", "padding: 0px 2.5px;" ) ) ), htmltools::div(htmltools::div(bar_chart(val_x, fill = colors)), style = "position: relative;top: 1.2em;" ) ) %>% as.character() %>% gt::html() } gt_object %>% gt::cols_merge( c({{ category_column }}, {{ column }}), pattern = "{1}^split^{2}", hide_columns = FALSE ) %>% gt::text_transform( locations = cells_body({{ category_column }}), fn = function(xz) { lapply(xz, color_dots) } ) } ================================================ FILE: R/gt_dt__.R ================================================ # vendored code with attribution from gt # https://github.com/rstudio/gt/blob/7929072221b059901a1649fe7f83d725521fb02a/R/dt__.R dt__get <- function(data, key) { data[[key, exact = TRUE]] } dt__set <- function(data, key, value) { data[[key]] <- value data } ================================================ FILE: R/gt_dt_data.R ================================================ # Vendored gt code with attribution # https://github.com/rstudio/gt/blob/7929072221b059901a1649fe7f83d725521fb02a/R/dt_data.R .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()) } # rownames_to_column is a string; if not NA, it means the row.names(data_tbl) # should be turned into a column with the name !!rownames_to_column dt_data_init <- function(data, data_tbl, rownames_to_column = NA) { if (!is.na(rownames_to_column)) { data_rownames <- rownames(data_tbl) if (rownames_to_column %in% colnames(data_tbl)) { stop("Reserved column name `", rownames_to_column, "` was detected in ", "the data; please rename this column", call. = FALSE ) } data_tbl <- data_tbl %>% dplyr::mutate(!!sym(rownames_to_column) := data_rownames) %>% dplyr::select(!!sym(rownames_to_column), dplyr::everything()) } dt_data_set(data = data, data_tbl = data_tbl) } ================================================ FILE: R/gt_duplicate_column.R ================================================ #' Duplicate an existing column in a gt table #' @description This function takes an existing gt table and will duplicate a column. #' You also have the option to specify where the column ends up, and what will #' be appending to the end of the column name to differentiate it. #' @param gt_object An existing gt table object of class `gt_tbl` #' @param column The column to be duplicated #' @param after The column to place the duplicate column after #' @param append_text The text to add to the column name to differentiate it from the original column name #' @param dupe_name A full name for the "new" duplicated column, will override `append_text` #' @return An object of class `gt_tbl`. #' @export #' @examples #' library(gt) #' dupe_table <- head(mtcars) %>% #' dplyr::select(mpg, disp) %>% #' gt() %>% #' gt_duplicate_column(mpg, after = disp, append_text = "2") #' #' @family Utilities #' @section Function ID: #' 2-15 #' gt_duplicate_column <- function(gt_object, column, after = dplyr::last_col(), append_text = "_dupe", dupe_name = NULL) { stopifnot("'gt_object' must be a 'gt_tbl', have you accidentally passed raw data?" = "gt_tbl" %in% class(gt_object)) columns <- resolve_cols_c( expr = {{ column }}, data = gt_object ) col_dupe_name <- if (is.null(dupe_name)) { stopifnot("Appended text must be at least 1 character" = nchar(append_text) > 0) paste0(columns, append_text) } else { dupe_name } # add a duplicate column in the raw data gt_object[["_data"]] <- gt_object[["_data"]] %>% dplyr::mutate(!!col_dupe_name := {{ column }}) added_row <- gt_object[["_boxhead"]] %>% dplyr::filter(.data$var == columns) %>% dplyr::mutate( var = !!col_dupe_name, column_label = list(!!col_dupe_name) ) # add metadata for gt about new column gt_object[["_boxhead"]] <- gt_object[["_boxhead"]] %>% dplyr::bind_rows(added_row) gt_object %>% cols_move(!!col_dupe_name, after = {{ after }}) } ================================================ FILE: R/gt_highlight_cols.R ================================================ #' Add color highlighting to a specific column(s) #' @description #' The `gt_highlight_cols` function takes an existing `gt_tbl` object and #' adds highlighting color to the cell background of a specific column(s). #' #' @param gt_object An existing gt table object of class `gt_tbl` #' @param columns Specific columns to apply color to, accepts either `tidyeval` colum names or columns by position. #' @param fill A character string indicating the fill color. If nothing is provided, then "#80bcd8" (light blue) will be used as a default. #' @param alpha An optional alpha transparency value for the color as single value in the range of 0 (fully transparent) to 1 (fully opaque). If not provided the fill color will either be fully opaque or use alpha information from the color value if it is supplied in the #RRGGBBAA format. #' @param font_weight A string or number indicating the weight of the font. Can be a text-based keyword such as "normal", "bold", "lighter", "bolder", or, a numeric value between 1 and 1000, inclusive. Note that only variable fonts may support the numeric mapping of weight. #' @param font_color A character string indicating the text color. If nothing is provided, then "#000000" (black) will be used as a default. #' @return An object of class `gt_tbl`. #' @export #' @section Examples: #' ```r #' library(gt) #' basic_col <- head(mtcars) %>% #' gt() %>% #' gt_highlight_cols(cyl, fill = "red", alpha = 0.5) #' ``` #' @section Figures: #' \if{html}{\figure{highlight-col.png}{options: style="width:500px;"}} #' #' @family Utilities #' @section Function ID: #' 2-9 #' #' gt_highlight_cols <- function(gt_object, columns, fill = "#80bcd8", alpha = 1, font_weight = "normal", font_color = "#000000") { stopifnot("Table must be of class 'gt_tbl'" = "gt_tbl" %in% class(gt_object)) gt_object %>% tab_style( style = list( cell_fill(color = fill, alpha = alpha), cell_text(weight = font_weight, color = font_color), cell_borders(sides = c("top", "bottom"), color = fill) ), locations = cells_body( columns = {{ columns }}, rows = TRUE ) ) } ================================================ FILE: R/gt_highlight_rows.R ================================================ #' Add color highlighting to a specific row #' @description #' The `gt_highlight_rows` function takes an existing `gt_tbl` object and #' adds highlighting color to the cell background of a specific row. The function #' accepts rows only by number (not by logical expression) for now. #' #' @param gt_object An existing gt table object of class `gt_tbl` #' @param columns Specific columns to apply color to, accepts either `tidyeval` colum names or columns by position. #' @param rows The rows to apply the highlight to. Can either by a `tidyeval` compliant statement (like `cyl == 4`), a number indicating specific row(s) to apply color to or `TRUE` to indicate all rows. #' @param fill A character string indicating the fill color. If nothing is provided, then "#80bcd8" (light blue) will be used as a default. #' @param alpha An optional alpha transparency value for the color as single value in the range of 0 (fully transparent) to 1 (fully opaque). If not provided the fill color will either be fully opaque or use alpha information from the color value if it is supplied in the #RRGGBBAA format. #' @param font_weight A string or number indicating the weight of the font. Can be a text-based keyword such as "normal", "bold", "lighter", "bolder", or, a numeric value between 1 and 1000, inclusive. Note that only variable fonts may support the numeric mapping of weight. #' @param font_color A character string indicating the text color. If nothing is provided, then "#000000" (black) will be used as a default. #' @param bold_target_only A logical of TRUE/FALSE indicating whether to apply bold to only the specific `target_col`. You must indicate a specific column with `target_col`. #' @param target_col A specific `tidyeval` column to apply bold text to, which allows for normal weight text for the remaining highlighted columns. #' @return An object of class `gt_tbl`. #' @export #' @section Examples: #' ```r #' library(gt) #' basic_use <- head(mtcars[,1:5]) %>% #' tibble::rownames_to_column("car") %>% #' gt() %>% #' gt_highlight_rows(rows = 2, font_weight = "normal") #' #' target_bold_column <- head(mtcars[,1:5]) %>% #' tibble::rownames_to_column("car") %>% #' gt() %>% #' gt_highlight_rows( #' rows = 5, #' fill = "lightgrey", #' bold_target_only = TRUE, #' target_col = car #' ) #' ``` #' @section Figures: #' \if{html}{\figure{highlight-basic.png}{options: style="width:500px;"}} #' \if{html}{\figure{highlight-target.png}{options: style="width:500px;"}} #' #' @family Utilities #' @section Function ID: #' 2-10 gt_highlight_rows <- function(gt_object, columns = gt::everything(), rows = TRUE, fill = "#80bcd8", alpha = 0.8, font_weight = "bold", font_color = "#000000", bold_target_only = FALSE, target_col = c()) { stopifnot("Table must be of class 'gt_tbl'" = "gt_tbl" %in% class(gt_object)) if (isTRUE(bold_target_only)) { gt_object %>% tab_style( style = cell_fill(color = fill, alpha = alpha), locations = cells_body( columns = {{ columns }}, rows = {{ rows }} ) ) %>% tab_style( style = list( cell_text(weight = font_weight, color = font_color) ), locations = cells_body( columns = {{ target_col }}, rows = {{ rows }} ) ) } else { gt_object %>% tab_style( style = list( cell_fill(color = fill, alpha = alpha), cell_text(weight = font_weight, color = font_color) ), locations = cells_body( columns = {{ columns }}, rows = {{ rows }} ) ) } } ================================================ FILE: R/gt_hulk_color.R ================================================ #' Apply 'hulk' palette to specific columns in a gt table. #' @description #' The hulk name comes from the idea of a diverging purple and green theme #' that is colorblind safe and visually appealing. #' It is a useful alternative to the red/green palette where purple typically #' can indicate low or "bad" value, and green can indicate a high or "good" value. #' #' @param gt_object An existing gt table object of class `gt_tbl` #' @param columns The columns wherein changes to cell data colors should occur. #' @param trim trim the palette to give less intense maximal colors #' @inheritParams scales::col_numeric #' @param ... Additional arguments passed to `scales::col_numeric()` #' @return An object of class `gt_tbl`. #' @export #' @section Examples: #' ```r #' library(gt) #' # basic use #' hulk_basic <- mtcars %>% #' head() %>% #' gt::gt() %>% #' gt_hulk_col_numeric(mpg) #' #' hulk_trim <- mtcars %>% #' head() %>% #' gt::gt() %>% #' # trim gives small range of colors #' gt_hulk_col_numeric(mpg:disp, trim = TRUE) #' #' # option to reverse the color palette #' hulk_rev <- mtcars %>% #' head() %>% #' gt::gt() %>% #' # trim gives small range of colors #' gt_hulk_col_numeric(mpg:disp, reverse = TRUE) #' ``` #' @section Figures: #' \if{html}{\figure{hulk_basic.png}{options: style="width:500px;"}} #' #' \if{html}{\figure{hulk_trim.png}{options: style="width:500px;"}} #' #' \if{html}{\figure{hulk_reverse.png}{options: style="width:500px;"}} #' #' @family Colors #' @section Function ID: #' 4-1 gt_hulk_col_numeric <- function(gt_object, columns = NULL, domain = NULL, ..., trim = FALSE) { stopifnot("Input must be a gt table" = "gt_tbl" %in% class(gt_object)) pal_hex <- c( "#762a83", "#af8dc3", "#e7d4e8", "#f7f7f7", "#d9f0d3", "#7fbf7b", "#1b7837" ) if (isTRUE(trim)) pal_hex <- pal_hex[2:6] hulk_pal <- function(x) { scales::col_numeric( pal_hex, domain = domain, ... )(x) } gt::data_color( gt_object, columns = {{ columns }}, fn = hulk_pal ) } ================================================ FILE: R/gt_image_multi_rows.R ================================================ #' Add multiple local or web images into rows of a `gt` table #' @description #' The `gt_multi_img_rows` function takes an existing `gt_tbl` object and #' converts nested cells with filenames or urls to images into inline images. This is a wrapper #' around `gt::text_transform()` + `gt::web_image()`/`gt::local_image()` with #' the necessary boilerplate already applied. #' #' @param gt_object An existing gt table object of class `gt_tbl` #' @param columns The columns wherein changes to cell data colors should occur. #' @param img_source A string, specifying either "local" or "web" as the source of the images. #' @inheritParams gt::web_image #' @inheritParams gt::local_image #' @return An object of class `gt_tbl`. #' @export #' @section Examples: #' ```r #' library(gt) #' teams <- "https://github.com/nflverse/nflfastR-data/raw/master/teams_colors_logos.rds" #' team_df <- readRDS(url(teams)) #' #' conf_table <- team_df %>% #' dplyr::select(team_conf, team_division, logo = team_logo_espn) %>% #' dplyr::distinct() %>% #' tidyr::nest(data = logo) %>% #' dplyr::rename(team_logos = data) %>% #' dplyr::arrange(team_conf, team_division) %>% #' gt() %>% #' gt_img_multi_rows(columns = team_logos, height = 25) #' #' ``` #' @section Figures: #' \if{html}{\figure{img-rows.png}{options: style="width:500px;"}} #' #' @family Utilities #' @section Function ID: #' 2-9 gt_img_multi_rows <- function(gt_object, columns, img_source = "web", height = 30) { stopifnot("Table must be of class 'gt_tbl'" = "gt_tbl" %in% class(gt_object)) # convert tidyeval column to bare strings column_names <- resolve_cols_c( expr = {{ columns }}, data = gt_object ) stub_var <- gt_object[["_boxhead"]][["var"]][which(gt_object[["_boxhead"]][["type"]] == "stub")] grp_var <- gt_object[["_boxhead"]][["var"]][which(gt_object[["_boxhead"]][["type"]] == "row_group")] stopifnot("img_source must be 'web' or 'local'" = img_source %in% c("web", "local")) gt_object %>% text_transform( locations = if (isTRUE(grp_var %in% column_names)) { cells_row_groups() } else if (isTRUE(stub_var %in% column_names)) { cells_stub(rows = !is.na({{ columns }})) } else { cells_body({{ columns }}, rows = !is.na({{ columns }})) }, fn = function(x) { lapply( x, function(x) { display_fn_image_multi(x, img_source, height) } ) } ) %>% # NA Handling so doesn't return broken img text_transform( locations = if (isTRUE(stub_var %in% column_names)) { cells_stub(rows = is.na({{ columns }})) } else { cells_body({{ columns }}, rows = is.na({{ columns }})) }, fn = function(x) { # warning("Column has some NA values, returning empty row", call. = FALSE) "" } ) } # Not exported function to convert multiple addresses within a cell into separate HTML components. display_fn_image_multi <- function(x, img_source, height) { vals <- gsub("c\\(|\\)", "", x, perl = TRUE) %>% strsplit(split = ", ") if (img_source == "web" & length(vals[[1]]) > 0) { lapply(vals, function(xx) { web_image(url = xx, height = height) }) %>% unlist() %>% paste0() %>% gt::html() %>% gsub("\"\"", "\"", .) %>% gt::html() } else if (img_source == "local" & length(vals[[1]]) > 0) { lapply(vals, function(xx) { local_image(filename = xx, height = height) }) %>% unlist() %>% paste0() %>% gt::html() %>% gsub("\"\"", "\"", .) %>% gt::html() } else if (length(vals[[1]]) == 0) { "" } } ================================================ FILE: R/gt_image_rows.R ================================================ #' Add local or web images into rows of a `gt` table #' @description #' The `gt_img_rows` function takes an existing `gt_tbl` object and #' converts filenames or urls to images into inline images. This is a wrapper #' around `gt::text_transform()` + `gt::web_image()`/`gt::local_image()` with #' the necessary boilerplate already applied. #' #' @param gt_object An existing gt table object of class `gt_tbl` #' @param columns The columns wherein changes to cell data colors should occur. #' @param img_source A string, specifying either "local" or "web" as the source of the images. #' @inheritParams gt::web_image #' @inheritParams gt::local_image #' @return An object of class `gt_tbl`. #' @export #' @section Examples: #' ```r #' library(gt) #' teams <- "https://github.com/nflverse/nflfastR-data/raw/master/teams_colors_logos.rds" #' team_df <- readRDS(url(teams)) #' #' logo_table <- team_df %>% #' dplyr::select(team_wordmark, team_abbr, logo = team_logo_espn, team_name:team_conf) %>% #' head() %>% #' gt() %>% #' gt_img_rows(columns = team_wordmark, height = 25) %>% #' gt_img_rows(columns = logo, img_source = "web", height = 30) %>% #' tab_options(data_row.padding = px(1)) #' ``` #' @section Figures: #' \if{html}{\figure{img-rows.png}{options: width:500px}} #' #' @family Utilities #' @section Function ID: #' 2-7 gt_img_rows <- function(gt_object, columns, img_source = "web", height = 30) { stopifnot("Table must be of class 'gt_tbl'" = "gt_tbl" %in% class(gt_object)) # convert tidyeval column to bare strings column_names <- resolve_cols_c( expr = {{ columns }}, data = gt_object ) stub_var <- gt_object[["_boxhead"]][["var"]][which( gt_object[["_boxhead"]][["type"]] == "stub" )] grp_var <- gt_object[["_boxhead"]][["var"]][which( gt_object[["_boxhead"]][["type"]] == "row_group" )] stopifnot( "img_source must be 'web' or 'local'" = img_source %in% c("web", "local") ) gt_object %>% text_transform( locations = if (isTRUE(grp_var %in% column_names)) { cells_row_groups() } else if (isTRUE(stub_var %in% column_names)) { cells_stub(rows = !is.na({{ columns }})) } else { cells_body({{ columns }}, rows = !is.na({{ columns }})) }, fn = function(x) { if (img_source == "web") { web_image(url = x, height = height) } else if (img_source == "local") { local_image(filename = x, height = height) } } ) %>% # NA Handling so doesn't return broken img text_transform( locations = if (isTRUE(stub_var %in% column_names)) { cells_stub(rows = is.na({{ columns }})) } else { cells_body({{ columns }}, rows = is.na({{ columns }})) }, fn = function(x) { # warning("Column has some NA values, returning empty row", call. = FALSE) "" } ) } ================================================ FILE: R/gt_img_circle.R ================================================ # Create a circular border around a image # # @param value The source image # @param height The height in pixels of the circle # @param border_color A string indicating the color of the border # @param border_weight The weight of the border in pixels # @keywords internal # @return HTML img_circle <- function(value, height, border_color, border_weight) { image <- htmltools::div( style = glue::glue( "background-image: url({value});background-size:cover;", "background-position:center;", "border: {border_weight}px solid {border_color};", "border-radius: 50%;height:{height}px;width:100%;" ) ) image } # Create a square colored border around an image # # @param value The source image # @param height The height in pixels of the circle # @param width A number indicating the height of the image in pixels. # @param border_color A string indicating the color of the border # @param border_weight The weight of the border in pixels # @keywords internal # @return HTML img_square <- function(value, height, width, border_color, border_weight) { image <- htmltools::div( style = glue::glue( "background-image: url({value});background-size:cover;", "background-position:center;", "border-bottom: {border_weight}px solid {border_color};", "border-radius: 0%;height:{height}px;width:{width}px;", "object-fit: contain;" ) ) image } #' Create an identifier line border at the bottom of an image #' #' @param gt_object An existing gt object #' @param column The column to apply the transformation to #' @param height A number indicating the height of the image in pixels. #' @param width A number indicating the width of the image in pixels. #' @param border_color The color of the circular border, can either be a single value ie (`white` or `#FF0000`) or a vector where the length of the vector is equal to the number of rows. #' @param border_weight A number indicating the weight of the border in pixels. #' @return a gt object #' @export #' #' @section Examples: #' #' ```r #' library(gt) #' gt_img_tab <- dplyr::tibble( #' x = 1:4, #' names = c("Waking Up", "Wiggling", "Sleep"," Glamour"), #' img = c( #' "https://pbs.twimg.com/media/EiIY-1fXgAEV6CJ?format=jpg&name=360x360", #' "https://pbs.twimg.com/media/EiIY-1fXcAIPdTS?format=jpg&name=360x360", #' "https://pbs.twimg.com/media/EiIY-1mX0AE-YkC?format=jpg&name=360x360", #' "https://pbs.twimg.com/media/EiIY-2cXYAA1VaO?format=jpg&name=360x360" #' ) #' ) %>% #' gt() %>% #' gt_img_border(img) #' ``` #' @section Figures: #' \if{html}{\figure{gt_img_circle.png}{options: style="width:500px;"}} #' #' @family Utilities gt_img_border <- function(gt_object, column, height = 25, width = 25, border_color = "black", border_weight = 2.5) { stopifnot("'gt_object' must be a 'gt_tbl', have you accidentally passed raw data?" = "gt_tbl" %in% class(gt_object)) gt_object %>% text_transform( locations = cells_body({{ column }}), fn = function(value) { mapply(img_square, value, height, width, border_color, border_weight, SIMPLIFY = FALSE ) } ) } #' Create circular border around an image #' #' @param gt_object An existing gt object #' @param column The column to apply the transformation to #' @param height A number indicating the height of the image in pixels. #' @param border_color The color of the circular border, can either be a single value ie (`white` or `#FF0000`) or a vector where the length of the vector is equal to the number of rows. #' @param border_weight A number indicating the weight of the border in pixels. #' @return a gt object #' @export #' #' @section Examples: #' #' ```r #' library(gt) #' gt_img_tab <- dplyr::tibble( #' x = 1:4, #' names = c("Rich Iannone", "Katie Masiello", "Tom Mock","Hadley Wickham"), #' img = c( #' "https://pbs.twimg.com/profile_images/961326215792533504/Ih6EsvtF_400x400.jpg", #' "https://pbs.twimg.com/profile_images/1471188460220260354/rHhoIXkZ_400x400.jpg", #' "https://pbs.twimg.com/profile_images/1467219661121064965/Lfondr9M_400x400.jpg", #' "https://pbs.twimg.com/profile_images/905186381995147264/7zKAG5sY_400x400.jpg" #' ) #' ) %>% #' gt() %>% #' gt_img_circle(img) #' ``` #' @section Figures: #' \if{html}{\figure{gt_img_circle.png}{options: style="width:500px;"}} #' #' @family Utilities #' @section Function ID: #' 2-15 gt_img_circle <- function(gt_object, column, height = 25, border_color = "black", border_weight = 1.5) { stopifnot("'gt_object' must be a 'gt_tbl', have you accidentally passed raw data?" = "gt_tbl" %in% class(gt_object)) gt_object %>% text_transform( locations = cells_body({{ column }}), fn = function(value) { mapply(img_circle, value, height, border_color, border_weight, SIMPLIFY = FALSE ) } ) } ================================================ FILE: R/gt_index.R ================================================ #' Return the underlying data, arranged by the internal index #' @description This is a utility function to extract the underlying data from #' a `gt` table. You can use it with a saved `gt` table, in the pipe (`%>%`) #' or even within most other `gt` functions (eg `tab_style()`). It defaults to #' returning the column indicated as a vector, so that you can work with the #' values. Typically this is used with logical statements to affect one column #' based on the values in that specified secondary column. #' Alternatively, you can extract the entire ordered data according to the #' internal index as a `tibble`. This allows for even more complex steps #' based on multiple indices. #' #' @param gt_object An existing gt table object #' @param column The column name that you intend to extract, accepts tidyeval semantics (ie `mpg` instead of `"mpg"`) #' @param as_vector A logical indicating whether you'd like just the column indicated as a vector, or the entire dataframe #' @return A vector or a `tibble` #' @export #' #' @examples #' library(gt) #' #' # This is a key step, as gt will create the row groups #' # based on first observation of the unique row items #' # this sampling will return a row-group order for cyl of 6,4,8 #' #' set.seed(1234) #' sliced_data <- mtcars %>% #' dplyr::group_by(cyl) %>% #' dplyr::slice_head(n = 3) %>% #' dplyr::ungroup() %>% #' # randomize the order #' dplyr::slice_sample(n = 9) #' #' # not in "order" yet #' sliced_data$cyl #' #' # But unique order of 6,4,8 #' unique(sliced_data$cyl) #' #' # creating a standalone basic table #' test_tab <- sliced_data %>% #' gt(groupname_col = "cyl") #' #' # can style a specific column based on the contents of another column #' tab_out_styled <- test_tab %>% #' tab_style( #' locations = cells_body(mpg, rows = gt_index(., am) == 0), #' style = cell_fill("red") #' ) #' #' # OR can extract the underlying data in the "correct order" #' # according to the internal gt structure, ie arranged by group #' # by cylinder, 6,4,8 #' gt_index(test_tab, mpg, as_vector = FALSE) #' #' # note that the order of the index data is #' # not equivalent to the order of the input data #' # however all the of the rows still match #' sliced_data #' @section Figures: #' \if{html}{\figure{gt_index_style.png}{options: style="width:500px;"}} #' #' @family Utilities #' @section Function ID: #' 2-20 gt_index <- function(gt_object, column, as_vector = TRUE) { stopifnot( "'gt_object' must be a 'gt_tbl', have you accidentally passed raw data?" = "gt_tbl" %in% class(gt_object) ) stopifnot("'as_vector' must be a TRUE or FALSE" = is.logical(as_vector)) if (length(gt_object[["_row_groups"]]) >= 1) { # if the data is grouped you need to identify the group column # and arrange by that column. I convert to a factor so that the # columns don't default to arrange by other defaults # (ie alphabetical or numerical) gt_row_grps <- gt_object[["_row_groups"]] grp_vec_ord <- gt_object[["_stub_df"]] %>% dplyr::mutate(group_id = factor(group_id, levels = gt_row_grps)) %>% dplyr::arrange(group_id) %>% dplyr::pull(rownum_i) df_ordered <- gt_object[["_data"]] %>% dplyr::slice(grp_vec_ord) } else { # if the data is not grouped, then it will just "work" df_ordered <- gt_object[["_data"]] } # return as vector or tibble in correct, gt-indexed ordered if (isTRUE(as_vector)) { df_ordered %>% dplyr::pull({{ column }}) } else { df_ordered } } ================================================ FILE: R/gt_pct_bar.R ================================================ #' Add a percent stacked barchart in place of existing data. #' @description #' The `gt_plt_bar_stack` function takes an existing `gt_tbl` object and #' converts the existing values into a percent stacked barchart. The bar chart #' will represent either 2 or 3 user-specified values per row, and requires #' a list column ahead of time. The palette and labels need to be equal length. #' The values must either add up to 100 ie as percentage points if using #' `position = 'fill'`, or can be raw values with `position = 'stack'`. Note that #' the labels can be controlled via the `fmt_fn` argument and the #' `scales::label_???()` family of function. #' #' @param gt_object An existing gt table object of class `gt_tbl` #' @param column The column wherein the percent stacked barchart should replace existing data. Note that the data *must* be represented as a list of numeric values ahead of time. #' @param palette A color palette of length 2 or 3, represented either by hex colors (`"#ff4343"`) or named colors (`"red"`). #' @param labels A vector of strings of length 2 or 3, representing the labels for the bar chart, will be colored according to the palette as well. #' @param position An string indicator passed to `ggplot2` indicating if the bar should be a percent of total `"fill"` or stacked as the raw values `"stack"`. #' @param width An integer representing the width of the bar chart in pixels. #' @param fmt_fn A specific function from `scales::label_???` family. Defaults to `scales::label_number()` #' @param font A string representing the font family of the numbers of the bar labels. Defaults to `mono`. #' @return An object of class `gt_tbl`. #' @export #' @family Plotting #' @section Examples: #' #' ```r #' library(gt) #' library(dplyr) #' #' ex_df <- dplyr::tibble( #' x = c("Example 1","Example 1", #' "Example 1","Example 2","Example 2","Example 2", #' "Example 3","Example 3","Example 3","Example 4","Example 4", #' "Example 4"), #' measure = c("Measure 1","Measure 2", #' "Measure 3","Measure 1","Measure 2","Measure 3", #' "Measure 1","Measure 2","Measure 3","Measure 1","Measure 2", #' "Measure 3"), #' data = c(30, 20, 50, 30, 30, 40, 30, 40, 30, 30, 50, 20) #' ) #' #' #' tab_df <- ex_df %>% #' group_by(x) %>% #' summarise(list_data = list(data)) #' #' tab_df #' #' ex_tab <- tab_df %>% #' gt() %>% #' gt_plt_bar_stack(column = list_data) #' ``` #' \if{html}{\figure{plt-bar-stack.png}{options: style="width:500px;"}} gt_plt_bar_stack <- function( gt_object, column = NULL, palette = c("#ff4343", "#bfbfbf", "#0a1c2b"), labels = c("Group 1", "Group 2", "Group 3"), position = "fill", width = 70, fmt_fn = scales::label_number(scale_cut = cut_short_scale(), trim = TRUE), font = "mono" ) { stopifnot("Table must be of class 'gt_tbl'" = "gt_tbl" %in% class(gt_object)) stopifnot("There must be 2 or 3 labels" = (length(labels) %in% c(2:3))) stopifnot( "There must be 2 or 3 colors in the palette" = (length(palette) %in% c(2:3)) ) stopifnot( "`position` must be one of 'stack' or 'fill'" = (position %in% c("stack", "fill")) ) var_sym <- rlang::enquo(column) var_bare <- rlang::as_label(var_sym) all_vals <- gt_index(gt_object, {{ column }}) %>% lapply(X = ., FUN = sum, na.rm = TRUE) %>% unlist() if (length(all_vals) == 0) { return(gt_object) } total_rng <- max(all_vals, na.rm = TRUE) tab_out <- text_transform( gt_object, locations = cells_body({{ column }}), fn = function(x) { bar_fx <- function(x_val) { if (x_val %in% c("NA", "NULL")) { return("
") } col_pal <- palette vals <- strsplit(x_val, split = ", ") %>% unlist() %>% as.double() n_val <- length(vals) stopifnot("There must be 2 or 3 values" = (n_val %in% c(2, 3))) col_fill <- if (n_val == 2) { c(1, 2) } else { c(1:3) } df_in <- dplyr::tibble( x = vals, y = rep(1, n_val), fill = col_pal[col_fill] ) plot_out <- df_in %>% ggplot( aes( x = .data$x, y = factor(.data$y), fill = I(.data$fill), group = .data$y ) ) + geom_col(position = position, color = "white", width = 1) + geom_text( aes(label = fmt_fn(x)), hjust = 0.5, size = 3, family = font, position = if (position == "fill") { position_fill(vjust = .5) } else if (position == "stack") { position_stack(vjust = .5) }, color = "white" ) + scale_x_continuous( expand = if (position == "stack") { expansion(mult = c(0, 0.1)) } else { c(0, 0) }, limits = if (position == "stack") { c(0, total_rng) } else { NULL } ) + scale_y_discrete(expand = c(0, 0)) + coord_cartesian(clip = "off") + theme_void() + theme( legend.position = "none", plot.margin = margin(0, 0, 0, 0, "pt") ) out_name <- file.path(tempfile( pattern = "file", tmpdir = tempdir(), fileext = ".svg" )) ggsave( out_name, plot = plot_out, dpi = 25.4, height = 5, width = width, units = "mm", device = "svg" ) img_plot <- readLines(out_name) %>% paste0(collapse = "") %>% gt::html() on.exit(file.remove(out_name), add = TRUE) img_plot } tab_built <- lapply(X = x, FUN = bar_fx) } ) label_built <- if (length(labels) == 2) { lab_pal1 <- palette[1] lab_pal2 <- palette[2] lab1 <- labels[1] lab2 <- labels[2] glue::glue( "{lab1}", "||", "{lab2}" ) %>% gt::html() } else { lab_pal1 <- palette[1] lab_pal2 <- palette[2] lab_pal3 <- palette[3] lab1 <- labels[1] lab2 <- labels[2] lab3 <- labels[3] glue::glue( "
{lab1}", "||", "{lab2}", "||", "{lab3}
" ) %>% gt::html() } # Get the columns supplied in `columns` as a character vector tab_out <- dt_boxhead_edit_column_label( data = tab_out, var = var_bare, column_label = label_built ) suppressWarnings( tab_out %>% # format the label 'column' as gt::html cols_label( {{ column }} := gt::html(label_built) ) ) } ================================================ FILE: R/gt_plt_bar.R ================================================ #' Add bar plots into rows of a `gt` table #' @description #' The `gt_plt_bar` function takes an existing `gt_tbl` object and #' adds horizontal barplots via `ggplot2`. Note that values are plotted on a #' shared x-axis, and a vertical black bar is added at x = zero. To add labels #' to each of the of the bars, set `scale_type` to either `'percent'` or `'number`'. #' #' @param gt_object An existing gt table object of class `gt_tbl` #' @param column A single column wherein the bar plot should replace existing data. #' @param color A character representing the color for the bar, defaults to purple. Accepts a named color (eg `'purple'`) or a hex color. #' @param ... Additional arguments passed to `scales::label_number()` or `scales::label_percent()`, depending on what was specified in `scale_type` #' @param keep_column `TRUE`/`FALSE` logical indicating if you want to keep a copy of the "plotted" column as raw values next to the plot itself.. #' @param width An integer indicating the width of the plot in pixels. #' @param scale_type A string indicating additional text formatting and the addition of numeric labels to the plotted bars if not `'none'`. If `'none'`, no numbers will be added to the bar, but if `"number"` or `"percent"` are used, then the numbers in the plotted column will be added as a bar-label and formatted according to `scales::label_percent()` or `scales::label_number()`. #' @param text_color A string indicating the color of text if `scale_type` is used. Defaults to `"white"` #' @return An object of class `gt_tbl`. #' @export #' @section Examples: #' ```r #' library(gt) #' gt_plt_bar_tab <- mtcars %>% #' head() %>% #' gt() %>% #' gt_plt_bar(column = mpg, keep_column = TRUE) #' ``` #' #' \if{html}{\figure{gt_plt_bar.png}{options: style="width:500px;"}} #' #' @family Plotting #' @section Function ID: #' 3-4 gt_plt_bar <- function(gt_object, column = NULL, color = "purple", ..., keep_column = FALSE, width = 40, scale_type = "none", text_color = "white") { stopifnot( "'gt_object' must be a 'gt_tbl', have you accidentally passed raw data?" = "gt_tbl" %in% class(gt_object) ) stopifnot( "`scale_type` must be one of 'number', 'percent' or 'none'" = scale_type %in% c("number", "percent", "none") ) var_sym <- rlang::enquo(column) var_bare <- rlang::as_label(var_sym) col_bare <- var_bare all_vals <- gt_index(gt_object, {{ column }}) %>% unlist() # need to handle truly empty cols if (length(na.omit(all_vals)) == 0) { return(gt_object) } stopifnot( "Colors must be either length 1 or equal length to the column" = isTRUE(length(color) == 1 | length(color) == length(all_vals)) ) stopifnot("'text_color' must be length 1" = length(text_color) == 1) if (length(color) == 1) { colors <- rep(color, length(all_vals)) } else if (length(color) == length(all_vals)) { colors <- color } if ((min(all_vals, na.rm = TRUE) >= 0)) { min_val <- 0 rng_multiplier <- c(0.98, 1.02) } else if ( (max(all_vals, na.rm = TRUE) < 0 & min(all_vals, na.rm = TRUE) < 0) ) { min_val <- min(all_vals, na.rm = TRUE) rng_multiplier <- c(1.02, 0) } else { min_val <- min(all_vals, na.rm = TRUE) rng_multiplier <- c(1.02, 1.02) } total_rng <- c(min_val, max(all_vals, na.rm = TRUE)) * rng_multiplier if (isTRUE(keep_column)) { gt_object <- gt_object %>% gt_duplicate_column({{ column }}, dupe_name = "DUPE_COLUMN_PLT") } bar_fx <- function(x_val, colors) { if (x_val %in% c("NA", "NULL", NA)) { return("
") } vals <- as.double(x_val) df_in <- dplyr::tibble( x = vals, y = rep(1), fill = colors ) plot_out <- df_in %>% ggplot( aes( x = .data$x, y = factor(.data$y), fill = I(.data$fill), group = .data$y ) ) + geom_col(color = "transparent", width = 0.35) + scale_x_continuous( limits = total_rng, expand = expansion(mult = c(0.05, 0.08)), ) + scale_y_discrete(expand = expansion(mult = c(0.2, 0.2))) + geom_vline(xintercept = 0, color = "black", linewidth = 0.5) + coord_cartesian(clip = "off") + theme_void() + theme(legend.position = "none", plot.margin = unit(rep(0, 4), "pt")) if (scale_type != "none") { plot_out <- plot_out + geom_text( aes( x = .data$x, label = if (scale_type == "number") { scales::label_number(...)(.data$x) } else if (scale_type == "percent") { scales::label_percent(...)(.data$x) }, hjust = ifelse(.data$x >= 0, 1.2, -.2) ), vjust = 0.5, size = 3, color = text_color, fontface = "bold" ) } out_name <- file.path(tempfile( pattern = "file", tmpdir = tempdir(), fileext = ".svg" )) ggsave( out_name, plot = plot_out, dpi = 25.4, height = 5, width = width, units = "mm", device = "svg" ) img_plot <- readLines(out_name) %>% paste0(collapse = "") %>% gt::html() on.exit(file.remove(out_name), add = TRUE) img_plot } tab_out <- text_transform( gt_object, locations = if (isTRUE(keep_column)) { cells_body(columns = c(DUPE_COLUMN_PLT)) } else { cells_body(columns = {{ column }}) }, fn = function(x) { tab_built <- mapply(bar_fx, x_val = x, colors = colors) } ) if (isTRUE(keep_column)) { tab_out %>% cols_label(DUPE_COLUMN_PLT = col_bare) %>% cols_align("left", columns = c(DUPE_COLUMN_PLT)) } else { tab_out %>% cols_align("left", columns = {{ column }}) } } ================================================ FILE: R/gt_plt_bullet.R ================================================ #' Create an inline 'bullet chart' in a gt table #' #' @param gt_object An existing gt table object of class `gt_tbl` #' @param column The column where a 'bullet chart' will replace the inline values. #' @param target The column indicating the target values that will be represented by a vertical line #' @param width Width of the plot in pixels #' @param palette Color of the bar and target line, defaults to `c("grey", "red")`, can use named colors or hex colors. Must be of length two, and the first color will always be used as the bar color. #' @param palette_col An additional column that contains specific colors for the bar colors themselves. Defaults to NULL which skips this argument. #' @importFrom stats na.omit #' @return An object of class `gt_tbl`. #' @export #' #' @section Examples: #' #' ```r #' set.seed(37) #' bullet_tab <- tibble::rownames_to_column(mtcars) %>% #' dplyr::select(rowname, cyl:drat, mpg) %>% #' dplyr::group_by(cyl) %>% #' dplyr::mutate(target_col = mean(mpg)) %>% #' dplyr::slice_sample(n = 3) %>% #' dplyr::ungroup() %>% #' gt::gt() %>% #' gt_plt_bullet(column = mpg, target = target_col, width = 45, #' palette = c("lightblue", "black")) %>% #' gt_theme_538() #' ``` #' \if{html}{\figure{gt_bullet.png}{options: style="width:500px;"}} #' #' @family Themes #' @section Function ID: #' 3-7 gt_plt_bullet <- function( gt_object, column = NULL, target = NULL, width = 65, palette = c("grey", "red"), palette_col = NULL ) { stopifnot("'gt_object' must be a 'gt_tbl', have you accidentally passed raw data?" = "gt_tbl" %in% class(gt_object)) stopifnot("'palette' must be 2 colors" = length(palette) == 2) # extract the values from specified columns all_vals <- gt_index(gt_object, {{ column }}) target_vals <- gt_index(gt_object, {{ target }}) if (length(all_vals) == 0) { return(gt_object) } # provide a forced zero baseline - needed for small value ranges rng_val <- range(c(all_vals, target_vals), na.rm = TRUE) if (all(na.omit(all_vals) >= 0)) rng_val <- c(0, max(rng_val)) length_val <- length(all_vals) col_bare <- gt_index(gt_object, {{ column }}, as_vector = FALSE) %>% dplyr::select({{ column }}) %>% names() if (!rlang::quo_is_null(rlang::enquo(palette_col))) { bar_pal <- gt_index(gt_object, {{ palette_col }}) tar_pal <- rep(palette[2], length(bar_pal)) } else { tar_pal <- rep(palette[2], length_val) bar_pal <- rep(palette[1], length_val) } tab_out <- gt_object %>% text_transform( locations = cells_body({{ column }}), fn = function(x) { bar_fx <- function(vals, target_vals, tar_pal, bar_pal) { if (is.na(vals) | is.null(vals)) { return("
") } if (is.na(target_vals)) { stop( "Target Column not coercible to numeric, please create and supply an unformatted column ahead of time with gtExtras::gt_duplicate_columns()", call. = FALSE ) } if (is.na(vals)) { stop( "Column not coercible to numeric, please create and supply an unformatted column ahead of time with gtExtras::gt_duplicate_columns()", call. = FALSE ) } plot_out <- ggplot(data = NULL, aes(x = vals, y = factor("1"))) + geom_col(width = 0.1, color = bar_pal, fill = bar_pal) + geom_vline( xintercept = target_vals, color = tar_pal, linewidth = 1.5, alpha = 0.7 ) + geom_vline(xintercept = 0, color = "black", linewidth = 1) + theme_void() + coord_cartesian(xlim = rng_val) + scale_x_continuous(expand = expansion(mult = c(0, 0.15))) + scale_y_discrete(expand = expansion(mult = c(0.1, 0.1))) + theme_void() + theme( legend.position = "none", plot.margin = margin(0, 0, 0, 0, "pt"), plot.background = element_blank(), panel.background = element_blank() ) out_name <- file.path(tempfile( pattern = "file", tmpdir = tempdir(), fileext = ".svg" )) ggsave( out_name, plot = plot_out, dpi = 25.4, height = 5, width = width, units = "mm", device = "svg" ) img_plot <- readLines(out_name) %>% paste0(collapse = "") %>% gt::html() on.exit(file.remove(out_name), add = TRUE) img_plot } tab_built <- mapply(bar_fx, all_vals, target_vals, tar_pal, bar_pal) tab_built } ) %>% gt::cols_align(align = "left", columns = {{ column }}) %>% gt::cols_hide({{ target }}) if (!rlang::quo_is_null(rlang::enquo(palette_col))) { tab_out %>% gt::cols_hide({{ palette_col }}) } else { tab_out } } ================================================ FILE: R/gt_plt_conf_int.R ================================================ #' Plot a confidence interval around a point #' #' @param gt_object An existing gt table #' @param column The column that contains the mean of the sample. This can either be a single number per row, if you have calculated the values ahead of time, or a list of values if you want to calculate the confidence intervals. #' @param ci_columns Optional columns representing the left/right confidence intervals of your sample. #' @param ci The confidence interval, representing the percentage, ie `0.9` which represents `10-90` for the two tails. #' @param palette A vector of color strings of exactly length 4. The colors represent the central point, the color of the range, the color of the stroke around the central point, and the color of the text, in that specific order. #' @param width A number indicating the width of the plot in `"mm"`, defaults to `45`. #' @param text_args A list of named arguments. Optional text arguments passed as a list to `scales::label_number`. #' @param text_size A number indicating the size of the text indicators in the plot. Defaults to 1.5. Can also be set to `0` to "remove" the text itself. #' @param ref_line A number indicating where to place reference line on x-axis. #' #' @return a gt table #' @export #' #' @section Examples: #' ```r #' # gtExtras can calculate basic conf int #' # using confint() function #' #' ci_table <- generate_df( #' n = 50, n_grps = 3, #' mean = c(10, 15, 20), sd = c(10, 10, 10), #' with_seed = 37 #' ) %>% #' dplyr::group_by(grp) %>% #' dplyr::summarise( #' n = dplyr::n(), #' avg = mean(values), #' sd = sd(values), #' list_data = list(values) #' ) %>% #' gt::gt() %>% #' gt_plt_conf_int(list_data, ci = 0.9) #' #' # You can also provide your own values #' # based on your own algorithm/calculations #' pre_calc_ci_tab <- dplyr::tibble( #' mean = c(12, 10), ci1 = c(8, 5), ci2 = c(16, 15), #' ci_plot = c(12, 10) #' ) %>% #' gt::gt() %>% #' gt_plt_conf_int( #' ci_plot, c(ci1, ci2), #' palette = c("red", "lightgrey", "black", "red") #' ) #' ``` #' @section Figures: #' \if{html}{\figure{gt_plt_ci_calc.png}{options: style="width:500px;"}} #' \if{html}{\figure{gt_plt_ci_vals.png}{options: style="width:500px;"}} #' #' @family Themes #' @section Function ID: #' 3-10 gt_plt_conf_int <- function( gt_object, column, ci_columns, ci = 0.9, ref_line = NULL, palette = c("black", "grey", "white", "black"), width = 45, text_args = list(accuracy = 1), text_size = 1.5 ) { all_vals <- gt_index(gt_object, {{ column }}, as_vector = FALSE) stopifnot( "Confidence level must be between 0 and 1" = dplyr::between(ci, 0, 1) ) # convert desired confidence interval from percentage # to a two-tailed level to be used in confint() function level <- 1 - ((1 - ci) * 2) # if user doesn't supply their own pre-defined columns # grab them or save as "none" if (!missing(ci_columns)) { ci_vals <- all_vals %>% dplyr::select({{ ci_columns }}) ci_val1 <- ci_vals[[1]] ci_val2 <- ci_vals[[2]] } else { ci_val1 <- "none" } column_vals <- all_vals %>% dplyr::select({{ column }}) %>% dplyr::pull() if ("none" %in% ci_val1) { stopifnot( "Must provide list column if no defined Confidence Intervals" = (class( column_vals ) %in% c("list")) ) # create a list of dataframes with # roughly calculated confidence intervals data_in <- lapply(column_vals, function(x) { dplyr::tibble(x = stats::na.omit(x), y = "1a") %>% dplyr::summarise( mean = mean(.data$x, na.rm = TRUE), y = unique(.data$y, na.rm = TRUE), lm_out = list(stats::lm(x ~ 1)), ci = list(stats::confint(.data$lm_out[[1]], level = level)), ci1 = ci[[1]][1], ci2 = ci[[1]][2] ) %>% dplyr::mutate(y = "1a") }) } else { stopifnot( "Must provide single values per row if defining Confidence Intervals" = !(class( column_vals ) %in% "list") ) data_in <- dplyr::tibble(mean = column_vals, y = "1a") %>% dplyr::mutate( ci1 = ci_val1, ci2 = ci_val2, row_n = dplyr::row_number() ) %>% split(.$row_n) } # calculate the total range so the x-axis can be shared across rows all_ci_min <- min(dplyr::bind_rows(data_in)$ci1, na.rm = TRUE) all_ci_max <- max(dplyr::bind_rows(data_in)$ci2, na.rm = TRUE) ext_range <- scales::expand_range( c(all_ci_min, all_ci_max), mul = 0.1, zero_width = 1 ) ref_line <- if (is.null(ref_line)) { list("none") } else { list(ref_line) } gt_object %>% text_transform( locations = cells_body(columns = {{ column }}), fn = function(x) { tab_built <- mapply( FUN = add_ci_plot, data_in, list(palette), width, list(ext_range), list(text_args), text_size, list(ref_line), SIMPLIFY = FALSE ) tab_built } ) %>% gt::cols_align(align = "left", columns = {{ column }}) } #' Add a confidence interval plot inside a specific row #' #' @param data_in A dataframe of length 1 #' @param pal_vals A length 4 palette to be used for coloring points, segments and text #' @param width Width of the output plot in `'mm'` #' @param ext_range A length two vector of the full range across all values #' @param text_args A list of optional text arguments passed to `scales::label_number()` #' @inheritParams gt_plt_conf_int #' @noRd #' #' @return SVG/HTML add_ci_plot <- function( data_in, pal_vals, width, ext_range, text_args = list(scale_cut = cut_short_scale()), text_size, ref_line ) { if (NA %in% unlist(data_in)) { return(" ") } if (unlist(ref_line) == "none") { base_plot <- data_in %>% ggplot(aes(x = .data$mean, y = "1a")) } else { base_plot <- data_in %>% ggplot(aes(x = .data$mean, y = "1a")) + geom_text( aes( x = unlist(ref_line) * 1.01, label = do.call(scales::label_number, text_args)(unlist(ref_line)) ), color = pal_vals[4], vjust = 1.1, size = text_size, hjust = 0, position = position_nudge(y = -0.25), family = "mono", fontface = "bold" ) + geom_vline(xintercept = ref_line[[1]], color = pal_vals[4]) } plot_out <- base_plot + geom_segment( aes(x = .data$ci1, xend = .data$ci2, y = .data$y, yend = .data$y), lineend = "round", linewidth = 1, color = pal_vals[2], alpha = 0.75 ) + geom_point( aes(x = .data$mean, y = .data$y), size = 2, shape = 21, fill = pal_vals[1], color = pal_vals[3], stroke = 0.75 ) + geom_label( aes( x = .data$ci2, label = do.call(scales::label_number, text_args)(.data$ci2) ), color = pal_vals[4], hjust = 1.1, size = text_size, vjust = 0, fill = "transparent", position = position_nudge(y = 0.25), family = "mono", fontface = "bold", label.size = 0, label.padding = unit(0.05, "lines"), label.r = unit(0, "lines") ) + geom_label( aes( x = .data$ci1, label = do.call(scales::label_number, text_args)(.data$ci1) ), position = position_nudge(y = 0.25), color = pal_vals[4], hjust = -0.1, size = text_size, vjust = 0, fill = "transparent", family = "mono", fontface = "bold", label.size = 0, label.padding = unit(0.05, "lines"), label.r = unit(0, "lines") ) + theme_void() + theme( legend.position = "none", plot.margin = margin(0, 0, 0, 0, "pt"), plot.background = element_blank(), panel.background = element_blank() ) + coord_cartesian(ylim = c(0.9, 1.5), xlim = ext_range) out_name <- file.path(tempfile( pattern = "file", tmpdir = tempdir(), fileext = ".svg" )) ggsave( out_name, plot = plot_out, dpi = 25.4, height = 5, width = width, units = "mm", device = "svg" ) img_plot <- readLines(out_name) %>% paste0(collapse = "") %>% gt::html() on.exit(file.remove(out_name), add = TRUE) img_plot } ================================================ FILE: R/gt_plt_dist.R ================================================ #' Add distribution plots into rows of a `gt` table #' @description #' The `gt_plt_dist` function takes an existing `gt_tbl` object and #' adds summary distribution sparklines via `ggplot2`. Note that these sparklines #' are limited to density, histogram, boxplot or rug/strip charts. If you're #' wanting to plot more traditional spark**lines**, you can use `gtExtras::gt_plt_sparkline()`. #' #' @param gt_object An existing gt table object of class `gt_tbl` #' @param column The column wherein the sparkline plot should replace existing data. Note that the data *must* be represented as a list of numeric values ahead of time. #' @param type A string indicating the type of plot to generate, accepts `"boxplot"`, `"histogram"`, `"rug_strip"` or `"density"`. #' @param fig_dim A vector of two numbers indicating the height/width of the plot in mm at a DPI of 25.4, defaults to `c(5,30)` #' @param line_color Color for the line, defaults to `"black"`. Accepts a named color (eg 'blue') or a hex color. #' @param fill_color Color for the fill of histograms/density plots, defaults to `"grey"`. Accepts a named color (eg `'blue'`) or a hex color. #' @param bw The bandwidth or binwidth, passed to `density()` or `ggplot2::geom_histogram()`. If `type = "density"`, then `bw` is passed to the `bw` argument, if `type = "histogram"`, then `bw` is passed to the `binwidth` argument. #' @param trim A logical indicating whether to trim the values in `type = "density"` to a slight expansion beyond the observable range. Can help with long tails in `density` plots. #' @param same_limit A logical indicating that the plots will use the same axis range (`TRUE`) or have individual axis ranges (`FALSE`). #' @param type_col A tidyselect column indicating a vector of which `type` of plot to make by row. Must be equal to the total number of rows and limited to `"boxplot"`, `"histogram"`, `"rug_strip"` or `"density"`. #' @return An object of class `gt_tbl`. #' @export #' @section Examples: #' ```r #' library(gt) #' gt_sparkline_tab <- mtcars %>% #' dplyr::group_by(cyl) %>% #' # must end up with list of data for each row in the input dataframe #' dplyr::summarize(mpg_data = list(mpg), .groups = "drop") %>% #' gt() %>% #' gt_plt_dist(mpg_data) #' ``` #' @section Figures: #' \if{html}{\figure{gt_plt_dist.png}{options: style="width:500px;"}} #' #' @family Plotting #' @section Function ID: #' 1-4 gt_plt_dist <- function(gt_object, column, type = "density", fig_dim = c(5, 30), line_color = "black", fill_color = "grey", bw = NULL, trim = FALSE, same_limit = TRUE, type_col = NULL ) { is_gt_stop(gt_object) # convert tidyeval column to bare string col_bare <- dplyr::select(gt_object[["_data"]], {{ column }}) %>% names() # segment data with bare string column name list_data_in <- gt_index(gt_object, col_bare, as_vector = TRUE) # convert to a single vector data_in <- unlist(list_data_in) stopifnot("Specified column must contain list of values" = any(class(list_data_in) %in% "list")) stopifnot("Specified column must be numeric" = is.numeric(data_in)) stopifnot("You must indicate the `type` of plot as one of 'boxplot', 'histogram', 'rug_strip' or 'density'." = isTRUE(type %in% c("boxplot", "rug_strip", "histogram", "density"))) # range to be used for plotting if same axis total_rng <- grDevices::extendrange(data_in, r = range(data_in, na.rm = TRUE), f = 0.02) # TODO: Need to account for bw as well. plot_fn_spark <- function(trim, list_data_in, type_in) { if (all(list_data_in %in% c(NA, NULL))) { return("
") } vals <- as.double(stats::na.omit(list_data_in)) max_val <- max(vals, na.rm = TRUE) min_val <- min(vals, na.rm = TRUE) x_max <- vals[vals == max_val] x_min <- vals[vals == min_val] input_data <- dplyr::tibble( x = 1:length(vals), y = vals ) # respect type column or value type = type_in if (type == "boxplot") { plot_base <- ggplot(input_data) + theme_void() if (isTRUE(same_limit)) { plot_base <- plot_base + scale_x_continuous(expand = expansion(mult = 0.05)) + coord_cartesian( clip = "off", xlim = grDevices::extendrange(total_rng, f = c(0, 0.01)), ylim = c(0.9, 1.15) ) } else { plot_base <- plot_base + scale_x_continuous(expand = expansion(mult = 0.05)) + coord_cartesian( clip = "off", xlim = grDevices::extendrange(vals, f = 0.09), ylim = c(0.9, 1.15) ) } plot_out <- plot_base + geom_boxplot( aes(x = .data$y, y = 1), width = 0.15, color = line_color, fill = fill_color, outlier.size = 0.3, linewidth = 0.3 ) } else if (type == "rug_strip") { plot_base <- ggplot(input_data) + theme_void() if (isTRUE(same_limit)) { plot_base <- plot_base + scale_x_continuous(expand = expansion(mult = 0.05)) + coord_cartesian( clip = "off", xlim = grDevices::extendrange(total_rng, f = 0.09), ylim = c(0.75, 1.15) ) } else { plot_base <- plot_base + scale_x_continuous(expand = expansion(mult = 0.05)) + coord_cartesian( clip = "off", xlim = grDevices::extendrange(vals, f = 0.09), ylim = c(0.75, 1.15) ) } plot_out <- plot_base + geom_point( aes(x = .data$y, y = 1), alpha = 0.2, size = 0.3, color = line_color, position = position_jitter(height = 0.15, seed = 37) ) + geom_rug( aes(x = .data$y), length = unit(0.2, "npc"), alpha = 0.5, linewidth = 0.2 ) } else if (type == "histogram") { plot_base <- ggplot(input_data) + theme_void() if (isTRUE(same_limit)) { if (is.null(bw)) { bw <- bw_calc(data_in) } else { bw <- bw } plot_out <- plot_base + { if(bw > 0){ geom_histogram( aes(x = .data$y), color = line_color, fill = fill_color, binwidth = bw, linewidth = 0.2 ) } else if(bw == 0) { bw <- 1 geom_histogram( aes(x = .data$y), color = line_color, fill = fill_color, binwidth = bw, linewidth = 0.2 ) } else { hist_breaks <- graphics::hist(data_in[!is.na(data_in)], breaks = "FD", plot=FALSE)$breaks geom_histogram( aes(x = .data$y), color = line_color, fill = fill_color, breaks = hist_breaks, linewidth = 0.2 ) } } + scale_x_continuous(expand = expansion(mult = 0.1)) + coord_cartesian( clip = "off", xlim = grDevices::extendrange( data_in, r = range(data_in, na.rm = TRUE), f = 0.02 ) ) } else { if (is.null(bw)) { bw <- 2 * stats::IQR(vals, na.rm = TRUE) / length(vals)^(1 / 3) } else { bw <- bw } plot_out <- plot_base + geom_histogram( aes(x = .data$y), color = line_color, fill = fill_color, binwidth = bw ) + coord_cartesian( clip = "off", xlim = grDevices::extendrange( vals, r = range(vals, na.rm = TRUE), f = 0.02 ) ) } } else if (type == "density") { if (isTRUE(same_limit)) { if (is.null(bw)) { bw <- stats::bw.nrd0(stats::na.omit(as.vector(data_in))) } else { bw <- bw } total_rng_dens <- stats::density( as.vector( stats::na.omit(data_in) ), bw = bw )[["x"]] density_calc <- stats::density(input_data[["y"]], bw = bw) density_range <- density_calc[["x"]] density_df <- dplyr::tibble( x = density_calc[["x"]], y = density_calc[["y"]] ) if (trim) { # implementation of filtering values # only to actual and slightly outside the range filter_range <- range(vals, na.rm = TRUE) %>% scales::expand_range(mul = 0.05) density_df <- dplyr::filter( density_df, dplyr::between(.data$x, filter_range[1], filter_range[2]) ) } plot_base <- ggplot(density_df) + theme_void() plot_out <- plot_base + geom_area( aes(x = .data$x, y = .data$y), color = line_color, fill = fill_color ) + xlim(range(density_range)) + coord_cartesian( xlim = range(total_rng_dens, na.rm = TRUE), expand = TRUE, clip = "off" ) } else { if (is.null(bw)) { bw <- stats::bw.nrd0(stats::na.omit(as.vector(data_in))) } else { bw <- bw } total_rng_dens <- stats::density(stats::na.omit(as.vector(vals)), bw = bw)[["x"]] density_calc <- stats::density(input_data[["y"]], bw = bw) density_range <- density_calc[["x"]] density_df <- dplyr::tibble( x = density_calc[["x"]], y = density_calc[["y"]] ) if (trim) { # implementation of filtering values # only to actual and slightly outside the range filter_range <- range(vals, na.rm = TRUE) %>% scales::expand_range(mul = 0.05) density_df <- dplyr::filter( density_df, dplyr::between(.data$x, filter_range[1], filter_range[2]) ) } plot_base <- ggplot(density_df) + theme_void() plot_out <- plot_base + geom_area( aes(x = .data$x, y = .data$y), color = line_color, fill = fill_color ) + xlim(range(density_range, na.rm = TRUE)) + coord_cartesian( xlim = range(total_rng_dens, na.rm = TRUE), expand = TRUE, clip = "off" ) } } out_name <- file.path( tempfile(pattern = "file", tmpdir = tempdir(), fileext = ".svg") ) ggsave( out_name, plot = plot_out, dpi = 25.4, height = fig_dim[1], width = fig_dim[2], units = "mm" ) img_plot <- out_name %>% readLines() %>% paste0(collapse = "") %>% gt::html() on.exit(file.remove(out_name), add = TRUE) img_plot } if(!rlang::quo_is_null(rlang::enquo(type_col))){ type_vec <- gt_index(gt_object, {{ type_col }}, as_vector = TRUE) type <- type_vec stopifnot("You must indicate the `type` of plot as one of 'boxplot', 'histogram', 'rug_strip' or 'density'." = isTRUE(all(type %in% c("boxplot", "rug_strip", "histogram", "density")))) } text_transform( gt_object, locations = cells_body(columns = {{ column }}), fn = function(x) { mapply(plot_fn_spark, trim, list_data_in, type, SIMPLIFY = FALSE) } ) } ================================================ FILE: R/gt_plt_dumbbell.R ================================================ #' Add a dumbbell plot in place of two columns #' #' @param gt_object an existing gt_tbl or pipeline #' @param col1 column 1, plot will replace this column #' @param col2 column 2, will be hidden #' @param label an optional new label for the transformed column #' @param palette must be 3 colors in order of col1, col2, bar color #' @param width width in mm, defaults to 70 #' @param text_args A list of named arguments. Optional text arguments passed as a list to `scales::label_number`. #' @param text_size A number indicating the size of the text indicators in the plot. Defaults to 1.5. Can also be set to `0` to "remove" the text itself. #' #' @return a gt_object table #' @export #' #' @section Examples: #' ```r #' head(mtcars) %>% #' gt() %>% #' gt_plt_dumbbell(disp, mpg) #' ``` #' @section Figures: #' \if{html}{\figure{gt_plt_dumbell.png}{options: style="width:500px;"}} gt_plt_dumbbell <- function( gt_object, col1 = NULL, col2 = NULL, label = NULL, palette = c("#378E38", "#A926B6", "#D3D3D3"), width = 70, text_args = list(accuracy = 1), text_size = 2.5 ) { stopifnot("'gt_object' must be a 'gt_tbl', have you accidentally passed raw data?" = "gt_tbl" %in% class(gt_object)) stopifnot("'palette' must be 3 colors in order of col1, col2, bar color" = length(palette) == 3) if (rlang::quo_is_null(rlang::enquo(col1)) | rlang::quo_is_null(rlang::enquo(col2))) { stop("'col1' and 'col2' must be specified") } # extract the values from specified columns df_in <- gtExtras::gt_index(gt_object, {{ col1 }}, as_vector = FALSE) %>% dplyr::select(x1 = {{ col1 }}, x2 = {{ col2 }}) if (length(df) == 0) { return(gt_object) } all_vals <- df_in %>% unlist() %>% as.vector() rng_val <- range(all_vals, na.rm = TRUE) tab_out <- gt_object %>% text_transform( locations = cells_body({{ col1 }}), fn = function(x) { dumbbell_fx <- function(col1_vals, col2_vals, text_args, text_size) { all_df_in_vals <- c(col1_vals, col2_vals) if (any(is.na(all_df_in_vals)) | any(is.null(all_df_in_vals))) { return("
") } df_vals <- dplyr::tibble(x1 = col1_vals, x2 = col2_vals) # TODO: revisit horizontal adjustment hjust_val <- ifelse(col1_vals >= col2_vals, list(1,0), list(0,1)) plot_obj <- ggplot(df_vals, aes(y = "y1")) + geom_segment( aes(x = x1, xend = x2, yend = "y1"), linewidth = 1.5, color = palette[3] ) + geom_point( aes(x = x1), color = "white", pch = 21, fill = palette[1], size = 3, stroke = 1.25 ) + geom_point( aes(x = x2), color = "white", pch = 21, fill = palette[2], size = 3, stroke = 1.25 ) + geom_text( aes( x = x1, y = 1.05, label = do.call(scales::label_number, text_args)(x1), ), # TODO: revisit horizontal adjustment # hjust = hjust_val[[1]], family = "mono", color = palette[1], size = text_size, ) + geom_text( aes( x = x2, y = 1.05, label = do.call(scales::label_number, text_args)(x2), ), # TODO: revisit horizontal adjustment # hjust = hjust_val[[2]], family = "mono", color = palette[2], size = text_size ) + coord_cartesian(xlim = rng_val) + scale_x_continuous(expand = expansion(mult = c(0.1, 0.1))) + scale_y_discrete(expand = expansion(mult = c(0.03, 0.095))) + theme( legend.position = "none", plot.margin = margin(0, 0, 0, 0, "pt"), plot.background = element_blank(), panel.background = element_blank() ) + theme_void() save_svg(plot_obj, height = 7, width = width, units = "mm") } tab_built <- mapply( dumbbell_fx, df_in[[1]], df_in[[2]], list(text_args), text_size, SIMPLIFY = FALSE ) tab_built } ) %>% gt::cols_align(align = "left", columns = {{ col1 }}) %>% gt::cols_hide({{ col2 }}) if(!is.null(label)){ return( tab_out %>% cols_label({{ col1 }} := label) ) } tab_out } ================================================ FILE: R/gt_plt_percentile_dot.R ================================================ #' Create a dot plot from 0 to 100 #' @param data The single value that will be used to plot the point. #' @param palette A length 3 palette, used to highlight high/med/low #' @param add_label A logical indicating whether to add the label or note. This will only be added if it is the first or last row. #' @param width A numeric indicating the #' @return gt table #' add_pcttile_plot <- function(data, palette, add_label, width) { if (data %in% c("NA", "NULL", NA, NULL)) { return("
") } stopifnot("Values must be between 0 and 100" = dplyr::between(data, 0, 100)) df_in <- dplyr::tibble( x = data, y = 1, color = palette ) out_pct_plt <- ggplot(df_in) + geom_vline(xintercept = 50, color = "black", linewidth = 0.5) + geom_vline(xintercept = c(0, 25, 75, 100), color = "grey", linewidth = 0.25) + geom_hline(yintercept = 1, color = "lightgrey", linewidth = 0.25, linetype = "dotted") + geom_point(aes(x = .data$x, y = .data$y, fill = I(.data$color)), color = "black", size = 3, stroke = 0.5, shape = 21 ) + theme_void() + coord_cartesian( xlim = c(0, 100), ylim = c(0.6, 1.2), clip = "off" ) if (isTRUE(add_label)) { out_pct_plt <- out_pct_plt + geom_text( data = NULL, aes(x = 1, y = .61, label = "0"), hjust = 0, vjust = 0, size = 1.5, family = "mono", color = "black" ) + geom_text(aes(x = 99, y = 0.61, label = "100"), hjust = 1, vjust = 0, size = 1.5, family = "mono", color = "black" ) + geom_text(aes(x = 49, y = 0.61, label = "5"), hjust = 1, vjust = 0, size = 1.5, family = "mono", color = "black" ) + geom_text(aes(x = 51, y = 0.61, label = "0"), hjust = 0, vjust = 0, size = 1.5, family = "mono", color = "black" ) } else { out_pct_plt <- out_pct_plt } out_name <- file.path(tempfile( pattern = "file", tmpdir = tempdir(), fileext = ".svg" )) ggsave(out_name, out_pct_plt, height = 5, width = width, dpi = 25.4, units = "mm", device = "svg" ) img_plot <- readLines(out_name) %>% paste0(collapse = "") %>% gt::html() on.exit(file.remove(out_name), add = TRUE) img_plot } #' Create a dot plot for percentiles #' @description Creates a percentile dot plot in each row. Can be used as an #' alternative for a 0 to 100% bar plot. Allows for scaling values as well and #' accepts a vector of colors for the range of values. #' @param gt_object An existing gt table #' @param column The column to transform to the percentile dot plot. Accepts `tidyeval`. All values must be end up being between 0 and 100. #' @param palette A vector of strings of length 3. Defaults to `c('blue', 'lightgrey', 'red')` as hex so `c("#007ad6", "#f0f0f0", "#f72e2e")` #' @param width A numeric, indicating the width of the plot in `mm`, defaults to 25 #' @param scale A number to multiply/scale the values in the column by. Defaults to 1, but can also be 100 if you have decimals. #' @return a gt table #' @export #' #' @section Examples: #' ```r #' library(gt) #' dot_plt <- dplyr::tibble(x = c(seq(10, 90, length.out = 5))) %>% #' gt() %>% #' gt_duplicate_column(x,dupe_name = "dot_plot") %>% #' gt_plt_percentile(dot_plot) #' ``` #' @section Figures: #' \if{html}{\figure{gt_plt_percentile.png}{options: style="width:500px;"}} #' #' @family Plotting #' @section Function ID: #' 3-8 gt_plt_percentile <- function(gt_object, column, palette = c("#007ad6", "#f0f0f0", "#f72e2e"), width = 25, scale = 1) { gt_object %>% text_transform( locations = cells_body({{ column }}), fn = function(x) { x <- as.double(x) * scale n_vals <- 1:length(x) stopifnot("Values must be scaled between 0 and 100" = dplyr::between(x, 0, 100)) col_pal <- scales::col_quantile( palette = palette, domain = c(0:100), reverse = TRUE, alpha = TRUE, n = 5 )(x) add_label <- n_vals %in% c(min(n_vals), max(n_vals)) mapply(add_pcttile_plot, x, col_pal, add_label, width, SIMPLIFY = FALSE) } ) } ================================================ FILE: R/gt_plt_point.R ================================================ #' Create a dot plot from any range - add_point_plot #' #' @param data The single value that will be used to plot the point. #' @param palette A length 3 palette, used to highlight high/med/low #' @param add_label A logical indicating whether to add the label or note. This will only be added if it is the first or last row. #' @param width A numeric indicating the #' @param vals_range vector of length two indicating range #' @inheritParams scales::label_number #' #' @return gt table add_point_plot <- function(data, palette, add_label, width, vals_range, accuracy) { if (data %in% c("NA", "NULL", NA, NULL)) { return("
") } else { df_in <- dplyr::tibble( x = data, y = 1, color = palette ) val_breaks <- seq(from = vals_range[1], to = vals_range[2], length.out = 4) break_labs <- scales::label_number( accuracy = accuracy, scale_cut = cut_short_scale() )(val_breaks[c(1, 4)]) out_pt_plt <- ggplot(df_in) + geom_vline( xintercept = val_breaks, color = "grey", linewidth = 0.25 ) + geom_hline( yintercept = 1, color = "lightgrey", linewidth = 0.25, linetype = "dotted" ) + geom_point( aes(x = .data$x, y = .data$y, fill = I(.data$color)), color = "black", size = 3, stroke = 0.5, shape = 21 ) + theme_void() + coord_cartesian( xlim = vals_range, ylim = c(0.6, 1.2), clip = "off" ) if (isTRUE(add_label)) { out_pt_plt <- out_pt_plt + geom_text( data = NULL, aes(x = val_breaks[1], y = .61, label = break_labs[1]), hjust = -0.1, vjust = 0, size = 1.5, family = "mono", color = "black" ) + geom_text( aes(x = val_breaks[4], y = .61, label = break_labs[2]), hjust = 1.1, vjust = 0, size = 1.5, family = "mono", color = "black" ) } else { out_pt_plt <- out_pt_plt } out_name <- file.path(tempfile( pattern = "file", tmpdir = tempdir(), fileext = ".svg" )) ggsave( out_name, out_pt_plt, height = 5, width = width, dpi = 25.4, units = "mm", device = "svg" ) img_plot <- readLines(out_name) %>% paste0(collapse = "") %>% gt::html() on.exit(file.remove(out_name), add = TRUE) img_plot } } #' Create a point plot in place of each value. #' @description Creates a dot/point plot in each row. Can be used as an #' alternative for a bar plot. Accepts any range of values, as opposed to #' `gt_plt_percentile` which is intended to be used for values between 0 and 100. #' @param gt_object An existing gt table #' @param column The column to transform to the percentile dot plot. Accepts `tidyeval`. All values must be end up being between 0 and 100. #' @param palette A vector of strings of length 3. Defaults to `c('blue', 'lightgrey', 'red')` as hex so `c("#007ad6", "#f0f0f0", "#f72e2e")` #' @param width A numeric, indicating the width of the plot in `mm`, defaults to 25 #' @param scale A number to multiply/scale the values in the column by. Defaults to 1, but can also be 100 if you have decimals. #' @param accuracy Accuracy of the number labels in the plot, passed to `scales::label_number()` #' @return a gt table #' @export #' #' @section Examples: #' ```r #' point_tab <- dplyr::tibble(x = c(seq(1.2e6, 2e6, length.out = 5))) %>% #' gt::gt() %>% #' gt_duplicate_column(x,dupe_name = "point_plot") %>% #' gt_plt_point(point_plot, accuracy = .1, width = 25) %>% #' gt::fmt_number(x, suffixing = TRUE, decimals = 1) #' ``` #' @section Figures: #' \if{html}{\figure{gt_plt_point.png}{options: style="width:500px;"}} #' #' @family Plotting #' @section Function ID: #' 3-9 gt_plt_point <- function(gt_object, column, palette = c("#007ad6", "#f0f0f0", "#f72e2e"), width = 25, scale = 1, accuracy = 1) { col_vals <- gt_index(gt_object, {{ column }}) val_range <- scales::expand_range( range = range(col_vals, na.rm = TRUE), mul = 0.1 ) gt_object %>% text_transform( locations = cells_body({{ column }}), fn = function(x) { x <- as.double(x) * scale n_vals <- 1:length(x) col_pal <- scales::col_quantile( palette = palette, domain = val_range, reverse = TRUE, alpha = TRUE, n = 5 )(x) add_label <- n_vals %in% c(min(n_vals), max(n_vals)) mapply( add_point_plot, x, col_pal, add_label, width, list(val_range), accuracy, SIMPLIFY = FALSE ) } ) } ================================================ FILE: R/gt_plt_sparkline.R ================================================ #' Add sparklines into rows of a `gt` table #' @description #' The `gt_plt_sparkline` function takes an existing `gt_tbl` object and #' adds sparklines via the `ggplot2`. Note that if you'd rather plot summary #' distributions (ie density/histograms) you can instead use: `gtExtras::gt_plt_dist()` #' #' @param gt_object An existing gt table object of class `gt_tbl` #' @param column The column wherein the sparkline plot should replace existing data. Note that the data *must* be represented as a list of numeric values ahead of time. #' @param type A string indicating the type of plot to generate, accepts `"default"`, `"points"`, `"shaded"`, `"ref_median"`, `'ref_mean'`, `"ref_iqr"`, `"ref_last"`. "points" will add points to every observation instead of just the high/low and final. "shaded" will add shading below the sparkline. The "ref_" options add a thin reference line based off the summary statistic chosen #' @param fig_dim A vector of two numbers indicating the height/width of the plot in mm at a DPI of 25.4, defaults to `c(5,30)` #' @param palette A character string with 5 elements indicating the colors of various components. Order matters, and palette = sparkline color, final value color, range color low, range color high, and 'type' color (eg shading or reference lines). To show a plot with no points (only the line itself), use: `palette = c("black", rep("transparent", 4))`. #' @param same_limit A logical indicating that the plots will use the same axis range (`TRUE`) or have individual axis ranges (`FALSE`). #' @param label A logical indicating whether the sparkline will have a numeric label for the last value in the vector, placed at the end of the plot. #' @return An object of class `gt_tbl`. #' @export #' @section Examples: #' ```r #' library(gt) #' gt_sparkline_tab <- mtcars %>% #' dplyr::group_by(cyl) %>% #' # must end up with list of data for each row in the input dataframe #' dplyr::summarize(mpg_data = list(mpg), .groups = "drop") %>% #' gt() %>% #' gt_plt_sparkline(mpg_data) #' ``` #' @section Figures: #' \if{html}{\figure{gt_plt_sparkline.png}{options: style="width:500px;"}} #' #' @family Plotting #' @section Function ID: #' 1-4 gt_plt_sparkline <- function( gt_object, column, type = "default", fig_dim = c(5, 30), palette = c("black", "black", "purple", "green", "lightgrey"), same_limit = TRUE, label = TRUE ) { stopifnot( "'gt_object' must be a 'gt_tbl', have you accidentally passed raw data?" = "gt_tbl" %in% class(gt_object) ) # convert tidyeval column to bare string col_bare <- dplyr::select(gt_object[["_data"]], {{ column }}) %>% names() # segment data with bare string column name list_data_in <- gt_index(gt_object, col_bare, as_vector = TRUE) # convert to a single vector data_in <- unlist(list_data_in) stopifnot( "Specified column must contain list of values" = class(list_data_in) %in% "list" ) stopifnot( "You must supply five colors for the palette." = length(palette) == 5L ) stopifnot( "You must indicate the `type` of plot as one of 'default', 'shaded', 'ref_median', 'ref_mean', 'points', 'ref_last' or 'ref_iqr'." = isTRUE( type %in% c( "default", "shaded", "ref_median", "ref_mean", "ref_iqr", "points", "ref_last" ) ) ) # range to be used for plotting if same axis total_rng <- grDevices::extendrange( data_in, r = range(data_in, na.rm = TRUE), f = 0.02 ) plot_fn_spark <- function(list_data_in) { if (all(list_data_in %in% c(NA, NULL))) { return("
") } # vals <- as.double(stats::na.omit(list_data_in)) vals <- as.double(list_data_in) max_val <- max(vals, na.rm = TRUE) min_val <- min(vals, na.rm = TRUE) x_max <- vals[vals == max_val] x_min <- vals[vals == min_val] point_data <- dplyr::tibble( x = c( c(1:length(vals))[vals == min_val], c(1:length(vals))[vals == max_val] ), y = c(x_min, x_max), colors = c( rep(palette[3], length(x_min)), rep(palette[4], length(x_max)) ) ) input_data <- dplyr::tibble( x = 1:length(vals), y = vals ) plot_base <- ggplot(input_data) + theme_void() med_y_rnd <- round(stats::median(input_data$y, na.rm = TRUE)) last_val_label <- input_data[nrow(vals), 2] if (isTRUE(same_limit) && isFALSE(label)) { plot_base <- plot_base + scale_y_continuous(expand = expansion(mult = 0.05)) + coord_cartesian( clip = "off", ylim = grDevices::extendrange(total_rng, f = 0.09) ) } else if (isFALSE(same_limit) && isFALSE(label)) { plot_base <- plot_base + scale_y_continuous(expand = expansion(mult = 0.05)) + coord_cartesian( clip = "off", ylim = grDevices::extendrange(vals, f = 0.09) ) } else if (isFALSE(same_limit) && isTRUE(label)) { plot_base <- plot_base + geom_text( data = filter(input_data, .data$x == max(.data$x)), aes( x = .data$x, y = .data$y, label = scales::label_number( scale_cut = cut_short_scale(), accuracy = if (med_y_rnd > 0) { .1 } else if (med_y_rnd == 0) { .01 } )(.data$y) ), size = 2, family = "mono", hjust = 0, vjust = 0.5, position = position_nudge(x = max(input_data$x) * 0.05), color = palette[2], na.rm = TRUE ) + scale_y_continuous(expand = expansion(mult = 0.05)) + coord_cartesian( clip = "off", ylim = grDevices::extendrange(vals, f = 0.09), xlim = c(0.25, length(vals) * 1.25) ) } else if (isTRUE(same_limit) && isTRUE(label)) { plot_base <- plot_base + geom_text( data = filter(input_data, .data$x == max(.data$x)), aes( x = .data$x, y = .data$y, label = scales::label_number( scale_cut = cut_short_scale(), accuracy = if (med_y_rnd > 0) { .1 } else if (med_y_rnd == 0) { .01 } )(.data$y) ), size = 2, family = "mono", hjust = 0, vjust = 0.5, position = position_nudge(x = max(input_data$x) * 0.05), color = palette[2], na.rm = TRUE ) + scale_y_continuous(expand = expansion(mult = 0.05)) + coord_cartesian( clip = "off", ylim = grDevices::extendrange(total_rng, f = 0.09), xlim = c(0.25, length(vals) * 1.25) ) } plot_out <- plot_base + geom_line( aes(x = .data$x, y = .data$y, group = 1), linewidth = 0.5, color = palette[1], na.rm = TRUE ) + geom_point( data = filter(input_data, .data$x == max(.data$x)), aes(x = .data$x, y = .data$y), size = 0.5, color = palette[2], na.rm = TRUE ) + geom_point( data = point_data, aes(x = .data$x, y = .data$y, color = I(.data$colors), group = 1), size = 0.5, na.rm = TRUE ) ### Shaded area if (type == "shaded") { plot_out$layers <- c( geom_area( aes(x = .data$x, y = .data$y), fill = palette[5], alpha = 0.75, na.rm = TRUE ), plot_out$layers ) ### Horizontal ref line at median } else if (type == "ref_median") { plot_out$layers <- c( annotate( "segment", x = min(input_data$x), y = stats::median(input_data$y), xend = max(input_data$x), yend = stats::median(input_data$y), color = palette[5], linewidth = 0.5, na.rm = TRUE ), plot_out$layers ) ### dots on all points } else if (type == "points") { plot_out$layers <- c( geom_point( aes(x = .data$x, y = .data$y), color = palette[5], size = 0.4, na.rm = TRUE ), plot_out$layers ) ### Horizontal ref line at mean } else if (type == "ref_mean") { plot_out$layers <- c( annotate( "segment", x = min(input_data$x), y = mean(input_data$y), xend = max(input_data$x), yend = mean(input_data$y), color = palette[5], linewidth = 0.5, na.rm = TRUE ), plot_out$layers ) ### Horizontal ref line at last point } else if (type == "ref_last") { plot_out$layers <- c( annotate( "segment", x = min(input_data$x), y = dplyr::last(input_data$y), xend = max(input_data$x), yend = dplyr::last(input_data$y), color = palette[5], linewidth = 0.5, na.rm = TRUE ), plot_out$layers ) ### Horizontal area/ribbon for 25/75 interquantile range } else if (type == "ref_iqr") { ribbon_df <- input_data %>% summarise( q25 = stats::quantile(.data$y, 0.25), q75 = stats::quantile(.data$y, 0.75) ) plot_out$layers <- c( geom_ribbon( aes(x = .data$x, ymin = ribbon_df$q25, ymax = ribbon_df$q75), fill = palette[5], alpha = 0.5, na.rm = TRUE ), annotate( "segment", x = min(input_data$x), y = ribbon_df$q25, xend = max(input_data$x), yend = ribbon_df$q25, color = palette[5], linewidth = 0.5, na.rm = TRUE ), plot_out$layers ) } out_name <- file.path( tempfile(pattern = "file", tmpdir = tempdir(), fileext = ".svg") ) ggsave( out_name, plot = plot_out, dpi = 25.4, height = fig_dim[1], width = fig_dim[2], units = "mm" ) img_plot <- out_name %>% readLines() %>% paste0(collapse = "") %>% gt::html() on.exit(file.remove(out_name), add = TRUE) img_plot } text_transform( gt_object, locations = cells_body(columns = {{ column }}), fn = function(x) lapply(list_data_in, plot_fn_spark) ) } ================================================ FILE: R/gt_reprex_image.R ================================================ #' Render 'gt' Table to Temporary png File #' #' Saves a gt table to a temporary png image file and uses #' `knitr::include_graphics()` to render tables in reproducible examples #' like `reprex::reprex()` where the HTML is not transferrable to GitHub. #' #' @description Take a gt pipeline or object and print it as an image within #' a reprex #' @param gt_object An object of class `gt_tbl` usually created by [gt::gt()] #' @importFrom knitr include_graphics #' #' @return a png image #' @export #' gt_reprex_image <- function(gt_object) { stopifnot("Table must be of class 'gt_tbl'" = inherits(gt_object, "gt_tbl")) # create temp file img_out <- tempfile(fileext = ".png") # save image to temp save_obj <- gt::gtsave(gt_object, img_out) %>% utils::capture.output(type = "message") %>% invisible() if(!grepl("screenshot completed", tolower(save_obj))) print(save_obj) # just include the image knitr::include_graphics(img_out) } ================================================ FILE: R/gt_resolver.R ================================================ # vendored code with attribution from gt # https://github.com/rstudio/gt/blob/ec97f7385166946d7a964ef31b7f6508ccd56550/R/resolver.R #' Resolve the `cells_body` 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_body()` function. #' #' @import rlang #' @noRd resolve_cells_body <- function(data, object) { # Get the `stub_df` data frame from `data` stub_df <- dt_stub_df_get(data = data) data_tbl <- dt_data_get(data = data) # # Resolution of columns and rows as integer vectors # providing the positions of the matched variables # # Resolve columns as index values resolved_columns_idx <- resolve_cols_i( expr = !!object$columns, data = data ) # Resolve rows as index values resolved_rows_idx <- resolve_rows_i( expr = !!object$rows, data = data ) # Get all possible combinations with `expand.grid()` expansion <- expand.grid( resolved_columns_idx, resolved_rows_idx, stringsAsFactors = FALSE ) %>% dplyr::arrange(Var1) %>% dplyr::distinct() # Create a list object cells_resolved <- list( columns = expansion[[1]], colnames = names(expansion[[1]]), rows = expansion[[2]] ) # Apply the `data_cells_resolved` class class(cells_resolved) <- "data_cells_resolved" cells_resolved } #' Resolve the `cells_stub` 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_stub()` function. #' @noRd resolve_cells_stub <- function(data, object) { # # Resolution of rows as integer vectors # providing the positions of the matched variables # resolved_rows_idx <- resolve_rows_i( expr = !!object$rows, data = data ) # Create a list object cells_resolved <- list(rows = resolved_rows_idx) # Apply the `stub_cells_resolved` class class(cells_resolved) <- "stub_cells_resolved" cells_resolved } #' Resolve 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_labels <- function(data, object) { # # Resolution of columns as integer vectors # providing the positions of the matched variables # resolved_columns <- resolve_cols_i( expr = !!object$columns, data = data ) # Create a list object cells_resolved <- list(columns = resolved_columns) # Apply the `columns_cells_resolved` class 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() spanner_ids <- dt_spanners_get(data = data) %>% .$spanner_id %>% .[!is.na(.)] resolved_spanners_idx <- resolve_vector_i( expr = !!object$spanners, vector = spanner_ids, item_label = "spanner" ) resolved_spanners <- spanner_ids[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 } #' @param expr An unquoted expression that follows **tidyselect** semantics #' @param data A gt object or data frame or tibble #' @return Character vector #' @noRd resolve_cols_c <- function(expr, data, strict = TRUE, excl_stub = TRUE, null_means = c("everything", "nothing")) { null_means <- match.arg(null_means) names( resolve_cols_i( expr = {{ expr }}, data = data, strict = strict, excl_stub = excl_stub, null_means = null_means ) ) } #' @param expr An unquoted expression that follows **tidyselect** semantics #' @param data A gt object or data frame or tibble #' @param strict If TRUE, out-of-bounds errors are thrown if `expr` attempts to #' select a column that doesn't exist. If FALSE, failed selections are #' ignored. #' @param excl_stub If TRUE then the table stub column, if present, will be #' excluded from the selection of column names. #' @return Named integer vector #' @noRd resolve_cols_i <- function(expr, data, strict = TRUE, excl_stub = TRUE, null_means = c("everything", "nothing")) { quo <- rlang::enquo(expr) cols_excl <- c() null_means <- match.arg(null_means) if (is_gt(data)) { cols <- colnames(dt_data_get(data = data)) # In most cases we would want to exclude the column that # represents the stub but that isn't always the case (e.g., # when considering the stub for column sizing); the `excl_stub` # argument will determine whether the stub column is obtained # for exclusion or not (if FALSE, we get NULL which removes the # stub, if present, from `cols_excl`) stub_var <- if (excl_stub) { dt_boxhead_get_var_stub(data) } else { NULL } # The columns that represent the group rows are always # excluded (i.e., included in the `col_excl` vector) group_rows_vars <- dt_boxhead_get_vars_groups(data) cols_excl <- c(stub_var, group_rows_vars) data <- dt_data_get(data = data) } stopifnot(is.data.frame(data)) quo <- translate_legacy_resolver_expr(quo, null_means) # With the quosure and the `data`, we can use `tidyselect::eval_select()` # to resolve the expression to columns indices/names; no `env` argument # is required here because the `expr` is a quosure selected <- tidyselect::eval_select(expr = quo, data = data, strict = strict) # Exclude certain columns (e.g., stub & group columns) if necessary selected[!names(selected) %in% cols_excl] } #' @param quo A quosure that might contain legacy gt column criteria #' @noRd translate_legacy_resolver_expr <- function(quo, null_means) { expr <- rlang::quo_get_expr(quo = quo) if (identical(expr, FALSE)) { warning( "`columns = FALSE` has been deprecated in gt 0.3.0:\n", "* please use `columns = c()` instead", call. = FALSE ) rlang::quo_set_expr(quo = quo, expr = quote(NULL)) } else if (identical(expr, TRUE)) { warning( "`columns = TRUE` has been deprecated in gt 0.3.0:\n", "* please use `columns = everything()` instead", call. = FALSE ) rlang::quo_set_expr(quo = quo, expr = quote(everything())) } else if (is.null(expr)) { if (null_means == "everything") { warning( "`columns = NULL` has been deprecated in gt 0.3.0:\n", "* please use `columns = everything()` instead", call. = FALSE ) rlang::quo_set_expr(quo = quo, expr = quote(everything())) } else { rlang::quo_set_expr(quo = quo, expr = quote(NULL)) } } else if (rlang::quo_is_call(quo = quo, name = "vars")) { warning( "`columns = vars(...)` has been deprecated in gt 0.3.0:\n", "* please use `columns = c(...)` instead", call. = FALSE ) rlang::quo_set_expr( quo = quo, expr = rlang::call2(quote(c), !!!rlang::call_args(expr)) ) } else { # No legacy expression detected quo } } resolve_rows_l <- function(expr, data) { if (is_gt(data)) { row_names <- dt_stub_df_get(data)$rowname data <- dt_data_get(data = data) } else { row_names <- row.names(data) } stopifnot(is.data.frame(data)) quo <- rlang::enquo(expr) resolved <- tidyselect::with_vars( vars = row_names, expr = rlang::eval_tidy(expr = quo, data = data) ) if (is.null(resolved)) { warning( "The use of `NULL` for rows has been deprecated in gt 0.3.0:\n", "* please use `TRUE` instead", call. = FALSE ) # Modify the NULL value of `resolved` to `TRUE` (which is # fully supported for selecting all rows) resolved <- TRUE } resolved <- normalize_resolved( resolved = resolved, item_names = row_names, item_label = "row" ) resolved } resolve_rows_i <- function(expr, data) { which(resolve_rows_l(expr = {{ expr }}, data = data)) } resolve_vector_l <- function(expr, vector, item_label = "item") { quo <- rlang::enquo(expr) resolved <- tidyselect::with_vars( vars = vector, expr = rlang::eval_tidy(expr = quo, data = NULL) ) resolved <- normalize_resolved( resolved = resolved, item_names = vector, item_label = item_label ) resolved } resolve_vector_i <- function(expr, vector, item_label = "item") { which(resolve_vector_l(expr = {{ expr }}, vector = vector, item_label = item_label)) } normalize_resolved <- function(resolved, item_names, item_label) { item_count <- length(item_names) item_sequence <- seq_along(item_names) if (is.null(resolved)) { # Maintained for backcompatability resolved <- rep_len(TRUE, item_count) # TODO: this may not apply to all types of resolution so we may # want to either make this warning conditional (after investigating which # resolving contexts still allow `NULL`) warning( "The use of `NULL` for ", item_label, "s has been deprecated in gt 0.3.0:\n", "* please use `everything()` instead", call. = FALSE ) } else if (is.logical(resolved)) { if (length(resolved) == 1) { resolved <- rep_len(resolved, item_count) } else if (length(resolved) == item_count) { # Do nothing } else { resolver_stop_on_logical(item_label = item_label) } } else if (is.numeric(resolved)) { unknown_resolved <- setdiff(resolved, item_sequence) if (length(unknown_resolved) != 0) { resolver_stop_on_numeric(item_label = item_label, unknown_resolved = unknown_resolved) } resolved <- item_sequence %in% resolved } else if (is.character(resolved)) { unknown_resolved <- setdiff(resolved, item_names) if (length(unknown_resolved) != 0) { resolver_stop_on_character(item_label = item_label, unknown_resolved = unknown_resolved) } resolved <- item_names %in% resolved } else { resolver_stop_unknown(item_label = item_label, resolved = resolved) } resolved } resolver_stop_on_logical <- function(item_label) { stop( "The number of logical values must either be 1 or the number of ", item_label, "s", call. = FALSE ) } resolver_stop_on_numeric <- function(item_label, unknown_resolved) { stop( "The following ", item_label, " indices do not exist in the data: ", paste0(unknown_resolved, collapse = ", "), call. = FALSE ) } resolver_stop_on_character <- function(item_label, unknown_resolved) { stop( "The following ", item_label, "(s) do not exist in the data: ", paste0(unknown_resolved, collapse = ", "), call. = FALSE ) } resolver_stop_unknown <- function(item_label, resolved) { stop( "Don't know how to select ", item_label, "s using an object of class ", class(resolved)[1], call. = FALSE ) } ================================================ FILE: R/gt_summary_table.R ================================================ #' Create a summary table from a dataframe #' @description Create a summary table from a dataframe with inline #' histograms or area bar charts. Inspired by the Observable team and #' the observablehq/SummaryTable function: https://observablehq.com/d/d8d2929832202050 #' @param df a dataframe or tibble #' @param title a character string to be used in the table title #' @importFrom stats median sd #' @import gt #' @importFrom gt %>% #' @importFrom stats IQR #' @importFrom graphics hist #' @importFrom utils packageVersion #' @return a gt table #' @export #' @section Examples: #' #' Create a summary table from a `data.frame` or `tibble`. #' #' ```r #' gt_plt_summary(datasets::ChickWeight) #' ``` #' \if{html}{\out{ #' `r man_get_image_tag(file = "gt_plt_summary-chicks.png", alt = "A summary table of the chicks dataset.")` #' }} gt_plt_summary <- function(df, title = NULL) { # if no title, return name of input dataframe # returns a . for df %>% gt_plt_summary() if (is.null(title)) title <- deparse(substitute(df)) if (any(sapply(df, class) == "list")) { stop("gt_plt_summary() doesn't handle list columns.", call. = FALSE) } if (nrow(df) >= 1e5) { warning( "Data has more than 100,000 rows, consider sampling the data to reduce size.", call. = FALSE ) } sum_table <- create_sum_table(df) dim_df <- dim(df) tab_out <- sum_table %>% gt() %>% text_transform( cells_body(name), fn = function(x) { temp_df <- gtExtras::gt_index(gt_object = ., name, as_vector = FALSE) apply_detail <- function(type, name, value) { if (grepl(x = type, pattern = "factor|character|ordered")) { value_count <- tapply(value, value, length) %>% sort(decreasing = TRUE) %>% labels() %>% unlist() html( glue::glue( "
{name} {glue::glue_collapse(value_count, ', ', last = ' and ')}
" ) ) } else { name } } mapply( FUN = apply_detail, temp_df$type, temp_df$name, temp_df$value, MoreArgs = NULL ) } ) %>% text_transform(cells_body(value), fn = function(x) { .mapply( FUN = plot_data, list( gtExtras::gt_index(gt_object = ., value), gtExtras::gt_index(gt_object = ., name), gtExtras::gt_index(gt_object = ., n_missing) ), MoreArgs = NULL ) }) %>% # add number formatting to numeric cols fmt_number( 5:7, #Mean:SD, decimals = 1, rows = type %in% c("numeric", "double", "integer") ) %>% fmt_percent(n_missing, decimals = 1) %>% # add symbols for specific types text_transform( cells_body(type), fn = function(x) { lapply(x, function(z) { if (grepl(x = z, pattern = "factor|character|ordered")) { fontawesome::fa("list", "#4e79a7", height = "20px") } else if ( grepl(x = z, pattern = "number|numeric|double|integer|complex") ) { fontawesome::fa("signal", "#f18e2c", height = "20px") } else if ( grepl(x = z, pattern = "date|time|posix|hms", ignore.case = TRUE) ) { fontawesome::fa("clock", "#73a657", height = "20px") } else { fontawesome::fa("question", "black", height = "20px") } }) } ) %>% cols_label( name = "Column", value = "Plot Overview", type = "", n_missing = "Missing" ) %>% gtExtras::gt_theme_espn() %>% tab_style(cells_body(name), style = cell_text(weight = "bold")) %>% tab_header( title = title, subtitle = glue::glue("{dim_df[1]} rows x {dim_df[2]} cols") ) %>% tab_options( column_labels.border.top.width = px(0), heading.border.bottom.width = px(0) ) { if (utils::packageVersion("gt")$major <= 1) { tab_out %>% sub_missing(5:7) #Mean:SD) } else { tab_out %>% fmt_missing(5:7, missing_text = "--") } } } #' Create a summary table from a dataframe #' #' @param df a dataframe or tibble #' #' @return A summary dataframe as a tibble #' @export #' #' @examples #' \dontrun{ #' create_sum_table(iris) #' #> # A tibble: 5 × 7 #' #> type name value n_missing Mean Median SD #' #> #' #> 1 numeric Sepal.Length 0 5.84 5.8 0.828 #' #> 2 numeric Sepal.Width 0 3.06 3 0.436 #' #> 3 numeric Petal.Length 0 3.76 4.35 1.77 #' #> 4 numeric Petal.Width 0 1.20 1.3 0.762 #' #> 5 factor Species 0 NA NA NA #' } #' create_sum_table <- function(df) { sum_table <- df %>% dplyr::summarise(dplyr::across(dplyr::everything(), list)) %>% tidyr::pivot_longer(dplyr::everything()) %>% dplyr::rowwise() %>% dplyr::mutate( type = paste0(class(value), collapse = " "), n_missing = sum(is.na(value) | is.null(value)) / length(value) ) %>% dplyr::mutate( Mean = ifelse( type %in% c("double", "integer", "numeric"), mean(value, na.rm = TRUE), NA ), Median = ifelse( type %in% c("double", "integer", "numeric"), median(value, na.rm = TRUE), NA ), SD = ifelse( type %in% c("double", "integer", "numeric"), sd(value, na.rm = TRUE), NA ) ) %>% dplyr::ungroup() %>% dplyr::select(type, name, dplyr::everything()) sum_table # browser() } #' Create inline plots for a summary table #' #' @param col The column of data to be used for plotting #' @param col_name the name of the column - use for reporting warnings #' @param n_missing Number of missing - used if all missing #' @param ... additional arguments passed to scales::label_number() #' @import ggplot2 dplyr #' @importFrom scales seq_gradient_pal expand_range label_number cut_long_scale label_date #' @return svg text encoded as HTML plot_data <- function(col, col_name, n_missing, ...) { if (n_missing >= 0.99) { return("
") } col_type <- paste0(class(col), collapse = " ") col <- col[!is.na(col)] if (col_type %in% c("factor", "character", "ordered factor")) { n_unique <- length(unique(col)) cat_lab <- ifelse( col_type == "ordered factor", "categories, ordered", "categories" ) cc <- scales::seq_gradient_pal( low = "#3181bd", high = "#ddeaf7", space = "Lab" )(seq(0, 1, length.out = n_unique)) plot_out <- dplyr::tibble(vals = as.character(col)) %>% dplyr::group_by(vals) %>% dplyr::mutate(n = n(), .groups = "drop") %>% dplyr::arrange(desc(n)) %>% dplyr::ungroup() %>% dplyr::mutate( vals = factor(vals, levels = unique(rev(vals)), ordered = TRUE) ) %>% ggplot(aes(y = 1, fill = vals)) + geom_bar(position = "fill") + guides(fill = "none") + scale_fill_manual(values = rev(cc)) + theme_void() + theme( axis.title.x = element_text(hjust = 0, size = 8), plot.margin = margin(3, 1, 3, 1) ) + scale_x_continuous(expand = c(0, 0)) + labs(x = paste(n_unique, cat_lab)) } else if (col_type %in% c("numeric", "double", "integer", "complex")) { df_in <- dplyr::tibble(x = col) %>% dplyr::filter(!is.na(x)) rng_vals <- scales::expand_range(range(col, na.rm = TRUE), mul = 0.01) # auto binwidth per Rob Hyndman # https://stats.stackexchange.com/questions/798/calculating-optimal-number-of-bins-in-a-histogram bw <- 2 * IQR(col, na.rm = TRUE) / length(col)^(1 / 3) plot_out <- ggplot(df_in, aes(x = x)) + # conditional to switch between estimated binwidth or Freedman–Diaconis rule { if (bw > 0) { geom_histogram(color = "white", fill = "#f8bb87", binwidth = bw) } else { hist_breaks <- graphics::hist( col[!is.na(col)], breaks = "FD", plot = FALSE )$breaks geom_histogram( color = "white", fill = "#f8bb87", breaks = hist_breaks ) } } + scale_x_continuous( breaks = range(col, na.rm = TRUE), labels = scales::label_number( big.mark = ",", ..., scale_cut = scales::cut_si(unit = "auto") )(range(col, na.rm = TRUE)) ) + geom_point( data = data.frame(x = rng_vals[1], y = 1), aes(x = x, y = y), color = "transparent", size = 0.1 ) + geom_point( data = data.frame(x = rng_vals[1], y = 1), aes(x = x, y = y), color = "transparent", size = 0.1 ) + scale_y_continuous(expand = c(0, 0)) + { if (length(unique(col)) > 2) geom_vline(xintercept = median(col, na.rm = TRUE)) } + theme_void() + theme( axis.text.x = element_text( color = "black", vjust = -2, size = 6 ), axis.line.x = element_line(color = "black"), axis.ticks.x = element_line(color = "black"), axis.ticks.length.x = unit(1, "mm"), plot.margin = margin(1, 1, 3, 1), text = element_text(family = "mono", size = 6) ) } else if ( grepl(x = col_type, pattern = "date|posix|time|hms", ignore.case = TRUE) ) { # message(glue::glue("Dates and times are not fully supported yet - plot and summaries skipped for col {col_name}")) df_in <- dplyr::tibble(x = col) %>% dplyr::filter(!is.na(x)) bw <- 2 * IQR(col, na.rm = TRUE) / length(col)^(1 / 5) plot_out <- ggplot(data = df_in, aes(x = x)) + geom_histogram(color = "white", fill = "#73a657", binwidth = bw) + { if ("continuous" %in% ggplot2::scale_type(col)) { scale_x_continuous( breaks = range(col, na.rm = TRUE), labels = scales::label_date()(range(col, na.rm = TRUE)) ) } else if ("time" %in% ggplot2::scale_type(col)) { scale_x_time( breaks = range(col, na.rm = TRUE) ) } else { scale_x_discrete( breaks = range(col, na.rm = TRUE) ) } } + theme_void() + theme( axis.text.x = element_text( color = "black", vjust = -2, size = 6 ), axis.line.x = element_line(color = "black"), axis.ticks.x = element_line(color = "black"), axis.ticks.length.x = unit(1, "mm"), plot.margin = margin(1, 1, 3, 1), text = element_text(family = "mono", size = 6) ) } out_name <- file.path(tempfile( pattern = "file", tmpdir = tempdir(), fileext = ".svg" )) ggsave( out_name, plot = plot_out, dpi = 25.4, height = 12, width = 50, units = "mm", device = "svg" ) img_plot <- readLines(out_name) %>% paste0(collapse = "") %>% gt::html() on.exit(file.remove(out_name), add = TRUE) img_plot } ================================================ FILE: R/gt_text_img.R ================================================ #' Add text and an image to the left or right of it #' @description #' The `add_text_img` function takes an existing `gt_tbl` object and #' adds some user specified text and an image url to a specific cell. This is a #' wrapper raw HTML strings and `gt::web_image()`. Intended to be used inside #' the header of a table via `gt::tab_header()`. #' #' @param text A text string to be added to the cell. #' @inheritParams gt::web_image #' @param left A logical TRUE/FALSE indicating if text should be on the left (TRUE) or right (FALSE) #' @return An object of class `gt_tbl`. #' @export #' #' @family Utilities #' @section Function ID: #' 2-5 #' #' @examples #' library(gt) #' title_car <- mtcars %>% #' head() %>% #' gt() %>% #' gt::tab_header( #' title = add_text_img( #' "A table about cars made with", #' url = "https://www.r-project.org/logo/Rlogo.png" #' ) #' ) #' @section Figures: #' \if{html}{\figure{title-car.png}{options: style="width:500px;"}} #' add_text_img <- function(text, url, height = 30, left = FALSE) { text_div <- glue::glue("
{text}
") img_div <- glue::glue("
{web_image(url = url, height = height)}
") if (isFALSE(left)) { paste0(text_div, img_div) %>% gt::html() } else { paste0(img_div, text_div) %>% gt::html() } } ================================================ FILE: R/gt_theme_538.R ================================================ #' Apply FiveThirtyEight theme to a gt table #' #' @param gt_object An existing gt table object of class `gt_tbl` #' @param ... Optional additional arguments to `gt::table_options()` #' @param quiet A logical to silence the warning about missing ID #' @return An object of class `gt_tbl`. #' @export #' @section Examples: #' ```r #' library(gt) #' themed_tab <- head(mtcars) %>% #' gt() %>% #' gt_theme_538() #' ``` #' @section Figures: #' \if{html}{\figure{gt_538.png}{options: style="width:500px;"}} #' #' @family Themes #' @section Function ID: #' 1-1 gt_theme_538 <- function(gt_object, ..., quiet = FALSE) { stopifnot("'gt_object' must be a 'gt_tbl', have you accidentally passed raw data?" = "gt_tbl" %in% class(gt_object)) table_id <- subset(gt_object[['_options']], parameter == 'table_id')[["value"]][[1]] if(is.na(table_id)){ table_id <- gt::random_id() if(isFALSE(quiet)){ message(glue::glue( "Table has no assigned ID, using random ID '{table_id}' to apply `gt::opt_css()`", "\nAvoid this message by assigning an ID: `gt(id = '')` or `gt_theme_538(quiet = TRUE)`" )) } opt_position <- which("table_id" %in% gt_object[["_options"]][["parameter"]])[[1]] gt_object[["_options"]][["value"]][[opt_position]] <- table_id } gt_object %>% opt_table_font( font = list( google_font("Cairo"), default_fonts() ), weight = 400 ) %>% tab_style( locations = cells_title("title"), style = cell_text( font = google_font("Chivo"), weight = 700 ) ) %>% tab_style( locations = cells_title("subtitle"), style = cell_text( font = google_font("Chivo"), weight = 300 ) ) %>% tab_style( style = list( cell_borders( sides = "top", color = "black", weight = px(0) ), cell_text( font = google_font("Chivo"), transform = "uppercase", v_align = "bottom", size = px(14), weight = 200 ) ), locations = list( gt::cells_column_labels(), gt::cells_stubhead() ) ) %>% tab_style( style = cell_borders( sides = "bottom", color = "black", weight = px(1) ), locations = cells_row_groups() ) %>% tab_options( column_labels.background.color = "white", data_row.padding = px(3), heading.border.bottom.style = "none", table.border.top.width = px(3), table.border.top.style = "none", # transparent table.border.bottom.style = "none", column_labels.font.weight = "normal", column_labels.border.top.style = "none", column_labels.border.bottom.width = px(2), column_labels.border.bottom.color = "black", row_group.border.top.style = "none", row_group.border.top.color = "black", row_group.border.bottom.width = px(1), row_group.border.bottom.color = "white", stub.border.color = "white", stub.border.width = px(0), source_notes.font.size = 12, source_notes.border.lr.style = "none", table.font.size = 16, heading.align = "left", ... ) %>% opt_css( paste0("#", table_id, " tbody tr:last-child {border-bottom: 2px solid #ffffff00;}"), add = TRUE ) } ================================================ FILE: R/gt_theme_dark.R ================================================ #' Apply dark theme to a `gt` table #' #' @param gt_object An existing gt table object of class `gt_tbl` #' @param ... Optional additional arguments to `gt::table_options()` #' @return An object of class `gt_tbl`. #' @export #' @examples #' #' library(gt) #' dark_tab <- head(mtcars) %>% #' gt() %>% #' gt_theme_dark() %>% #' tab_header(title = "Dark mode table") #' #' @section Figures: #' \if{html}{\figure{gt_dark.png}{options: style="width:500px;"}} #' #' @family Themes #' @section Function ID: #' 1-6 gt_theme_dark <- function(gt_object, ...) { stopifnot("'gt_object' must be a 'gt_tbl', have you accidentally passed raw data?" = "gt_tbl" %in% class(gt_object)) gt_object %>% tab_options( heading.align = "left", heading.border.bottom.style = "none", table.background.color = "#333333", table.font.color.light = "white", table.border.top.style = "none", table.border.bottom.color = "#333333", table.border.left.color = "#333333", table.border.right.color = "#333333", table_body.border.top.style = "none", table_body.border.bottom.color = "#333333", column_labels.border.top.style = "none", column_labels.background.color = "#333333", column_labels.border.bottom.width = 3, column_labels.border.bottom.color = "white", data_row.padding = px(7), ... ) %>% tab_style( style = cell_text( color = "white", font = google_font("Source Sans Pro"), transform = "uppercase" ), locations = list( cells_column_labels(), cells_stubhead() ) ) %>% tab_style( style = cell_text( font = google_font("Libre Franklin"), weight = 800 ), locations = cells_title(groups = "title") ) %>% tab_style( style = cell_text( font = google_font("Source Sans Pro"), weight = 400 ), locations = cells_body() ) } ================================================ FILE: R/gt_theme_dot_matrix.R ================================================ #' Apply dot matrix theme to a gt table #' #' @param gt_object An existing gt table object of class `gt_tbl` #' @param ... Additional arguments passed to `gt::tab_options()` #' @param color A string indicating the color of the row striping, defaults to a light green. Accepts either named colors or hex colors. #' @param quiet A logical to silence the warning about missing ID #' @return An object of class `gt_tbl`. #' @export #' @section Examples: #' ```r #' library(gt) #' themed_tab <- head(mtcars) %>% #' gt() %>% #' gt_theme_dot_matrix() %>% #' tab_header(title = "Styled like dot matrix printer paper") #' ``` #' @section Figures: #' \if{html}{\figure{gt_dot_matrix.png}{options: style="width:500px;"}} #' #' @family Themes gt_theme_dot_matrix <- function(gt_object, ..., color = "#b5dbb6", quiet = FALSE) { stopifnot("'gt_object' must be a 'gt_tbl', have you accidentally passed raw data?" = "gt_tbl" %in% class(gt_object)) table_id <- subset(gt_object[['_options']], parameter == 'table_id')[["value"]][[1]] if(is.na(table_id)){ table_id <- gt::random_id() if(isFALSE(quiet)){ message(glue::glue( "Table has no assigned ID, using random ID '{table_id}' to apply `gt::opt_css()`", "\nAvoid this message by assigning an ID: `gt(id = '')` or `gt_theme_538(quiet = TRUE)`" )) } opt_position <- which("table_id" %in% gt_object[["_options"]][["parameter"]])[[1]] gt_object[["_options"]][["value"]][[opt_position]] <- table_id } gt_object %>% opt_row_striping() %>% opt_table_font(font = "Courier") %>% tab_options( ..., heading.align = "left", heading.border.bottom.color = "white", column_labels.text_transform = "lowercase", column_labels.font.size = pct(85), column_labels.border.top.style = "none", column_labels.border.bottom.color = "black", column_labels.border.bottom.width = px(2), table.border.bottom.style = "none", table.border.bottom.width = px(2), table.border.bottom.color = "white", table.border.top.style = "none", row.striping.background_color = color, table_body.hlines.style = "none", table_body.vlines.style = "none", data_row.padding = px(1) ) %>% opt_css( paste0("#", table_id, " tbody tr:last-child {border-bottom: 2px solid #ffffff00;}"), add = TRUE ) } ================================================ FILE: R/gt_theme_espn.R ================================================ #' Apply ESPN theme to a gt table #' #' @param gt_object An existing gt table object of class `gt_tbl` #' @param ... Optional additional arguments to `gt::table_options()` #' @return An object of class `gt_tbl`. #' @export #' @examples #' #' library(gt) #' themed_tab <- head(mtcars) %>% #' gt() %>% #' gt_theme_espn() #' @section Figures: #' \if{html}{\figure{gt_espn.png}{options: style="width:500px;"}} #' #' @family Themes #' @section Function ID: #' 1-2 gt_theme_espn <- function(gt_object, ...) { stopifnot("'gt_object' must be a 'gt_tbl', have you accidentally passed raw data?" = "gt_tbl" %in% class(gt_object)) gt_object %>% opt_all_caps() %>% opt_table_font( font = list( google_font("Lato"), default_fonts() ) ) %>% opt_row_striping() %>% tab_options( row.striping.background_color = "#fafafa", table_body.hlines.color = "#f6f7f7", source_notes.font.size = 12, table.font.size = 16, heading.align = "left", heading.title.font.size = 24, table.border.top.color = "white", table.border.top.width = px(3), data_row.padding = px(7), ... ) } ================================================ FILE: R/gt_theme_excel.R ================================================ #' Apply Excel-style theme to an existing gt table #' #' @param gt_object An existing gt table object of class `gt_tbl` #' @param ... Additional arguments passed to `gt::tab_options()` #' @param color A string indicating the color of the row striping, defaults to a light gray Accepts either named colors or hex colors. #' @return An object of class `gt_tbl`. #' @export #' @examples #' library(gt) #' themed_tab <- head(mtcars) %>% #' gt() %>% #' gt_theme_excel() %>% #' tab_header(title = "Styled like your old pal, Excel") #' @section Figures: #' \if{html}{\figure{gt_excel.png}{options: style="width:500px;"}} #' #' @family Themes #' @section Function ID: #' 1-7 gt_theme_excel <- function(gt_object, ..., color = "lightgrey") { stopifnot("'gt_object' must be a 'gt_tbl', have you accidentally passed raw data?" = "gt_tbl" %in% class(gt_object)) gt_object %>% opt_row_striping() %>% tab_style( style = cell_borders(sides = "all", weight = px(1), color = "black"), locations = list( cells_body() ) ) %>% tab_style( style = cell_borders(sides = "left", weight = px(2), color = "black"), locations = list( cells_body(columns = 1), cells_column_labels(columns = 1), cells_stub() ) ) %>% tab_style( style = cell_borders(sides = "left", weight = px(1), color = "black"), locations = list( cells_row_groups() ) ) %>% tab_style( style = cell_borders(sides = "right", weight = px(2), color = "black"), locations = list( cells_body(columns = dplyr::last_col()), cells_column_labels(columns = dplyr::last_col()), cells_row_groups() ) ) %>% tab_style( style = cell_borders(sides = "bottom", weight = px(2), color = "black"), locations = list( cells_body(rows = nrow(gt_object[["_data"]])), cells_stub(rows = nrow(gt_object[["_data"]])) ) ) %>% opt_table_font(font = "Calibri") %>% tab_options( ..., heading.align = "left", heading.border.bottom.color = "black", column_labels.background.color = "black", column_labels.font.weight = "bold", stub.background.color = "white", stub.border.color = "black", row_group.background.color = "white", row_group.border.top.color = "black", row_group.border.bottom.color = "black", row_group.border.left.color = "black", row_group.border.right.color = "black", row_group.border.left.width = px(1), row_group.border.right.width = px(1), column_labels.font.size = pct(85), column_labels.border.top.style = "none", column_labels.border.bottom.color = "black", column_labels.border.bottom.width = px(2), table.border.left.color = "black", table.border.left.style = "solid", table.border.right.style = "solid", table.border.left.width = px(2), table.border.right.width = px(2), table.border.right.color = "black", table.border.bottom.width = px(2), table.border.bottom.color = "black", table.border.top.width = px(2), table.border.top.color = "black", row.striping.background_color = color, table_body.hlines.color = "black", table_body.vlines.color = "black", data_row.padding = px(1) ) } ================================================ FILE: R/gt_theme_guardian.R ================================================ #' Apply Guardian theme to a `gt` table #' #' @param gt_object An existing gt table object of class `gt_tbl` #' @param ... Optional additional arguments to `gt::table_options()` #' @return An object of class `gt_tbl`. #' @export #' @examples #' #' library(gt) #' themed_tab <- head(mtcars) %>% #' gt() %>% #' gt_theme_guardian() #' @section Figures: #' \if{html}{\figure{gt_guardian.png}{options: style="width:500px;"}} #' #' @family Themes #' @section Function ID: #' 1-4 gt_theme_guardian <- function(gt_object, ...) { stopifnot("'gt_object' must be a 'gt_tbl', have you accidentally passed raw data?" = "gt_tbl" %in% class(gt_object)) tab_out <- gt_object %>% opt_table_font( font = list( google_font("Noto Sans"), default_fonts() ) ) %>% tab_style( style = cell_borders( sides = "top", color = "white", weight = px(0) ), locations = cells_body(rows = ifelse(nrow(gt_object[["_data"]]) > 0, 1, NA)) ) %>% tab_style( style = cell_text(color = "#005689", size = px(22), weight = 700), locations = list(cells_title(groups = "title")) ) %>% tab_style( style = cell_text(color = "#005689", size = px(16), weight = 700), locations = list(cells_title(groups = "subtitle")) ) tab_out <- tab_out %>% tab_options( row.striping.include_table_body = TRUE, table.background.color = "#f6f6f6", row.striping.background_color = "#ececec", column_labels.background.color = "#f6f6f6", column_labels.font.weight = "bold", table.border.top.width = px(1), table.border.top.color = "#40c5ff", table.border.bottom.width = px(3), table.border.bottom.color = "white", footnotes.border.bottom.width = px(0), source_notes.border.bottom.width = px(0), table_body.border.bottom.width = px(3), table_body.border.bottom.color = "white", table_body.hlines.width = "white", table_body.hlines.color = "white", row_group.border.top.width = px(1), row_group.border.top.color = "grey", row_group.border.bottom.width = px(1), row_group.border.bottom.color = "grey", row_group.font.weight = "bold", column_labels.border.top.width = px(1), column_labels.border.top.color = if ( is.null(tab_out[["_heading"]][["title"]])) { "#40c5ff" } else { "#ececec" }, column_labels.border.bottom.width = px(2), column_labels.border.bottom.color = "#ececec", heading.border.bottom.width = px(0), data_row.padding = px(4), source_notes.font.size = 12, table.font.size = 16, heading.align = "left", ... ) tab_out } ================================================ FILE: R/gt_theme_nytimes.R ================================================ #' Apply NY Times theme to a `gt` table #' #' @param gt_object An existing gt table object of class `gt_tbl` #' @param ... Optional additional arguments to `gt::table_options()` #' @return An object of class `gt_tbl`. #' @export #' @examples #' #' library(gt) #' nyt_tab <- head(mtcars) %>% #' gt() %>% #' gt_theme_nytimes() %>% #' tab_header(title = "Table styled like the NY Times") #' #' @section Figures: #' \if{html}{\figure{gt_nyt.png}{options: style="width:500px;"}} #' #' @family Themes #' @section Function ID: #' 1-3 gt_theme_nytimes <- function(gt_object, ...) { stopifnot("'gt_object' must be a 'gt_tbl', have you accidentally passed raw data?" = "gt_tbl" %in% class(gt_object)) gt_object %>% tab_options( heading.align = "left", column_labels.border.top.style = "none", table.border.top.style = "none", column_labels.border.bottom.style = "none", column_labels.border.bottom.width = 1, column_labels.border.bottom.color = "#334422", table_body.border.top.style = "none", table_body.border.bottom.color = "white", heading.border.bottom.style = "none", data_row.padding = px(7), column_labels.font.size = px(12), ... ) %>% tab_style( style = cell_text( color = "darkgrey", font = google_font("Source Sans Pro"), transform = "uppercase" ), locations = list( gt::cells_column_labels(), gt::cells_stubhead() ) ) %>% tab_style( style = cell_text( font = google_font("Libre Franklin"), weight = 800 ), locations = cells_title(groups = "title") ) %>% tab_style( style = cell_text( font = google_font("Source Sans Pro"), weight = 400 ), locations = cells_body() ) } ================================================ FILE: R/gt_theme_pff.R ================================================ #' Apply a table theme like PFF #' #' @param gt_object an existing gt_tbl object #' @param ... Additional arguments passed to gt::tab_options() #' @param divider A column name to add a divider to the left of - accepts tidy-eval column names. #' @param spanners Character string that indicates the names of specific spanners you have created with gt::tab_spanner(). #' @param rank_col A column name to add a grey background to. Accepts tidy-eval column names. #' #' @return gt_tbl #' @export #' #' @section Examples: #' #' ``` r #' library(gt) #' out_df <- tibble::tribble( #' ~rank, ~player, ~jersey, ~team, ~g, ~pass, ~pr_snaps, ~rsh_pct, ~prp, ~prsh, #' 1L, "Trey Hendrickson", "91", "CIN", 16, 495, 454, 91.7, 10.8, 83.9, #' 2L, "T.J. Watt", "90", "PIT", 15, 461, 413, 89.6, 10.7, 90.6, #' 3L, "Rashan Gary", "52", "GB", 16, 471, 463, 98.3, 10.4, 88.9, #' 4L, "Maxx Crosby", "98", "LV", 17, 599, 597, 99.7, 10, 91.8, #' 5L, "Matthew Judon", "09", "NE", 17, 510, 420, 82.4, 9.7, 73.2, #' 6L, "Myles Garrett", "95", "CLV", 17, 554, 543, 98, 9.5, 92.7, #' 7L, "Shaquil Barrett", "58", "TB", 15, 563, 485, 86.1, 9.3, 81.5, #' 8L, "Nick Bosa", "97", "SF", 17, 529, 525, 99.2, 9.2, 89.8, #' 9L, "Marcus Davenport", "92", "NO", 11, 302, 297, 98.3, 9.1, 82, #' 10L, "Joey Bosa", "97", "LAC", 16, 495, 468, 94.5, 8.9, 90.3, #' 11L, "Robert Quinn", "94", "CHI", 16, 445, 402, 90.3, 8.6, 79.7, #' 12L, "Randy Gregory", "94", "DAL", 12, 315, 308, 97.8, 8.6, 84.4 #' ) #' out_df %>% #' gt() %>% #' tab_spanner(columns = pass:rsh_pct, label = "snaps") %>% #' tab_spanner(columns = prp:prsh, label = "grade") %>% #' gt_theme_pff( #' spanners = c("snaps", "grade"), #' divider = jersey, rank_col = rank #' ) %>% #' gt_color_box( #' columns = prsh, domain = c(0, 95), width = 50, accuracy = 0.1, #' palette = "pff" #' ) %>% #' cols_label(jersey = "#", g = "#G", rsh_pct = "RSH%") %>% #' tab_header( #' title = "Pass Rush Grades", #' subtitle = "Grades and pass rush stats" #' ) %>% #' gt_highlight_cols(columns = prp, fill = "#e4e8ec") %>% #' tab_style( #' style = list( #' cell_borders("bottom", "white"), #' cell_fill(color = "#393c40") #' ), #' locations = cells_column_labels(prp) #' ``` #' @section Figures: #' \if{html}{\figure{gt_theme_pff.png}{options: style="width:500px;"}} #' #' @family Themes gt_theme_pff <- function(gt_object, ..., divider, spanners, rank_col) { is_gt_stop(gt_object) built_table <- gt_object %>% opt_row_striping() %>% opt_all_caps() %>% tab_options( table_body.hlines.color = "transparent", table.border.top.width = px(3), table.border.top.color = "transparent", table.border.bottom.color = "lightgrey", table.border.bottom.width = px(1), column_labels.border.top.width = px(3), column_labels.padding = px(6), column_labels.border.top.color = "transparent", column_labels.border.bottom.width = px(3), column_labels.border.bottom.color = "transparent", row.striping.background_color = "#f5f5f5", data_row.padding = px(6), heading.align = "left", heading.title.font.size = px(30), heading.title.font.weight = "bold", heading.subtitle.font.size = px(16), table.font.size = px(12), ... ) %>% # customize font opt_table_font( font = google_font("Roboto") ) if (!missing(spanners)) { span_vars <- unlist(gt_object[["_spanners"]][["vars"]]) # add blank span and modify built_table <- built_table %>% tab_spanner( columns = c(gt::everything(), -any_of(span_vars)), label = " ", id = "blank" ) %>% tab_style( style = list( cell_fill(color = "transparent"), cell_text(color = "transparent", size = px(9), weight = "bold"), cell_borders(sides = "left", color = "transparent", weight = px(3)), cell_borders(sides = "top", color = "transparent", weight = px(3)) ), locations = list( cells_column_spanners( spanners = "blank" ) ) ) %>% # add real spanners and style tab_style( style = list( cell_fill(color = "#f5f5f5"), cell_text(color = "#878e94", size = px(10), weight = "bold"), cell_borders(sides = "left", color = "white", weight = px(3)), cell_borders(sides = "top", color = "white", weight = px(3)) ), locations = list( cells_column_spanners( spanners = spanners ) ) ) } if (!missing(divider)) { built_table <- built_table %>% tab_style( style = cell_borders( sides = "left", color = "lightgrey", weight = px(2) ), locations = cells_body(columns = {{ divider }}) ) %>% tab_style( style = cell_borders("left", color = "#212426", weight = px(2)), locations = cells_column_labels(columns = {{ divider }}) ) } if (!missing(rank_col)) { built_table <- built_table %>% tab_style( style = list( cell_fill(color = "#e4e8ec"), cell_borders(color = "#e4e8ec") ), locations = cells_body(columns = {{ rank_col }}) ) %>% cols_align("center", {{ rank_col }}) } built_table %>% tab_style( style = list( cell_fill(color = "#585d63"), cell_text(color = "white", size = px(10), weight = "bold"), cell_borders( sides = c("bottom"), color = "#585d63", weight = px(2.5) ) ), locations = list( gt::cells_column_labels(), gt::cells_stubhead() ) ) } ================================================ FILE: R/gt_vendor.R ================================================ # gt internal functions vendored with attribution from: ### ---- ### https://github.com/rstudio/gt/blob/fcabb414c55b70c9e445fbedfb24d52fe394ba61/R/dt_boxhead.R .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) boxh_df <- 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 ) boxh_df %>% dt_boxhead_set(boxh = ., data = data) } dt_boxhead_edit <- function(data, var, ...) { dt_boxhead <- dt_boxhead_get(data = data) var_name <- var val_list <- list(...) if (length(val_list) != 1) { cli::cli_abort("`dt_boxhead_edit()` expects a single value at `...`.") } check_names_dt_boxhead_expr(expr = val_list) check_vars_dt_boxhead(var = var, dt_boxhead = dt_boxhead) if (is.list(dt_boxhead[[names(val_list)]])) { dt_boxhead[[which(dt_boxhead$var == var_name), names(val_list)]] <- unname(val_list) } else { dt_boxhead[[which(dt_boxhead$var == var_name), names(val_list)]] <- unlist(val_list) } dt_boxhead_set(data = data, boxh = dt_boxhead) } dt_boxhead_add_var <- function(data, var, type, column_label = list(var), column_align = "left", column_width = list(NULL), hidden_px = list(NULL), add_where = "top") { dt_boxhead <- data %>% dt_boxhead_get() dt_boxhead_row <- dplyr::tibble( var = var, type = type, column_label = column_label, column_align = column_align, column_width = column_width, hidden_px = hidden_px ) if (add_where == "top") { dt_boxhead <- dplyr::bind_rows(dt_boxhead_row, dt_boxhead) } else if (add_where == "bottom") { dt_boxhead <- dplyr::bind_rows(dt_boxhead, dt_boxhead_row) } else { stop("The `add_where` value must be either `top` or `bottom`.") } dt_boxhead %>% dt_boxhead_set(data = data) } dt_boxhead_set_hidden <- function(data, vars) { dt_boxhead <- dt_boxhead_get(data = data) dt_boxhead[which(dt_boxhead$var %in% vars), "type"] <- "hidden" dt_boxhead %>% dt_boxhead_set(data = data) } dt_boxhead_set_not_hidden <- function(data, vars) { dt_boxhead <- dt_boxhead_get(data = data) dt_boxhead[which(dt_boxhead$var %in% vars), "type"] <- "default" dt_boxhead %>% dt_boxhead_set(data = data) } dt_boxhead_set_stub <- function(data, var) { dt_boxhead <- dt_boxhead_get(data = data) dt_boxhead[which(dt_boxhead$var == var), "type"] <- "stub" dt_boxhead[which(dt_boxhead$var == var), "column_align"] <- "left" dt_boxhead %>% dt_boxhead_set(data = data) } dt_boxhead_set_row_group <- function(data, vars) { dt_boxhead <- dt_boxhead_get(data = data) dt_boxhead[which(dt_boxhead$var %in% vars), "type"] <- "row_group" dt_boxhead[which(dt_boxhead$var %in% vars), "column_align"] <- "left" dt_boxhead %>% dt_boxhead_set(data = data) } dt_boxhead_edit_column_label <- function(data, var, column_label) { dt_boxhead_edit( data = data, var = var, column_label = column_label ) } dt_boxhead_get_vars <- function(data) { dplyr::pull(dt_boxhead_get(data = data), var) } dt_boxhead_get_vars_default <- function(data) { dplyr::pull(subset(dt_boxhead_get(data = data), type == "default"), var) } dt_boxhead_get_var_stub <- function(data) { res <- dt_boxhead_get_var_by_type(data = data, type = "stub") # FIXME: don't return NA_character_ here, just return res or NULL if (length(res) == 0) { NA_character_ } else { res } } dt_boxhead_get_vars_groups <- function(data) { res <- dt_boxhead_get_var_by_type(data = data, type = "row_group") # FIXME: don't return NA_character_ here, just return res or NULL if (length(res) == 0) { NA_character_ } else { res } } dt_boxhead_get_var_by_type <- function(data, type) { dplyr::filter(dt_boxhead_get(data = data), type == !!type) %>% magrittr::extract2("var") } dt_boxhead_get_vars_labels_default <- function(data) { unlist( subset(dt_boxhead_get(data = data), type == "default") %>% magrittr::extract2("column_label") ) } dt_boxhead_get_vars_align_default <- function(data) { unlist( subset(dt_boxhead_get(data = data), type == "default") %>% magrittr::extract2("column_align") ) } dt_boxhead_get_alignment_by_var <- function(data, var) { data %>% dt_boxhead_get() %>% dplyr::filter(var == !!var) %>% magrittr::extract2("column_align") } 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 = 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 = 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 } ### ---- ### https://github.com/rstudio/gt/blob/81694d4c2c9c6cebaea005f04feddda5763fccec/R/export.R gt_save_html <- function(data, filename, path = NULL, ..., inline_css = FALSE) { filename <- gtsave_filename(path = path, filename = filename) if (inline_css) { data %>% as_raw_html(inline_css = inline_css) %>% htmltools::HTML() %>% htmltools::save_html(filename, ...) } else { data %>% htmltools::as.tags() %>% htmltools::save_html(filename, ...) } } gtsave_filename <- function(path, filename) { if (is.null(path)) path <- "." # The use of `fs::path_abs()` works around # the saving code in `htmltools::save_html()` # See htmltools Issue #165 for more details fs::path_abs( path = filename, start = path ) %>% fs::path_expand() %>% as.character() } ## ---- ### is_html <- function(x) { inherits(x, "html") && isTRUE(attr(x, "html")) } ## ---- ### https://github.com/rstudio/gt/blob/ec97f7385166946d7a964ef31b7f6508ccd56550/R/resolver.R resolve_cols_c <- function(expr, data, strict = TRUE, excl_stub = TRUE, null_means = c("everything", "nothing")) { null_means <- match.arg(null_means) names( resolve_cols_i( expr = {{ expr }}, data = data, strict = strict, excl_stub = excl_stub, null_means = null_means ) ) } ## ---- ### https://github.com/rstudio/gt/blob/3241b1e6ed53670fbce0361b999b929b4df8df83/R/utils.R utf8_aware_sub <- NULL .onLoad <- function(libname, pkgname, ...) { op <- options() toset <- !(names(gt_default_options) %in% names(op)) if (any(toset)) options(gt_default_options[toset]) utf8_aware_sub <<- identical("UTF-8", Encoding(sub(".", "\u00B1", ".", fixed = TRUE))) invisible() } markdown_to_latex <- function(text) { # Vectorize `commonmark::markdown_latex` and modify output # behavior to passthrough NAs lapply(text, function(x) { if (is.na(x)) { return(NA_character_) } if (isTRUE(getOption("gt.html_tag_check", TRUE))) { if (grepl("<[a-zA-Z\\/][^>]*>", x)) { warning("HTML tags found, and they will be removed.\n", " * set `options(gt.html_tag_check = FALSE)` to disable this check", call. = FALSE ) } } commonmark::markdown_latex(x) %>% tidy_gsub("\\n$", "") }) %>% unlist() %>% unname() } markdown_to_rtf <- function(text) { text <- text %>% as.character() %>% vapply( FUN.VALUE = character(1), USE.NAMES = FALSE, FUN = commonmark::markdown_xml ) %>% vapply( FUN.VALUE = character(1), USE.NAMES = FALSE, FUN = function(cmark) { # cat(cmark) x <- xml2::read_xml(cmark) if (!identical(xml2::xml_name(x), "document")) { stop("Unexpected result from markdown parsing: `document` element not found") } children <- xml2::xml_children(x) if (length(children) == 1 && xml2::xml_type(children[[1]]) == "element" && xml2::xml_name(children[[1]]) == "paragraph") { children <- xml2::xml_children(children[[1]]) } apply_rules <- function(x) { if (inherits(x, "xml_nodeset")) { len <- length(x) results <- character(len) # preallocate vector for (i in seq_len(len)) { results[[i]] <- apply_rules(x[[i]]) } # TODO: is collapse = "" correct? rtf_raw(paste0("", results, collapse = "")) } else { output <- if (xml2::xml_type(x) == "element") { rule <- cmark_rules[[xml2::xml_name(x)]] if (is.null(rule)) { rlang::warn( paste0("Unknown commonmark element encountered: ", xml2::xml_name(x)), .frequency = "once", .frequency_id = "gt_commonmark_unknown_element" ) apply_rules(xml2::xml_contents(x)) } else if (is.character(rule)) { rtf_wrap(rule, x, apply_rules) } else if (is.function(rule)) { rule(x, apply_rules) } } if (!is_rtf(output)) { warning("Rule for ", xml2::xml_name(x), " did not return RTF") } # TODO: is collapse = "" correct? rtf_raw(paste0("", output, collapse = "")) } } apply_rules(children) } ) text } markdown_to_text <- function(text) { # Vectorize `commonmark::markdown_text` and modify output # behavior to passthrough NAs lapply(text, function(x) { if (is.na(x)) { return(NA_character_) } if (isTRUE(getOption("gt.html_tag_check", TRUE))) { if (grepl("<[a-zA-Z\\/][^>]*>", x)) { warning("HTML tags found, and they will be removed.\n", " * set `options(gt.html_tag_check = FALSE)` to disable this check", call. = FALSE ) } } commonmark::markdown_text(x) %>% tidy_gsub("\\n$", "") }) %>% unlist() %>% unname() } # https://github.com/rstudio/gt/blob/ec97f7385166946d7a964ef31b7f6508ccd56550/R/zzz.R gt_default_options <- list( gt.row_group.sep = " - ", gt.rtf_page_width = 9468L, gt.html_tag_check = TRUE ) tidy_gsub <- function(x, pattern, replacement, fixed = FALSE) { if (!utf8_aware_sub) { # See variable definition for utf8_aware_sub for more info x <- enc2utf8(as.character(x)) replacement <- enc2utf8(as.character(replacement)) res <- gsub(pattern, replacement, x, fixed = fixed) Encoding(res) <- "UTF-8" res } else { gsub(pattern, replacement, x, fixed = fixed) } } #' Process text based on rendering context any applied classes #' #' If the incoming text has the class `from_markdown` (applied by the `md()` #' helper function), then the text will be sanitized and transformed to HTML #' from Markdown. If the incoming text has the class `html` (applied by `html()` #' helper function), then the text will be seen as HTML and it won't undergo #' sanitization. #' @noRd process_text <- function(text, context = "html") { # If text is marked `AsIs` (by using `I()`) then just # return the text unchanged if (inherits(text, "AsIs")) { return(text) } if (is.list(text)) { if (context %in% names(text)) { return(process_text(text = text[[context]], context = context)) } } if (context == "html") { # Text processing for HTML output if (inherits(text, "from_markdown")) { text <- as.character(text) %>% vapply(commonmark::markdown_html, character(1)) %>% stringr::str_replace_all(c("^

" = "", "

\n$" = "")) return(text) } else if (is_html(text) || inherits(text, "shiny.tag") || inherits(text, "shiny.tag.list")) { text <- as.character(text) return(text) } else { text <- htmltools::htmlEscape(as.character(text)) return(text) } } else if (context == "latex") { # Text processing for LaTeX output if (inherits(text, "from_markdown")) { text <- markdown_to_latex(text = text) return(text) } else if (is_html(text)) { text <- as.character(text) return(text) } else { text <- escape_latex(text = text) return(text) } } else if (context == "rtf") { # Text processing for RTF output if (inherits(text, "from_markdown")) { return(markdown_to_rtf(text)) } else if (inherits(text, "rtf_text")) { text <- as.character(text) return(text) } else { text <- rtf_escape(text) return(text) } } else { # Text processing in the default case if (inherits(text, "from_markdown")) { text <- markdown_to_text(text = text) return(text) } else if (is_html(text)) { text <- as.character(text) return(text) } else { text <- htmltools::htmlEscape(as.character(text)) return(text) } } } ### ---- # https://github.com/rstudio/gt/blob/ec97f7385166946d7a964ef31b7f6508ccd56550/R/utils_render_rtf.R # Mark the given text as being RTF, meaning, it should not be escaped if passed # to rtf_text rtf_raw <- function(...) { text <- paste0(..., collapse = "") class(text) <- "rtf_text" text } rtf_escape <- function(x) { if (length(x) < 1) { return(x) } x <- gsub("\\", "\\'5c", x, fixed = TRUE) x <- gsub("{", "\\'7b", x, fixed = TRUE) x <- gsub("}", "\\'7d", x, fixed = TRUE) x <- vapply(x, FUN.VALUE = character(1), FUN = rtf_escape_unicode, USE.NAMES = FALSE) class(x) <- "rtf_text" x } ### ---- ## https://github.com/rstudio/gt/blob/ec97f7385166946d7a964ef31b7f6508ccd56550/R/dt_spanners.R .dt_spanners_key <- "_spanners" dt_spanners_get <- function(data) { dt__get(data, .dt_spanners_key) } # https://github.com/rstudio/gt/blob/fcabb414c55b70c9e445fbedfb24d52fe394ba61/R/dt_stub_df.R .dt_stub_df_key <- "_stub_df" dt_stub_df_get <- function(data) { dt__get(data, .dt_stub_df_key) } # https://github.com/rstudio/gt/blob/a6736d30ae72e68e5b66ae122c0424e441b3fba8/R/helpers.R is_rtf <- function(x) { inherits(x, "rtf_text") } # vendored from: https://github.com/rstudio/gt/blob/7a6186dee0be6ed71cdf34d3815e2b32c2905e8f/R/data_color.R#L342-L365 #' Are color values in rgba() format? #' #' The input for this is a character vector that should contain color strings. #' While users won't directly supply colors in rgba() format, the `html_color()` #' function can produce these types of color values and this utility function is #' used in `rgba_to_hex()` to help convert colors *back* to hexadecimal #' (ultimately for the `ideal_fgnd_color()` function). The output of #' `is_rgba_col()` is a vector of logical values (the same length as the input #' `colors` vector). #' #' @param colors A vector of color values. #' #' @noRd is_rgba_col <- function(colors) { grepl("^rgba\\(\\s*(?:[0-9]+?\\s*,\\s*){3}[0-9\\.]+?\\s*\\)$", colors) } #' Are color values in hexadecimal format? #' #' This regex checks for valid hexadecimal colors in either the `#RRGGBB` and #' `#RRGGBBAA` forms (not including shortened form `#RGB` here, #' `is_short_hex()` handles this case). #' #' @param colors A vector of color values. #' #' @noRd is_hex_col <- function(colors) { grepl("^#[0-9a-fA-F]{6}([0-9a-fA-F]{2})?$", colors) } #' Are color values in the shorthand hexadecimal format? #' #' This regex checks for valid hexadecimal colors in the `#RGB` or `#RGBA` #' shorthand forms. #' #' @param colors A vector of color values. #' #' @noRd is_short_hex <- function(colors) { grepl("^#[0-9a-fA-F]{3}([0-9a-fA-F])?$", colors) } #' Expand shorthand hexadecimal colors to the normal form #' #' This function takes a vector of colors in the `#RGB` or `#RGBA` #' shorthand forms and transforms them to their respective normal forms #' (`#RRGGBB` and `#RRGGBBAA`). This should only be used with a vector of #' `#RGB`- and `#RGBA`-formatted color values; `is_short_hex()` should be used #' beforehand to ensure that input `colors` vector conforms to this expectation. #' #' @param colors A vector of color values. #' #' @noRd expand_short_hex <- function(colors) { gsub("^#(.)(.)(.)(.?)$", "#\\1\\1\\2\\2\\3\\3\\4\\4", toupper(colors)) } #' For a background color, which foreground color provides better contrast? #' #' The input for this function is a single color value in 'rgba()' format. The #' output is a single color value in #RRGGBB hexadecimal format #' #' @noRd ideal_fgnd_color <- function(bgnd_color, light = "#FFFFFF", dark = "#000000") { # Normalize color to hexadecimal color if it is in the 'rgba()' string format bgnd_color <- rgba_to_hex(colors = bgnd_color) # Normalize color to a #RRGGBB (stripping the alpha channel) bgnd_color <- html_color(colors = bgnd_color, alpha = 1) # Determine the ideal color for the chosen background color yiq_contrasted_threshold <- 128 colors <- grDevices::col2rgb(bgnd_color) score <- colSums(colors * c(299, 587, 144)) / 1000 ifelse(score >= yiq_contrasted_threshold, dark, light) } #' Convert colors in mixed formats (incl. rgba() strings) format to hexadecimal #' #' This function will accept colors in mixed formats and convert any in the #' 'rgba()' string format (e.g., "`rgba(255,170,0,0.5)`") to a hexadecimal #' format that preserves the alpha information (#RRGGBBAA). This function is #' required for the `ideal_fgnd_color()` function. #' #' @noRd rgba_to_hex <- function(colors) { colors_vec <- rep(NA_character_, length(colors)) colors_rgba <- is_rgba_col(colors = colors) colors_vec[!colors_rgba] <- colors[!colors_rgba] color_matrix <- colors[colors_rgba] %>% gsub(pattern = "(rgba\\(|\\))", replacement = "", x = .) %>% strsplit(",") %>% unlist() %>% as.numeric() %>% matrix( ., ncol = 4, dimnames = list(c(), c("r", "g", "b", "alpha")), byrow = TRUE ) alpha <- color_matrix[, "alpha"] %>% unname() # Convert color matrix to hexadecimal colors in the #RRGGBBAA format colors_to_hex <- grDevices::rgb( red = color_matrix[, "r"] / 255, green = color_matrix[, "g"] / 255, blue = color_matrix[, "b"] / 255, alpha = alpha ) colors_vec[colors_rgba] <- colors_to_hex colors_vec } #' With a vector of input colors return normalized color strings #' #' Input colors can be color names (e.g., `"green"`, `"steelblue"`, etc.) or #' colors in hexadecimal format with or without an alpha component (either #' #RRGGBB or #RRGGBBAA). Output is the same length vector as the #' input but it will contain a mixture of either #RRGGBB colors (if the input #' alpha value for a color is 1) or 'rgba()' string format colors (if the input #' alpha value for a color is not 1). #' #' @noRd html_color <- function(colors, alpha = NULL) { # Stop function if there are any NA values in `colors` if (any(is.na(colors))) { stop("No values supplied in `colors` should be `NA`.", call. = FALSE) } is_rgba <- is_rgba_col(colors = colors) is_short_hex <- is_short_hex(colors = colors) # Expand any shorthand hexadecimal color values to the `RRGGBB` form colors[is_short_hex] <- expand_short_hex(colors = colors[is_short_hex]) is_hex <- is_hex_col(colors = colors) # If not classified as RGBA or hexadecimal, assume other values are named # colors to be handled separately is_named <- !is_rgba & !is_hex colors[is_named] <- tolower(colors[is_named]) named_colors <- colors[is_named] if (length(named_colors) > 0) { # Ensure that all color names are in the set of X11/R color # names or CSS color names check_named_colors(named_colors) # Translate the `transparent` color to #FFFFFF00 (white, transparent) named_colors[named_colors == "transparent"] <- "#FFFFFF00" # Translate any CSS exclusive colors to hexadecimal values; # there are nine CSS 3.0 named colors that don't belong to the # set of X11/R color names (not included numbered variants and # the numbered grays, those will be handled by `grDevices::col2rgb()`) is_css_excl_named <- colors %in% names(css_exclusive_colors()) if (any(is_css_excl_named)) { # The `css_exclusive_colors()` function returns a named vector # of the CSS colors not in the X11/R set; the names are the hexadecimal # color values colors[is_css_excl_named] <- unname(css_exclusive_colors()[colors[is_css_excl_named]]) } } # Normalize all non-'rgba()' color values and combine # with any preexisting 'rgba()' color values colors[!is_rgba] <- normalize_colors( colors = colors[!is_rgba], alpha = alpha ) colors } # Utility function for creating 'rgba()' color values # from an RGBA color matrix (already subsetted to those # rows where alpha < 1) col_matrix_to_rgba <- function(color_matrix) { paste0( "rgba(", color_matrix[, "red"], ",", color_matrix[, "green"], ",", color_matrix[, "blue"], ",", round(color_matrix[, "alpha"], 2), ")" ) } # Utility function for generating hexadecimal or 'rgba()' colors (for IE11 # compatibility with colors having some transparency) from hexadecimal color # values and X11/R color names normalize_colors <- function(colors, alpha) { # Create a color matrix with an `alpha` column color_matrix <- t(grDevices::col2rgb(col = colors, alpha = TRUE)) color_matrix[, "alpha"] <- color_matrix[, "alpha"] / 255 # If `alpha` has a value, replace all pre-existing # alpha values in the color matrix with `alpha` if (!is.null(alpha)) { color_matrix[, "alpha"] <- alpha } # Generate a vector for the finalized HTML color values colors_html <- rep(NA_character_, nrow(color_matrix)) # Determine which of the input colors have an alpha of `1` colors_alpha_1 <- color_matrix[, "alpha"] == 1 # Generate #RRGGBB color values for `colors_html` colors_html[colors_alpha_1] <- grDevices::rgb( red = color_matrix[colors_alpha_1, "red", drop = FALSE] / 255, green = color_matrix[colors_alpha_1, "green", drop = FALSE] / 255, blue = color_matrix[colors_alpha_1, "blue", drop = FALSE] / 255 ) # Generate rgba() color values for `colors_html` colors_html[!colors_alpha_1] <- color_matrix[!colors_alpha_1, , drop = FALSE] %>% col_matrix_to_rgba() colors_html } css_exclusive_colors <- function() { color_tbl_subset <- css_colors[!css_colors$is_x11_color, ] color_values <- color_tbl_subset[["hexadecimal"]] color_values <- stats::setNames( color_values, tolower(color_tbl_subset[["color_name"]]) ) color_values } valid_color_names <- function() { c(tolower(grDevices::colors()), names(css_exclusive_colors()), "transparent") } check_named_colors <- function(named_colors) { named_colors <- tolower(named_colors) if (!all(named_colors %in% valid_color_names())) { invalid_colors <- setdiff(unique(named_colors), valid_color_names()) one_several_invalid <- ifelse( length(invalid_colors) > 1, "Several invalid color names were ", "An invalid color name was " ) stop( "Only R/X11 color names and CSS 3.0 color names can be used.", call. = FALSE ) } } ================================================ FILE: R/gt_win_loss.R ================================================ #' Add win loss point plot into rows of a `gt` table #' @description #' The `gt_plt_winloss` function takes an existing `gt_tbl` object and #' adds squares of a specific color and vertical position based on wins/losses. #' It is a wrapper around `gt::text_transform()`. The column chosen **must** be #' a list-column as seen in the example code. The column should also only contain #' values of 0 (loss), 0.5 (tie), and 1 (win). #' #' @param gt_object An existing gt table object of class `gt_tbl` #' @param column The column wherein the winloss plot should replace existing data. Note that the data *must* be represented as a list of numeric values ahead of time. #' @param max_wins An integer indicating the max possible wins, this will be used to add padding if the total wins/losses observed is less than the max. This is useful for mid-season reporting. Defaults to a red, blue, grey palette. #' @param palette A character vector of length 3, specifying the colors for win, loss, tie in that exact order. #' @param type A character string representing the type of plot, either a 'pill' or 'square' #' @param width A numeric indicating the width of the plot in `mm`, this can help with larger datasets where data points are overlapping. #' @return An object of class `gt_tbl`. #' @export #' @section Examples: #' ```r #' #' library(gt) #' #' set.seed(37) #' data_in <- dplyr::tibble( #' grp = rep(c("A", "B", "C"), each = 10), #' wins = sample(c(0,1,.5), size = 30, prob = c(0.45, 0.45, 0.1), replace = TRUE) #' ) %>% #' dplyr::group_by(grp) %>% #' dplyr::summarize(wins=list(wins), .groups = "drop") #' #' data_in #' #' win_table <- data_in %>% #' gt() %>% #' gt_plt_winloss(wins) #' ``` #' \if{html}{\out{ #' `r man_get_image_tag(file = "gt_plt_winloss-ex.png", width = 60, alt="A table of various win/loss outcomes")` #' }} #' #' @family Plotting #' @section Function ID: #' 3-1 gt_plt_winloss <- function(gt_object, column, max_wins = 17, palette = c("#013369", "#D50A0A", "gray"), type = "pill", width = max_wins / 0.83) { stopifnot("'gt_object' must be a 'gt_tbl', have you accidentally passed raw data?" = "gt_tbl" %in% class(gt_object)) stopifnot("type must be on of 'pill' or 'square'" = { type %in% c("pill", "square") }) stopifnot("There must be 3 colors" = length(palette) == 3L) list_vals <- gt_index(gt_object = gt_object, {{ column }}, as_vector = TRUE) stopifnot("The column must be a list-column" = is.list(list_vals)) stopifnot("All values must be 1, 0 or 0.5" = unlist(list_vals) %in% c(NA, NULL, 1, 0, 0.5)) plot_fn_pill <- function(vals) { if (all(is.na(vals) | is.null(vals))) { plot_out <- ggplot() + theme_void() } else { input_data <- data.frame( x = 1:length(vals), xend = 1:length(vals), y = ifelse(vals == 0.5, 0.4, vals), yend = ifelse(vals == 0, 0.6, ifelse(vals > 0.5, 0.4, 0.6)), color = ifelse(vals == 0, palette[2], ifelse(vals == 1, palette[1], palette[3])) ) plot_out <- ggplot(input_data) + geom_segment( aes( x = .data$x, xend = .data$xend, y = .data$y, yend = .data$yend, color = I(.data$color) ), linewidth = 1, lineend = "round" ) + scale_x_continuous(limits = c(0.5, max_wins + 0.5)) + scale_y_continuous(limits = c(-.2, 1.2)) + theme_void() } out_name <- file.path( tempfile(pattern = "file", tmpdir = tempdir(), fileext = ".svg") ) ggsave( out_name, plot = plot_out, dpi = 20, height = 3.81, width = width, units = "mm" ) img_plot <- out_name %>% readLines() %>% paste0(collapse = "") %>% gt::html() on.exit(file.remove(out_name), add = TRUE) img_plot } plot_fn_square <- function(vals) { if (all(is.na(vals) | is.null(vals))) { plot_out <- ggplot() + theme_void() } else { input_data <- data.frame( x = 1:length(vals), xend = 1:length(vals), y = ifelse(vals == 0.5, 0.4, vals), yend = ifelse(vals == 0, 0.6, ifelse(vals > 0.5, 0.4, 0.6)), color = ifelse(vals == 0, palette[2], ifelse(vals == 1, palette[1], palette[3])) ) plot_out <- ggplot(input_data) + geom_point( aes( x = .data$x, y = .data$y, color = I(.data$color) ), size = 1, shape = 15 ) + scale_x_continuous(limits = c(0.5, max_wins + 0.5)) + scale_y_continuous(limits = c(-.2, 1.2)) + theme_void() } out_name <- file.path( tempfile(pattern = "file", tmpdir = tempdir(), fileext = ".svg") ) ggsave( out_name, plot = plot_out, dpi = 20, height = 0.15, width = 0.9 ) img_plot <- out_name %>% readLines() %>% paste0(collapse = "") %>% gt::html() on.exit(file.remove(out_name), add = TRUE) img_plot } text_transform( gt_object, locations = cells_body(columns = {{ column }}), fn = function(x) { lapply( list_vals, if (type == "pill") { plot_fn_pill } else { plot_fn_square } ) } ) } ================================================ FILE: R/gtsave_extra.R ================================================ #' Use webshot2 to save a gt table as a PNG #' @description Takes existing HTML content, typically additional HTML including a gt table as a PNG via the `{webshot2}` package. #' @param data HTML content to be saved temporarily to disk #' @param filename The name of the file, should end in `.png` #' @param path An optional path #' @param ... Additional arguments to `webshot2::webshot()` #' @param zoom A number specifying the zoom factor. A zoom factor of 2 will result in twice as many pixels vertically and horizontally. Note that using 2 is not exactly the same as taking a screenshot on a HiDPI (Retina) device: it is like increasing the zoom to 200 doubling the height and width of the browser window. #' @param expand A numeric vector specifying how many pixels to expand the clipping rectangle by. If one number, the rectangle will be expanded by that many pixels on all sides. If four numbers, they specify the top, right, bottom, and left, in that order. #' @return Prints the HTML content to the RStudio viewer and saves a `.png` file to disk #' @export #' @importFrom utils capture.output #' @family Utilities #' @section Function ID: #' 2-14 #' gtsave_extra <- function( data, filename, path = NULL, ..., zoom = 2, expand = 5 ) { filename <- gtsave_filename(path = path, filename = filename) # Create a temporary file with the `html` extension tempfile_ <- tempfile(fileext = ".html") # Reverse slashes on Windows filesystems tempfile_ <- tempfile_ %>% tidy_gsub("\\\\", "/") # Save gt table as HTML using the `gt_save_html()` function gt_save_html( data = data, filename = tempfile_, path = NULL ) # Saving an image requires the webshot2 package; if it's # not present, stop with a message if (!rlang::is_installed("webshot2")) { stop( "The 'webshot2' package is required for saving images of gt tables.)", call. = FALSE ) } else { # Save the image in the working directory web_out <- webshot2::webshot( url = paste0("file:///", tempfile_), file = filename, zoom = zoom, expand = expand, ... ) %>% utils::capture.output(type = "message") %>% invisible() #if(!grepl("screenshot completed", tolower(web_out))) print(web_out) } if (interactive()) { htmltools::browsable(data) } } ================================================ FILE: R/html-helpers.R ================================================ #' Add a simple table with column names and matching labels #' #' @param label A string representing the label for the details expansion section. #' @param content A named list or wide data.frame with 2 rows #' @param names a string indicating the name of the two columns inside the details tag #' @return HTML text #' @export gt_label_details <- function( label, content, names = c("Column", "Description") ) { stopifnot("Must be a named list" = length(names(content)) >= 1) stopifnot("'names' must be length 2" = length(names) == 2) build_content <- function(lab_item, content_item) { glue::glue( "{lab_item}{content_item}" ) } fill_content <- mapply( FUN = build_content, names(content), as.character(content), SIMPLIFY = FALSE ) %>% unlist() %>% as.character() %>% paste0(collapse = "") c( glue::glue("
{label}"), glue::glue("
"), fill_content, "
{names[1]}{names[2]}
" ) %>% paste0(collapse = "") %>% as.character() %>% gt::html() } #' A helper to add basic tooltip inside a gt table #' @description This is a lightweight helper to add tooltip, typically to be #' used within `gt::cols_label()`. #' @param label The label for the item with a tooltip #' @param tooltip The text based tooltip for the item #' #' @return HTML text #' @export with_tooltip <- function(label, tooltip) { tags$abbr( style = paste0( "text-decoration: underline; text-decoration-style: solid;", " cursor: question; color: blue" ), title = tooltip, label ) %>% as.character() %>% gt::html() } #' Add a basic hyperlink in a gt table #' @description A lightweight helper to add a hyperlink, can be used throughout #' a `gt` table. #' @param text The text displayed for the hyperlink #' @param url The url for the hyperlink #' @return HTML text #' @export gt_hyperlink <- function(text, url) { htmltools::a(href = url, text, target = "_blank") %>% as.character() %>% gt::html() } #' Add badge color #' #' @param add_color A color to add to the badge #' @param add_label The label to add to the badge #' @param alpha_lvl The alpha level #' #' @return HTML character #' add_badge_color <- function(add_color, add_label, alpha_lvl) { add_color <- paste0("background:", scales::alpha(add_color, alpha_lvl), ";") div_out <- htmltools::div( style = paste( "display: inline-block; padding: 2px 12px; border-radius: 15px;", "font-weight: 600; font-size: 12px;", add_color ), add_label ) as.character(div_out) %>% gt::html() } #' Add a 'badge' based on values and palette #' @param gt_object An existing `gt` table object #' @param column The column to convert to badges, accepts `tidyeval` #' @param palette Name of palette as a string. Must be either length of 1 or a vector of valid color names/hex values of equal length to the unique levels of the column (ie if there are 4 names, there need to be 4x colors). Note that if you would like to specify a specific color to match a specific icon, you can also use a named vector like: `c("angle-double-up" = "#009E73", "angle-double-down" = "#D55E00","sort" = "#000000")` #' @param alpha A numeric indicating the alpha/transparency. Range from 0 to 1 #' @param rows The rows to apply the badge to, accepts `tidyeval`. Defaults to all rows. #' @export #' @return `gt` table #' @section Examples: #' ```r #' library(gt) #' head(mtcars) %>% #' dplyr::mutate(cyl = paste(cyl, "Cyl")) %>% #' gt() %>% #' gt_badge(cyl, palette = c("4 Cyl"="red","6 Cyl"="blue","8 Cyl"="green")) #' ``` #' @section Figures: #' \if{html}{\figure{gt_badge.png}{options: style="width:500px;"}} #' #' @family Utilities gt_badge <- function( gt_object, column, palette = NULL, alpha = 0.2, rows = gt::everything() ) { stopifnot("Table must be of class 'gt_tbl'" = "gt_tbl" %in% class(gt_object)) text_transform( gt_object, locations = cells_body( columns = {{ column }}, rows = {{ rows }} ), fn = function(x) { if (is.null(palette)) { pal_filler <- rev(c( "#CC79A7", "#D55E00", "#0072B2", "#F0E442", "#009E73", "#56B4E9", "#E69F00", "#000000" ))[seq_along(unique(x))] } else if (length(palette) == 1) { pal_filler <- palette %>% rep(length(unique(x))) } else { pal_filler <- palette } # lapply(X = x, FUN = function(xy) { fct_lvl <- unique(x) stopifnot( "The length of the unique elements must match the palette length" = length( fct_lvl ) == length(pal_filler) ) if (!is.null(names(pal_filler))) { fct_x <- factor( xy, levels = names(pal_filler), labels = pal_filler ) %>% as.character() } else { fct_x <- factor(xy, levels = fct_lvl, labels = pal_filler) %>% as.character() } add_badge_color(fct_x, xy, alpha_lvl = alpha) }) } ) } ================================================ FILE: R/icon_fun.R ================================================ #' Repeat `{fontawesome}` icons and convert to HTML #' @description #' The `fa_icon_repeat` function takes an [fontawesome](https://fontawesome.com/) icon and repeats it `n` times. #' #' @param name The name of the Font Awesome icon. This could be as a short name (e.g., "npm", "drum", etc.), or, a full name (e.g., "fab fa-npm", "fas fa-drum", etc.). The names should correspond to current Version 5 Font Awesome names. A list of short and full names can be accessed through the fa_metadata() function with fa_metadata()$icon_names and fa_metadata()$icon_names_full. If supplying a Version 4 icon name, it will be internally translated to the Version 5 icon name and a Version 5 icon will be returned. A data frame containing the short names that changed from version 4 (v4_name) to version 5 (v5_name) can be obtained by using fa_metadata()$v4_v5_name_tbl. #' @param repeats An integer indicating the number of repeats for that specific icon/row. #' @param fill,fill_opacity The fill color of the icon can be set with fill. If not provided then the default value of "currentColor" is applied so that the SVG fill matches the color of the parent HTML element's color attribute. The opacity level of the SVG fill can be controlled with a decimal value between 0 and 1. #' @param stroke,stroke_width,stroke_opacity The stroke options allow for setting the color, width, and opacity of the SVG outline stroke. By default, the stroke width is very small at "1px" so a size adjustment with "stroke_width" can be useful. The "stroke_opacity" value can be any decimal values between 0 and 1 (bounds included). #' @param height,width The height and width style attributes of the rendered SVG. If nothing is provided for height then a default value of "1em" will be applied. If a width isn't given, then it will be calculated in units of "em" on the basis of the icon's SVG "viewBox" dimensions. #' @param margin_left,margin_right The length value for the margin that's either left or right of the icon. By default, "auto" is used for both properties. If space is needed on either side then a length of "0.2em" is recommended as a starting point. #' @param position The value for the position style attribute. By default, "relative" is used here. #' @param title An option for populating the SVG 'title' attribute, which provides on-hover text for the icon. By default, no title text is given to the icon. If a11y == "semantic" then title text will be automatically given to the rendered icon, however, providing text here will override that. #' @param a11y Cases that distinguish the role of the icon and inform which accessibility attributes to be used. Icons can either be "deco" (decorative, the default case) or "sem" (semantic). Using "none" will result in no accessibility features for the icon. #' @return A character string of class HTML, representing repeated SVG logos #' #' @family Utilities #' @section Function ID: #' 2-4 fa_icon_repeat <- function(name = "star", repeats = 1, fill = NULL, fill_opacity = NULL, stroke = NULL, stroke_width = NULL, stroke_opacity = NULL, height = NULL, width = NULL, margin_left = NULL, margin_right = NULL, position = NULL, title = NULL, a11y = c("deco", "sem", "none")) { fontawesome::fa( name, fill, fill_opacity, stroke, stroke_width, height, width, margin_left, margin_right, position, title, a11y ) %>% rep(., repeats) %>% gt::html() } ================================================ FILE: R/img_header.R ================================================ #' Add images as the column label for a table #' #' @param label A string indicating the label of the column. #' @param img_url A string for the image url. #' @param height A number indicating the height of the image in pixels. #' @param font_size The font size of the label in pixels. #' @param palette A vector of two colors, indictating the bottom border color and the text color. #' @return HTML string #' @export #' @section Examples: #' ```r #' library(gt) #' dplyr::tibble( #' x = 1:5, y = 6:10 #' ) %>% #' gt() %>% #' cols_label( #' x = img_header( #' "Luka Doncic", #' "https://secure.espn.com/combiner/i?img=/i/headshots/nba/players/full/3945274.png", #' height = 60, #' font_size = 14 #' ) #' ) #' ``` #' @section Figures: #' \if{html}{\figure{img_header.png}{options: style="width:500px;"}} #' #' @family Utilities img_header <- function(label, img_url, height = 60, font_size = 12, palette = c("black", "black")) { html_content <- htmltools::div( style = "text-align: center;", htmltools::img( src = img_url, height = gt::html(gt::px(as.integer(height))), style = glue::glue( "border-bottom: 2px solid {palette[1]};" ) ), htmltools::div( style = glue::glue( "font-size:{font_size}px;color: {palette[2]};", "text-align: center;width:100%;font-weight:bold;" ), label ) ) html_content <- as.character(html_content) %>% gt::html() html_content } ================================================ FILE: R/last_row_id.R ================================================ #' Get last row id/index even by group #' #' @param gt_object An existing gt table object of class `gt_tbl` last_row_id <- function(gt_object) { is_gt_stop(gt_object) get_row_index(gt_object) %>% dplyr::last() } ================================================ FILE: R/merge_and_stack.R ================================================ #' Merge and stack text from two columns in `gt` #' #' @description #' The `gt_merge_stack()` function takes an existing `gt` table and merges #' column 1 and column 2, stacking column 1's text on top of column 2's. #' Top text is in all caps with black bold text, while the lower text is smaller #' and dark grey. #' #' @param gt_object An existing gt table object of class `gt_tbl` #' @param col1 The column to stack on top. Will be converted to all caps, with black and bold text. #' @param col2 The column to merge and place below. Will be smaller and dark grey. #' @param palette The colors for the text, where the first color is the top , #' ie `col1` and the second color is the bottom, ie `col2`. Defaults to `c("black","grey")`. #' For more information on built-in color names, see [colors()]. #' @param small_cap a logical indicating whether to use 'small-cap' on the top line of text #' @param font_size a string of length 2 indicating the font-size in px of the top and bottom text #' @param font_weight a string of length 2 indicating the 'font-weight' of the top and bottom text. Must be one of 'bold', 'normal', 'lighter' #' @inheritDotParams scales::col2hcl -colour #' @return An object of class `gt_tbl`. #' @export #' @section Examples: #' #' ```r #' library(gt) #' teams <- "https://github.com/nflverse/nflfastR-data/raw/master/teams_colors_logos.rds" #' team_df <- readRDS(url(teams)) #' #' stacked_tab <- team_df %>% #' dplyr::select(team_nick, team_abbr, team_conf, team_division, team_wordmark) %>% #' head(8) %>% #' gt(groupname_col = "team_conf") %>% #' gt_merge_stack(col1 = team_nick, col2 = team_division) %>% #' gt_img_rows(team_wordmark) #' ``` #' @section Figures: #' \if{html}{\figure{merge-stack.png}{options: style="width:500px;"}} #' #' @family Utilities #' @section Function ID: #' 2-6 gt_merge_stack <- function(gt_object, col1, col2, palette = c("black", "grey"), ..., small_cap = TRUE, font_size = c("14px", "10px"), font_weight = c("bold", "bold")) { stopifnot("'gt_object' must be a 'gt_tbl', have you accidentally passed raw data?" = "gt_tbl" %in% class(gt_object)) stopifnot("There must be two colors" = length(palette) == 2) stopifnot("There must be two 'font_size'" = length(font_size) == 2) stopifnot("There must be two 'font_weight'" = length(font_weight) == 2) stopifnot("'font_size' must be a string with 'px'" = all(grepl(x = font_size, pattern = "px"))) stopifnot("'font_weight' must be a 'bold', 'normal' or 'lighter'" = font_weight %in% c("bold", "normal", "lighter")) # translate colors to hcl. Allows R color names like "grey30". colors <- scales::col2hcl(palette, ...) col1_bare <- rlang::enexpr(col1) %>% rlang::as_string() row_name_var <- gt_object[["_boxhead"]][["var"]][which(gt_object[["_boxhead"]][["type"]] == "stub")] # segment data with bare string column name data_in <- gt_index(gt_object, column = {{ col2 }}) gt_object %>% text_transform( locations = if (isTRUE(row_name_var == col1_bare)) { cells_stub(rows = gt::everything()) } else { cells_body(columns = {{ col1 }}) }, fn = function(x) { if (small_cap) { font_variant <- "small-caps" } else { font_variant <- "normal" } glue::glue( "
{x}
{data_in}
" ) } ) %>% cols_hide(columns = {{ col2 }}) } #' Merge and stack text with background coloring from two columns in `gt` #' #' @description #' The `gt_merge_stack_color()` function takes an existing `gt` table and merges #' column 1 and column 2, stacking column 1's text on top of column 2's. #' This variant also accepts a palette argument to colorize the background #' values. #' #' #' @param gt_object An existing gt table object of class `gt_tbl` #' @param top_val The column to stack on top. Will be converted to all caps, with bold text by default. #' @param color_val The column to merge and place below, and controls the background color value. Will be smaller by default. #' @param palette The colours or colour function that values will be mapped to, accepts a string or named palettes from paletteer. #' @param domain The possible values that can be mapped. This can be a simple numeric range (e.g. `c(0, 100)`). #' @param small_cap a logical indicating whether to use 'small-cap' on the top line of text, defaults to `TRUE`. #' @param font_size a string of length 2 indicating the font-size in px of the top and bottom text #' @param font_weight a string of length 2 indicating the 'font-weight' of the top and bottom text. Must be one of 'bold', 'normal', 'lighter' #' #' @return An object of class `gt_tbl`. #' @export #' #' @section Examples: #' #' ```r #' set.seed(12345) #' dplyr::tibble( #' value = sample(state.name, 5), #' color_by = seq.int(10, 98, length.out = 5) #' ) %>% #' gt::gt() %>% #' gt_merge_stack_color(value, color_by) #' ``` #' @section Figures: #' \if{html}{\figure{merge-stack-color.png}{options: style="width:500px;"}} #' #' @family Utilities gt_merge_stack_color <- function(gt_object, top_val, color_val, palette = c("#512daa", "white", "#2d6a22"), domain = NULL, small_cap = TRUE, font_size = c("14px", "10px"), font_weight = c("bold", "bold")) { stopifnot("Table must be of class 'gt_tbl'" = "gt_tbl" %in% class(gt_object)) if (is.null(domain)) { warning( "Domain not specified, defaulting to observed range within each specified column.", call. = FALSE ) } if (small_cap) { font_variant <- "small-caps" } else { font_variant <- "normal" } data_in <- gt_index(gt_object, column = {{ top_val }}) gt_object %>% data_color( columns = {{ color_val }}, fn = scales::col_numeric( palette = if (grepl(x = palette[1], pattern = "::")) { paletteer::paletteer_d( palette = palette ) %>% as.character() } else { palette }, domain = domain ) ) %>% text_transform( locations = cells_body({{ color_val }}), fn = function(x) { merge_pattern <- glue::glue( '
{data_in}
', '
{x}
' ) } ) %>% cols_hide(columns = {{ top_val }}) } ================================================ FILE: R/pad_fn.R ================================================ #' Pad a vector of numbers to align on the decimal point. #' @description #' This helper function adds whitespace to numeric values so that they can #' be aligned on the decimal without requiring additional trailing zeroes. #' This function is intended to use within the `gt::fmt()` function. #' @param x A vector of numbers to pad/align at the decimal point #' @param nsmall The max number of decimal places to round at/display #' @param pad0 A logical, indicating whether to pad the values with trailing zeros. #' @return Returns a vector of equal length to the input vector #' @export #' @examples #' #' library(gt) #' padded_tab <- data.frame(x = c(1.2345, 12.345, 123.45, 1234.5, 12345)) %>% #' gt() %>% #' fmt(fns = function(x) { #' pad_fn(x, nsmall = 4) #' }) %>% #' tab_style( #' # MUST USE A MONO-SPACED FONT #' # https://fonts.google.com/?category=Monospace #' style = cell_text(font = google_font("Fira Mono")), #' locations = cells_body(columns = x) #' ) #' #' @section Figures: #' \if{html}{\figure{gt_pad_fn.png}{options: style="width:500px;"}} #' #' @family Utilities #' @section Function ID: #' 2-3 pad_fn <- function(x, nsmall = 2, pad0) { # round and format values as text with specific number of decimals round_x <- round(x, digits = nsmall) fmt_x <- format(round_x, nsmall = nsmall) # calc number of trailing zeros zero_len <- nchar(fmt_x) - nchar(sub("0*$", "", fmt_x)) # create string of zero if (pad0) { rep_zero <- strrep(0, zero_len) } else { rep_zero <- "" } # remove trailing zeros by position fmt_out <- substr(fmt_x, 1, nchar(fmt_x) - zero_len) # add the non-breaking spaces to the formatted values filled_out <- paste0(fmt_out, rep_zero) filled_out } ================================================ FILE: R/reexports.R ================================================ # dplyr ------------------------------------------------------------------------ #' @export #' @importFrom dplyr %>% dplyr::`%>%` #' @importFrom dplyr vars #' @export dplyr::vars #' @importFrom dplyr select #' @export dplyr::select #' @importFrom dplyr mutate #' @export dplyr::mutate #' @importFrom dplyr starts_with #' @export dplyr::starts_with #' @importFrom dplyr ends_with #' @export dplyr::ends_with #' @importFrom dplyr contains #' @export dplyr::contains #' @importFrom dplyr matches #' @export dplyr::matches #' @importFrom dplyr num_range #' @export dplyr::num_range #' @importFrom dplyr all_of #' @export dplyr::all_of #' @importFrom dplyr any_of #' @export dplyr::any_of #' @importFrom dplyr everything #' @export dplyr::everything #' @importFrom dplyr last_col #' @export dplyr::last_col #' @importFrom dplyr one_of #' @export dplyr::one_of ================================================ FILE: R/tab_style_by_grp.R ================================================ #' Add table styling to specific rows by group #' @description #' The `tab_style_by_grp` function takes an existing `gt_tbl` object and #' styling according to each group. Currently it support styling the `max()`/`min()` #' for each group. #' #' @param gt_object An existing gt table object of class `gt_tbl` #' @param column The column using tidy variable name or a number indicating which column should have the styling affect it. #' @param fn The name of a summarizing function (ie `max()`, `min()`) #' @param ... Arguments passed to `tab_style(style = ...)` #' @return An object of class `gt_tbl`. #' @export #' @section Examples: #' ```r #' library(gt) #' df_in <- mtcars %>% #' dplyr::select(cyl:hp, mpg) %>% #' tibble::rownames_to_column() %>% #' dplyr::group_by(cyl) %>% #' dplyr::slice(1:4) %>% #' dplyr::ungroup() #' #' test_tab <- df_in %>% #' gt(groupname_col = "cyl") %>% #' tab_style_by_grp(mpg, fn = max, #' cell_fill(color = "red", alpha = 0.5)) #' ``` #' @section Figures: #' \if{html}{\figure{grp-tab-style.png}{options: style="width:500px;"}} #' #' @family Utilities #' @section Function ID: #' 2-12 tab_style_by_grp <- function(gt_object, column, fn, ...) { stopifnot("'gt_object' must be a 'gt_tbl', have you accidentally passed raw data?" = "gt_tbl" %in% class(gt_object)) # extract group names as a character and then turn into sym # for later tidyeveal ## logical vector subset_log <- gt_object[["_boxhead"]][["type"]] == "row_group" ## subset vars by vector grp_names <- gt_object[["_boxhead"]][["var"]][subset_log] ## create a list of symbols grp_col <- rlang::syms(grp_names) # ordered levels of the row groups gt_row_grps <- gt_object[["_row_groups"]] # pull the ordered row numbers grp_vec_ord <- gt_object[["_stub_df"]] %>% dplyr::mutate(group_id = factor(group_id, levels = gt_row_grps)) %>% dplyr::arrange(group_id) %>% dplyr::pull(rownum_i) # get the actual row id of the data for gt to target row_ids <- gt_object[["_data"]] %>% dplyr::mutate(row_id = dplyr::row_number()) %>% dplyr::slice(grp_vec_ord) %>% ### !!! to evaluate the list of symbols dplyr::group_by(!!!grp_col) %>% dplyr::filter({{ column }} == do.call(what = fn, args = list({{ column }}))) %>% dplyr::ungroup() %>% dplyr::pull(row_id) gt_object %>% tab_style( style = ..., locations = cells_body(columns = {{ column }}, rows = row_ids) ) } ================================================ FILE: R/two-column-layouts.R ================================================ #' Take data, a gt-generating function, and create a list of two tables #' #' @description The `gt_double_table` function takes some data and a user-supplied #' function to generate two tables in a list. To convert existing `gt::gt()` #' code to a function, you can follow the approximate pattern: #' `gt_fn <- function(x){gt(x) %>% more_gt_code}` #' #' Your function should only have a **single argument**, which is the **data** #' to be supplied directly into the `gt::gt()` function. This function is #' intended to be passed directly into `gt_two_column_layout()`, for printing #' it to the viewer, saving it to a `.png`, or returning the raw HTML. #' #' @param data A `tibble` or dataframe to be passed into the supplied `gt_fn` #' @param gt_fn A user-defined function that has one argument, this argument should pass data to the `gt::gt()` function, which will be supplied by the `data` argument. It should follow the pattern of `gt_function <- function(x) gt(x) %>% more_gt_code...`. #' @param nrows The number of rows to split at, defaults to `NULL` and will attempt to split approximately 50/50 in the left vs right table. #' @param noisy A logical indicating whether to return the warning about not supplying `nrows` argument. #' @return a `list()` of two `gt` tables #' @export #' #' @section Examples: #' ```r #' library(gt) #' # define your own function #' my_gt_function <- function(x) { #' gt(x) %>% #' gtExtras::gt_color_rows(columns = mpg, domain = range(mtcars$mpg)) %>% #' tab_options(data_row.padding = px(3)) #' } #' #' two_tables <- gt_double_table(mtcars, my_gt_function, nrows = 16) #' #' # list of two gt_tbl objects #' # ready to pass to gtExtras::gt_two_column_layout() #' str(two_tables, max.level = 1) #' #' #> List of 2 #' #> $ :List of 16 #' #> ..- attr(*, "class")= chr [1:2] "gt_tbl" "list" #' #> $ :List of 16 #' #> ..- attr(*, "class")= chr [1:2] "gt_tbl" "list" #' ``` #' @family Utilities #' @section Function ID: #' 2-13 gt_double_table <- function(data, gt_fn, nrows = NULL, noisy = TRUE) { if (is.null(nrows) && isTRUE(noisy)) { message("'nrows' is not defined, defaulting to approximately 50/50 split of data.") } if (is.null(nrows)) { total_rows <- nrow(data) half_rows <- ceiling(total_rows / 2) tab2_start <- half_rows + 1 tab1 <- data %>% dplyr::slice(1:half_rows) %>% gt_fn() tab2 <- data %>% slice(tab2_start:total_rows) %>% gt_fn() } else if (!is.null(nrows)) { tab1 <- data %>% dplyr::slice(1:nrows) %>% gt_fn() tab2 <- data %>% dplyr::slice((nrows + 1):nrow(.)) %>% gt_fn() } # returns a list object, to be used in gt_two_column_layout list(tab1, tab2) } #' Create a two-column layout from a list of two gt tables #' @description This function takes a `list()` of two gt-tables and returns #' them as a two-column layout. The expectation is that the user either supplies #' two tables like `list(table1, table2)`, or passes the output of `gt_double_table()` #' into this function. The user should indicate whether they want to return the #' HTML to R's viewer with `output = "viewer"` to "view" the final output, or to #' save to disk as a `.png` via `output = "save".` Note that this is a relatively #' complex wrapper around `htmltools::div()` + `webshot2::webshot()`. Additional #' arguments can be passed to `webshot2::webshot()` if the automatic output is not #' satisfactory. In most situations, modifying the `vwidth` argument is sufficient #' to get the desired output, but all arguments to `webshot2::webshot()` are #' available by their original name via the passed `...`. #' #' @param tables A `list()` of two tables, typically supplied by `gt_double_table()` #' @param output A character string indicating the desired output, either `"save"` to save it to disk via `webshot`, `"viewer"` to return it to the RStudio Viewer, or `"html"` to return the raw HTML. #' @param filename The filename of the table, must contain `.png` and only used if `output = "save"` #' @param path An optional path of where to save the printed `.png`, used in conjunction with `filename`. #' @param vwidth Viewport width. This is the width of the browser "window" when passed to `webshot2::webshot()`. #' @param vheight Viewport height This is the height of the browser "window" when passed to `webshot2::webshot()`. #' @param ... Additional arguments passed to `webshot2::webshot()`, only to be used if `output = "save"`, saving the two-column layout tables to disk as a `.png`. #' @param zoom Argument to `webshot2::webshot()`. A number specifying the zoom factor. A zoom factor of 2 will result in twice as many pixels vertically and horizontally. Note that using 2 is not exactly the same as taking a screenshot on a HiDPI (Retina) device: it is like increasing the zoom to 200 doubling the height and width of the browser window. This differs from using a HiDPI device because some web pages load different, higher-resolution images when they know they will be displayed on a HiDPI device (but using zoom will not report that there is a HiDPI device). #' @param expand Argument to `webshot2::webshot()`. A numeric vector specifying how many pixels to expand the clipping rectangle by. If one number, the rectangle will be expanded by that many pixels on all sides. If four numbers, they specify the top, right, bottom, and left, in that order. When taking screenshots of multiple URLs, this parameter can also be a list with same length as url with each element of the list containing a single number or four numbers to use for the corresponding URL. #' @param tab_header_from If `NULL` (the default) renders tab headers of each table individually. If one of "table1" or "table2", the function extracts tab header information (including styling) from table 1 or table 2 respectively and renders it as high level header for the combined view (individual headers will be removed). #' @return Saves a `.png` to disk if `output = "save"`, returns HTML to the viewer via `htmltools::browsable()` when `output = "viewer"`, or returns raw HTML if `output = "html"`. #' @export #' @family Utilities #' @section Examples: #' Add row numbers and drop some columns #' ``` r #' library(gt) #' my_cars <- mtcars %>% #' dplyr::mutate(row_n = dplyr::row_number(), .before = mpg) %>% #' dplyr::select(row_n, mpg:drat) #' ``` #' Create two tables, just split half/half #' #' ```r #' tab1 <- my_cars %>% #' dplyr::slice(1:16) %>% #' gt() %>% #' gtExtras::gt_color_rows(columns = row_n, domain = 1:32) #' #' tab2 <- my_cars %>% #' dplyr::slice(17:32) %>% #' gt() %>% #' gtExtras::gt_color_rows(columns = row_n, domain = 1:32) #' ``` #' Put the tables in a list and then pass list to the `gt_two_column_layout` function. #' ```r #' listed_tables <- list(tab1, tab2) #' #' gt_two_column_layout(listed_tables) #' ``` #' #' A better option - write a small function, use `gt_double_table()` to generate #' the tables and then pass it to `gt_double_table()` #' #' ```r #' my_gt_fn <- function(x) { #' gt(x) %>% #' gtExtras::gt_color_rows(columns = row_n, domain = 1:32) #' } #' #' my_tables <- gt_double_table(my_cars, my_gt_fn, nrows = nrow(my_cars) / 2) #' ``` #' #' This will return it to the viewer #' #' ```r #' gt_two_column_layout(my_tables) #' ``` #' If you wanted to save it out instead, could use the code below #' #' ```r #' gt_two_column_layout(my_tables, output = "save", #' filename = "basic-two-col.png", #' vwidth = 550, vheight = 620) #' ``` #' @section Figures: #' \if{html}{\figure{basic-two-col.png}{options: style="width:500px;"}} #' gt_two_column_layout <- function(tables = NULL, output = "viewer", filename = NULL, path = NULL, vwidth = 992, vheight = 600, ..., zoom = 2, expand = 5, tab_header_from = NULL) { if (length(tables) != 2) { stop("Two 'gt' tables must be provided like `list(table1, table2)` and be of length == 2", call. = FALSE) } if (!is.null(filename) && !grepl(".png", filename)) { stop("If supplying a filename, it must be a `.png`") } stopifnot("Output must be one of 'viewer', 'save', 'html'" = output %in% c("viewer", "save", "html")) stopifnot("Two 'gt' tables must be provided like `list(table1, table2)`" = !is.null(tables)) stopifnot("Two 'gt' tables must be provided like `list(table1, table2)`" = is.list(tables)) stopifnot("Both tables in the list must be a 'gt_tbl' object" = all(c(class(tables[[1]])[1], class(tables[[2]])[1]) == "gt_tbl")) if (!is.null(tab_header_from)){ stopifnot("The `tab_header_from` argument must be one of 'table1', or 'table2'" = tab_header_from %in% c("table1", "table2")) extract_from <- switch (tab_header_from, "table1" = tables[[1]], "table2" = tables[[2]] ) header_data <- extract_tab_header_and_style(extract_from) double_tables <- htmltools::div( id = "mycombinedtable", htmltools::tag("style", header_data[["style"]]), htmltools::div( header_data[["title"]], class = header_data[["title_class"]], style = header_data[["title_style"]] ), htmltools::div( header_data[["subtitle"]], class = header_data[["subtitle_class"]], style = header_data[["subtitle_style"]] ), htmltools::div(tables[[1]] %>% gt::tab_header(NULL, NULL), style = "display: inline-block;float:left;"), htmltools::div(tables[[2]] %>% gt::tab_header(NULL, NULL), style = "display: inline-block;float:right;") ) } else { double_tables <- htmltools::div( htmltools::div(tables[1], style = "display: inline-block;float:left;"), htmltools::div(tables[2], style = "display: inline-block;float:right;") ) } if (output == "viewer") { htmltools::browsable(double_tables) } else if (output == "save") { filename <- gtsave_filename(path = path, filename = filename) # Create a temporary file with the `html` extension tempfile_ <- tempfile(fileext = ".html") # Reverse slashes on Windows filesystems tempfile_ <- tempfile_ %>% tidy_gsub("\\\\", "/") htmltools::save_html(html = double_tables, file = tempfile_) # Saving an image requires the webshot2 package; if it's # not present, stop with a message if (!rlang::is_installed("webshot2")) { stop("The `webshot2` package is required for saving images of gt tables.)", call. = FALSE ) } else { # Save the image in the working directory webshot2::webshot( url = paste0("file:///", tempfile_), file = filename, vwidth = vwidth, vheight = vheight, zoom = zoom, expand = expand, ... ) } } else if (output == "html") { double_tables } } extract_tab_header_and_style <- function(table) { raw_html <- gt::as_raw_html(table, inline_css = FALSE) %>% xml2::read_html() gt_title <- raw_html %>% xml2::xml_find_first("//*[contains(concat(' ',normalize-space(@class),' '),' gt_title ')]") gt_subtitle <- raw_html %>% xml2::xml_find_first("//*[contains(concat(' ',normalize-space(@class),' '),' gt_subtitle ')]") gt_table_id <- raw_html %>% xml2::xml_find_all("//body/div") %>% xml2::xml_attr("id") s <- raw_html %>% xml2::xml_find_first("//style") %>% xml2::xml_contents() %>% xml2::xml_text() %>% gsub(gt_table_id, "mycombinedtable", x = .) %>% gsub("mycombinedtable table", "mycombinedtable div", x = .) list( title = xml_missing(gt_title), title_class = paste("gt_table", xml2::xml_attr(gt_title, "class")), title_style = xml2::xml_attr(gt_title, "style"), subtitle = xml_missing(gt_subtitle), subtitle_class = paste("gt_table", xml2::xml_attr(gt_subtitle, "class")), subtitle_style = xml2::xml_attr(gt_subtitle, "style"), style = s ) } xml_missing <- function(xml){ xml_txt <- xml2::xml_text(xml) if (is.na(xml_txt)) return(NULL) xml_txt } ================================================ FILE: R/utils.R ================================================ #' Count number of decimals #' #' @param x A value to count decimals from #' #' @return an integer #' @export #' n_decimals <- function(x) { # adapted from: https://stackoverflow.com/questions/5173692/how-to-return-number-of-decimal-places-in-r if (abs(x - round(x)) > .Machine$double.eps^0.5) { # x <- format(x, drop0trailing = TRUE) # nchar(strsplit(x, ".", fixed = TRUE)[[1]][[2]]) nchar(strsplit(sub("0+$", "", as.character(x)), ".", fixed = TRUE)[[1]][[2]]) } else { return(0) } } # Calculate binwidth for histograms based on good defaults bw_calc <- function(x) { bw <- 2 * IQR(x, na.rm = TRUE) / length(x)^(1 / 3) bw } # save the SVG of a plot out save_svg <- function(plot, ..., dpi = 25.4) { out_name <- file.path( tempfile(pattern = "file", tmpdir = tempdir(), fileext = ".svg") ) ggsave( out_name, plot = plot, ..., bg = "transparent", # below are some general defaults, but don't want to # force them if used more generally dpi = dpi#, # height = fig_dim[1], # width = fig_dim[2], # units = "mm" ) img_plot <- out_name %>% readLines() %>% # potentially required as PANDOC turns 4 spaces into pre code block # https://github.com/jthomasmock/gtExtras/issues/56 # https://stackoverflow.com/questions/40730902/r-markdown-asis-breaks-valid-html-code tidy_gsub(pattern = "\\s+", replacement = " ") %>% paste0(collapse = "") %>% gt::html() on.exit(file.remove(out_name), add = TRUE) img_plot } # check if gt #' @noRd is_gt <- function(gt_object) { any("gt_tbl" %in% class(gt_object)) } # check if stop gt #' @noRd is_gt_stop <- function(gt_object) { stopifnot("'gt_object' must be a 'gt_tbl', have you accidentally passed raw data?" = any("gt_tbl" %in% class(gt_object))) } # vendored from gt # https://github.com/rstudio/gt/blob/04c34936a9d09e96b339dea8da07e414730ec17d/R/utils.R#L1654-L1661 man_get_image_tag <- function(file, width = 100, dir = "images", alt = NULL) { repo_url <- "https://raw.githubusercontent.com/jthomasmock/gtExtras/master" image_url <- file.path(repo_url, dir, file) paste0("\"",") } # https://stackoverflow.com/questions/19655579/a-function-that-returns-true-on-na-null-nan-in-r is_blank <- function(x) { if (missing(x) || is.null(x) || length(x) == 0 || is.na(x)) { return(TRUE) } else { return(FALSE) } } ================================================ FILE: README.Rmd ================================================ --- output: github_document --- ```{r setup, include = FALSE} knitr::opts_chunk$set( eval = FALSE, comment = "#>", fig.path = "man/figures/README-", out.width = "100%" ) ``` # gtExtras [![Codecov test coverage](https://codecov.io/gh/jthomasmock/gtExtras/branch/master/graph/badge.svg)](https://app.codecov.io/gh/jthomasmock/gtExtras?branch=master) [![R-CMD-check](https://github.com/jthomasmock/gtExtras/workflows/R-CMD-check/badge.svg)](https://github.com/jthomasmock/gtExtras/actions) [![CRAN status](https://www.r-pkg.org/badges/version/gtExtras)](https://CRAN.R-project.org/package=gtExtras) [![R-CMD-check](https://github.com/jthomasmock/gtExtras/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/jthomasmock/gtExtras/actions/workflows/R-CMD-check.yaml) ![gtExtras Total Downloads](https://cranlogs.r-pkg.org/badges/grand-total/gtExtras) The goal of `{gtExtras}` is to provide some additional helper functions to assist in creating beautiful tables with `{gt}`. The functions are generally wrappers around boilerplate or adding capabilities that are currently not *yet* built into `{gt}`. The [`{gt}` package](https://gt.rstudio.com/) is amazing, make sure to go read the official documentation. ## Installation ``` r install.packages("gtExtras") ``` ## Development version To get a bug fix or to use a feature from the development version, you can install the development version of gtExtras from [GitHub](https://github.com/jthomasmock/gtExtras) ``` r # if needed install.packages("remotes") remotes::install_github("jthomasmock/gtExtras") ``` See the full [function reference](https://jthomasmock.github.io/gtExtras/reference/index.html) or the [package website](https://jthomasmock.github.io/gtExtras/) for more details. ================================================ FILE: README.md ================================================ # gtExtras [![Codecov test coverage](https://codecov.io/gh/jthomasmock/gtExtras/branch/master/graph/badge.svg)](https://app.codecov.io/gh/jthomasmock/gtExtras?branch=master) [![R-CMD-check](https://github.com/jthomasmock/gtExtras/workflows/R-CMD-check/badge.svg)](https://github.com/jthomasmock/gtExtras/actions) [![CRAN status](https://www.r-pkg.org/badges/version/gtExtras)](https://CRAN.R-project.org/package=gtExtras) [![R-CMD-check](https://github.com/jthomasmock/gtExtras/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/jthomasmock/gtExtras/actions/workflows/R-CMD-check.yaml) ![gtExtras Total Downloads](https://cranlogs.r-pkg.org/badges/grand-total/gtExtras) The goal of `{gtExtras}` is to provide some additional helper functions to assist in creating beautiful tables with `{gt}`. The functions are generally wrappers around boilerplate or adding capabilities that are currently not *yet* built into `{gt}`. The [`{gt}` package](https://gt.rstudio.com/) is amazing, make sure to go read the official documentation. ## Installation ``` r install.packages("gtExtras") ``` ## Development version To get a bug fix or to use a feature from the development version, you can install the development version of gtExtras from [GitHub](https://github.com/jthomasmock/gtExtras) ``` r # if needed install.packages("remotes") remotes::install_github("jthomasmock/gtExtras") ``` See the full [function reference](https://jthomasmock.github.io/gtExtras/reference/index.html) or the [package website](https://jthomasmock.github.io/gtExtras/) for more details. ================================================ FILE: _pkgdown.yml ================================================ url: https://jthomasmock.github.io/gtExtras/ home: title: Additional features for creating beautiful tables with gt description: An easy to use and powerful package for creating tables that will blow your mind template: bootstrap: 5 opengraph: image: src: man/figures/opengraph.png alt: The package hex logo, it is pixel art of a table with a computer on top. A small boston terrier is underneath and then the text gtExtras. twitter: creator: "@thomas_mock" site: https://jthomasmock.github.io/gtExtras card: summary reference: - title: Themes desc: Full blown `{gt}` themes that affect most if not all visual components of the table. Similar in spirit to `{ggplot2}` themes like `ggplot2::theme_minimal()` or `{ggthemes}` like `ggthemes::theme_fivethirtyeight()`. contents: - gt_theme_538 - gt_theme_espn - gt_theme_nytimes - gt_theme_guardian - gt_theme_dot_matrix - gt_theme_dark - gt_theme_excel - gt_theme_pff - title: Plotting desc: Add plots to specific rows of an existing table contents: - gt_plt_bar - gt_plt_bar_pct - gt_plt_bar_stack - gt_plt_bullet - gt_plt_conf_int - gt_plt_dist - gt_plt_dot - gt_plt_dumbbell - gt_plt_percentile - gt_plt_point - gt_plt_sparkline - gt_plt_summary - gt_plt_winloss - title: Images and icons desc: Add fontawesome icons or web images to a table contents: - fa_icon_repeat # - gt_fa_column # - gt_fa_repeats - gt_fa_rating - gt_fa_rank_change - add_text_img - img_header - gt_img_rows - gt_img_multi_rows - gt_img_circle - gt_img_border - title: Colors desc: Add color to the entire table or to specific locations. Includes wrappers around the `{scales}` and `{paletteer}` packages that provide easier or more succinct applications of palettes and colors inside `{gt}`. contents: - gt_hulk_col_numeric - gt_color_rows - gt_color_box - gt_alert_icon - title: HTML Helpers desc: Various HTML helpers to avoid repeated boilerplate contents: - gt_label_details - with_tooltip - gt_hyperlink - title: Utilities desc: Helper functions and utilities with features not _yet_ built into `{gt}`. contents: - fmt_symbol_first - fmt_pad_num - fmt_pct_extra - pad_fn - gt_merge_stack - gt_merge_stack_color - gt_highlight_rows - gt_highlight_cols - gt_add_divider - tab_style_by_grp - gt_double_table - gt_two_column_layout - gtsave_extra - gt_duplicate_column - gt_index - get_row_index - generate_df - gt_reprex_image - title: internal desc: Internally used functions contents: - add_badge_color - add_pcttile_plot - add_point_plot - gt_badge - n_decimals - create_sum_table - plot_data - last_row_id ================================================ FILE: codecov.yml ================================================ comment: false coverage: status: project: default: target: auto threshold: 1% informational: true patch: default: target: auto threshold: 1% informational: true ================================================ FILE: cran-comments.md ================================================ ## Submission details - This is an update to solve a few bugs as indicated by users and CRAN maintainers. ## R CMD check results There were no ERRORs, WARNINGs or NOTEs Checked against automated test environments, RHub, MacBuilder, and WinBuilder (oldrel/devel/release) ## Automated Test environments on Github Actions: - ubuntu (devel, release, oldrel) - windows (release) - macOS (release) on R-universe - Windows (devel, release, oldrel) - MacOS (release, oldrel) ## R CMD check results ── R CMD check results ─────── gtExtras 0.6.1 ──── Duration: 42.7s 0 errors ✔ | 0 warnings ✔ | 0 notes ✔ ================================================ FILE: data-raw/x06-css-colors.R ================================================ css_colors <- dplyr::tribble( ~color_name, ~hexadecimal, ~category, "IndianRed", "#CD5C5C", "Reds", "LightCoral", "#F08080", "Reds", "Salmon", "#FA8072", "Reds", "DarkSalmon", "#E9967A", "Reds", "LightSalmon", "#FFA07A", "Reds", "Crimson", "#DC143C", "Reds", "Red", "#FF0000", "Reds", "FireBrick", "#B22222", "Reds", "DarkRed", "#8B0000", "Reds", "Pink", "#FFC0CB", "Pinks", "LightPink", "#FFB6C1", "Pinks", "HotPink", "#FF69B4", "Pinks", "DeepPink", "#FF1493", "Pinks", "MediumVioletRed", "#C71585", "Pinks", "PaleVioletRed", "#DB7093", "Pinks", "Coral", "#FF7F50", "Oranges", "Tomato", "#FF6347", "Oranges", "OrangeRed", "#FF4500", "Oranges", "DarkOrange", "#FF8C00", "Oranges", "Orange", "#FFA500", "Oranges", "Gold", "#FFD700", "Yellows", "Yellow", "#FFFF00", "Yellows", "LightYellow", "#FFFFE0", "Yellows", "LemonChiffon", "#FFFACD", "Yellows", "LightGoldenrodYellow", "#FAFAD2", "Yellows", "PapayaWhip", "#FFEFD5", "Yellows", "Moccasin", "#FFE4B5", "Yellows", "PeachPuff", "#FFDAB9", "Yellows", "PaleGoldenrod", "#EEE8AA", "Yellows", "Khaki", "#F0E68C", "Yellows", "DarkKhaki", "#BDB76B", "Yellows", "Lavender", "#E6E6FA", "Purples", "Thistle", "#D8BFD8", "Purples", "Plum", "#DDA0DD", "Purples", "Violet", "#EE82EE", "Purples", "Orchid", "#DA70D6", "Purples", "Fuchsia", "#FF00FF", "Purples", "Magenta", "#FF00FF", "Purples", "MediumOrchid", "#BA55D3", "Purples", "MediumPurple", "#9370DB", "Purples", "BlueViolet", "#8A2BE2", "Purples", "DarkViolet", "#9400D3", "Purples", "DarkOrchid", "#9932CC", "Purples", "DarkMagenta", "#8B008B", "Purples", "Purple", "#800080", "Purples", "RebeccaPurple", "#663399", "Purples", "Indigo", "#4B0082", "Purples", "MediumSlateBlue", "#7B68EE", "Purples", "SlateBlue", "#6A5ACD", "Purples", "DarkSlateBlue", "#483D8B", "Purples", "GreenYellow", "#ADFF2F", "Greens", "Chartreuse", "#7FFF00", "Greens", "LawnGreen", "#7CFC00", "Greens", "Lime", "#00FF00", "Greens", "LimeGreen", "#32CD32", "Greens", "PaleGreen", "#98FB98", "Greens", "LightGreen", "#90EE90", "Greens", "MediumSpringGreen", "#00FA9A", "Greens", "SpringGreen", "#00FF7F", "Greens", "MediumSeaGreen", "#3CB371", "Greens", "SeaGreen", "#2E8B57", "Greens", "ForestGreen", "#228B22", "Greens", "Green", "#008000", "Greens", "DarkGreen", "#006400", "Greens", "YellowGreen", "#9ACD32", "Greens", "OliveDrab", "#6B8E23", "Greens", "Olive", "#808000", "Greens", "DarkOliveGreen", "#556B2F", "Greens", "MediumAquamarine", "#66CDAA", "Greens", "DarkSeaGreen", "#8FBC8F", "Greens", "LightSeaGreen", "#20B2AA", "Greens", "DarkCyan", "#008B8B", "Greens", "Teal", "#008080", "Greens", "Aqua", "#00FFFF", "Blues/Cyans", "Cyan", "#00FFFF", "Blues/Cyans", "LightCyan", "#E0FFFF", "Blues/Cyans", "PaleTurquoise", "#AFEEEE", "Blues/Cyans", "Aquamarine", "#7FFFD4", "Blues/Cyans", "Turquoise", "#40E0D0", "Blues/Cyans", "MediumTurquoise", "#48D1CC", "Blues/Cyans", "DarkTurquoise", "#00CED1", "Blues/Cyans", "CadetBlue", "#5F9EA0", "Blues/Cyans", "SteelBlue", "#4682B4", "Blues/Cyans", "LightSteelBlue", "#B0C4DE", "Blues/Cyans", "PowderBlue", "#B0E0E6", "Blues/Cyans", "LightBlue", "#ADD8E6", "Blues/Cyans", "SkyBlue", "#87CEEB", "Blues/Cyans", "LightSkyBlue", "#87CEFA", "Blues/Cyans", "DeepSkyBlue", "#00BFFF", "Blues/Cyans", "DodgerBlue", "#1E90FF", "Blues/Cyans", "CornflowerBlue", "#6495ED", "Blues/Cyans", "RoyalBlue", "#4169E1", "Blues/Cyans", "Blue", "#0000FF", "Blues/Cyans", "MediumBlue", "#0000CD", "Blues/Cyans", "DarkBlue", "#00008B", "Blues/Cyans", "Navy", "#000080", "Blues/Cyans", "MidnightBlue", "#191970", "Blues/Cyans", "Cornsilk", "#FFF8DC", "Browns", "BlanchedAlmond", "#FFEBCD", "Browns", "Bisque", "#FFE4C4", "Browns", "NavajoWhite", "#FFDEAD", "Browns", "Wheat", "#F5DEB3", "Browns", "BurlyWood", "#DEB887", "Browns", "Tan", "#D2B48C", "Browns", "RosyBrown", "#BC8F8F", "Browns", "SandyBrown", "#F4A460", "Browns", "Goldenrod", "#DAA520", "Browns", "DarkGoldenrod", "#B8860B", "Browns", "Peru", "#CD853F", "Browns", "Chocolate", "#D2691E", "Browns", "SaddleBrown", "#8B4513", "Browns", "Sienna", "#A0522D", "Browns", "Brown", "#A52A2A", "Browns", "Maroon", "#800000", "Browns", "White", "#FFFFFF", "Whites", "Snow", "#FFFAFA", "Whites", "Honeydew", "#F0FFF0", "Whites", "MintCream", "#F5FFFA", "Whites", "Azure", "#F0FFFF", "Whites", "AliceBlue", "#F0F8FF", "Whites", "GhostWhite", "#F8F8FF", "Whites", "WhiteSmoke", "#F5F5F5", "Whites", "Seashell", "#FFF5EE", "Whites", "Beige", "#F5F5DC", "Whites", "OldLace", "#FDF5E6", "Whites", "FloralWhite", "#FFFAF0", "Whites", "Ivory", "#FFFFF0", "Whites", "AntiqueWhite", "#FAEBD7", "Whites", "Linen", "#FAF0E6", "Whites", "LavenderBlush", "#FFF0F5", "Whites", "MistyRose", "#FFE4E1", "Whites", "Gainsboro", "#DCDCDC", "Greys", "LightGray", "#D3D3D3", "Greys", "LightGrey", "#D3D3D3", "Greys", "Silver", "#C0C0C0", "Greys", "DarkGray", "#A9A9A9", "Greys", "DarkGrey", "#A9A9A9", "Greys", "Gray", "#808080", "Greys", "Grey", "#808080", "Greys", "DimGray", "#696969", "Greys", "DimGrey", "#696969", "Greys", "LightSlateGray", "#778899", "Greys", "LightSlateGrey", "#778899", "Greys", "SlateGray", "#708090", "Greys", "SlateGrey", "#708090", "Greys", "DarkSlateGray", "#2F4F4F", "Greys", "DarkSlateGrey", "#2F4F4F", "Greys", "Black", "#000000", "Greys" ) css_colors <- dplyr::mutate( css_colors, is_x11_color = ifelse( tolower(color_name) %in% grDevices::colors(), TRUE, FALSE ) ) ================================================ FILE: data-raw/zz_process_datasets_ext.R ================================================ library(usethis) source("data-raw/x06-css-colors.R") # Create internal datasets (`sysdata.rda`) usethis::use_data( css_colors, internal = TRUE, overwrite = TRUE ) ================================================ FILE: man/add_badge_color.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/html-helpers.R \name{add_badge_color} \alias{add_badge_color} \title{Add badge color} \usage{ add_badge_color(add_color, add_label, alpha_lvl) } \arguments{ \item{add_color}{A color to add to the badge} \item{add_label}{The label to add to the badge} \item{alpha_lvl}{The alpha level} } \value{ HTML character } \description{ Add badge color } ================================================ FILE: man/add_pcttile_plot.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_plt_percentile_dot.R \name{add_pcttile_plot} \alias{add_pcttile_plot} \title{Create a dot plot from 0 to 100} \usage{ add_pcttile_plot(data, palette, add_label, width) } \arguments{ \item{data}{The single value that will be used to plot the point.} \item{palette}{A length 3 palette, used to highlight high/med/low} \item{add_label}{A logical indicating whether to add the label or note. This will only be added if it is the first or last row.} \item{width}{A numeric indicating the} } \value{ gt table } \description{ Create a dot plot from 0 to 100 } ================================================ FILE: man/add_point_plot.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_plt_point.R \name{add_point_plot} \alias{add_point_plot} \title{Create a dot plot from any range - add_point_plot} \usage{ add_point_plot(data, palette, add_label, width, vals_range, accuracy) } \arguments{ \item{data}{The single value that will be used to plot the point.} \item{palette}{A length 3 palette, used to highlight high/med/low} \item{add_label}{A logical indicating whether to add the label or note. This will only be added if it is the first or last row.} \item{width}{A numeric indicating the} \item{vals_range}{vector of length two indicating range} \item{accuracy}{A number to round to. Use (e.g.) \code{0.01} to show 2 decimal places of precision. If \code{NULL}, the default, uses a heuristic that should ensure breaks have the minimum number of digits needed to show the difference between adjacent values. Applied to rescaled data.} } \value{ gt table } \description{ Create a dot plot from any range - add_point_plot } ================================================ FILE: man/add_text_img.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_text_img.R \name{add_text_img} \alias{add_text_img} \title{Add text and an image to the left or right of it} \usage{ add_text_img(text, url, height = 30, left = FALSE) } \arguments{ \item{text}{A text string to be added to the cell.} \item{url}{\emph{An image URL} \verb{scalar} // \strong{required} A url that resolves to an image file.} \item{height}{\emph{Height of image} \verb{scalar} // \emph{default:} \code{30} The absolute height of the image in the table cell (in \code{"px"} units). By default, this is set to \code{"30px"}.} \item{left}{A logical TRUE/FALSE indicating if text should be on the left (TRUE) or right (FALSE)} } \value{ An object of class \code{gt_tbl}. } \description{ The \code{add_text_img} function takes an existing \code{gt_tbl} object and adds some user specified text and an image url to a specific cell. This is a wrapper raw HTML strings and \code{gt::web_image()}. Intended to be used inside the header of a table via \code{gt::tab_header()}. } \section{Function ID}{ 2-5 } \section{Figures}{ \if{html}{\figure{title-car.png}{options: style="width=70\%;"}} } \examples{ library(gt) title_car <- mtcars \%>\% head() \%>\% gt() \%>\% gt::tab_header( title = add_text_img( "A table about cars made with", url = "https://www.r-project.org/logo/Rlogo.png" ) ) } \seealso{ Other Utilities: \code{\link{fa_icon_repeat}()}, \code{\link{fmt_pad_num}()}, \code{\link{fmt_pct_extra}()}, \code{\link{fmt_symbol_first}()}, \code{\link{generate_df}()}, \code{\link{gt_add_divider}()}, \code{\link{gt_badge}()}, \code{\link{gt_double_table}()}, \code{\link{gt_duplicate_column}()}, \code{\link{gt_fa_rank_change}()}, \code{\link{gt_fa_rating}()}, \code{\link{gt_highlight_cols}()}, \code{\link{gt_highlight_rows}()}, \code{\link{gt_img_border}()}, \code{\link{gt_img_circle}()}, \code{\link{gt_img_multi_rows}()}, \code{\link{gt_img_rows}()}, \code{\link{gt_index}()}, \code{\link{gt_merge_stack}()}, \code{\link{gt_merge_stack_color}()}, \code{\link{gt_two_column_layout}()}, \code{\link{gtsave_extra}()}, \code{\link{img_header}()}, \code{\link{pad_fn}()}, \code{\link{tab_style_by_grp}()} } \concept{Utilities} ================================================ FILE: man/create_sum_table.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_summary_table.R \name{create_sum_table} \alias{create_sum_table} \title{Create a summary table from a dataframe} \usage{ create_sum_table(df) } \arguments{ \item{df}{a dataframe or tibble} } \value{ A summary dataframe as a tibble } \description{ Create a summary table from a dataframe } \examples{ \dontrun{ create_sum_table(iris) #> # A tibble: 5 × 7 #> type name value n_missing Mean Median SD #> #> 1 numeric Sepal.Length 0 5.84 5.8 0.828 #> 2 numeric Sepal.Width 0 3.06 3 0.436 #> 3 numeric Petal.Length 0 3.76 4.35 1.77 #> 4 numeric Petal.Width 0 1.20 1.3 0.762 #> 5 factor Species 0 NA NA NA } } ================================================ FILE: man/fa_icon_repeat.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/icon_fun.R \name{fa_icon_repeat} \alias{fa_icon_repeat} \title{Repeat \code{{fontawesome}} icons and convert to HTML} \usage{ fa_icon_repeat( name = "star", repeats = 1, fill = NULL, fill_opacity = NULL, stroke = NULL, stroke_width = NULL, stroke_opacity = NULL, height = NULL, width = NULL, margin_left = NULL, margin_right = NULL, position = NULL, title = NULL, a11y = c("deco", "sem", "none") ) } \arguments{ \item{name}{The name of the Font Awesome icon. This could be as a short name (e.g., "npm", "drum", etc.), or, a full name (e.g., "fab fa-npm", "fas fa-drum", etc.). The names should correspond to current Version 5 Font Awesome names. A list of short and full names can be accessed through the fa_metadata() function with fa_metadata()$icon_names and fa_metadata()$icon_names_full. If supplying a Version 4 icon name, it will be internally translated to the Version 5 icon name and a Version 5 icon will be returned. A data frame containing the short names that changed from version 4 (v4_name) to version 5 (v5_name) can be obtained by using fa_metadata()$v4_v5_name_tbl.} \item{repeats}{An integer indicating the number of repeats for that specific icon/row.} \item{fill, fill_opacity}{The fill color of the icon can be set with fill. If not provided then the default value of "currentColor" is applied so that the SVG fill matches the color of the parent HTML element's color attribute. The opacity level of the SVG fill can be controlled with a decimal value between 0 and 1.} \item{stroke, stroke_width, stroke_opacity}{The stroke options allow for setting the color, width, and opacity of the SVG outline stroke. By default, the stroke width is very small at "1px" so a size adjustment with "stroke_width" can be useful. The "stroke_opacity" value can be any decimal values between 0 and 1 (bounds included).} \item{height, width}{The height and width style attributes of the rendered SVG. If nothing is provided for height then a default value of "1em" will be applied. If a width isn't given, then it will be calculated in units of "em" on the basis of the icon's SVG "viewBox" dimensions.} \item{margin_left, margin_right}{The length value for the margin that's either left or right of the icon. By default, "auto" is used for both properties. If space is needed on either side then a length of "0.2em" is recommended as a starting point.} \item{position}{The value for the position style attribute. By default, "relative" is used here.} \item{title}{An option for populating the SVG 'title' attribute, which provides on-hover text for the icon. By default, no title text is given to the icon. If a11y == "semantic" then title text will be automatically given to the rendered icon, however, providing text here will override that.} \item{a11y}{Cases that distinguish the role of the icon and inform which accessibility attributes to be used. Icons can either be "deco" (decorative, the default case) or "sem" (semantic). Using "none" will result in no accessibility features for the icon.} } \value{ A character string of class HTML, representing repeated SVG logos } \description{ The \code{fa_icon_repeat} function takes an \href{https://fontawesome.com/}{fontawesome} icon and repeats it \code{n} times. } \section{Function ID}{ 2-4 } \seealso{ Other Utilities: \code{\link{add_text_img}()}, \code{\link{fmt_pad_num}()}, \code{\link{fmt_pct_extra}()}, \code{\link{fmt_symbol_first}()}, \code{\link{generate_df}()}, \code{\link{gt_add_divider}()}, \code{\link{gt_badge}()}, \code{\link{gt_double_table}()}, \code{\link{gt_duplicate_column}()}, \code{\link{gt_fa_rank_change}()}, \code{\link{gt_fa_rating}()}, \code{\link{gt_highlight_cols}()}, \code{\link{gt_highlight_rows}()}, \code{\link{gt_img_border}()}, \code{\link{gt_img_circle}()}, \code{\link{gt_img_multi_rows}()}, \code{\link{gt_img_rows}()}, \code{\link{gt_index}()}, \code{\link{gt_merge_stack}()}, \code{\link{gt_merge_stack_color}()}, \code{\link{gt_two_column_layout}()}, \code{\link{gtsave_extra}()}, \code{\link{img_header}()}, \code{\link{pad_fn}()}, \code{\link{tab_style_by_grp}()} } \concept{Utilities} ================================================ FILE: man/fmt_pad_num.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/fmt_pad_num.R \name{fmt_pad_num} \alias{fmt_pad_num} \title{Format numeric columns to align at decimal point without trailing zeroes} \usage{ fmt_pad_num(gt_object, columns, sep = ".", nsmall = 2, pad0 = FALSE) } \arguments{ \item{gt_object}{An existing gt table object of class \code{gt_tbl}} \item{columns}{The columns to format. Can either be a series of column names provided in \code{c()}, a vector of column indices, or a helper function focused on selections. The select helper functions are: \code{starts_with()}, \code{ends_with()}, \code{contains()}, \code{matches()}, \code{one_of()}, \code{num_range()}, and \code{everything()}.} \item{sep}{A character for the separator, typically \code{"."} or \code{","}} \item{nsmall}{The max number of decimal places to round at/display} \item{pad0}{A logical, indicating whether to pad the values with trailing zeros.} } \value{ An object of class \code{gt_tbl}. } \description{ This function removes repeating trailing zeroes and adds blank white space to align at the decimal point. } \section{Figures}{ \if{html}{\figure{fmt_pad_num.png}{options: style="width=20\%;"}} } \section{Function ID}{ 2-2 } \examples{ library(gt) padded_tab <- data.frame(numbers = c(1.2345, 12.345, 123.45, 1234.5, 12345)) \%>\% gt() \%>\% fmt_pad_num(columns = numbers, nsmall = 4) } \seealso{ \code{\link[=pad_fn]{pad_fn()}} Other Utilities: \code{\link{add_text_img}()}, \code{\link{fa_icon_repeat}()}, \code{\link{fmt_pct_extra}()}, \code{\link{fmt_symbol_first}()}, \code{\link{generate_df}()}, \code{\link{gt_add_divider}()}, \code{\link{gt_badge}()}, \code{\link{gt_double_table}()}, \code{\link{gt_duplicate_column}()}, \code{\link{gt_fa_rank_change}()}, \code{\link{gt_fa_rating}()}, \code{\link{gt_highlight_cols}()}, \code{\link{gt_highlight_rows}()}, \code{\link{gt_img_border}()}, \code{\link{gt_img_circle}()}, \code{\link{gt_img_multi_rows}()}, \code{\link{gt_img_rows}()}, \code{\link{gt_index}()}, \code{\link{gt_merge_stack}()}, \code{\link{gt_merge_stack_color}()}, \code{\link{gt_two_column_layout}()}, \code{\link{gtsave_extra}()}, \code{\link{img_header}()}, \code{\link{pad_fn}()}, \code{\link{tab_style_by_grp}()} } \concept{Utilities} ================================================ FILE: man/fmt_pct_extra.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/fmt_pct_extra.R \name{fmt_pct_extra} \alias{fmt_pct_extra} \title{Convert to percent and show less than 1\% as <1\% in grey} \usage{ fmt_pct_extra(gt_object, columns, ..., scale = 1) } \arguments{ \item{gt_object}{An existing gt table} \item{columns}{The columns to affect} \item{...}{Additional argument passed to \code{scales::label_percent()}} \item{scale}{A number to multiply values by, defaults to 1} } \value{ a gt table } \description{ Convert to percent and show less than 1\% as <1\% in grey } \examples{ library(gt) pct_tab <- dplyr::tibble(x = c(.001, .05, .008, .1, .2, .5, .9)) \%>\% gt::gt() \%>\% fmt_pct_extra(x, scale = 100, accuracy = .1) } \seealso{ Other Utilities: \code{\link{add_text_img}()}, \code{\link{fa_icon_repeat}()}, \code{\link{fmt_pad_num}()}, \code{\link{fmt_symbol_first}()}, \code{\link{generate_df}()}, \code{\link{gt_add_divider}()}, \code{\link{gt_badge}()}, \code{\link{gt_double_table}()}, \code{\link{gt_duplicate_column}()}, \code{\link{gt_fa_rank_change}()}, \code{\link{gt_fa_rating}()}, \code{\link{gt_highlight_cols}()}, \code{\link{gt_highlight_rows}()}, \code{\link{gt_img_border}()}, \code{\link{gt_img_circle}()}, \code{\link{gt_img_multi_rows}()}, \code{\link{gt_img_rows}()}, \code{\link{gt_index}()}, \code{\link{gt_merge_stack}()}, \code{\link{gt_merge_stack_color}()}, \code{\link{gt_two_column_layout}()}, \code{\link{gtsave_extra}()}, \code{\link{img_header}()}, \code{\link{pad_fn}()}, \code{\link{tab_style_by_grp}()} } \concept{Utilities} ================================================ FILE: man/fmt_symbol_first.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/fmt_symbol_first.R \name{fmt_symbol_first} \alias{fmt_symbol_first} \title{Aligning first-row text only} \usage{ fmt_symbol_first( gt_object, column = NULL, symbol = NULL, suffix = "", decimals = NULL, last_row_n = NULL, symbol_first = FALSE, scale_by = NULL, gfont = NULL ) } \arguments{ \item{gt_object}{An existing gt table object of class \code{gt_tbl}} \item{column}{columns to apply color to with tidyeval} \item{symbol}{The HTML code or raw character string of the symbol being inserted, optionally} \item{suffix}{a suffix to add, optionally} \item{decimals}{the number of decimal places to round to} \item{last_row_n}{Defining the last row to apply this to. The function will attempt to guess the proper length, but you can always hardcode a specific length.} \item{symbol_first}{TRUE/FALSE - symbol before after suffix.} \item{scale_by}{A numeric value to multiply the values by. Useful for scaling percentages from 0 to 1 to 0 to 100.} \item{gfont}{A string passed to \code{gt::google_font()} - Existing Google Monospaced fonts are available at: \href{https://fonts.google.com/?category=Monospace&preview.text=0123456789&preview.text_type=custom}{fonts.google.com}} } \value{ An object of class \code{gt_tbl}. } \description{ This is an experimental function that allows you to apply a suffix/symbol to only the first row of a table, and maintain the alignment with whitespace in the remaining rows. } \section{Figures}{ \if{html}{\figure{gt_fmt_first.png}{options: style="width=100\%;"}} } \section{Function ID}{ 2-1 } \examples{ library(gt) fmted_tab <- gtcars \%>\% head() \%>\% dplyr::select(mfr, year, bdy_style, mpg_h, hp) \%>\% dplyr::mutate(mpg_h = rnorm(n = dplyr::n(), mean = 22, sd = 1)) \%>\% gt::gt() \%>\% gt::opt_table_lines() \%>\% fmt_symbol_first(column = mfr, symbol = "$", last_row_n = 6) \%>\% fmt_symbol_first(column = year, suffix = "\%") \%>\% fmt_symbol_first(column = mpg_h, symbol = "%", decimals = 1) \%>\% fmt_symbol_first(hp, symbol = "°", suffix = "F", symbol_first = TRUE) } \seealso{ Other Utilities: \code{\link{add_text_img}()}, \code{\link{fa_icon_repeat}()}, \code{\link{fmt_pad_num}()}, \code{\link{fmt_pct_extra}()}, \code{\link{generate_df}()}, \code{\link{gt_add_divider}()}, \code{\link{gt_badge}()}, \code{\link{gt_double_table}()}, \code{\link{gt_duplicate_column}()}, \code{\link{gt_fa_rank_change}()}, \code{\link{gt_fa_rating}()}, \code{\link{gt_highlight_cols}()}, \code{\link{gt_highlight_rows}()}, \code{\link{gt_img_border}()}, \code{\link{gt_img_circle}()}, \code{\link{gt_img_multi_rows}()}, \code{\link{gt_img_rows}()}, \code{\link{gt_index}()}, \code{\link{gt_merge_stack}()}, \code{\link{gt_merge_stack_color}()}, \code{\link{gt_two_column_layout}()}, \code{\link{gtsave_extra}()}, \code{\link{img_header}()}, \code{\link{pad_fn}()}, \code{\link{tab_style_by_grp}()} } \concept{Utilities} ================================================ FILE: man/generate_df.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/generate_df.R \name{generate_df} \alias{generate_df} \title{Generate pseudorandom dataframes with specific parameters} \usage{ generate_df(n = 10L, n_grps = 1L, mean = c(10), sd = mean/10, with_seed = NULL) } \arguments{ \item{n}{An integer indicating the number of rows per group, default to \code{10}} \item{n_grps}{An integer indicating the number of rows per group, defaults to \code{1}} \item{mean}{A number indicating the mean of the randomly generated values, must be a vector of equal length to the \code{n_grps}} \item{sd}{A number indicating the standard deviation of the randomly generated values, must be a vector of equal length to the \code{n_grps}} \item{with_seed}{A seed to make the randomization reproducible} } \value{ a tibble/dataframe } \description{ This function is a small utility to create a specific length dataframe with a set number of groups, specific mean/sd per group. Note that the total length of the dataframe will be \code{n} * \code{n_grps}. } \section{Function ID}{ 2-19 } \examples{ library(dplyr) generate_df( 100L, n_grps = 5, mean = seq(10, 50, length.out = 5) ) \%>\% group_by(grp) \%>\% summarise( mean = mean(values), # mean is approx mean sd = sd(values), # sd is approx sd n = n(), # each grp is of length n # showing that the sd default of mean/10 works `mean/sd` = round(mean / sd, 1) ) } \seealso{ Other Utilities: \code{\link{add_text_img}()}, \code{\link{fa_icon_repeat}()}, \code{\link{fmt_pad_num}()}, \code{\link{fmt_pct_extra}()}, \code{\link{fmt_symbol_first}()}, \code{\link{gt_add_divider}()}, \code{\link{gt_badge}()}, \code{\link{gt_double_table}()}, \code{\link{gt_duplicate_column}()}, \code{\link{gt_fa_rank_change}()}, \code{\link{gt_fa_rating}()}, \code{\link{gt_highlight_cols}()}, \code{\link{gt_highlight_rows}()}, \code{\link{gt_img_border}()}, \code{\link{gt_img_circle}()}, \code{\link{gt_img_multi_rows}()}, \code{\link{gt_img_rows}()}, \code{\link{gt_index}()}, \code{\link{gt_merge_stack}()}, \code{\link{gt_merge_stack_color}()}, \code{\link{gt_two_column_layout}()}, \code{\link{gtsave_extra}()}, \code{\link{img_header}()}, \code{\link{pad_fn}()}, \code{\link{tab_style_by_grp}()} } \concept{Utilities} ================================================ FILE: man/get_row_index.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/get_row_index.R \name{get_row_index} \alias{get_row_index} \title{Get underlying row index for gt tables} \usage{ get_row_index(gt_object) } \arguments{ \item{gt_object}{an existing gt table} } \value{ a vector of row indices } \description{ Provides underlying row index for grouped or ungrouped \code{gt} tables. In some cases the visual representation of specific rows is inconsistent with the "row number" so this function provides the final output index for subsetting or targetting rows. } \section{Examples}{ \subsection{Create a helper function}{ This helper functions lets us be a bit more efficient when showing the row numbers/colors. \if{html}{\out{
}}\preformatted{library(gt) row_sty <- function(tab, row)\{ OkabeIto <- c("#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#CC79A7", "#999999") tab \%>\% tab_style( cell_fill(color = OkabeIto[row]), locations = cells_body(rows = row) ) \} }\if{html}{\out{
}} } \subsection{Randomize the data}{ We will randomly sample the data to get it in a specific order. \if{html}{\out{
}}\preformatted{set.seed(37) df <- mtcars \%>\% dplyr::group_by(cyl) \%>\% dplyr::slice_sample(n = 2) \%>\% dplyr::ungroup() \%>\% dplyr::slice_sample(n = 6) \%>\% dplyr::mutate(row_id = dplyr::row_number(), .before = 1) #> df #> A tibble: 6 × 12 #> row_id mpg cyl disp hp drat wt qsec vs am gear carb #> #> 1 10.4 8 472 205 2.93 5.25 18.0 0 0 3 4 #> 2 18.1 6 225 105 2.76 3.46 20.2 1 0 3 1 #> 3 21.4 6 258 110 3.08 3.22 19.4 1 0 3 1 #> 4 13.3 8 350 245 3.73 3.84 15.4 0 0 3 4 #> 5 33.9 4 71.1 65 4.22 1.84 19.9 1 1 4 1 #> 6 22.8 4 108 93 3.85 2.32 18.6 1 1 4 1 }\if{html}{\out{
}} } \subsection{Ungrouped data}{ Ungrouped data works just fine, and the row indices are identical between the visual representation and the output. \if{html}{\out{
}}\preformatted{gt(df) \%>\% row_sty(1) \%>\% row_sty(3) \%>\% row_sty(5) }\if{html}{\out{
}} \if{html}{\figure{ungrouped-tab.png}{options: style="width=40\%;"}} } \subsection{Grouped data}{ However, for grouped data, the row indices are representative of the underlying data before grouping, leading to some potential confusion. \if{html}{\out{
}}\preformatted{tab2 <- gt(df, groupname_col = "cyl") tab2 \%>\% row_sty(1) \%>\% ## actually row 1 row_sty(3) \%>\% ## actually row 5 row_sty(5) ## actually row 2 }\if{html}{\out{
}} \if{html}{\figure{grouped-tab.png}{options: style="width=40\%;"}} The \code{get_row_index()} function gives ability to create an index of the final output, so you can reference specific rows by number. \if{html}{\out{
}}\preformatted{tab_index <- get_row_index(tab2) tab2 \%>\% row_sty(4) \%>\% ## wrong row, actually row 6 visually row_sty(tab_index[4]) ## correct row, actually row 4 }\if{html}{\out{
}} \if{html}{\figure{grouped-tab-row4.png}{options: style="width=40\%;"}} \if{html}{\out{
}}\preformatted{tab2 \%>\% row_sty(tab_index[1]) \%>\% row_sty(tab_index[3]) \%>\% row_sty(tab_index[5]) }\if{html}{\out{
}} \if{html}{\figure{grouped-tab-index.png}{options: style="width=40\%;"}} } } ================================================ FILE: man/gtExtras-package.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gtExtras-package.R \docType{package} \name{gtExtras-package} \alias{gtExtras} \alias{gtExtras-package} \title{gtExtras: Extending 'gt' for Beautiful HTML Tables} \description{ \if{html}{\figure{logo.png}{options: style='float: right' alt='logo' width='120'}} Provides additional functions for creating beautiful tables with 'gt'. The functions are generally wrappers around boilerplate or adding opinionated niche capabilities and helpers functions. } \seealso{ Useful links: \itemize{ \item \url{https://github.com/jthomasmock/gtExtras} \item \url{https://jthomasmock.github.io/gtExtras/} \item Report bugs at \url{https://github.com/jthomasmock/gtExtras/issues} } } \author{ \strong{Maintainer}: Thomas Mock \email{j.thomasmock@gmail.com} [copyright holder] Other contributors: \itemize{ \item Daniel D. Sjoberg \email{danield.sjoberg@gmail.com} (\href{https://orcid.org/0000-0003-0862-2018}{ORCID}) [contributor] } } \keyword{internal} ================================================ FILE: man/gt_add_divider.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_add_divider.R \name{gt_add_divider} \alias{gt_add_divider} \title{Add a dividing border to an existing \code{gt} table.} \usage{ gt_add_divider( gt_object, columns, sides = "right", color = "grey", style = "solid", weight = px(2), include_labels = TRUE ) } \arguments{ \item{gt_object}{An existing gt table object of class \code{gt_tbl}} \item{columns}{Specific columns to apply color to, accepts either \code{tidyeval} colum names or columns by position.} \item{sides}{The border sides to be modified. Options include \code{"left"}, \code{"right"}, \code{"top"}, and \code{"bottom"}. For all borders surrounding the selected cells, we can use the `"all"`` option.} \item{color, style, weight}{The border color, style, and weight. The \code{color} can be defined with a color name or with a hexadecimal color code. The default \code{color} value is \code{"#00FFFFFF"} (black). The \code{style} can be one of either \code{"solid"} (the default), \code{"dashed"}, or \code{"dotted"}. The \code{weight} of the border lines is to be given in pixel values (the \code{px()} helper function is useful for this. The default value for \code{weight} is \code{"1px"}.} \item{include_labels}{A logical, either \code{TRUE} or \code{FALSE} indicating whether to also add dividers through the column labels.} } \value{ An object of class \code{gt_tbl}. } \description{ The \code{gt_add_divider} function takes an existing \code{gt_tbl} object and adds borders or dividers to specific columns. } \section{Examples}{ \if{html}{\out{
}}\preformatted{library(gt) basic_divider <- head(mtcars) \%>\% gt() \%>\% gt_add_divider(columns = "cyl", style = "dashed") }\if{html}{\out{
}} } \section{Figures}{ \if{html}{\figure{add-divider.png}{options: style="width=70\%;"}} } \section{Function ID}{ 2-11 } \seealso{ Other Utilities: \code{\link{add_text_img}()}, \code{\link{fa_icon_repeat}()}, \code{\link{fmt_pad_num}()}, \code{\link{fmt_pct_extra}()}, \code{\link{fmt_symbol_first}()}, \code{\link{generate_df}()}, \code{\link{gt_badge}()}, \code{\link{gt_double_table}()}, \code{\link{gt_duplicate_column}()}, \code{\link{gt_fa_rank_change}()}, \code{\link{gt_fa_rating}()}, \code{\link{gt_highlight_cols}()}, \code{\link{gt_highlight_rows}()}, \code{\link{gt_img_border}()}, \code{\link{gt_img_circle}()}, \code{\link{gt_img_multi_rows}()}, \code{\link{gt_img_rows}()}, \code{\link{gt_index}()}, \code{\link{gt_merge_stack}()}, \code{\link{gt_merge_stack_color}()}, \code{\link{gt_two_column_layout}()}, \code{\link{gtsave_extra}()}, \code{\link{img_header}()}, \code{\link{pad_fn}()}, \code{\link{tab_style_by_grp}()} } \concept{Utilities} ================================================ FILE: man/gt_alert_icon.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_alert_icon.R \name{gt_alert_icon} \alias{gt_alert_icon} \title{Insert an alert icon to a specific column} \usage{ gt_alert_icon( gt_object, column, palette = c("#a962b6", "#f1f1f1", "#378e38"), domain = NULL, height = "10px", direction = 1, align = "center", v_pad = -5 ) } \arguments{ \item{gt_object}{An existing gt table object of class \code{gt_tbl}} \item{column}{The column wherein the numeric values should be replaced with circular alert icons.} \item{palette}{The colours or colour function that values will be mapped to. Can be a character vector (eg \code{c("white", "red")} or hex colors) or a named palette from the \code{{paletteer}} package in the \code{package::palette_name} structure.} \item{domain}{The possible values that can be mapped. This should be a simple numeric range (e.g. \code{c(0, 100)})} \item{height}{A character string indicating the height in pixels, like "10px"} \item{direction}{The direction of the \code{paletteer} palette, should be either \code{-1} for reversed or the default of \code{1} for the existing direction.} \item{align}{Character string indicating alignment of the column, defaults to "left"} \item{v_pad}{A numeric value indicating the vertical padding, defaults to -5 to aid in centering within the vertical space.} } \value{ a gt table } \description{ Insert an alert icon to a specific column } \section{Examples}{ \if{html}{\out{
}}\preformatted{head(mtcars) \%>\% dplyr::mutate(warn = ifelse(mpg >= 21, 1, 0), .before = mpg) \%>\% gt::gt() \%>\% gt_alert_icon(warn) }\if{html}{\out{
}} \if{html}{\figure{man/figures/gt_alert_icon-binary.png}{options: style="width=100\%;"}} } ================================================ FILE: man/gt_badge.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/html-helpers.R \name{gt_badge} \alias{gt_badge} \title{Add a 'badge' based on values and palette} \usage{ gt_badge( gt_object, column, palette = NULL, alpha = 0.2, rows = gt::everything() ) } \arguments{ \item{gt_object}{An existing \code{gt} table object} \item{column}{The column to convert to badges, accepts \code{tidyeval}} \item{palette}{Name of palette as a string. Must be either length of 1 or a vector of valid color names/hex values of equal length to the unique levels of the column (ie if there are 4 names, there need to be 4x colors). Note that if you would like to specify a specific color to match a specific icon, you can also use a named vector like: \code{c("angle-double-up" = "#009E73", "angle-double-down" = "#D55E00","sort" = "#000000")}} \item{alpha}{A numeric indicating the alpha/transparency. Range from 0 to 1} \item{rows}{The rows to apply the badge to, accepts \code{tidyeval}. Defaults to all rows.} } \value{ \code{gt} table } \description{ Add a 'badge' based on values and palette } \section{Examples}{ \if{html}{\out{
}}\preformatted{library(gt) head(mtcars) \%>\% dplyr::mutate(cyl = paste(cyl, "Cyl")) \%>\% gt() \%>\% gt_badge(cyl, palette = c("4 Cyl"="red","6 Cyl"="blue","8 Cyl"="green")) }\if{html}{\out{
}} } \section{Figures}{ \if{html}{\figure{gt_badge.png}{options: style="width=50\%;"}} } \seealso{ Other Utilities: \code{\link{add_text_img}()}, \code{\link{fa_icon_repeat}()}, \code{\link{fmt_pad_num}()}, \code{\link{fmt_pct_extra}()}, \code{\link{fmt_symbol_first}()}, \code{\link{generate_df}()}, \code{\link{gt_add_divider}()}, \code{\link{gt_double_table}()}, \code{\link{gt_duplicate_column}()}, \code{\link{gt_fa_rank_change}()}, \code{\link{gt_fa_rating}()}, \code{\link{gt_highlight_cols}()}, \code{\link{gt_highlight_rows}()}, \code{\link{gt_img_border}()}, \code{\link{gt_img_circle}()}, \code{\link{gt_img_multi_rows}()}, \code{\link{gt_img_rows}()}, \code{\link{gt_index}()}, \code{\link{gt_merge_stack}()}, \code{\link{gt_merge_stack_color}()}, \code{\link{gt_two_column_layout}()}, \code{\link{gtsave_extra}()}, \code{\link{img_header}()}, \code{\link{pad_fn}()}, \code{\link{tab_style_by_grp}()} } \concept{Utilities} ================================================ FILE: man/gt_color_box.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_color_box.R \name{gt_color_box} \alias{gt_color_box} \title{Add a small color box relative to the cell value.} \usage{ gt_color_box( gt_object, columns, palette = NULL, ..., domain = NULL, width = 70, font_weight = "bold" ) } \arguments{ \item{gt_object}{An existing gt table object of class \code{gt_tbl}} \item{columns}{The columns wherein changes to cell data colors should occur.} \item{palette}{The colours or colour function that values will be mapped to. Can be a character vector (eg \code{c("white", "red")} or hex colors) or a named palette from the \code{{paletteer}} package in the \code{package::palette_name} structure. Note that \code{'pff'} will fill in a blue -> green -> yellow -> orange -> red palette.} \item{...}{Additional arguments passed to \code{scales::label_number()}, primarily used to format the numbers inside the color box} \item{domain}{The possible values that can be mapped. This should be a simple numeric range (e.g. \code{c(0, 100)})} \item{width}{The width of the entire coloring area in pixels.} \item{font_weight}{A string indicating the font weight, defaults to \code{"bold"}, change to \code{"normal"} for default weight.} } \value{ An object of class \code{gt_tbl}. } \description{ Create \code{PFF}-style colorboxes in a \code{gt} table. Note that rather than using \code{gt::fmt_} functions on this column, you can send numeric formatting arguments via \code{...}. All arguments should be named and are passed to \code{scales::label_number()}. } \section{Examples}{ \if{html}{\out{
}}\preformatted{library(gt) test_data <- dplyr::tibble(x = letters[1:10], y = seq(100, 10, by = -10), z = seq(10, 100, by = 10)) color_box_tab <- test_data \%>\% gt() \%>\% gt_color_box(columns = y, domain = 0:100, palette = "ggsci::blue_material") \%>\% gt_color_box(columns = z, domain = 0:100, palette = c("purple", "lightgrey", "green")) }\if{html}{\out{
}} } \section{Figures}{ \if{html}{\figure{color_box.png}{options: style="width=30\%;"}} } \section{Function ID}{ 4-3 } \seealso{ Other Colors: \code{\link{gt_color_rows}()}, \code{\link{gt_hulk_col_numeric}()} } \concept{Colors} ================================================ FILE: man/gt_color_rows.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_color_rows.R \name{gt_color_rows} \alias{gt_color_rows} \title{Add scaled colors according to numeric values or categories/factors} \usage{ gt_color_rows( gt_object, columns, palette = "ggsci::red_material", direction = 1, domain = NULL, pal_type = c("discrete", "continuous"), ... ) } \arguments{ \item{gt_object}{An existing gt table object of class \code{gt_tbl}} \item{columns}{The columns wherein changes to cell data colors should occur.} \item{palette}{The colours or colour function that values will be mapped to} \item{direction}{Either \code{1} or \code{-1}. If \code{-1} the palette will be reversed.} \item{domain}{The possible values that can be mapped. For \code{col_numeric} and \code{col_bin}, this can be a simple numeric range (e.g. \code{c(0, 100)}); \code{col_quantile} needs representative numeric data; and \code{col_factor} needs categorical data. If \code{NULL}, then whenever the resulting colour function is called, the \code{x} value will represent the domain. This implies that if the function is invoked multiple times, the encoding between values and colours may not be consistent; if consistency is needed, you must provide a non-\code{NULL} domain.} \item{pal_type}{A string indicating the palette type (one of \code{c("discrete", "continuous")})} \item{...}{Additional arguments passed to \code{scales::col_numeric()}} } \value{ An object of class \code{gt_tbl}. } \description{ The \code{gt_color_rows} function takes an existing \code{gt_tbl} object and applies pre-existing palettes from the \code{{paletteer}} package or custom palettes defined by the user. This function is a custom wrapper around \code{gt::data_color()}, and uses some of the boilerplate code. Basic use is simpler than \code{data_color()}. } \section{Examples}{ \if{html}{\out{
}}\preformatted{ library(gt) # basic use basic_use <- mtcars \%>\% head(15) \%>\% gt() \%>\% gt_color_rows(mpg:disp) # change palette to one that paletteer recognizes change_pal <- mtcars \%>\% head(15) \%>\% gt() \%>\% gt_color_rows(mpg:disp, palette = "ggsci::blue_material") # change palette to raw values vector_pal <- mtcars \%>\% head(15) \%>\% gt() \%>\% gt_color_rows( mpg:disp, palette = c("white", "green")) # could also use palette = c("#ffffff", "##00FF00") # use discrete instead of continuous palette discrete_pal <- mtcars \%>\% head(15) \%>\% gt() \%>\% gt_color_rows( cyl, pal_type = "discrete", palette = "ggthemes::colorblind", domain = range(mtcars$cyl) ) # use discrete and manually define range range_pal <- mtcars \%>\% dplyr::select(gear, mpg:hp) \%>\% head(15) \%>\% gt() \%>\% gt_color_rows( gear, pal_type = "discrete", direction = -1, palette = "colorblindr::OkabeIto_black", domain = c(3,4,5)) }\if{html}{\out{
}} } \section{Figures}{ \if{html}{\figure{basic-pal.png}{options: style="width=100\%;"}} \if{html}{\figure{blue-pal.png}{options: style="width=100\%;"}} \if{html}{\figure{custom-pal.png}{options: style="width=100\%;"}} \if{html}{\figure{discrete-pal.png}{options: style="width=100\%;"}} } \section{Function ID}{ 4-2 } \seealso{ Other Colors: \code{\link{gt_color_box}()}, \code{\link{gt_hulk_col_numeric}()} } \concept{Colors} ================================================ FILE: man/gt_double_table.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/two-column-layouts.R \name{gt_double_table} \alias{gt_double_table} \title{Take data, a gt-generating function, and create a list of two tables} \usage{ gt_double_table(data, gt_fn, nrows = NULL, noisy = TRUE) } \arguments{ \item{data}{A \code{tibble} or dataframe to be passed into the supplied \code{gt_fn}} \item{gt_fn}{A user-defined function that has one argument, this argument should pass data to the \code{gt::gt()} function, which will be supplied by the \code{data} argument. It should follow the pattern of \code{gt_function <- function(x) gt(x) \%>\% more_gt_code...}.} \item{nrows}{The number of rows to split at, defaults to \code{NULL} and will attempt to split approximately 50/50 in the left vs right table.} \item{noisy}{A logical indicating whether to return the warning about not supplying \code{nrows} argument.} } \value{ a \code{list()} of two \code{gt} tables } \description{ The \code{gt_double_table} function takes some data and a user-supplied function to generate two tables in a list. To convert existing \code{gt::gt()} code to a function, you can follow the approximate pattern: \code{gt_fn <- function(x){gt(x) \%>\% more_gt_code}} Your function should only have a \strong{single argument}, which is the \strong{data} to be supplied directly into the \code{gt::gt()} function. This function is intended to be passed directly into \code{gt_two_column_layout()}, for printing it to the viewer, saving it to a \code{.png}, or returning the raw HTML. } \section{Examples}{ \if{html}{\out{
}}\preformatted{library(gt) # define your own function my_gt_function <- function(x) \{ gt(x) \%>\% gtExtras::gt_color_rows(columns = mpg, domain = range(mtcars$mpg)) \%>\% tab_options(data_row.padding = px(3)) \} two_tables <- gt_double_table(mtcars, my_gt_function, nrows = 16) # list of two gt_tbl objects # ready to pass to gtExtras::gt_two_column_layout() str(two_tables, max.level = 1) #> List of 2 #> $ :List of 16 #> ..- attr(*, "class")= chr [1:2] "gt_tbl" "list" #> $ :List of 16 #> ..- attr(*, "class")= chr [1:2] "gt_tbl" "list" }\if{html}{\out{
}} } \section{Function ID}{ 2-13 } \seealso{ Other Utilities: \code{\link{add_text_img}()}, \code{\link{fa_icon_repeat}()}, \code{\link{fmt_pad_num}()}, \code{\link{fmt_pct_extra}()}, \code{\link{fmt_symbol_first}()}, \code{\link{generate_df}()}, \code{\link{gt_add_divider}()}, \code{\link{gt_badge}()}, \code{\link{gt_duplicate_column}()}, \code{\link{gt_fa_rank_change}()}, \code{\link{gt_fa_rating}()}, \code{\link{gt_highlight_cols}()}, \code{\link{gt_highlight_rows}()}, \code{\link{gt_img_border}()}, \code{\link{gt_img_circle}()}, \code{\link{gt_img_multi_rows}()}, \code{\link{gt_img_rows}()}, \code{\link{gt_index}()}, \code{\link{gt_merge_stack}()}, \code{\link{gt_merge_stack_color}()}, \code{\link{gt_two_column_layout}()}, \code{\link{gtsave_extra}()}, \code{\link{img_header}()}, \code{\link{pad_fn}()}, \code{\link{tab_style_by_grp}()} } \concept{Utilities} ================================================ FILE: man/gt_duplicate_column.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_duplicate_column.R \name{gt_duplicate_column} \alias{gt_duplicate_column} \title{Duplicate an existing column in a gt table} \usage{ gt_duplicate_column( gt_object, column, after = dplyr::last_col(), append_text = "_dupe", dupe_name = NULL ) } \arguments{ \item{gt_object}{An existing gt table object of class \code{gt_tbl}} \item{column}{The column to be duplicated} \item{after}{The column to place the duplicate column after} \item{append_text}{The text to add to the column name to differentiate it from the original column name} \item{dupe_name}{A full name for the "new" duplicated column, will override \code{append_text}} } \value{ An object of class \code{gt_tbl}. } \description{ This function takes an existing gt table and will duplicate a column. You also have the option to specify where the column ends up, and what will be appending to the end of the column name to differentiate it. } \section{Function ID}{ 2-15 } \examples{ library(gt) dupe_table <- head(mtcars) \%>\% dplyr::select(mpg, disp) \%>\% gt() \%>\% gt_duplicate_column(mpg, after = disp, append_text = "2") } \seealso{ Other Utilities: \code{\link{add_text_img}()}, \code{\link{fa_icon_repeat}()}, \code{\link{fmt_pad_num}()}, \code{\link{fmt_pct_extra}()}, \code{\link{fmt_symbol_first}()}, \code{\link{generate_df}()}, \code{\link{gt_add_divider}()}, \code{\link{gt_badge}()}, \code{\link{gt_double_table}()}, \code{\link{gt_fa_rank_change}()}, \code{\link{gt_fa_rating}()}, \code{\link{gt_highlight_cols}()}, \code{\link{gt_highlight_rows}()}, \code{\link{gt_img_border}()}, \code{\link{gt_img_circle}()}, \code{\link{gt_img_multi_rows}()}, \code{\link{gt_img_rows}()}, \code{\link{gt_index}()}, \code{\link{gt_merge_stack}()}, \code{\link{gt_merge_stack_color}()}, \code{\link{gt_two_column_layout}()}, \code{\link{gtsave_extra}()}, \code{\link{img_header}()}, \code{\link{pad_fn}()}, \code{\link{tab_style_by_grp}()} } \concept{Utilities} ================================================ FILE: man/gt_fa_rank_change.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/fontawesome-icons.R \name{gt_fa_rank_change} \alias{gt_fa_rank_change} \title{Add rank change indicators to a gt table} \usage{ gt_fa_rank_change( gt_object, column, palette = c("#1b7837", "lightgrey", "#762a83"), fa_type = c("angles", "arrow", "turn", "chevron", "caret"), font_color = "black", show_text = TRUE ) } \arguments{ \item{gt_object}{An existing \code{gt} table object} \item{column}{The single column that you would like to convert to rank change indicators.} \item{palette}{A character vector of length 3. Colors can be represented as hex values or named colors. Colors should be in the order of up-arrow, no-change, down-arrow, defaults to green, grey, purple.} \item{fa_type}{The name of the Fontawesome icon, limited to 5 types of various arrows, one of \code{c("angles", "arrow", "turn", "chevron", "caret")}} \item{font_color}{A string, indicating the color of the font, can also be returned as \code{'match'} to match the font color to the arrow palette.} \item{show_text}{A logical indicating whether to show/hide the values in the column.} } \value{ a \code{gt} table } \description{ Takes an existing \code{gt} table and converts a column of integers into various types of up/down arrows. Note that you need to specify a palette of three colors, in the order of up, neutral, down. Defaults to green, grey, purple. There are 6 supported \code{fa_type}, representing various arrows. Note that you can use \code{font_color = 'match'} to match the palette across arrows and text. \code{show_text = FALSE} will remove the text from the column, resulting only in colored arrows. } \section{Examples}{ \if{html}{\out{
}}\preformatted{rank_table <- dplyr::tibble(x = c(1:3, -1, -2, -5, 0)) \%>\% gt::gt() \%>\% gt_fa_rank_change(x, font_color = "match") }\if{html}{\out{
}} } \section{Figures}{ \if{html}{\figure{fa_rank_change.png}{options: style="width=5\%;"}} } \seealso{ Other Utilities: \code{\link{add_text_img}()}, \code{\link{fa_icon_repeat}()}, \code{\link{fmt_pad_num}()}, \code{\link{fmt_pct_extra}()}, \code{\link{fmt_symbol_first}()}, \code{\link{generate_df}()}, \code{\link{gt_add_divider}()}, \code{\link{gt_badge}()}, \code{\link{gt_double_table}()}, \code{\link{gt_duplicate_column}()}, \code{\link{gt_fa_rating}()}, \code{\link{gt_highlight_cols}()}, \code{\link{gt_highlight_rows}()}, \code{\link{gt_img_border}()}, \code{\link{gt_img_circle}()}, \code{\link{gt_img_multi_rows}()}, \code{\link{gt_img_rows}()}, \code{\link{gt_index}()}, \code{\link{gt_merge_stack}()}, \code{\link{gt_merge_stack_color}()}, \code{\link{gt_two_column_layout}()}, \code{\link{gtsave_extra}()}, \code{\link{img_header}()}, \code{\link{pad_fn}()}, \code{\link{tab_style_by_grp}()} } \concept{Utilities} ================================================ FILE: man/gt_fa_rating.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/fontawesome-icons.R \name{gt_fa_rating} \alias{gt_fa_rating} \title{Add rating "stars" to a gt column} \usage{ gt_fa_rating( gt_object, column, max_rating = 5, ..., color = "orange", icon = "star" ) } \arguments{ \item{gt_object}{An existing gt table object of class \code{gt_tbl}} \item{column}{The column wherein the numeric values should be replaced with their corresponding \code{{fontawesome}} icons.} \item{max_rating}{The max number of icons to add, these will be added in grey to indicate "missing"} \item{...}{Additional arguments passed to \code{fontawesome::fa()}} \item{color}{The color of the icon, accepts named colors (\code{"orange"}) or hex strings.} \item{icon}{The icon name, passed to \code{fontawesome::fa()}} } \value{ An object of class \code{gt_tbl}. } \description{ Add rating "stars" to a gt column } \section{Examples}{ \if{html}{\out{
}}\preformatted{library(gt) set.seed(37) rating_table <- mtcars \%>\% dplyr::select(mpg:wt) \%>\% dplyr::slice(1:5) \%>\% dplyr::mutate(rating = sample(1:5, size = 5, TRUE)) \%>\% gt() \%>\% gt_fa_rating(rating, icon = "r-project") }\if{html}{\out{
}} } \section{Figures}{ \if{html}{\figure{fa-stars.png}{options: style="width=60\%;"}} } \section{Function ID}{ 2-16 } \seealso{ Other Utilities: \code{\link{add_text_img}()}, \code{\link{fa_icon_repeat}()}, \code{\link{fmt_pad_num}()}, \code{\link{fmt_pct_extra}()}, \code{\link{fmt_symbol_first}()}, \code{\link{generate_df}()}, \code{\link{gt_add_divider}()}, \code{\link{gt_badge}()}, \code{\link{gt_double_table}()}, \code{\link{gt_duplicate_column}()}, \code{\link{gt_fa_rank_change}()}, \code{\link{gt_highlight_cols}()}, \code{\link{gt_highlight_rows}()}, \code{\link{gt_img_border}()}, \code{\link{gt_img_circle}()}, \code{\link{gt_img_multi_rows}()}, \code{\link{gt_img_rows}()}, \code{\link{gt_index}()}, \code{\link{gt_merge_stack}()}, \code{\link{gt_merge_stack_color}()}, \code{\link{gt_two_column_layout}()}, \code{\link{gtsave_extra}()}, \code{\link{img_header}()}, \code{\link{pad_fn}()}, \code{\link{tab_style_by_grp}()} } \concept{Utilities} ================================================ FILE: man/gt_highlight_cols.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_highlight_cols.R \name{gt_highlight_cols} \alias{gt_highlight_cols} \title{Add color highlighting to a specific column(s)} \usage{ gt_highlight_cols( gt_object, columns, fill = "#80bcd8", alpha = 1, font_weight = "normal", font_color = "#000000" ) } \arguments{ \item{gt_object}{An existing gt table object of class \code{gt_tbl}} \item{columns}{Specific columns to apply color to, accepts either \code{tidyeval} colum names or columns by position.} \item{fill}{A character string indicating the fill color. If nothing is provided, then "#80bcd8" (light blue) will be used as a default.} \item{alpha}{An optional alpha transparency value for the color as single value in the range of 0 (fully transparent) to 1 (fully opaque). If not provided the fill color will either be fully opaque or use alpha information from the color value if it is supplied in the #RRGGBBAA format.} \item{font_weight}{A string or number indicating the weight of the font. Can be a text-based keyword such as "normal", "bold", "lighter", "bolder", or, a numeric value between 1 and 1000, inclusive. Note that only variable fonts may support the numeric mapping of weight.} \item{font_color}{A character string indicating the text color. If nothing is provided, then "#000000" (black) will be used as a default.} } \value{ An object of class \code{gt_tbl}. } \description{ The \code{gt_highlight_cols} function takes an existing \code{gt_tbl} object and adds highlighting color to the cell background of a specific column(s). } \section{Examples}{ \if{html}{\out{
}}\preformatted{library(gt) basic_col <- head(mtcars) \%>\% gt() \%>\% gt_highlight_cols(cyl, fill = "red", alpha = 0.5) }\if{html}{\out{
}} } \section{Figures}{ \if{html}{\figure{highlight-col.png}{options: style="width=70\%;"}} } \section{Function ID}{ 2-9 } \seealso{ Other Utilities: \code{\link{add_text_img}()}, \code{\link{fa_icon_repeat}()}, \code{\link{fmt_pad_num}()}, \code{\link{fmt_pct_extra}()}, \code{\link{fmt_symbol_first}()}, \code{\link{generate_df}()}, \code{\link{gt_add_divider}()}, \code{\link{gt_badge}()}, \code{\link{gt_double_table}()}, \code{\link{gt_duplicate_column}()}, \code{\link{gt_fa_rank_change}()}, \code{\link{gt_fa_rating}()}, \code{\link{gt_highlight_rows}()}, \code{\link{gt_img_border}()}, \code{\link{gt_img_circle}()}, \code{\link{gt_img_multi_rows}()}, \code{\link{gt_img_rows}()}, \code{\link{gt_index}()}, \code{\link{gt_merge_stack}()}, \code{\link{gt_merge_stack_color}()}, \code{\link{gt_two_column_layout}()}, \code{\link{gtsave_extra}()}, \code{\link{img_header}()}, \code{\link{pad_fn}()}, \code{\link{tab_style_by_grp}()} } \concept{Utilities} ================================================ FILE: man/gt_highlight_rows.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_highlight_rows.R \name{gt_highlight_rows} \alias{gt_highlight_rows} \title{Add color highlighting to a specific row} \usage{ gt_highlight_rows( gt_object, columns = gt::everything(), rows = TRUE, fill = "#80bcd8", alpha = 0.8, font_weight = "bold", font_color = "#000000", bold_target_only = FALSE, target_col = c() ) } \arguments{ \item{gt_object}{An existing gt table object of class \code{gt_tbl}} \item{columns}{Specific columns to apply color to, accepts either \code{tidyeval} colum names or columns by position.} \item{rows}{The rows to apply the highlight to. Can either by a \code{tidyeval} compliant statement (like \code{cyl == 4}), a number indicating specific row(s) to apply color to or \code{TRUE} to indicate all rows.} \item{fill}{A character string indicating the fill color. If nothing is provided, then "#80bcd8" (light blue) will be used as a default.} \item{alpha}{An optional alpha transparency value for the color as single value in the range of 0 (fully transparent) to 1 (fully opaque). If not provided the fill color will either be fully opaque or use alpha information from the color value if it is supplied in the #RRGGBBAA format.} \item{font_weight}{A string or number indicating the weight of the font. Can be a text-based keyword such as "normal", "bold", "lighter", "bolder", or, a numeric value between 1 and 1000, inclusive. Note that only variable fonts may support the numeric mapping of weight.} \item{font_color}{A character string indicating the text color. If nothing is provided, then "#000000" (black) will be used as a default.} \item{bold_target_only}{A logical of TRUE/FALSE indicating whether to apply bold to only the specific \code{target_col}. You must indicate a specific column with \code{target_col}.} \item{target_col}{A specific \code{tidyeval} column to apply bold text to, which allows for normal weight text for the remaining highlighted columns.} } \value{ An object of class \code{gt_tbl}. } \description{ The \code{gt_highlight_rows} function takes an existing \code{gt_tbl} object and adds highlighting color to the cell background of a specific row. The function accepts rows only by number (not by logical expression) for now. } \section{Examples}{ \if{html}{\out{
}}\preformatted{library(gt) basic_use <- head(mtcars[,1:5]) \%>\% tibble::rownames_to_column("car") \%>\% gt() \%>\% gt_highlight_rows(rows = 2, font_weight = "normal") target_bold_column <- head(mtcars[,1:5]) \%>\% tibble::rownames_to_column("car") \%>\% gt() \%>\% gt_highlight_rows( rows = 5, fill = "lightgrey", bold_target_only = TRUE, target_col = car ) }\if{html}{\out{
}} } \section{Figures}{ \if{html}{\figure{highlight-basic.png}{options: style="width=70\%;"}} \if{html}{\figure{highlight-target.png}{options: style="width=70\%;"}} } \section{Function ID}{ 2-10 } \seealso{ Other Utilities: \code{\link{add_text_img}()}, \code{\link{fa_icon_repeat}()}, \code{\link{fmt_pad_num}()}, \code{\link{fmt_pct_extra}()}, \code{\link{fmt_symbol_first}()}, \code{\link{generate_df}()}, \code{\link{gt_add_divider}()}, \code{\link{gt_badge}()}, \code{\link{gt_double_table}()}, \code{\link{gt_duplicate_column}()}, \code{\link{gt_fa_rank_change}()}, \code{\link{gt_fa_rating}()}, \code{\link{gt_highlight_cols}()}, \code{\link{gt_img_border}()}, \code{\link{gt_img_circle}()}, \code{\link{gt_img_multi_rows}()}, \code{\link{gt_img_rows}()}, \code{\link{gt_index}()}, \code{\link{gt_merge_stack}()}, \code{\link{gt_merge_stack_color}()}, \code{\link{gt_two_column_layout}()}, \code{\link{gtsave_extra}()}, \code{\link{img_header}()}, \code{\link{pad_fn}()}, \code{\link{tab_style_by_grp}()} } \concept{Utilities} ================================================ FILE: man/gt_hulk_col_numeric.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_hulk_color.R \name{gt_hulk_col_numeric} \alias{gt_hulk_col_numeric} \title{Apply 'hulk' palette to specific columns in a gt table.} \usage{ gt_hulk_col_numeric( gt_object, columns = NULL, domain = NULL, ..., trim = FALSE ) } \arguments{ \item{gt_object}{An existing gt table object of class \code{gt_tbl}} \item{columns}{The columns wherein changes to cell data colors should occur.} \item{domain}{The possible values that can be mapped. For \code{col_numeric} and \code{col_bin}, this can be a simple numeric range (e.g. \code{c(0, 100)}); \code{col_quantile} needs representative numeric data; and \code{col_factor} needs categorical data. If \code{NULL}, then whenever the resulting colour function is called, the \code{x} value will represent the domain. This implies that if the function is invoked multiple times, the encoding between values and colours may not be consistent; if consistency is needed, you must provide a non-\code{NULL} domain.} \item{...}{Additional arguments passed to \code{scales::col_numeric()}} \item{trim}{trim the palette to give less intense maximal colors} } \value{ An object of class \code{gt_tbl}. } \description{ The hulk name comes from the idea of a diverging purple and green theme that is colorblind safe and visually appealing. It is a useful alternative to the red/green palette where purple typically can indicate low or "bad" value, and green can indicate a high or "good" value. } \section{Examples}{ \if{html}{\out{
}}\preformatted{ library(gt) # basic use hulk_basic <- mtcars \%>\% head() \%>\% gt::gt() \%>\% gt_hulk_col_numeric(mpg) hulk_trim <- mtcars \%>\% head() \%>\% gt::gt() \%>\% # trim gives small range of colors gt_hulk_col_numeric(mpg:disp, trim = TRUE) # option to reverse the color palette hulk_rev <- mtcars \%>\% head() \%>\% gt::gt() \%>\% # trim gives small range of colors gt_hulk_col_numeric(mpg:disp, reverse = TRUE) }\if{html}{\out{
}} } \section{Figures}{ \if{html}{\figure{hulk_basic.png}{options: style="width=100\%;"}} \if{html}{\figure{hulk_trim.png}{options: style="width=100\%;"}} \if{html}{\figure{hulk_reverse.png}{options: style="width=100\%;"}} } \section{Function ID}{ 4-1 } \seealso{ Other Colors: \code{\link{gt_color_box}()}, \code{\link{gt_color_rows}()} } \concept{Colors} ================================================ FILE: man/gt_hyperlink.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/html-helpers.R \name{gt_hyperlink} \alias{gt_hyperlink} \title{Add a basic hyperlink in a gt table} \usage{ gt_hyperlink(text, url) } \arguments{ \item{text}{The text displayed for the hyperlink} \item{url}{The url for the hyperlink} } \value{ HTML text } \description{ A lightweight helper to add a hyperlink, can be used throughout a \code{gt} table. } ================================================ FILE: man/gt_img_border.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_img_circle.R \name{gt_img_border} \alias{gt_img_border} \title{Create an identifier line border at the bottom of an image} \usage{ gt_img_border( gt_object, column, height = 25, width = 25, border_color = "black", border_weight = 2.5 ) } \arguments{ \item{gt_object}{An existing gt object} \item{column}{The column to apply the transformation to} \item{height}{A number indicating the height of the image in pixels.} \item{width}{A number indicating the width of the image in pixels.} \item{border_color}{The color of the circular border, can either be a single value ie (\code{white} or \verb{#FF0000}) or a vector where the length of the vector is equal to the number of rows.} \item{border_weight}{A number indicating the weight of the border in pixels.} } \value{ a gt object } \description{ Create an identifier line border at the bottom of an image } \section{Examples}{ \if{html}{\out{
}}\preformatted{library(gt) gt_img_tab <- dplyr::tibble( x = 1:4, names = c("Waking Up", "Wiggling", "Sleep"," Glamour"), img = c( "https://pbs.twimg.com/media/EiIY-1fXgAEV6CJ?format=jpg&name=360x360", "https://pbs.twimg.com/media/EiIY-1fXcAIPdTS?format=jpg&name=360x360", "https://pbs.twimg.com/media/EiIY-1mX0AE-YkC?format=jpg&name=360x360", "https://pbs.twimg.com/media/EiIY-2cXYAA1VaO?format=jpg&name=360x360" ) ) \%>\% gt() \%>\% gt_img_border(img) }\if{html}{\out{
}} } \section{Figures}{ \if{html}{\figure{gt_img_circle.png}{options: style="width=80\%;"}} } \seealso{ Other Utilities: \code{\link{add_text_img}()}, \code{\link{fa_icon_repeat}()}, \code{\link{fmt_pad_num}()}, \code{\link{fmt_pct_extra}()}, \code{\link{fmt_symbol_first}()}, \code{\link{generate_df}()}, \code{\link{gt_add_divider}()}, \code{\link{gt_badge}()}, \code{\link{gt_double_table}()}, \code{\link{gt_duplicate_column}()}, \code{\link{gt_fa_rank_change}()}, \code{\link{gt_fa_rating}()}, \code{\link{gt_highlight_cols}()}, \code{\link{gt_highlight_rows}()}, \code{\link{gt_img_circle}()}, \code{\link{gt_img_multi_rows}()}, \code{\link{gt_img_rows}()}, \code{\link{gt_index}()}, \code{\link{gt_merge_stack}()}, \code{\link{gt_merge_stack_color}()}, \code{\link{gt_two_column_layout}()}, \code{\link{gtsave_extra}()}, \code{\link{img_header}()}, \code{\link{pad_fn}()}, \code{\link{tab_style_by_grp}()} } \concept{Utilities} ================================================ FILE: man/gt_img_circle.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_img_circle.R \name{gt_img_circle} \alias{gt_img_circle} \title{Create circular border around an image} \usage{ gt_img_circle( gt_object, column, height = 25, border_color = "black", border_weight = 1.5 ) } \arguments{ \item{gt_object}{An existing gt object} \item{column}{The column to apply the transformation to} \item{height}{A number indicating the height of the image in pixels.} \item{border_color}{The color of the circular border, can either be a single value ie (\code{white} or \verb{#FF0000}) or a vector where the length of the vector is equal to the number of rows.} \item{border_weight}{A number indicating the weight of the border in pixels.} } \value{ a gt object } \description{ Create circular border around an image } \section{Examples}{ \if{html}{\out{
}}\preformatted{library(gt) gt_img_tab <- dplyr::tibble( x = 1:4, names = c("Rich Iannone", "Katie Masiello", "Tom Mock","Hadley Wickham"), img = c( "https://pbs.twimg.com/profile_images/961326215792533504/Ih6EsvtF_400x400.jpg", "https://pbs.twimg.com/profile_images/1471188460220260354/rHhoIXkZ_400x400.jpg", "https://pbs.twimg.com/profile_images/1467219661121064965/Lfondr9M_400x400.jpg", "https://pbs.twimg.com/profile_images/905186381995147264/7zKAG5sY_400x400.jpg" ) ) \%>\% gt() \%>\% gt_img_circle(img) }\if{html}{\out{
}} } \section{Figures}{ \if{html}{\figure{gt_img_circle.png}{options: style="width=80\%;"}} } \section{Function ID}{ 2-15 } \seealso{ Other Utilities: \code{\link{add_text_img}()}, \code{\link{fa_icon_repeat}()}, \code{\link{fmt_pad_num}()}, \code{\link{fmt_pct_extra}()}, \code{\link{fmt_symbol_first}()}, \code{\link{generate_df}()}, \code{\link{gt_add_divider}()}, \code{\link{gt_badge}()}, \code{\link{gt_double_table}()}, \code{\link{gt_duplicate_column}()}, \code{\link{gt_fa_rank_change}()}, \code{\link{gt_fa_rating}()}, \code{\link{gt_highlight_cols}()}, \code{\link{gt_highlight_rows}()}, \code{\link{gt_img_border}()}, \code{\link{gt_img_multi_rows}()}, \code{\link{gt_img_rows}()}, \code{\link{gt_index}()}, \code{\link{gt_merge_stack}()}, \code{\link{gt_merge_stack_color}()}, \code{\link{gt_two_column_layout}()}, \code{\link{gtsave_extra}()}, \code{\link{img_header}()}, \code{\link{pad_fn}()}, \code{\link{tab_style_by_grp}()} } \concept{Utilities} ================================================ FILE: man/gt_img_multi_rows.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_image_multi_rows.R \name{gt_img_multi_rows} \alias{gt_img_multi_rows} \title{Add multiple local or web images into rows of a \code{gt} table} \usage{ gt_img_multi_rows(gt_object, columns, img_source = "web", height = 30) } \arguments{ \item{gt_object}{An existing gt table object of class \code{gt_tbl}} \item{columns}{The columns wherein changes to cell data colors should occur.} \item{img_source}{A string, specifying either "local" or "web" as the source of the images.} \item{height}{\emph{Height of image} \verb{scalar} // \emph{default:} \code{30} The absolute height of the image in the table cell (in \code{"px"} units). By default, this is set to \code{"30px"}.} } \value{ An object of class \code{gt_tbl}. } \description{ The \code{gt_multi_img_rows} function takes an existing \code{gt_tbl} object and converts nested cells with filenames or urls to images into inline images. This is a wrapper around \code{gt::text_transform()} + \code{gt::web_image()}/\code{gt::local_image()} with the necessary boilerplate already applied. } \section{Examples}{ \if{html}{\out{
}}\preformatted{library(gt) teams <- "https://github.com/nflverse/nflfastR-data/raw/master/teams_colors_logos.rds" team_df <- readRDS(url(teams)) conf_table <- team_df \%>\% dplyr::select(team_conf, team_division, logo = team_logo_espn) \%>\% dplyr::distinct() \%>\% tidyr::nest(data = logo) \%>\% dplyr::rename(team_logos = data) \%>\% dplyr::arrange(team_conf, team_division) \%>\% gt() \%>\% gt_img_multi_rows(columns = team_logos, height = 25) }\if{html}{\out{
}} } \section{Figures}{ \if{html}{\figure{img-rows.png}{options: style="width=100\%;"}} } \section{Function ID}{ 2-9 } \seealso{ Other Utilities: \code{\link{add_text_img}()}, \code{\link{fa_icon_repeat}()}, \code{\link{fmt_pad_num}()}, \code{\link{fmt_pct_extra}()}, \code{\link{fmt_symbol_first}()}, \code{\link{generate_df}()}, \code{\link{gt_add_divider}()}, \code{\link{gt_badge}()}, \code{\link{gt_double_table}()}, \code{\link{gt_duplicate_column}()}, \code{\link{gt_fa_rank_change}()}, \code{\link{gt_fa_rating}()}, \code{\link{gt_highlight_cols}()}, \code{\link{gt_highlight_rows}()}, \code{\link{gt_img_border}()}, \code{\link{gt_img_circle}()}, \code{\link{gt_img_rows}()}, \code{\link{gt_index}()}, \code{\link{gt_merge_stack}()}, \code{\link{gt_merge_stack_color}()}, \code{\link{gt_two_column_layout}()}, \code{\link{gtsave_extra}()}, \code{\link{img_header}()}, \code{\link{pad_fn}()}, \code{\link{tab_style_by_grp}()} } \concept{Utilities} ================================================ FILE: man/gt_img_rows.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_image_rows.R \name{gt_img_rows} \alias{gt_img_rows} \title{Add local or web images into rows of a \code{gt} table} \usage{ gt_img_rows(gt_object, columns, img_source = "web", height = 30) } \arguments{ \item{gt_object}{An existing gt table object of class \code{gt_tbl}} \item{columns}{The columns wherein changes to cell data colors should occur.} \item{img_source}{A string, specifying either "local" or "web" as the source of the images.} \item{height}{\emph{Height of image} \verb{scalar} // \emph{default:} \code{30} The absolute height of the image in the table cell (in \code{"px"} units). By default, this is set to \code{"30px"}.} } \value{ An object of class \code{gt_tbl}. } \description{ The \code{gt_img_rows} function takes an existing \code{gt_tbl} object and converts filenames or urls to images into inline images. This is a wrapper around \code{gt::text_transform()} + \code{gt::web_image()}/\code{gt::local_image()} with the necessary boilerplate already applied. } \section{Examples}{ \if{html}{\out{
}}\preformatted{library(gt) teams <- "https://github.com/nflverse/nflfastR-data/raw/master/teams_colors_logos.rds" team_df <- readRDS(url(teams)) logo_table <- team_df \%>\% dplyr::select(team_wordmark, team_abbr, logo = team_logo_espn, team_name:team_conf) \%>\% head() \%>\% gt() \%>\% gt_img_rows(columns = team_wordmark, height = 25) \%>\% gt_img_rows(columns = logo, img_source = "web", height = 30) \%>\% tab_options(data_row.padding = px(1)) }\if{html}{\out{
}} } \section{Figures}{ \if{html}{\figure{img-rows.png}{options: width=100\%}} } \section{Function ID}{ 2-7 } \seealso{ Other Utilities: \code{\link{add_text_img}()}, \code{\link{fa_icon_repeat}()}, \code{\link{fmt_pad_num}()}, \code{\link{fmt_pct_extra}()}, \code{\link{fmt_symbol_first}()}, \code{\link{generate_df}()}, \code{\link{gt_add_divider}()}, \code{\link{gt_badge}()}, \code{\link{gt_double_table}()}, \code{\link{gt_duplicate_column}()}, \code{\link{gt_fa_rank_change}()}, \code{\link{gt_fa_rating}()}, \code{\link{gt_highlight_cols}()}, \code{\link{gt_highlight_rows}()}, \code{\link{gt_img_border}()}, \code{\link{gt_img_circle}()}, \code{\link{gt_img_multi_rows}()}, \code{\link{gt_index}()}, \code{\link{gt_merge_stack}()}, \code{\link{gt_merge_stack_color}()}, \code{\link{gt_two_column_layout}()}, \code{\link{gtsave_extra}()}, \code{\link{img_header}()}, \code{\link{pad_fn}()}, \code{\link{tab_style_by_grp}()} } \concept{Utilities} ================================================ FILE: man/gt_index.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_index.R \name{gt_index} \alias{gt_index} \title{Return the underlying data, arranged by the internal index} \usage{ gt_index(gt_object, column, as_vector = TRUE) } \arguments{ \item{gt_object}{An existing gt table object} \item{column}{The column name that you intend to extract, accepts tidyeval semantics (ie \code{mpg} instead of \code{"mpg"})} \item{as_vector}{A logical indicating whether you'd like just the column indicated as a vector, or the entire dataframe} } \value{ A vector or a \code{tibble} } \description{ This is a utility function to extract the underlying data from a \code{gt} table. You can use it with a saved \code{gt} table, in the pipe (\verb{\%>\%}) or even within most other \code{gt} functions (eg \code{tab_style()}). It defaults to returning the column indicated as a vector, so that you can work with the values. Typically this is used with logical statements to affect one column based on the values in that specified secondary column. Alternatively, you can extract the entire ordered data according to the internal index as a \code{tibble}. This allows for even more complex steps based on multiple indices. } \section{Figures}{ \if{html}{\figure{gt_index_style.png}{options: style="width=50\%;"}} } \section{Function ID}{ 2-20 } \examples{ library(gt) # This is a key step, as gt will create the row groups # based on first observation of the unique row items # this sampling will return a row-group order for cyl of 6,4,8 set.seed(1234) sliced_data <- mtcars \%>\% dplyr::group_by(cyl) \%>\% dplyr::slice_head(n = 3) \%>\% dplyr::ungroup() \%>\% # randomize the order dplyr::slice_sample(n = 9) # not in "order" yet sliced_data$cyl # But unique order of 6,4,8 unique(sliced_data$cyl) # creating a standalone basic table test_tab <- sliced_data \%>\% gt(groupname_col = "cyl") # can style a specific column based on the contents of another column tab_out_styled <- test_tab \%>\% tab_style( locations = cells_body(mpg, rows = gt_index(., am) == 0), style = cell_fill("red") ) # OR can extract the underlying data in the "correct order" # according to the internal gt structure, ie arranged by group # by cylinder, 6,4,8 gt_index(test_tab, mpg, as_vector = FALSE) # note that the order of the index data is # not equivalent to the order of the input data # however all the of the rows still match sliced_data } \seealso{ Other Utilities: \code{\link{add_text_img}()}, \code{\link{fa_icon_repeat}()}, \code{\link{fmt_pad_num}()}, \code{\link{fmt_pct_extra}()}, \code{\link{fmt_symbol_first}()}, \code{\link{generate_df}()}, \code{\link{gt_add_divider}()}, \code{\link{gt_badge}()}, \code{\link{gt_double_table}()}, \code{\link{gt_duplicate_column}()}, \code{\link{gt_fa_rank_change}()}, \code{\link{gt_fa_rating}()}, \code{\link{gt_highlight_cols}()}, \code{\link{gt_highlight_rows}()}, \code{\link{gt_img_border}()}, \code{\link{gt_img_circle}()}, \code{\link{gt_img_multi_rows}()}, \code{\link{gt_img_rows}()}, \code{\link{gt_merge_stack}()}, \code{\link{gt_merge_stack_color}()}, \code{\link{gt_two_column_layout}()}, \code{\link{gtsave_extra}()}, \code{\link{img_header}()}, \code{\link{pad_fn}()}, \code{\link{tab_style_by_grp}()} } \concept{Utilities} ================================================ FILE: man/gt_label_details.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/html-helpers.R \name{gt_label_details} \alias{gt_label_details} \title{Add a simple table with column names and matching labels} \usage{ gt_label_details(label, content, names = c("Column", "Description")) } \arguments{ \item{label}{A string representing the label for the details expansion section.} \item{content}{A named list or wide data.frame with 2 rows} \item{names}{a string indicating the name of the two columns inside the details tag} } \value{ HTML text } \description{ Add a simple table with column names and matching labels } ================================================ FILE: man/gt_merge_stack.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/merge_and_stack.R \name{gt_merge_stack} \alias{gt_merge_stack} \title{Merge and stack text from two columns in \code{gt}} \usage{ gt_merge_stack( gt_object, col1, col2, palette = c("black", "grey"), ..., small_cap = TRUE, font_size = c("14px", "10px"), font_weight = c("bold", "bold") ) } \arguments{ \item{gt_object}{An existing gt table object of class \code{gt_tbl}} \item{col1}{The column to stack on top. Will be converted to all caps, with black and bold text.} \item{col2}{The column to merge and place below. Will be smaller and dark grey.} \item{palette}{The colors for the text, where the first color is the top , ie \code{col1} and the second color is the bottom, ie \code{col2}. Defaults to \code{c("black","grey")}. For more information on built-in color names, see \code{\link[=colors]{colors()}}.} \item{...}{ Arguments passed on to \code{\link[scales:col2hcl]{scales::col2hcl}} \describe{ \item{\code{h}}{Hue, \verb{[0, 360]}} \item{\code{c}}{Chroma, \verb{[0, 100]}} \item{\code{l}}{Luminance, \verb{[0, 100]}} \item{\code{alpha}}{Alpha, \verb{[0, 1]}.} }} \item{small_cap}{a logical indicating whether to use 'small-cap' on the top line of text} \item{font_size}{a string of length 2 indicating the font-size in px of the top and bottom text} \item{font_weight}{a string of length 2 indicating the 'font-weight' of the top and bottom text. Must be one of 'bold', 'normal', 'lighter'} } \value{ An object of class \code{gt_tbl}. } \description{ The \code{gt_merge_stack()} function takes an existing \code{gt} table and merges column 1 and column 2, stacking column 1's text on top of column 2's. Top text is in all caps with black bold text, while the lower text is smaller and dark grey. } \section{Examples}{ \if{html}{\out{
}}\preformatted{library(gt) teams <- "https://github.com/nflverse/nflfastR-data/raw/master/teams_colors_logos.rds" team_df <- readRDS(url(teams)) stacked_tab <- team_df \%>\% dplyr::select(team_nick, team_abbr, team_conf, team_division, team_wordmark) \%>\% head(8) \%>\% gt(groupname_col = "team_conf") \%>\% gt_merge_stack(col1 = team_nick, col2 = team_division) \%>\% gt_img_rows(team_wordmark) }\if{html}{\out{
}} } \section{Figures}{ \if{html}{\figure{merge-stack.png}{options: style="width=50\%;"}} } \section{Function ID}{ 2-6 } \seealso{ Other Utilities: \code{\link{add_text_img}()}, \code{\link{fa_icon_repeat}()}, \code{\link{fmt_pad_num}()}, \code{\link{fmt_pct_extra}()}, \code{\link{fmt_symbol_first}()}, \code{\link{generate_df}()}, \code{\link{gt_add_divider}()}, \code{\link{gt_badge}()}, \code{\link{gt_double_table}()}, \code{\link{gt_duplicate_column}()}, \code{\link{gt_fa_rank_change}()}, \code{\link{gt_fa_rating}()}, \code{\link{gt_highlight_cols}()}, \code{\link{gt_highlight_rows}()}, \code{\link{gt_img_border}()}, \code{\link{gt_img_circle}()}, \code{\link{gt_img_multi_rows}()}, \code{\link{gt_img_rows}()}, \code{\link{gt_index}()}, \code{\link{gt_merge_stack_color}()}, \code{\link{gt_two_column_layout}()}, \code{\link{gtsave_extra}()}, \code{\link{img_header}()}, \code{\link{pad_fn}()}, \code{\link{tab_style_by_grp}()} } \concept{Utilities} ================================================ FILE: man/gt_merge_stack_color.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/merge_and_stack.R \name{gt_merge_stack_color} \alias{gt_merge_stack_color} \title{Merge and stack text with background coloring from two columns in \code{gt}} \usage{ gt_merge_stack_color( gt_object, top_val, color_val, palette = c("#512daa", "white", "#2d6a22"), domain = NULL, small_cap = TRUE, font_size = c("14px", "10px"), font_weight = c("bold", "bold") ) } \arguments{ \item{gt_object}{An existing gt table object of class \code{gt_tbl}} \item{top_val}{The column to stack on top. Will be converted to all caps, with bold text by default.} \item{color_val}{The column to merge and place below, and controls the background color value. Will be smaller by default.} \item{palette}{The colours or colour function that values will be mapped to, accepts a string or named palettes from paletteer.} \item{domain}{The possible values that can be mapped. This can be a simple numeric range (e.g. \code{c(0, 100)}).} \item{small_cap}{a logical indicating whether to use 'small-cap' on the top line of text, defaults to \code{TRUE}.} \item{font_size}{a string of length 2 indicating the font-size in px of the top and bottom text} \item{font_weight}{a string of length 2 indicating the 'font-weight' of the top and bottom text. Must be one of 'bold', 'normal', 'lighter'} } \value{ An object of class \code{gt_tbl}. } \description{ The \code{gt_merge_stack_color()} function takes an existing \code{gt} table and merges column 1 and column 2, stacking column 1's text on top of column 2's. This variant also accepts a palette argument to colorize the background values. } \section{Examples}{ \if{html}{\out{
}}\preformatted{set.seed(12345) dplyr::tibble( value = sample(state.name, 5), color_by = seq.int(10, 98, length.out = 5) ) \%>\% gt::gt() \%>\% gt_merge_stack_color(value, color_by) }\if{html}{\out{
}} } \section{Figures}{ \if{html}{\figure{merge-stack-color.png}{options: style="width=50\%;"}} } \seealso{ Other Utilities: \code{\link{add_text_img}()}, \code{\link{fa_icon_repeat}()}, \code{\link{fmt_pad_num}()}, \code{\link{fmt_pct_extra}()}, \code{\link{fmt_symbol_first}()}, \code{\link{generate_df}()}, \code{\link{gt_add_divider}()}, \code{\link{gt_badge}()}, \code{\link{gt_double_table}()}, \code{\link{gt_duplicate_column}()}, \code{\link{gt_fa_rank_change}()}, \code{\link{gt_fa_rating}()}, \code{\link{gt_highlight_cols}()}, \code{\link{gt_highlight_rows}()}, \code{\link{gt_img_border}()}, \code{\link{gt_img_circle}()}, \code{\link{gt_img_multi_rows}()}, \code{\link{gt_img_rows}()}, \code{\link{gt_index}()}, \code{\link{gt_merge_stack}()}, \code{\link{gt_two_column_layout}()}, \code{\link{gtsave_extra}()}, \code{\link{img_header}()}, \code{\link{pad_fn}()}, \code{\link{tab_style_by_grp}()} } \concept{Utilities} ================================================ FILE: man/gt_plt_bar.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_plt_bar.R \name{gt_plt_bar} \alias{gt_plt_bar} \title{Add bar plots into rows of a \code{gt} table} \usage{ gt_plt_bar( gt_object, column = NULL, color = "purple", ..., keep_column = FALSE, width = 40, scale_type = "none", text_color = "white" ) } \arguments{ \item{gt_object}{An existing gt table object of class \code{gt_tbl}} \item{column}{A single column wherein the bar plot should replace existing data.} \item{color}{A character representing the color for the bar, defaults to purple. Accepts a named color (eg \code{'purple'}) or a hex color.} \item{...}{Additional arguments passed to \code{scales::label_number()} or \code{scales::label_percent()}, depending on what was specified in \code{scale_type}} \item{keep_column}{\code{TRUE}/\code{FALSE} logical indicating if you want to keep a copy of the "plotted" column as raw values next to the plot itself..} \item{width}{An integer indicating the width of the plot in pixels.} \item{scale_type}{A string indicating additional text formatting and the addition of numeric labels to the plotted bars if not \code{'none'}. If \code{'none'}, no numbers will be added to the bar, but if \code{"number"} or \code{"percent"} are used, then the numbers in the plotted column will be added as a bar-label and formatted according to \code{scales::label_percent()} or \code{scales::label_number()}.} \item{text_color}{A string indicating the color of text if \code{scale_type} is used. Defaults to \code{"white"}} } \value{ An object of class \code{gt_tbl}. } \description{ The \code{gt_plt_bar} function takes an existing \code{gt_tbl} object and adds horizontal barplots via \code{ggplot2}. Note that values are plotted on a shared x-axis, and a vertical black bar is added at x = zero. To add labels to each of the of the bars, set \code{scale_type} to either \code{'percent'} or \verb{'number}'. } \section{Examples}{ \if{html}{\out{
}}\preformatted{library(gt) gt_plt_bar_tab <- mtcars \%>\% head() \%>\% gt() \%>\% gt_plt_bar(column = mpg, keep_column = TRUE) }\if{html}{\out{
}} \if{html}{\figure{gt_plt_bar.png}{options: style="width=100\%;"}} } \section{Function ID}{ 3-4 } \seealso{ Other Plotting: \code{\link{gt_plt_bar_pct}()}, \code{\link{gt_plt_bar_stack}()}, \code{\link{gt_plt_dist}()}, \code{\link{gt_plt_percentile}()}, \code{\link{gt_plt_point}()}, \code{\link{gt_plt_sparkline}()}, \code{\link{gt_plt_winloss}()} } \concept{Plotting} ================================================ FILE: man/gt_plt_bar_pct.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt-bar-html.R \name{gt_plt_bar_pct} \alias{gt_plt_bar_pct} \title{Add HTML-based bar plots into rows of a \code{gt} table} \usage{ gt_plt_bar_pct( gt_object, column, height = 16, width = 100, fill = "purple", background = "#e1e1e1", scaled = FALSE, labels = FALSE, label_cutoff = 0.4, decimals = 1, font_style = "bold", font_size = "10px" ) } \arguments{ \item{gt_object}{An existing gt table object of class \code{gt_tbl}} \item{column}{The column wherein the bar plot should replace existing data.} \item{height}{A number representing the vertical height of the plot in pixels. Defaults to 16 px.} \item{width}{A number representing the horizontal width of the plot in pixels. Defaults to 100 px. Importantly, this interacts with the label_cutoff argument, so if you want to change the cutoff, you may need to adjust the width as well.} \item{fill}{A character representing the fill for the bar, defaults to purple. Accepts a named color (eg 'purple') or a hex color.} \item{background}{A character representing the background filling out the 100\% mark of the bar, defaults to light grey. Accepts a named color (eg 'white') or a hex color.} \item{scaled}{\code{TRUE}/\code{FALSE} logical indicating if the value is already scaled to a percent of max (\code{TRUE}) or if it needs to be scaled (\code{FALSE}). Defaults to \code{FALSE}, meaning the value will be divided by the max value in that column and then multiplied by 100.} \item{labels}{\code{TRUE}/\code{FALSE} logical representing if labels should be plotted. Defaults to \code{FALSE}, meaning that no value labels will be plotted.} \item{label_cutoff}{A number, 0 to 1, representing where to set the inside/outside label boundary. Defaults to 0.40 (40\%) of the column's maximum value. If the value in that row is less than the cutoff, the label will be placed outside the bar, otherwise it will be placed within the bar. This interacts with the overall width of the bar, so if you are not happy with the placement of the labels you may try adjusting the \code{width} argument as well.} \item{decimals}{A number representing how many decimal places to be used in label rounding. Defaults to 1.} \item{font_style}{A character representing the font style of the labels. Accepts one of 'bold' (default), 'italic', or 'normal'.} \item{font_size}{A character representing the font size of the labels. Defaults to '10px'.} } \value{ An object of class \code{gt_tbl}. } \description{ The \code{gt_plt_bar_pct} function takes an existing \code{gt_tbl} object and adds horizontal barplots via native HTML. Note that values default to being normalized to the percent of the maximum observed value in the specified column. You can turn this off if the values already represent a percentage value representing 0-100. } \section{Examples}{ \if{html}{\out{
}}\preformatted{library(gt) base_tab <- dplyr::tibble(x = seq(1, 100, length.out = 6)) \%>\% dplyr::mutate( x_unscaled = x, x_scaled = x / max(x) * 100 ) \%>\% gt() base_tab \%>\% gt_plt_bar_pct( column = x_unscaled, scaled = TRUE, fill = "forestgreen" ) \%>\% gt_plt_bar_pct( column = x_scaled, scaled = FALSE, labels = TRUE ) }\if{html}{\out{
}} } \section{Figures}{ \if{html}{\figure{gt_bar_plot.png}{options: width=100\%}} } \section{Function ID}{ 3-5 } \seealso{ Other Plotting: \code{\link{gt_plt_bar}()}, \code{\link{gt_plt_bar_stack}()}, \code{\link{gt_plt_dist}()}, \code{\link{gt_plt_percentile}()}, \code{\link{gt_plt_point}()}, \code{\link{gt_plt_sparkline}()}, \code{\link{gt_plt_winloss}()} } \concept{Plotting} ================================================ FILE: man/gt_plt_bar_stack.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_pct_bar.R \name{gt_plt_bar_stack} \alias{gt_plt_bar_stack} \title{Add a percent stacked barchart in place of existing data.} \usage{ gt_plt_bar_stack( gt_object, column = NULL, palette = c("#ff4343", "#bfbfbf", "#0a1c2b"), labels = c("Group 1", "Group 2", "Group 3"), position = "fill", width = 70, fmt_fn = scales::label_number(scale_cut = cut_short_scale(), trim = TRUE), font = "mono" ) } \arguments{ \item{gt_object}{An existing gt table object of class \code{gt_tbl}} \item{column}{The column wherein the percent stacked barchart should replace existing data. Note that the data \emph{must} be represented as a list of numeric values ahead of time.} \item{palette}{A color palette of length 2 or 3, represented either by hex colors (\code{"#ff4343"}) or named colors (\code{"red"}).} \item{labels}{A vector of strings of length 2 or 3, representing the labels for the bar chart, will be colored according to the palette as well.} \item{position}{An string indicator passed to \code{ggplot2} indicating if the bar should be a percent of total \code{"fill"} or stacked as the raw values \code{"stack"}.} \item{width}{An integer representing the width of the bar chart in pixels.} \item{fmt_fn}{A specific function from \verb{scales::label_???} family. Defaults to \code{scales::label_number()}} \item{font}{A string representing the font family of the numbers of the bar labels. Defaults to \code{mono}.} } \value{ An object of class \code{gt_tbl}. } \description{ The \code{gt_plt_bar_stack} function takes an existing \code{gt_tbl} object and converts the existing values into a percent stacked barchart. The bar chart will represent either 2 or 3 user-specified values per row, and requires a list column ahead of time. The palette and labels need to be equal length. The values must either add up to 100 ie as percentage points if using \code{position = 'fill'}, or can be raw values with \code{position = 'stack'}. Note that the labels can be controlled via the \code{fmt_fn} argument and the \verb{scales::label_???()} family of function. } \section{Examples}{ \if{html}{\out{
}}\preformatted{library(gt) library(dplyr) ex_df <- dplyr::tibble( x = c("Example 1","Example 1", "Example 1","Example 2","Example 2","Example 2", "Example 3","Example 3","Example 3","Example 4","Example 4", "Example 4"), measure = c("Measure 1","Measure 2", "Measure 3","Measure 1","Measure 2","Measure 3", "Measure 1","Measure 2","Measure 3","Measure 1","Measure 2", "Measure 3"), data = c(30, 20, 50, 30, 30, 40, 30, 40, 30, 30, 50, 20) ) tab_df <- ex_df \%>\% group_by(x) \%>\% summarise(list_data = list(data)) tab_df ex_tab <- tab_df \%>\% gt() \%>\% gt_plt_bar_stack(column = list_data) }\if{html}{\out{
}} \if{html}{\figure{plt-bar-stack.png}{options: style="width=70\%;"}} } \seealso{ Other Plotting: \code{\link{gt_plt_bar}()}, \code{\link{gt_plt_bar_pct}()}, \code{\link{gt_plt_dist}()}, \code{\link{gt_plt_percentile}()}, \code{\link{gt_plt_point}()}, \code{\link{gt_plt_sparkline}()}, \code{\link{gt_plt_winloss}()} } \concept{Plotting} ================================================ FILE: man/gt_plt_bullet.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_plt_bullet.R \name{gt_plt_bullet} \alias{gt_plt_bullet} \title{Create an inline 'bullet chart' in a gt table} \usage{ gt_plt_bullet( gt_object, column = NULL, target = NULL, width = 65, palette = c("grey", "red"), palette_col = NULL ) } \arguments{ \item{gt_object}{An existing gt table object of class \code{gt_tbl}} \item{column}{The column where a 'bullet chart' will replace the inline values.} \item{target}{The column indicating the target values that will be represented by a vertical line} \item{width}{Width of the plot in pixels} \item{palette}{Color of the bar and target line, defaults to \code{c("grey", "red")}, can use named colors or hex colors. Must be of length two, and the first color will always be used as the bar color.} \item{palette_col}{An additional column that contains specific colors for the bar colors themselves. Defaults to NULL which skips this argument.} } \value{ An object of class \code{gt_tbl}. } \description{ Create an inline 'bullet chart' in a gt table } \section{Examples}{ \if{html}{\out{
}}\preformatted{set.seed(37) bullet_tab <- tibble::rownames_to_column(mtcars) \%>\% dplyr::select(rowname, cyl:drat, mpg) \%>\% dplyr::group_by(cyl) \%>\% dplyr::mutate(target_col = mean(mpg)) \%>\% dplyr::slice_sample(n = 3) \%>\% dplyr::ungroup() \%>\% gt::gt() \%>\% gt_plt_bullet(column = mpg, target = target_col, width = 45, palette = c("lightblue", "black")) \%>\% gt_theme_538() }\if{html}{\out{
}} \if{html}{\figure{gt_bullet.png}{options: style="width=100\%;"}} } \section{Function ID}{ 3-7 } \seealso{ Other Themes: \code{\link{gt_plt_conf_int}()}, \code{\link{gt_plt_dot}()}, \code{\link{gt_theme_538}()}, \code{\link{gt_theme_dark}()}, \code{\link{gt_theme_dot_matrix}()}, \code{\link{gt_theme_espn}()}, \code{\link{gt_theme_excel}()}, \code{\link{gt_theme_guardian}()}, \code{\link{gt_theme_nytimes}()}, \code{\link{gt_theme_pff}()} } \concept{Themes} ================================================ FILE: man/gt_plt_conf_int.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_plt_conf_int.R \name{gt_plt_conf_int} \alias{gt_plt_conf_int} \title{Plot a confidence interval around a point} \usage{ gt_plt_conf_int( gt_object, column, ci_columns, ci = 0.9, ref_line = NULL, palette = c("black", "grey", "white", "black"), width = 45, text_args = list(accuracy = 1), text_size = 1.5 ) } \arguments{ \item{gt_object}{An existing gt table} \item{column}{The column that contains the mean of the sample. This can either be a single number per row, if you have calculated the values ahead of time, or a list of values if you want to calculate the confidence intervals.} \item{ci_columns}{Optional columns representing the left/right confidence intervals of your sample.} \item{ci}{The confidence interval, representing the percentage, ie \code{0.9} which represents \code{10-90} for the two tails.} \item{ref_line}{A number indicating where to place reference line on x-axis.} \item{palette}{A vector of color strings of exactly length 4. The colors represent the central point, the color of the range, the color of the stroke around the central point, and the color of the text, in that specific order.} \item{width}{A number indicating the width of the plot in \code{"mm"}, defaults to \code{45}.} \item{text_args}{A list of named arguments. Optional text arguments passed as a list to \code{scales::label_number}.} \item{text_size}{A number indicating the size of the text indicators in the plot. Defaults to 1.5. Can also be set to \code{0} to "remove" the text itself.} } \value{ a gt table } \description{ Plot a confidence interval around a point } \section{Examples}{ \if{html}{\out{
}}\preformatted{# gtExtras can calculate basic conf int # using confint() function ci_table <- generate_df( n = 50, n_grps = 3, mean = c(10, 15, 20), sd = c(10, 10, 10), with_seed = 37 ) \%>\% dplyr::group_by(grp) \%>\% dplyr::summarise( n = dplyr::n(), avg = mean(values), sd = sd(values), list_data = list(values) ) \%>\% gt::gt() \%>\% gt_plt_conf_int(list_data, ci = 0.9) # You can also provide your own values # based on your own algorithm/calculations pre_calc_ci_tab <- dplyr::tibble( mean = c(12, 10), ci1 = c(8, 5), ci2 = c(16, 15), ci_plot = c(12, 10) ) \%>\% gt::gt() \%>\% gt_plt_conf_int( ci_plot, c(ci1, ci2), palette = c("red", "lightgrey", "black", "red") ) }\if{html}{\out{
}} } \section{Figures}{ \if{html}{\figure{gt_plt_ci_calc.png}{options: style="width=70\%;"}} \if{html}{\figure{gt_plt_ci_vals.png}{options: style="width=70\%;"}} } \section{Function ID}{ 3-10 } \seealso{ Other Themes: \code{\link{gt_plt_bullet}()}, \code{\link{gt_plt_dot}()}, \code{\link{gt_theme_538}()}, \code{\link{gt_theme_dark}()}, \code{\link{gt_theme_dot_matrix}()}, \code{\link{gt_theme_espn}()}, \code{\link{gt_theme_excel}()}, \code{\link{gt_theme_guardian}()}, \code{\link{gt_theme_nytimes}()}, \code{\link{gt_theme_pff}()} } \concept{Themes} ================================================ FILE: man/gt_plt_dist.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_plt_dist.R \name{gt_plt_dist} \alias{gt_plt_dist} \title{Add distribution plots into rows of a \code{gt} table} \usage{ gt_plt_dist( gt_object, column, type = "density", fig_dim = c(5, 30), line_color = "black", fill_color = "grey", bw = NULL, trim = FALSE, same_limit = TRUE, type_col = NULL ) } \arguments{ \item{gt_object}{An existing gt table object of class \code{gt_tbl}} \item{column}{The column wherein the sparkline plot should replace existing data. Note that the data \emph{must} be represented as a list of numeric values ahead of time.} \item{type}{A string indicating the type of plot to generate, accepts \code{"boxplot"}, \code{"histogram"}, \code{"rug_strip"} or \code{"density"}.} \item{fig_dim}{A vector of two numbers indicating the height/width of the plot in mm at a DPI of 25.4, defaults to \code{c(5,30)}} \item{line_color}{Color for the line, defaults to \code{"black"}. Accepts a named color (eg 'blue') or a hex color.} \item{fill_color}{Color for the fill of histograms/density plots, defaults to \code{"grey"}. Accepts a named color (eg \code{'blue'}) or a hex color.} \item{bw}{The bandwidth or binwidth, passed to \code{density()} or \code{ggplot2::geom_histogram()}. If \code{type = "density"}, then \code{bw} is passed to the \code{bw} argument, if \code{type = "histogram"}, then \code{bw} is passed to the \code{binwidth} argument.} \item{trim}{A logical indicating whether to trim the values in \code{type = "density"} to a slight expansion beyond the observable range. Can help with long tails in \code{density} plots.} \item{same_limit}{A logical indicating that the plots will use the same axis range (\code{TRUE}) or have individual axis ranges (\code{FALSE}).} \item{type_col}{A tidyselect column indicating a vector of which \code{type} of plot to make by row. Must be equal to the total number of rows and limited to \code{"boxplot"}, \code{"histogram"}, \code{"rug_strip"} or \code{"density"}.} } \value{ An object of class \code{gt_tbl}. } \description{ The \code{gt_plt_dist} function takes an existing \code{gt_tbl} object and adds summary distribution sparklines via \code{ggplot2}. Note that these sparklines are limited to density, histogram, boxplot or rug/strip charts. If you're wanting to plot more traditional spark\strong{lines}, you can use \code{gtExtras::gt_plt_sparkline()}. } \section{Examples}{ \if{html}{\out{
}}\preformatted{ library(gt) gt_sparkline_tab <- mtcars \%>\% dplyr::group_by(cyl) \%>\% # must end up with list of data for each row in the input dataframe dplyr::summarize(mpg_data = list(mpg), .groups = "drop") \%>\% gt() \%>\% gt_plt_dist(mpg_data) }\if{html}{\out{
}} } \section{Figures}{ \if{html}{\figure{gt_plt_dist.png}{options: style="width=50\%;"}} } \section{Function ID}{ 1-4 } \seealso{ Other Plotting: \code{\link{gt_plt_bar}()}, \code{\link{gt_plt_bar_pct}()}, \code{\link{gt_plt_bar_stack}()}, \code{\link{gt_plt_percentile}()}, \code{\link{gt_plt_point}()}, \code{\link{gt_plt_sparkline}()}, \code{\link{gt_plt_winloss}()} } \concept{Plotting} ================================================ FILE: man/gt_plt_dot.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_dot_bar.R \name{gt_plt_dot} \alias{gt_plt_dot} \title{Add a color dot and thin bar chart to a table} \usage{ gt_plt_dot( gt_object, column, category_column, palette = NULL, max_value = NULL ) } \arguments{ \item{gt_object}{An existing gt table object of class \code{gt_tbl}} \item{column}{The column which supplies values to create the inline bar plot} \item{category_column}{The category column, where a colored dot and bar will be added} \item{palette}{The colors or color function that values will be mapped to. Can be a character vector (eg \code{c("white", "red")} or hex colors) or a named palette from the \code{{paletteer}} package.} \item{max_value}{A single numeric value indicating the max value, if left as \code{NULL} then the range of the \code{column} values will be used} } \value{ a \code{gt_tbl} } \description{ This function takes a data column and a categorical column and adds a colored dot and a colored dot to the categorical column. You can supply a specific palette or a palette from the \code{{paletteer}} package. } \section{Examples}{ \if{html}{\out{
}}\preformatted{library(gt) dot_bar_tab <- mtcars \%>\% head() \%>\% dplyr::mutate(cars = sapply(strsplit(rownames(.)," "), `[`, 1)) \%>\% dplyr::select(cars, mpg, disp) \%>\% gt() \%>\% gt_plt_dot(disp, cars, palette = "ggthemes::fivethirtyeight") \%>\% cols_width(cars ~ px(125)) }\if{html}{\out{
}} } \section{Figures}{ \if{html}{\figure{gt_dot_bar.png}{options: style="width=50\%;"}} } \seealso{ Other Themes: \code{\link{gt_plt_bullet}()}, \code{\link{gt_plt_conf_int}()}, \code{\link{gt_theme_538}()}, \code{\link{gt_theme_dark}()}, \code{\link{gt_theme_dot_matrix}()}, \code{\link{gt_theme_espn}()}, \code{\link{gt_theme_excel}()}, \code{\link{gt_theme_guardian}()}, \code{\link{gt_theme_nytimes}()}, \code{\link{gt_theme_pff}()} } \concept{Themes} ================================================ FILE: man/gt_plt_dumbbell.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_plt_dumbbell.R \name{gt_plt_dumbbell} \alias{gt_plt_dumbbell} \title{Add a dumbbell plot in place of two columns} \usage{ gt_plt_dumbbell( gt_object, col1 = NULL, col2 = NULL, label = NULL, palette = c("#378E38", "#A926B6", "#D3D3D3"), width = 70, text_args = list(accuracy = 1), text_size = 2.5 ) } \arguments{ \item{gt_object}{an existing gt_tbl or pipeline} \item{col1}{column 1, plot will replace this column} \item{col2}{column 2, will be hidden} \item{label}{an optional new label for the transformed column} \item{palette}{must be 3 colors in order of col1, col2, bar color} \item{width}{width in mm, defaults to 70} \item{text_args}{A list of named arguments. Optional text arguments passed as a list to \code{scales::label_number}.} \item{text_size}{A number indicating the size of the text indicators in the plot. Defaults to 1.5. Can also be set to \code{0} to "remove" the text itself.} } \value{ a gt_object table } \description{ Add a dumbbell plot in place of two columns } \section{Examples}{ \if{html}{\out{
}}\preformatted{head(mtcars) \%>\% gt() \%>\% gt_plt_dumbbell(disp, mpg) }\if{html}{\out{
}} } \section{Figures}{ \if{html}{\figure{gt_plt_dumbell.png}{options: style="width=70\%;"}} } ================================================ FILE: man/gt_plt_percentile.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_plt_percentile_dot.R \name{gt_plt_percentile} \alias{gt_plt_percentile} \title{Create a dot plot for percentiles} \usage{ gt_plt_percentile( gt_object, column, palette = c("#007ad6", "#f0f0f0", "#f72e2e"), width = 25, scale = 1 ) } \arguments{ \item{gt_object}{An existing gt table} \item{column}{The column to transform to the percentile dot plot. Accepts \code{tidyeval}. All values must be end up being between 0 and 100.} \item{palette}{A vector of strings of length 3. Defaults to \code{c('blue', 'lightgrey', 'red')} as hex so \code{c("#007ad6", "#f0f0f0", "#f72e2e")}} \item{width}{A numeric, indicating the width of the plot in \code{mm}, defaults to 25} \item{scale}{A number to multiply/scale the values in the column by. Defaults to 1, but can also be 100 if you have decimals.} } \value{ a gt table } \description{ Creates a percentile dot plot in each row. Can be used as an alternative for a 0 to 100\% bar plot. Allows for scaling values as well and accepts a vector of colors for the range of values. } \section{Examples}{ \if{html}{\out{
}}\preformatted{library(gt) dot_plt <- dplyr::tibble(x = c(seq(10, 90, length.out = 5))) \%>\% gt() \%>\% gt_duplicate_column(x,dupe_name = "dot_plot") \%>\% gt_plt_percentile(dot_plot) }\if{html}{\out{
}} } \section{Figures}{ \if{html}{\figure{gt_plt_percentile.png}{options: style="width=30\%;"}} } \section{Function ID}{ 3-8 } \seealso{ Other Plotting: \code{\link{gt_plt_bar}()}, \code{\link{gt_plt_bar_pct}()}, \code{\link{gt_plt_bar_stack}()}, \code{\link{gt_plt_dist}()}, \code{\link{gt_plt_point}()}, \code{\link{gt_plt_sparkline}()}, \code{\link{gt_plt_winloss}()} } \concept{Plotting} ================================================ FILE: man/gt_plt_point.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_plt_point.R \name{gt_plt_point} \alias{gt_plt_point} \title{Create a point plot in place of each value.} \usage{ gt_plt_point( gt_object, column, palette = c("#007ad6", "#f0f0f0", "#f72e2e"), width = 25, scale = 1, accuracy = 1 ) } \arguments{ \item{gt_object}{An existing gt table} \item{column}{The column to transform to the percentile dot plot. Accepts \code{tidyeval}. All values must be end up being between 0 and 100.} \item{palette}{A vector of strings of length 3. Defaults to \code{c('blue', 'lightgrey', 'red')} as hex so \code{c("#007ad6", "#f0f0f0", "#f72e2e")}} \item{width}{A numeric, indicating the width of the plot in \code{mm}, defaults to 25} \item{scale}{A number to multiply/scale the values in the column by. Defaults to 1, but can also be 100 if you have decimals.} \item{accuracy}{Accuracy of the number labels in the plot, passed to \code{scales::label_number()}} } \value{ a gt table } \description{ Creates a dot/point plot in each row. Can be used as an alternative for a bar plot. Accepts any range of values, as opposed to \code{gt_plt_percentile} which is intended to be used for values between 0 and 100. } \section{Examples}{ \if{html}{\out{
}}\preformatted{point_tab <- dplyr::tibble(x = c(seq(1.2e6, 2e6, length.out = 5))) \%>\% gt::gt() \%>\% gt_duplicate_column(x,dupe_name = "point_plot") \%>\% gt_plt_point(point_plot, accuracy = .1, width = 25) \%>\% gt::fmt_number(x, suffixing = TRUE, decimals = 1) }\if{html}{\out{
}} } \section{Figures}{ \if{html}{\figure{gt_plt_point.png}{options: style="width=30\%;"}} } \section{Function ID}{ 3-9 } \seealso{ Other Plotting: \code{\link{gt_plt_bar}()}, \code{\link{gt_plt_bar_pct}()}, \code{\link{gt_plt_bar_stack}()}, \code{\link{gt_plt_dist}()}, \code{\link{gt_plt_percentile}()}, \code{\link{gt_plt_sparkline}()}, \code{\link{gt_plt_winloss}()} } \concept{Plotting} ================================================ FILE: man/gt_plt_sparkline.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_plt_sparkline.R \name{gt_plt_sparkline} \alias{gt_plt_sparkline} \title{Add sparklines into rows of a \code{gt} table} \usage{ gt_plt_sparkline( gt_object, column, type = "default", fig_dim = c(5, 30), palette = c("black", "black", "purple", "green", "lightgrey"), same_limit = TRUE, label = TRUE ) } \arguments{ \item{gt_object}{An existing gt table object of class \code{gt_tbl}} \item{column}{The column wherein the sparkline plot should replace existing data. Note that the data \emph{must} be represented as a list of numeric values ahead of time.} \item{type}{A string indicating the type of plot to generate, accepts \code{"default"}, \code{"points"}, \code{"shaded"}, \code{"ref_median"}, \code{'ref_mean'}, \code{"ref_iqr"}, \code{"ref_last"}. "points" will add points to every observation instead of just the high/low and final. "shaded" will add shading below the sparkline. The "ref_" options add a thin reference line based off the summary statistic chosen} \item{fig_dim}{A vector of two numbers indicating the height/width of the plot in mm at a DPI of 25.4, defaults to \code{c(5,30)}} \item{palette}{A character string with 5 elements indicating the colors of various components. Order matters, and palette = sparkline color, final value color, range color low, range color high, and 'type' color (eg shading or reference lines). To show a plot with no points (only the line itself), use: \code{palette = c("black", rep("transparent", 4))}.} \item{same_limit}{A logical indicating that the plots will use the same axis range (\code{TRUE}) or have individual axis ranges (\code{FALSE}).} \item{label}{A logical indicating whether the sparkline will have a numeric label for the last value in the vector, placed at the end of the plot.} } \value{ An object of class \code{gt_tbl}. } \description{ The \code{gt_plt_sparkline} function takes an existing \code{gt_tbl} object and adds sparklines via the \code{ggplot2}. Note that if you'd rather plot summary distributions (ie density/histograms) you can instead use: \code{gtExtras::gt_plt_dist()} } \section{Examples}{ \if{html}{\out{
}}\preformatted{ library(gt) gt_sparkline_tab <- mtcars \%>\% dplyr::group_by(cyl) \%>\% # must end up with list of data for each row in the input dataframe dplyr::summarize(mpg_data = list(mpg), .groups = "drop") \%>\% gt() \%>\% gt_plt_sparkline(mpg_data) }\if{html}{\out{
}} } \section{Figures}{ \if{html}{\figure{gt_plt_sparkline.png}{options: style="width=50\%;"}} } \section{Function ID}{ 1-4 } \seealso{ Other Plotting: \code{\link{gt_plt_bar}()}, \code{\link{gt_plt_bar_pct}()}, \code{\link{gt_plt_bar_stack}()}, \code{\link{gt_plt_dist}()}, \code{\link{gt_plt_percentile}()}, \code{\link{gt_plt_point}()}, \code{\link{gt_plt_winloss}()} } \concept{Plotting} ================================================ FILE: man/gt_plt_summary.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_summary_table.R \name{gt_plt_summary} \alias{gt_plt_summary} \title{Create a summary table from a dataframe} \usage{ gt_plt_summary(df, title = NULL) } \arguments{ \item{df}{a dataframe or tibble} \item{title}{a character string to be used in the table title} } \value{ a gt table } \description{ Create a summary table from a dataframe with inline histograms or area bar charts. Inspired by the Observable team and the observablehq/SummaryTable function: https://observablehq.com/d/d8d2929832202050 } \section{Examples}{ Create a summary table from a \code{data.frame} or \code{tibble}. \if{html}{\out{
}}\preformatted{gt_plt_summary(datasets::ChickWeight) }\if{html}{\out{
}} \if{html}{\out{ A summary table of the chicks dataset. }} } ================================================ FILE: man/gt_plt_winloss.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_win_loss.R \name{gt_plt_winloss} \alias{gt_plt_winloss} \title{Add win loss point plot into rows of a \code{gt} table} \usage{ gt_plt_winloss( gt_object, column, max_wins = 17, palette = c("#013369", "#D50A0A", "gray"), type = "pill", width = max_wins/0.83 ) } \arguments{ \item{gt_object}{An existing gt table object of class \code{gt_tbl}} \item{column}{The column wherein the winloss plot should replace existing data. Note that the data \emph{must} be represented as a list of numeric values ahead of time.} \item{max_wins}{An integer indicating the max possible wins, this will be used to add padding if the total wins/losses observed is less than the max. This is useful for mid-season reporting. Defaults to a red, blue, grey palette.} \item{palette}{A character vector of length 3, specifying the colors for win, loss, tie in that exact order.} \item{type}{A character string representing the type of plot, either a 'pill' or 'square'} \item{width}{A numeric indicating the width of the plot in \code{mm}, this can help with larger datasets where data points are overlapping.} } \value{ An object of class \code{gt_tbl}. } \description{ The \code{gt_plt_winloss} function takes an existing \code{gt_tbl} object and adds squares of a specific color and vertical position based on wins/losses. It is a wrapper around \code{gt::text_transform()}. The column chosen \strong{must} be a list-column as seen in the example code. The column should also only contain values of 0 (loss), 0.5 (tie), and 1 (win). } \section{Examples}{ \if{html}{\out{
}}\preformatted{#' library(gt) set.seed(37) data_in <- dplyr::tibble( grp = rep(c("A", "B", "C"), each = 10), wins = sample(c(0,1,.5), size = 30, prob = c(0.45, 0.45, 0.1), replace = TRUE) ) \%>\% dplyr::group_by(grp) \%>\% dplyr::summarize(wins=list(wins), .groups = "drop") data_in win_table <- data_in \%>\% gt() \%>\% gt_plt_winloss(wins) }\if{html}{\out{
}} \if{html}{\out{ A table of various win/loss outcomes }} } \section{Function ID}{ 3-1 } \seealso{ Other Plotting: \code{\link{gt_plt_bar}()}, \code{\link{gt_plt_bar_pct}()}, \code{\link{gt_plt_bar_stack}()}, \code{\link{gt_plt_dist}()}, \code{\link{gt_plt_percentile}()}, \code{\link{gt_plt_point}()}, \code{\link{gt_plt_sparkline}()} } \concept{Plotting} ================================================ FILE: man/gt_reprex_image.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_reprex_image.R \name{gt_reprex_image} \alias{gt_reprex_image} \title{Render 'gt' Table to Temporary png File} \usage{ gt_reprex_image(gt_object) } \arguments{ \item{gt_object}{An object of class \code{gt_tbl} usually created by \code{\link[gt:gt]{gt::gt()}}} } \value{ a png image } \description{ Take a gt pipeline or object and print it as an image within a reprex } \details{ Saves a gt table to a temporary png image file and uses \code{knitr::include_graphics()} to render tables in reproducible examples like \code{reprex::reprex()} where the HTML is not transferrable to GitHub. } ================================================ FILE: man/gt_theme_538.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_theme_538.R \name{gt_theme_538} \alias{gt_theme_538} \title{Apply FiveThirtyEight theme to a gt table} \usage{ gt_theme_538(gt_object, ..., quiet = FALSE) } \arguments{ \item{gt_object}{An existing gt table object of class \code{gt_tbl}} \item{...}{Optional additional arguments to \code{gt::table_options()}} \item{quiet}{A logical to silence the warning about missing ID} } \value{ An object of class \code{gt_tbl}. } \description{ Apply FiveThirtyEight theme to a gt table } \section{Examples}{ \if{html}{\out{
}}\preformatted{library(gt) themed_tab <- head(mtcars) \%>\% gt() \%>\% gt_theme_538() }\if{html}{\out{
}} } \section{Figures}{ \if{html}{\figure{gt_538.png}{options: style="width=100\%;"}} } \section{Function ID}{ 1-1 } \seealso{ Other Themes: \code{\link{gt_plt_bullet}()}, \code{\link{gt_plt_conf_int}()}, \code{\link{gt_plt_dot}()}, \code{\link{gt_theme_dark}()}, \code{\link{gt_theme_dot_matrix}()}, \code{\link{gt_theme_espn}()}, \code{\link{gt_theme_excel}()}, \code{\link{gt_theme_guardian}()}, \code{\link{gt_theme_nytimes}()}, \code{\link{gt_theme_pff}()} } \concept{Themes} ================================================ FILE: man/gt_theme_dark.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_theme_dark.R \name{gt_theme_dark} \alias{gt_theme_dark} \title{Apply dark theme to a \code{gt} table} \usage{ gt_theme_dark(gt_object, ...) } \arguments{ \item{gt_object}{An existing gt table object of class \code{gt_tbl}} \item{...}{Optional additional arguments to \code{gt::table_options()}} } \value{ An object of class \code{gt_tbl}. } \description{ Apply dark theme to a \code{gt} table } \section{Figures}{ \if{html}{\figure{gt_dark.png}{options: style="width=100\%;"}} } \section{Function ID}{ 1-6 } \examples{ library(gt) dark_tab <- head(mtcars) \%>\% gt() \%>\% gt_theme_dark() \%>\% tab_header(title = "Dark mode table") } \seealso{ Other Themes: \code{\link{gt_plt_bullet}()}, \code{\link{gt_plt_conf_int}()}, \code{\link{gt_plt_dot}()}, \code{\link{gt_theme_538}()}, \code{\link{gt_theme_dot_matrix}()}, \code{\link{gt_theme_espn}()}, \code{\link{gt_theme_excel}()}, \code{\link{gt_theme_guardian}()}, \code{\link{gt_theme_nytimes}()}, \code{\link{gt_theme_pff}()} } \concept{Themes} ================================================ FILE: man/gt_theme_dot_matrix.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_theme_dot_matrix.R \name{gt_theme_dot_matrix} \alias{gt_theme_dot_matrix} \title{Apply dot matrix theme to a gt table} \usage{ gt_theme_dot_matrix(gt_object, ..., color = "#b5dbb6", quiet = FALSE) } \arguments{ \item{gt_object}{An existing gt table object of class \code{gt_tbl}} \item{...}{Additional arguments passed to \code{gt::tab_options()}} \item{color}{A string indicating the color of the row striping, defaults to a light green. Accepts either named colors or hex colors.} \item{quiet}{A logical to silence the warning about missing ID} } \value{ An object of class \code{gt_tbl}. } \description{ Apply dot matrix theme to a gt table } \section{Examples}{ \if{html}{\out{
}}\preformatted{library(gt) themed_tab <- head(mtcars) \%>\% gt() \%>\% gt_theme_dot_matrix() \%>\% tab_header(title = "Styled like dot matrix printer paper") }\if{html}{\out{
}} } \section{Figures}{ \if{html}{\figure{gt_dot_matrix.png}{options: style="width=100\%;"}} } \seealso{ Other Themes: \code{\link{gt_plt_bullet}()}, \code{\link{gt_plt_conf_int}()}, \code{\link{gt_plt_dot}()}, \code{\link{gt_theme_538}()}, \code{\link{gt_theme_dark}()}, \code{\link{gt_theme_espn}()}, \code{\link{gt_theme_excel}()}, \code{\link{gt_theme_guardian}()}, \code{\link{gt_theme_nytimes}()}, \code{\link{gt_theme_pff}()} } \concept{Themes} ================================================ FILE: man/gt_theme_espn.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_theme_espn.R \name{gt_theme_espn} \alias{gt_theme_espn} \title{Apply ESPN theme to a gt table} \usage{ gt_theme_espn(gt_object, ...) } \arguments{ \item{gt_object}{An existing gt table object of class \code{gt_tbl}} \item{...}{Optional additional arguments to \code{gt::table_options()}} } \value{ An object of class \code{gt_tbl}. } \description{ Apply ESPN theme to a gt table } \section{Figures}{ \if{html}{\figure{gt_espn.png}{options: style="width=100\%;"}} } \section{Function ID}{ 1-2 } \examples{ library(gt) themed_tab <- head(mtcars) \%>\% gt() \%>\% gt_theme_espn() } \seealso{ Other Themes: \code{\link{gt_plt_bullet}()}, \code{\link{gt_plt_conf_int}()}, \code{\link{gt_plt_dot}()}, \code{\link{gt_theme_538}()}, \code{\link{gt_theme_dark}()}, \code{\link{gt_theme_dot_matrix}()}, \code{\link{gt_theme_excel}()}, \code{\link{gt_theme_guardian}()}, \code{\link{gt_theme_nytimes}()}, \code{\link{gt_theme_pff}()} } \concept{Themes} ================================================ FILE: man/gt_theme_excel.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_theme_excel.R \name{gt_theme_excel} \alias{gt_theme_excel} \title{Apply Excel-style theme to an existing gt table} \usage{ gt_theme_excel(gt_object, ..., color = "lightgrey") } \arguments{ \item{gt_object}{An existing gt table object of class \code{gt_tbl}} \item{...}{Additional arguments passed to \code{gt::tab_options()}} \item{color}{A string indicating the color of the row striping, defaults to a light gray Accepts either named colors or hex colors.} } \value{ An object of class \code{gt_tbl}. } \description{ Apply Excel-style theme to an existing gt table } \section{Figures}{ \if{html}{\figure{gt_excel.png}{options: style="width=75\%;"}} } \section{Function ID}{ 1-7 } \examples{ library(gt) themed_tab <- head(mtcars) \%>\% gt() \%>\% gt_theme_excel() \%>\% tab_header(title = "Styled like your old pal, Excel") } \seealso{ Other Themes: \code{\link{gt_plt_bullet}()}, \code{\link{gt_plt_conf_int}()}, \code{\link{gt_plt_dot}()}, \code{\link{gt_theme_538}()}, \code{\link{gt_theme_dark}()}, \code{\link{gt_theme_dot_matrix}()}, \code{\link{gt_theme_espn}()}, \code{\link{gt_theme_guardian}()}, \code{\link{gt_theme_nytimes}()}, \code{\link{gt_theme_pff}()} } \concept{Themes} ================================================ FILE: man/gt_theme_guardian.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_theme_guardian.R \name{gt_theme_guardian} \alias{gt_theme_guardian} \title{Apply Guardian theme to a \code{gt} table} \usage{ gt_theme_guardian(gt_object, ...) } \arguments{ \item{gt_object}{An existing gt table object of class \code{gt_tbl}} \item{...}{Optional additional arguments to \code{gt::table_options()}} } \value{ An object of class \code{gt_tbl}. } \description{ Apply Guardian theme to a \code{gt} table } \section{Figures}{ \if{html}{\figure{gt_guardian.png}{options: style="width=100\%;"}} } \section{Function ID}{ 1-4 } \examples{ library(gt) themed_tab <- head(mtcars) \%>\% gt() \%>\% gt_theme_guardian() } \seealso{ Other Themes: \code{\link{gt_plt_bullet}()}, \code{\link{gt_plt_conf_int}()}, \code{\link{gt_plt_dot}()}, \code{\link{gt_theme_538}()}, \code{\link{gt_theme_dark}()}, \code{\link{gt_theme_dot_matrix}()}, \code{\link{gt_theme_espn}()}, \code{\link{gt_theme_excel}()}, \code{\link{gt_theme_nytimes}()}, \code{\link{gt_theme_pff}()} } \concept{Themes} ================================================ FILE: man/gt_theme_nytimes.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_theme_nytimes.R \name{gt_theme_nytimes} \alias{gt_theme_nytimes} \title{Apply NY Times theme to a \code{gt} table} \usage{ gt_theme_nytimes(gt_object, ...) } \arguments{ \item{gt_object}{An existing gt table object of class \code{gt_tbl}} \item{...}{Optional additional arguments to \code{gt::table_options()}} } \value{ An object of class \code{gt_tbl}. } \description{ Apply NY Times theme to a \code{gt} table } \section{Figures}{ \if{html}{\figure{gt_nyt.png}{options: style="width=100\%;"}} } \section{Function ID}{ 1-3 } \examples{ library(gt) nyt_tab <- head(mtcars) \%>\% gt() \%>\% gt_theme_nytimes() \%>\% tab_header(title = "Table styled like the NY Times") } \seealso{ Other Themes: \code{\link{gt_plt_bullet}()}, \code{\link{gt_plt_conf_int}()}, \code{\link{gt_plt_dot}()}, \code{\link{gt_theme_538}()}, \code{\link{gt_theme_dark}()}, \code{\link{gt_theme_dot_matrix}()}, \code{\link{gt_theme_espn}()}, \code{\link{gt_theme_excel}()}, \code{\link{gt_theme_guardian}()}, \code{\link{gt_theme_pff}()} } \concept{Themes} ================================================ FILE: man/gt_theme_pff.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_theme_pff.R \name{gt_theme_pff} \alias{gt_theme_pff} \title{Apply a table theme like PFF} \usage{ gt_theme_pff(gt_object, ..., divider, spanners, rank_col) } \arguments{ \item{gt_object}{an existing gt_tbl object} \item{...}{Additional arguments passed to gt::tab_options()} \item{divider}{A column name to add a divider to the left of - accepts tidy-eval column names.} \item{spanners}{Character string that indicates the names of specific spanners you have created with gt::tab_spanner().} \item{rank_col}{A column name to add a grey background to. Accepts tidy-eval column names.} } \value{ gt_tbl } \description{ Apply a table theme like PFF } \section{Examples}{ \if{html}{\out{
}}\preformatted{library(gt) out_df <- tibble::tribble( ~rank, ~player, ~jersey, ~team, ~g, ~pass, ~pr_snaps, ~rsh_pct, ~prp, ~prsh, 1L, "Trey Hendrickson", "91", "CIN", 16, 495, 454, 91.7, 10.8, 83.9, 2L, "T.J. Watt", "90", "PIT", 15, 461, 413, 89.6, 10.7, 90.6, 3L, "Rashan Gary", "52", "GB", 16, 471, 463, 98.3, 10.4, 88.9, 4L, "Maxx Crosby", "98", "LV", 17, 599, 597, 99.7, 10, 91.8, 5L, "Matthew Judon", "09", "NE", 17, 510, 420, 82.4, 9.7, 73.2, 6L, "Myles Garrett", "95", "CLV", 17, 554, 543, 98, 9.5, 92.7, 7L, "Shaquil Barrett", "58", "TB", 15, 563, 485, 86.1, 9.3, 81.5, 8L, "Nick Bosa", "97", "SF", 17, 529, 525, 99.2, 9.2, 89.8, 9L, "Marcus Davenport", "92", "NO", 11, 302, 297, 98.3, 9.1, 82, 10L, "Joey Bosa", "97", "LAC", 16, 495, 468, 94.5, 8.9, 90.3, 11L, "Robert Quinn", "94", "CHI", 16, 445, 402, 90.3, 8.6, 79.7, 12L, "Randy Gregory", "94", "DAL", 12, 315, 308, 97.8, 8.6, 84.4 ) out_df \%>\% gt() \%>\% tab_spanner(columns = pass:rsh_pct, label = "snaps") \%>\% tab_spanner(columns = prp:prsh, label = "grade") \%>\% gt_theme_pff( spanners = c("snaps", "grade"), divider = jersey, rank_col = rank ) \%>\% gt_color_box( columns = prsh, domain = c(0, 95), width = 50, accuracy = 0.1, palette = "pff" ) \%>\% cols_label(jersey = "#", g = "#G", rsh_pct = "RSH\%") \%>\% tab_header( title = "Pass Rush Grades", subtitle = "Grades and pass rush stats" ) \%>\% gt_highlight_cols(columns = prp, fill = "#e4e8ec") \%>\% tab_style( style = list( cell_borders("bottom", "white"), cell_fill(color = "#393c40") ), locations = cells_column_labels(prp) }\if{html}{\out{
}} } \section{Figures}{ \if{html}{\figure{gt_theme_pff.png}{options: style="width=80\%;"}} } \seealso{ Other Themes: \code{\link{gt_plt_bullet}()}, \code{\link{gt_plt_conf_int}()}, \code{\link{gt_plt_dot}()}, \code{\link{gt_theme_538}()}, \code{\link{gt_theme_dark}()}, \code{\link{gt_theme_dot_matrix}()}, \code{\link{gt_theme_espn}()}, \code{\link{gt_theme_excel}()}, \code{\link{gt_theme_guardian}()}, \code{\link{gt_theme_nytimes}()} } \concept{Themes} ================================================ FILE: man/gt_two_column_layout.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/two-column-layouts.R \name{gt_two_column_layout} \alias{gt_two_column_layout} \title{Create a two-column layout from a list of two gt tables} \usage{ gt_two_column_layout( tables = NULL, output = "viewer", filename = NULL, path = NULL, vwidth = 992, vheight = 600, ..., zoom = 2, expand = 5, tab_header_from = NULL ) } \arguments{ \item{tables}{A \code{list()} of two tables, typically supplied by \code{gt_double_table()}} \item{output}{A character string indicating the desired output, either \code{"save"} to save it to disk via \code{webshot}, \code{"viewer"} to return it to the RStudio Viewer, or \code{"html"} to return the raw HTML.} \item{filename}{The filename of the table, must contain \code{.png} and only used if \code{output = "save"}} \item{path}{An optional path of where to save the printed \code{.png}, used in conjunction with \code{filename}.} \item{vwidth}{Viewport width. This is the width of the browser "window" when passed to \code{webshot2::webshot()}.} \item{vheight}{Viewport height This is the height of the browser "window" when passed to \code{webshot2::webshot()}.} \item{...}{Additional arguments passed to \code{webshot2::webshot()}, only to be used if \code{output = "save"}, saving the two-column layout tables to disk as a \code{.png}.} \item{zoom}{Argument to \code{webshot2::webshot()}. A number specifying the zoom factor. A zoom factor of 2 will result in twice as many pixels vertically and horizontally. Note that using 2 is not exactly the same as taking a screenshot on a HiDPI (Retina) device: it is like increasing the zoom to 200 doubling the height and width of the browser window. This differs from using a HiDPI device because some web pages load different, higher-resolution images when they know they will be displayed on a HiDPI device (but using zoom will not report that there is a HiDPI device).} \item{expand}{Argument to \code{webshot2::webshot()}. A numeric vector specifying how many pixels to expand the clipping rectangle by. If one number, the rectangle will be expanded by that many pixels on all sides. If four numbers, they specify the top, right, bottom, and left, in that order. When taking screenshots of multiple URLs, this parameter can also be a list with same length as url with each element of the list containing a single number or four numbers to use for the corresponding URL.} \item{tab_header_from}{If \code{NULL} (the default) renders tab headers of each table individually. If one of "table1" or "table2", the function extracts tab header information (including styling) from table 1 or table 2 respectively and renders it as high level header for the combined view (individual headers will be removed).} } \value{ Saves a \code{.png} to disk if \code{output = "save"}, returns HTML to the viewer via \code{htmltools::browsable()} when \code{output = "viewer"}, or returns raw HTML if \code{output = "html"}. } \description{ This function takes a \code{list()} of two gt-tables and returns them as a two-column layout. The expectation is that the user either supplies two tables like \code{list(table1, table2)}, or passes the output of \code{gt_double_table()} into this function. The user should indicate whether they want to return the HTML to R's viewer with \code{output = "viewer"} to "view" the final output, or to save to disk as a \code{.png} via \verb{output = "save".} Note that this is a relatively complex wrapper around \code{htmltools::div()} + \code{webshot2::webshot()}. Additional arguments can be passed to \code{webshot2::webshot()} if the automatic output is not satisfactory. In most situations, modifying the \code{vwidth} argument is sufficient to get the desired output, but all arguments to \code{webshot2::webshot()} are available by their original name via the passed \code{...}. } \section{Examples}{ Add row numbers and drop some columns \if{html}{\out{
}}\preformatted{library(gt) my_cars <- mtcars \%>\% dplyr::mutate(row_n = dplyr::row_number(), .before = mpg) \%>\% dplyr::select(row_n, mpg:drat) }\if{html}{\out{
}} Create two tables, just split half/half \if{html}{\out{
}}\preformatted{tab1 <- my_cars \%>\% dplyr::slice(1:16) \%>\% gt() \%>\% gtExtras::gt_color_rows(columns = row_n, domain = 1:32) tab2 <- my_cars \%>\% dplyr::slice(17:32) \%>\% gt() \%>\% gtExtras::gt_color_rows(columns = row_n, domain = 1:32) }\if{html}{\out{
}} Put the tables in a list and then pass list to the \code{gt_two_column_layout} function. \if{html}{\out{
}}\preformatted{listed_tables <- list(tab1, tab2) gt_two_column_layout(listed_tables) }\if{html}{\out{
}} A better option - write a small function, use \code{gt_double_table()} to generate the tables and then pass it to \code{gt_double_table()} \if{html}{\out{
}}\preformatted{my_gt_fn <- function(x) \{ gt(x) \%>\% gtExtras::gt_color_rows(columns = row_n, domain = 1:32) \} my_tables <- gt_double_table(my_cars, my_gt_fn, nrows = nrow(my_cars) / 2) }\if{html}{\out{
}} This will return it to the viewer \if{html}{\out{
}}\preformatted{gt_two_column_layout(my_tables) }\if{html}{\out{
}} If you wanted to save it out instead, could use the code below \if{html}{\out{
}}\preformatted{gt_two_column_layout(my_tables, output = "save", filename = "basic-two-col.png", vwidth = 550, vheight = 620) }\if{html}{\out{
}} } \section{Figures}{ \if{html}{\figure{basic-two-col.png}{options: style="width=60\%;"}} } \seealso{ Other Utilities: \code{\link{add_text_img}()}, \code{\link{fa_icon_repeat}()}, \code{\link{fmt_pad_num}()}, \code{\link{fmt_pct_extra}()}, \code{\link{fmt_symbol_first}()}, \code{\link{generate_df}()}, \code{\link{gt_add_divider}()}, \code{\link{gt_badge}()}, \code{\link{gt_double_table}()}, \code{\link{gt_duplicate_column}()}, \code{\link{gt_fa_rank_change}()}, \code{\link{gt_fa_rating}()}, \code{\link{gt_highlight_cols}()}, \code{\link{gt_highlight_rows}()}, \code{\link{gt_img_border}()}, \code{\link{gt_img_circle}()}, \code{\link{gt_img_multi_rows}()}, \code{\link{gt_img_rows}()}, \code{\link{gt_index}()}, \code{\link{gt_merge_stack}()}, \code{\link{gt_merge_stack_color}()}, \code{\link{gtsave_extra}()}, \code{\link{img_header}()}, \code{\link{pad_fn}()}, \code{\link{tab_style_by_grp}()} } \concept{Utilities} ================================================ FILE: man/gtsave_extra.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gtsave_extra.R \name{gtsave_extra} \alias{gtsave_extra} \title{Use webshot2 to save a gt table as a PNG} \usage{ gtsave_extra(data, filename, path = NULL, ..., zoom = 2, expand = 5) } \arguments{ \item{data}{HTML content to be saved temporarily to disk} \item{filename}{The name of the file, should end in \code{.png}} \item{path}{An optional path} \item{...}{Additional arguments to \code{webshot2::webshot()}} \item{zoom}{A number specifying the zoom factor. A zoom factor of 2 will result in twice as many pixels vertically and horizontally. Note that using 2 is not exactly the same as taking a screenshot on a HiDPI (Retina) device: it is like increasing the zoom to 200 doubling the height and width of the browser window.} \item{expand}{A numeric vector specifying how many pixels to expand the clipping rectangle by. If one number, the rectangle will be expanded by that many pixels on all sides. If four numbers, they specify the top, right, bottom, and left, in that order.} } \value{ Prints the HTML content to the RStudio viewer and saves a \code{.png} file to disk } \description{ Takes existing HTML content, typically additional HTML including a gt table as a PNG via the \code{{webshot2}} package. } \section{Function ID}{ 2-14 } \seealso{ Other Utilities: \code{\link{add_text_img}()}, \code{\link{fa_icon_repeat}()}, \code{\link{fmt_pad_num}()}, \code{\link{fmt_pct_extra}()}, \code{\link{fmt_symbol_first}()}, \code{\link{generate_df}()}, \code{\link{gt_add_divider}()}, \code{\link{gt_badge}()}, \code{\link{gt_double_table}()}, \code{\link{gt_duplicate_column}()}, \code{\link{gt_fa_rank_change}()}, \code{\link{gt_fa_rating}()}, \code{\link{gt_highlight_cols}()}, \code{\link{gt_highlight_rows}()}, \code{\link{gt_img_border}()}, \code{\link{gt_img_circle}()}, \code{\link{gt_img_multi_rows}()}, \code{\link{gt_img_rows}()}, \code{\link{gt_index}()}, \code{\link{gt_merge_stack}()}, \code{\link{gt_merge_stack_color}()}, \code{\link{gt_two_column_layout}()}, \code{\link{img_header}()}, \code{\link{pad_fn}()}, \code{\link{tab_style_by_grp}()} } \concept{Utilities} ================================================ FILE: man/img_header.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/img_header.R \name{img_header} \alias{img_header} \title{Add images as the column label for a table} \usage{ img_header( label, img_url, height = 60, font_size = 12, palette = c("black", "black") ) } \arguments{ \item{label}{A string indicating the label of the column.} \item{img_url}{A string for the image url.} \item{height}{A number indicating the height of the image in pixels.} \item{font_size}{The font size of the label in pixels.} \item{palette}{A vector of two colors, indictating the bottom border color and the text color.} } \value{ HTML string } \description{ Add images as the column label for a table } \section{Examples}{ \if{html}{\out{
}}\preformatted{library(gt) dplyr::tibble( x = 1:5, y = 6:10 ) \%>\% gt() \%>\% cols_label( x = img_header( "Luka Doncic", "https://secure.espn.com/combiner/i?img=/i/headshots/nba/players/full/3945274.png", height = 60, font_size = 14 ) ) }\if{html}{\out{
}} } \section{Figures}{ \if{html}{\figure{img_header.png}{options: style="width=80\%;"}} } \seealso{ Other Utilities: \code{\link{add_text_img}()}, \code{\link{fa_icon_repeat}()}, \code{\link{fmt_pad_num}()}, \code{\link{fmt_pct_extra}()}, \code{\link{fmt_symbol_first}()}, \code{\link{generate_df}()}, \code{\link{gt_add_divider}()}, \code{\link{gt_badge}()}, \code{\link{gt_double_table}()}, \code{\link{gt_duplicate_column}()}, \code{\link{gt_fa_rank_change}()}, \code{\link{gt_fa_rating}()}, \code{\link{gt_highlight_cols}()}, \code{\link{gt_highlight_rows}()}, \code{\link{gt_img_border}()}, \code{\link{gt_img_circle}()}, \code{\link{gt_img_multi_rows}()}, \code{\link{gt_img_rows}()}, \code{\link{gt_index}()}, \code{\link{gt_merge_stack}()}, \code{\link{gt_merge_stack_color}()}, \code{\link{gt_two_column_layout}()}, \code{\link{gtsave_extra}()}, \code{\link{pad_fn}()}, \code{\link{tab_style_by_grp}()} } \concept{Utilities} ================================================ FILE: man/last_row_id.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/last_row_id.R \name{last_row_id} \alias{last_row_id} \title{Get last row id/index even by group} \usage{ last_row_id(gt_object) } \arguments{ \item{gt_object}{An existing gt table object of class \code{gt_tbl}} } \description{ Get last row id/index even by group } ================================================ FILE: man/n_decimals.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils.R \name{n_decimals} \alias{n_decimals} \title{Count number of decimals} \usage{ n_decimals(x) } \arguments{ \item{x}{A value to count decimals from} } \value{ an integer } \description{ Count number of decimals } ================================================ FILE: man/pad_fn.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/pad_fn.R \name{pad_fn} \alias{pad_fn} \title{Pad a vector of numbers to align on the decimal point.} \usage{ pad_fn(x, nsmall = 2, pad0) } \arguments{ \item{x}{A vector of numbers to pad/align at the decimal point} \item{nsmall}{The max number of decimal places to round at/display} \item{pad0}{A logical, indicating whether to pad the values with trailing zeros.} } \value{ Returns a vector of equal length to the input vector } \description{ This helper function adds whitespace to numeric values so that they can be aligned on the decimal without requiring additional trailing zeroes. This function is intended to use within the \code{gt::fmt()} function. } \section{Figures}{ \if{html}{\figure{gt_pad_fn.png}{options: style="width=20\%;"}} } \section{Function ID}{ 2-3 } \examples{ library(gt) padded_tab <- data.frame(x = c(1.2345, 12.345, 123.45, 1234.5, 12345)) \%>\% gt() \%>\% fmt(fns = function(x) { pad_fn(x, nsmall = 4) }) \%>\% tab_style( # MUST USE A MONO-SPACED FONT # https://fonts.google.com/?category=Monospace style = cell_text(font = google_font("Fira Mono")), locations = cells_body(columns = x) ) } \seealso{ Other Utilities: \code{\link{add_text_img}()}, \code{\link{fa_icon_repeat}()}, \code{\link{fmt_pad_num}()}, \code{\link{fmt_pct_extra}()}, \code{\link{fmt_symbol_first}()}, \code{\link{generate_df}()}, \code{\link{gt_add_divider}()}, \code{\link{gt_badge}()}, \code{\link{gt_double_table}()}, \code{\link{gt_duplicate_column}()}, \code{\link{gt_fa_rank_change}()}, \code{\link{gt_fa_rating}()}, \code{\link{gt_highlight_cols}()}, \code{\link{gt_highlight_rows}()}, \code{\link{gt_img_border}()}, \code{\link{gt_img_circle}()}, \code{\link{gt_img_multi_rows}()}, \code{\link{gt_img_rows}()}, \code{\link{gt_index}()}, \code{\link{gt_merge_stack}()}, \code{\link{gt_merge_stack_color}()}, \code{\link{gt_two_column_layout}()}, \code{\link{gtsave_extra}()}, \code{\link{img_header}()}, \code{\link{tab_style_by_grp}()} } \concept{Utilities} ================================================ FILE: man/plot_data.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gt_summary_table.R \name{plot_data} \alias{plot_data} \title{Create inline plots for a summary table} \usage{ plot_data(col, col_name, n_missing, ...) } \arguments{ \item{col}{The column of data to be used for plotting} \item{col_name}{the name of the column - use for reporting warnings} \item{n_missing}{Number of missing - used if all missing} \item{...}{additional arguments passed to scales::label_number()} } \value{ svg text encoded as HTML } \description{ Create inline plots for a summary table } ================================================ FILE: man/reexports.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/reexports.R \docType{import} \name{reexports} \alias{reexports} \alias{\%>\%} \alias{vars} \alias{select} \alias{mutate} \alias{starts_with} \alias{ends_with} \alias{contains} \alias{matches} \alias{num_range} \alias{all_of} \alias{any_of} \alias{everything} \alias{last_col} \alias{one_of} \title{Objects exported from other packages} \keyword{internal} \description{ These objects are imported from other packages. Follow the links below to see their documentation. \describe{ \item{dplyr}{\code{\link[dplyr:reexports]{\%>\%}}, \code{\link[dplyr:reexports]{all_of}}, \code{\link[dplyr:reexports]{any_of}}, \code{\link[dplyr:reexports]{contains}}, \code{\link[dplyr:reexports]{ends_with}}, \code{\link[dplyr:reexports]{everything}}, \code{\link[dplyr:reexports]{last_col}}, \code{\link[dplyr:reexports]{matches}}, \code{\link[dplyr]{mutate}}, \code{\link[dplyr:reexports]{num_range}}, \code{\link[dplyr:reexports]{one_of}}, \code{\link[dplyr]{select}}, \code{\link[dplyr:reexports]{starts_with}}, \code{\link[dplyr]{vars}}} }} ================================================ FILE: man/tab_style_by_grp.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/tab_style_by_grp.R \name{tab_style_by_grp} \alias{tab_style_by_grp} \title{Add table styling to specific rows by group} \usage{ tab_style_by_grp(gt_object, column, fn, ...) } \arguments{ \item{gt_object}{An existing gt table object of class \code{gt_tbl}} \item{column}{The column using tidy variable name or a number indicating which column should have the styling affect it.} \item{fn}{The name of a summarizing function (ie \code{max()}, \code{min()})} \item{...}{Arguments passed to \code{tab_style(style = ...)}} } \value{ An object of class \code{gt_tbl}. } \description{ The \code{tab_style_by_grp} function takes an existing \code{gt_tbl} object and styling according to each group. Currently it support styling the \code{max()}/\code{min()} for each group. } \section{Examples}{ \if{html}{\out{
}}\preformatted{library(gt) df_in <- mtcars \%>\% dplyr::select(cyl:hp, mpg) \%>\% tibble::rownames_to_column() \%>\% dplyr::group_by(cyl) \%>\% dplyr::slice(1:4) \%>\% dplyr::ungroup() test_tab <- df_in \%>\% gt(groupname_col = "cyl") \%>\% tab_style_by_grp(mpg, fn = max, cell_fill(color = "red", alpha = 0.5)) }\if{html}{\out{
}} } \section{Figures}{ \if{html}{\figure{grp-tab-style.png}{options: style="width=40\%;"}} } \section{Function ID}{ 2-12 } \seealso{ Other Utilities: \code{\link{add_text_img}()}, \code{\link{fa_icon_repeat}()}, \code{\link{fmt_pad_num}()}, \code{\link{fmt_pct_extra}()}, \code{\link{fmt_symbol_first}()}, \code{\link{generate_df}()}, \code{\link{gt_add_divider}()}, \code{\link{gt_badge}()}, \code{\link{gt_double_table}()}, \code{\link{gt_duplicate_column}()}, \code{\link{gt_fa_rank_change}()}, \code{\link{gt_fa_rating}()}, \code{\link{gt_highlight_cols}()}, \code{\link{gt_highlight_rows}()}, \code{\link{gt_img_border}()}, \code{\link{gt_img_circle}()}, \code{\link{gt_img_multi_rows}()}, \code{\link{gt_img_rows}()}, \code{\link{gt_index}()}, \code{\link{gt_merge_stack}()}, \code{\link{gt_merge_stack_color}()}, \code{\link{gt_two_column_layout}()}, \code{\link{gtsave_extra}()}, \code{\link{img_header}()}, \code{\link{pad_fn}()} } \concept{Utilities} ================================================ FILE: man/with_tooltip.Rd ================================================ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/html-helpers.R \name{with_tooltip} \alias{with_tooltip} \title{A helper to add basic tooltip inside a gt table} \usage{ with_tooltip(label, tooltip) } \arguments{ \item{label}{The label for the item with a tooltip} \item{tooltip}{The text based tooltip for the item} } \value{ HTML text } \description{ This is a lightweight helper to add tooltip, typically to be used within \code{gt::cols_label()}. } ================================================ FILE: tests/testthat/helper.R ================================================ check_suggests <- function() { skip_if_not_installed("rvest") skip_if_not_installed("xml2") } ================================================ FILE: tests/testthat/test-fmt_pad_num.R ================================================ test_that("gt_fmt_pad_num test that padding is correct", { check_suggests() skip_on_cran() padded_tab <- data.frame(numbers = c(1.2345, 12.345, 123.45, 1234.5, 12345)) %>% gt() %>% fmt_pad_num(columns = numbers, nsmall = 4) pad_html <- padded_tab %>% gt::as_raw_html() %>% rvest::read_html() %>% rvest::html_nodes("td:nth-child(1)") %>% rvest::html_text() pad_html <- gsub(x = pad_html, pattern = "^.*\\.", replacement = "") len_space <- stringr::str_count(pad_html, "\\s") expect_equal(len_space, rep(2, 5)) }) ================================================ FILE: tests/testthat/test-fmt_pct_extra.R ================================================ test_that("fmt_pct_extra generates expected output and colors", { check_suggests() skip_on_cran() testthat::skip_if(condition = !(Sys.getenv("IS_LOCAL") == "TOM")) pct_tab <- dplyr::tibble(x = c(.001, .05, .008, .1, .2, .5, .9)) %>% gt::gt() %>% fmt_pct_extra(x, scale = 100, accuracy = .1) %>% gt::as_raw_html() %>% rvest::read_html() text_out <- pct_tab %>% rvest::html_elements("tbody") %>% rvest::html_elements("tr") %>% rvest::html_elements("td") %>% rvest::html_text() # expect_equal(text_out, c( # "<1%", "5.0%", "<1%", "10.0%", # "20.0%", "50.0%", "90.0%" # )) txt_color <- pct_tab %>% rvest::html_elements("td:nth-child(1) > span") %>% rvest::html_attrs() %>% unlist() %>% unname() expect_equal(txt_color, c("color:grey;", "color:grey;")) }) ================================================ FILE: tests/testthat/test-fmt_symbol_first.R ================================================ test_gt_by_col <- function(col_n, row_first = TRUE, expectation) { check_suggests() skip_on_cran() ex_gt <- gt::gtcars %>% head() %>% dplyr::select(mfr, year, bdy_style, mpg_h, hp) %>% dplyr::mutate(mpg_h = c(20.2, 22.0, 20.8, 21.2, 22.8, 22.7)) %>% gt::gt() %>% gt::opt_table_font(font = google_font("Roboto Mono")) %>% gt::opt_table_lines() %>% fmt_symbol_first(column = mfr, symbol = "$", suffix = " ", last_row_n = 6) %>% fmt_symbol_first(column = year, symbol = NULL, suffix = "%", last_row_n = 6) %>% fmt_symbol_first(column = mpg_h, symbol = "%", suffix = NULL, last_row_n = 6, decimals = 1) %>% fmt_symbol_first(column = hp, symbol = "°", suffix = "F", last_row_n = 6, decimals = NULL, symbol_first = TRUE) ex_gt_raw <- ex_gt %>% gt::as_raw_html() # read into rvest, and grab the table body ex_html_tab <- rvest::read_html(ex_gt_raw) %>% rvest::html_node("table > tbody") # if row_first = TRUE, then just get the 1st row # otherwise select the remainder if(isTRUE(row_first)){ row_sel <- 1 } else { row_sel <- 2:6 } # use our example html # grab the column by number # get the rows by selection # test the expectation tested_out <- ex_html_tab %>% rvest::html_nodes(paste0("td:nth-child(", col_n , ")")) %>% rvest::html_text() %>% .[row_sel] if(row_first){ testthat::expect_match(tested_out, expectation) } else { n_spaces <- stringr::str_count(tested_out, "\\s") testthat::expect_equal(n_spaces, expectation) } } test_that("fmt_symbol_first works with escaped characters", { test_gt_by_col(1, expectation = "Ford \\$") test_gt_by_col(1, row_first = FALSE, expectation = rep(1, 5)) }) testthat::test_that("fmt_symbol_first, Raw percent character works", { test_gt_by_col(2, expectation = "2017%") test_gt_by_col(2, row_first = FALSE, expectation = rep(0, 5)) }) testthat::test_that("fmt_symbol_first, HTML symbol for percent works", { test_gt_by_col(4, expectation = "20.2%") test_gt_by_col(4, row_first = FALSE, expectation = rep(0, 5)) }) testthat::test_that("fmt_symbol_first, A combined suffix + symbol work", { test_gt_by_col(5, expectation = "647°F") test_gt_by_col(5, row_first = FALSE, expectation = rep(0, 5)) }) ================================================ FILE: tests/testthat/test-fontawesome-icons.R ================================================ test_that("fontawesome, test ratings all R and colors/numbers match", { check_suggests() skip_on_cran() skip_on_ci() rate_html <- mtcars %>% dplyr::select(mpg:hp) %>% dplyr::slice(1:5) %>% dplyr::mutate(rating = c(2, 3, 5, 4, 1)) %>% dplyr::add_row(mpg = mean(mtcars$mpg), cyl = 6, disp = 190, rating = NA) %>% gt::gt() %>% gt_fa_rating(rating, icon = "r-project") %>% gt::as_raw_html() %>% rvest::read_html() fa_stars <- rate_html %>% rvest::html_nodes("td:nth-child(5)") %>% rvest::html_nodes("svg") %>% rvest::html_attr("aria-label") star_color_fn <- function(row_n) { rate_html %>% rvest::html_nodes(paste0("tr:nth-child(", row_n, ")")) %>% rvest::html_nodes("td:nth-child(5)") %>% rvest::html_nodes("svg") %>% rvest::html_attr("style") %>% gsub(x = ., pattern = ".*fill:", "") %>% gsub(x = ., pattern = ";.*", "") } expect_equal(fa_stars, rep("R Project", 25)) expect_equal(star_color_fn(1), c(rep("orange", 2), rep("grey", 3))) expect_equal(star_color_fn(2), c(rep("orange", 3), rep("grey", 2))) expect_equal(star_color_fn(3), c(rep("orange", 5), rep("grey", 0))) expect_equal(star_color_fn(4), c(rep("orange", 4), rep("grey", 1))) expect_equal(star_color_fn(5), c(rep("orange", 1), rep("grey", 4))) }) # fa-palette -------------------------------------------------------------- # test_that("fontawesome, test repeats", { # check_suggests() # skip_on_cran() # skip_on_ci() # color_fn <- function(pal = "#FF0000") { # mtcars[1:5, 1:4] %>% # gt::gt() %>% # gt_fa_repeats(cyl, name = "car", palette = pal) %>% # gt::as_raw_html() %>% # rvest::read_html() %>% # rvest::html_nodes("td:nth-child(2)") %>% # rvest::html_nodes("svg") %>% # rvest::html_attr("style") %>% # gsub(x = ., pattern = ".*fill:", "") %>% # gsub(x = ., pattern = ";.*", "") # } # pal_out <- c("red", "blue", "green") # pal_rep <- c(rep("red", 12), rep("blue", 4), rep("red", 6), rep("green", 8)) # expect_equal(color_fn("#FF0000"), rep("#FF0000", 30)) # expect_equal(color_fn("blue"), rep("blue", 30)) # expect_equal(color_fn(pal_out), pal_rep) # }) # Check for palette ------------------------------------------------------- # test_that("fontawesome, test column, name and colors", { # check_suggests() # skip_on_cran() # skip_on_ci() # col_cog_fn <- function(pal) { # head(mtcars) %>% # dplyr::select(cyl, mpg, am, gear) %>% # dplyr::mutate(man = ifelse(am == 1, "gear", "gears")) %>% # gt::gt() %>% # gt_fa_column(man, palette = pal) %>% # gt::as_raw_html() %>% # rvest::read_html() %>% # rvest::html_nodes("td:nth-child(5)") %>% # rvest::html_nodes("svg") %>% # rvest::html_attr("style") %>% # gsub(x = ., pattern = ".*fill:", "") %>% # gsub(x = ., pattern = ";.*", "") %>% # substr(1, 7) # } # expect_equal(col_cog_fn(c("red", "green")), rep(c("red", "green"), each = 3)) # expect_equal(col_cog_fn(c("red")), rep(c("red"), each = 6)) # expect_equal(col_cog_fn(c("gear" = "red", "gears" = "green")), rep(c("red", "green"), each = 3)) # }) # Check for palette ------------------------------------------------------- test_that("fontawesome, test rank change", { check_suggests() skip_on_cran() base_tab <- dplyr::tibble(x = c(1:3, -1, -2, -5, 0)) %>% gt::gt() rank_tab <- base_tab %>% gt_fa_rank_change(x, font_color = "match") %>% gt::as_raw_html() %>% rvest::read_html() rank_tab_items <- rank_tab %>% rvest::html_elements("svg") %>% rvest::html_attrs() %>% lapply(function(x) { x[c("aria-label", "style")] %>% gsub(x = ., pattern = ".*fill:", "") %>% gsub(x = ., pattern = ";.*", "") }) expect_equal( c(sapply(rank_tab_items, function(x) x[1]) %>% unname()), c(rep("Angles Up", 3), rep("Angles Down", 3), "Equals") ) expect_equal( sapply(rank_tab_items, function(x) x[2]) %>% unname(), c(rep("#1b7837", 3), rep("#762a83", 3), "lightgrey") ) no_text <- base_tab %>% gt_fa_rank_change(x, show_text = FALSE, fa_type = "caret") %>% gt::as_raw_html() %>% rvest::read_html() no_text_items <- no_text %>% rvest::html_elements("svg") %>% rvest::html_attrs() %>% lapply(function(x) { x[c("aria-label", "style")] %>% gsub(x = ., pattern = ".*fill:", "") %>% gsub(x = ., pattern = ";.*", "") }) expect_equal( sapply(no_text_items, function(x) x[1]) %>% unname(), c(rep("Caret Up", 3), rep("Caret Down", 3), "Equals") ) expect_equal( sapply(no_text_items, function(x) x[2]) %>% unname(), c(rep("#1b7837", 3), rep("#762a83", 3), "lightgrey") ) custom_tab <- base_tab %>% gt_fa_rank_change( x, palette = c("blue", "grey", "red"), font_color = "black", fa_type = "caret" ) %>% gt::as_raw_html() %>% rvest::read_html() custom_tab_items <- custom_tab %>% rvest::html_elements("svg") %>% rvest::html_attrs() %>% lapply(function(x) { x[c("aria-label", "style")] %>% gsub(x = ., pattern = ".*fill:", "") %>% gsub(x = ., pattern = ";.*", "") }) expect_equal( sapply(custom_tab_items, function(x) x[1]) %>% unname(), c(rep("Caret Up", 3), rep("Caret Down", 3), "Equals") ) expect_equal( sapply(custom_tab_items, function(x) x[2]) %>% unname(), c(rep("blue", 3), rep("red", 3), "grey") ) }) ================================================ FILE: tests/testthat/test-generate_df.R ================================================ test_df <- generate_df( 100L, n_grps = 5, mean = seq(10, 50, length.out = 5), with_seed = 37 ) %>% dplyr::group_by(grp) %>% dplyr::summarise( mean = mean(values), # mean is approx mean sd = sd(values), # sd is approx sd n = n(), # each grp is of length n # showing that the sd default of mean/10 works `mean/sd` = round(mean / sd, 1) ) test_that("generate_df w/ n = 100", { expect_equal(test_df$n, rep(100, 5)) }) test_that("generate_df w/ n = 100", { expect_equal(round(test_df$mean, digits = 3), c(9.946, 20.156, 29.993, 39.361, 50.453)) }) test_that("Text ID in generate_df is equal length to N", { expect_equal(nchar(generate_df(10)$id), rep(3, 10)) expect_equal(nchar(generate_df(100)$id), rep(4, 100)) expect_equal(nchar(generate_df(1000)$id), rep(5, 1000)) }) ================================================ FILE: tests/testthat/test-gt-bar-html.R ================================================ test_that("gt_plt_bar_pct HTML is created and has specific values", { check_suggests() gt_bar_plot_tab <- mtcars %>% head() %>% dplyr::select(cyl, mpg) %>% dplyr::mutate( mpg_pct_max = round(mpg / max(mpg) * 100, digits = 2), mpg_scaled = mpg / max(mpg) * 100 ) %>% dplyr::mutate(mpg_unscaled = mpg) %>% gt::gt() %>% gt_plt_bar_pct(column = mpg_scaled, scaled = TRUE) %>% gt_plt_bar_pct( column = mpg_unscaled, scaled = FALSE, fill = "blue", background = "lightblue" ) %>% gt::as_raw_html() %>% rvest::read_html() #jotyuenmde > table > tbody > tr:nth-child(1) > td:nth-child(4) > div > div scaled_vals <- gt_bar_plot_tab %>% rvest::html_nodes("td:nth-child(4) > div > div") %>% rvest::html_attr("style") %>% gsub(x = ., pattern = ".*width:", replacement = "") %>% substr(1, 4) unscaled_vals <- gt_bar_plot_tab %>% rvest::html_nodes("td:nth-child(5) > div > div") %>% rvest::html_attr("style") %>% gsub(x = ., pattern = ".*width:", replacement = "") %>% substr(1, 4) expect_equal(scaled_vals, c("92.1", "92.1", "100%", "93.8", "82.0", "79.3")) expect_equal(unscaled_vals, c("92.1", "92.1", "100%", "93.8", "82.0", "79.3")) }) ================================================ FILE: tests/testthat/test-gt_add_divider.R ================================================ test_that("divider has border and type", { check_suggests() divide_html <- head(mtcars) %>% gt::gt() %>% gt_add_divider(columns = "cyl", style = "dashed") %>% gt::as_raw_html() %>% rvest::read_html() border_check <- function(row_n){ divide_html %>% rvest::html_nodes(paste0("td:nth-child(",row_n,")")) %>% rvest::html_attr("style") %>% gsub(x = ., pattern = ".*border-right-width: ", "") %>% gsub(x = ., pattern = " border-right-style: | border-right-color: ", "") } expect_equal(gsub(x=border_check(1), pattern ="; .*", ""), rep("1px;#D3D3D3", 6)) expect_equal(gsub(x=border_check(2), pattern ="; .*", ""), rep("2px;dashed;grey;", 6)) expect_equal(gsub(x=border_check(3), pattern ="; .*", ""), rep("1px;#D3D3D3", 6)) expect_equal(gsub(x=border_check(4), pattern ="; .*", ""), rep("1px;#D3D3D3", 6)) expect_equal(gsub(x=border_check(5), pattern ="; .*", ""), rep("1px;#D3D3D3", 6)) expect_equal(gsub(x=border_check(6), pattern ="; .*", ""), rep("1px;#D3D3D3", 6)) }) test_that("divider has border and type on far right", { check_suggests() divide_html_blue <- head(mtcars) %>% gt::gt() %>% gt_add_divider(columns = "carb", color = "blue", weight = px(5)) %>% gt::as_raw_html() %>% rvest::read_html() blue_border <- divide_html_blue %>% rvest::html_nodes("td:nth-child(11)") %>% rvest::html_attr("style") %>% gsub(x = ., pattern = ".*border-right-width: ", "") %>% gsub(x = ., pattern = " border-right-style: | border-right-color: ", "") expect_equal(blue_border, rep("5px;solid;blue;", 6)) }) test_that("divider has border and doesn't include labels", { check_suggests() divide_html_lab <- head(mtcars) %>% gt::gt() %>% gt_add_divider(columns = carb, include_labels = FALSE) %>% gt::as_raw_html() %>% rvest::read_html() lab_border <- divide_html_lab %>% rvest::html_nodes("td:nth-child(11)") %>% rvest::html_attr("style") %>% gsub(x = ., pattern = ".*border-right-width: ", "") %>% gsub(x = ., pattern = " border-right-style: | border-right-color: ", "") lab_top_border <- divide_html_lab %>% rvest::html_nodes("th:nth-child(11)") %>% rvest::html_attr("style") %>% gsub(x = ., pattern = ".*border-right-width: ", "") %>% gsub(x = ., pattern = " border-right-style: | border-right-color: ", "") %>% gsub(x = ., pattern = "; .*", "") expect_equal(lab_border, rep("2px;solid;grey;", 6)) expect_equal(lab_top_border, "1px;#D3D3D3") }) ================================================ FILE: tests/testthat/test-gt_color_box.R ================================================ test_that("gt_color_box palettes are created and have appropriate hex values", { check_suggests() test_data <- dplyr::tibble(x = letters[1:10], y = seq(100, 10, by = -10), z = seq(10, 100, by = 10), pff = seq(10, 100, by = 10), blank = seq(10, 100, by = 10)) color_box_html <- test_data %>% gt::gt() %>% gt_color_box(columns = y, domain = 0:100, palette = "ggsci::blue_material") %>% gt_color_box(columns = z, domain = 0:100, palette = c("purple", "lightgrey", "green")) %>% gt_color_box(columns = pff, domain = 0:100, palette = "pff") %>% gt_color_box(columns = blank, domain = 0:100, palette = NULL) %>% gt::as_raw_html() %>% rvest::read_html() get_colors <- function(n){ color_box_html %>% rvest::html_nodes(glue::glue("td:nth-child({n})")) %>% rvest::html_nodes("div > div > div:nth-child(1)") %>% rvest::html_attr("style") %>% sub(".*background-color: #", "", .) %>% substr(., 1, 6) } blue_colors <- get_colors(2) hulk_colors <- get_colors(3) pff_colors <- get_colors(4) def_colors <- get_colors(5) pff_def_colors <- c("E15B1F", "F48411", "FEA300", "FFBA00", "FFD000", "BBC416", "6FB620", "459D47", "437D77", "0C5EA0") def_def_colors <- c("9966A9", "BA9BCA", "DCC5E1", "EDE2EE", "F7F7F7", "E5F3E1", "C7E6C1", "91C98C", "5AA25F", "1B7837") expect_equal(blue_colors, c("0D47A1","1462BD","1873CE","1D83DF","2090ED", "349DF4","51ABF5","73BBF7","99CEF9","BFE0FB")) expect_equal(hulk_colors, c("B052EB","BC76E6","C696E0","CEB5DA","D3D3D3", "C0DDB5","A9E796","8CF075","65F84E","00FF00")) expect_equal(pff_colors, pff_def_colors) expect_equal(def_colors, def_def_colors) }) ================================================ FILE: tests/testthat/test-gt_color_rows.R ================================================ test_that("gt_color_rows palettes are created and have appropriate hex values", { check_suggests() base_red <- mtcars %>% head() %>% gt::gt() %>% gt_color_rows(mpg, domain = range(mtcars$mpg)) %>% gt::as_raw_html() %>% rvest::read_html() base_red_colors <- base_red %>% rvest::html_nodes("td:nth-child(1)") %>% rvest::html_attr("style") %>% sub(".*background-color: #", "", .) %>% substr(., 1, 6) blue_pal <- head(mtcars) %>% gt::gt() %>% gt_color_rows(mpg, palette = "ggsci::blue_material", domain = range(mtcars$mpg)) %>% gt::as_raw_html() %>% rvest::read_html() blue_colors <- blue_pal %>% rvest::html_nodes("td:nth-child(1)") %>% rvest::html_attr("style") %>% sub(".*background-color: #", "", .) %>% substr(., 1, 6) vector_pal <- head(mtcars) %>% gt::gt() %>% gt_color_rows( mpg, palette = c("#ffffff", "#00FF00"), domain = range(mtcars$mpg[1:6])) %>% gt::as_raw_html() %>% rvest::read_html() vector_colors <- vector_pal %>% rvest::html_nodes("td:nth-child(1)") %>% rvest::html_attr("style") %>% sub(".*background-color: #", "", .) %>% substr(., 1, 6) discrete_pal <- head(mtcars) %>% gt::gt() %>% gt_color_rows( cyl, pal_type = "discrete", palette = "ggthemes::colorblind", domain = range(mtcars$cyl) ) %>% gt::as_raw_html() %>% rvest::read_html() discrete_colors <- discrete_pal %>% rvest::html_nodes("td:nth-child(2)") %>% rvest::html_attr("style") %>% sub(".*background-color: #", "", .) %>% substr(., 1, 6) expect_equal(base_red_colors, c("EF524E","EF524E","F3473D","F0504B","E76E6D","E67575")) expect_equal(blue_colors, c("41A4F5","41A4F5","2C9AF4","3DA2F5","5FB2F6","67B6F6")) expect_equal(vector_colors, c("9BFF82","9BFF82","00FF00","88FF6F","EDFFE6","FFFFFF")) expect_equal(discrete_colors, c("98C160","98C160","000000","98C160","CC79A7","98C160")) expect_error(gt(head(mtcars)) %>% gt_color_rows( cyl, palette = "ggthemes::FAKENAME", domain = range(mtcars$cyl) ) ) }) ================================================ FILE: tests/testthat/test-gt_dot_bar.R ================================================ test_that("gt_plt_bullet SVG is created and has specific values", { check_suggests() dot_bar_tab <- mtcars %>% head() %>% dplyr::mutate(cars = sapply(strsplit(rownames(.), " "), `[`, 1)) %>% dplyr::select(cars, mpg, disp) %>% gt::gt() %>% gt_plt_dot(disp, cars, palette = "ggthemes::fivethirtyeight") %>% gt::as_raw_html() %>% rvest::read_html() dot_vals <- dot_bar_tab %>% rvest::html_nodes("div:nth-child(2) > div > div > div") %>% rvest::html_attr("style") %>% gsub(x = ., pattern = ".*width:", "") %>% substr(1, 4) dot_colors <- dot_bar_tab %>% rvest::html_nodes("div:nth-child(2) > div > div > div") %>% rvest::html_attr("style") %>% gsub(x = ., pattern = ".*background:", "") %>% substr(1, 7) expect_equal(dot_vals, c("44.4", "44.4", "30%;", "71.6", "100%", "62.5")) expect_equal(dot_colors, c("#3C3C3C", "#3C3C3C", "#E6E6E6", "#DA5D53", "#DA5D53", "#77AB43")) }) ================================================ FILE: tests/testthat/test-gt_duplicate_column.R ================================================ test_that("duplicate column, confirm column exists and matches", { check_suggests() dupe_table <- head(mtcars) %>% dplyr::select(mpg, disp) %>% gt::gt() %>% gt_duplicate_column(mpg, after = disp, append_text = "2") %>% gt::as_raw_html() %>% rvest::read_html() dupe_title <- rvest::html_node(dupe_table, "th:nth-child(3)") %>% rvest::html_text() dupe_vals <- rvest::html_nodes(dupe_table, "td:nth-child(3)") %>% rvest::html_text() %>% as.double() expect_equal(dupe_title, "mpg2") expect_equal(dupe_vals, mtcars$mpg[1:6]) }) test_that("duplicate column, check dupe_name", { check_suggests() dupe_table <- head(mtcars) %>% dplyr::select(mpg, disp) %>% gt::gt() %>% gt_duplicate_column(disp, after = mpg, dupe_name = "my_column") %>% gt::as_raw_html() %>% rvest::read_html() dupe_title <- rvest::html_node(dupe_table, "th:nth-child(2)") %>% rvest::html_text() dupe_vals <- rvest::html_nodes(dupe_table, "td:nth-child(2)") %>% rvest::html_text() %>% as.double() expect_equal(dupe_title, "my_column") expect_equal(dupe_vals, mtcars$disp[1:6]) }) ================================================ FILE: tests/testthat/test-gt_highlight_cols.R ================================================ test_that("gt_highlight_row correct row is highlighted and is blue", { check_suggests() basic_col <- gt::gt(head(mtcars)) %>% gt_highlight_cols(cyl, fill = "red", alpha = 0.5) %>% gt::as_raw_html() %>% rvest::read_html() high_col <- basic_col %>% rvest::html_nodes("td:nth-child(2)") %>% rvest::html_attr("style") %>% gsub(x = ., pattern = ".*background-color: ", "") %>% substr(1, 17) expect_equal(high_col, rep("rgba(255,0,0,0.5)", 6)) }) ================================================ FILE: tests/testthat/test-gt_highlight_rows.R ================================================ my_car <- head(mtcars[,1:5]) %>% tibble::rownames_to_column("car") basic_use <- gt::gt(my_car) %>% gt_highlight_rows(rows = 2, font_weight = "normal") target_bold_column <- gt::gt(my_car) %>% gt_highlight_rows( rows = 5, fill = "lightgrey", bold_target_only = TRUE, target_col = car ) tidyeval_tab <- gt::gt(my_car) %>% gt_highlight_rows(rows = grepl(x = car, pattern = "4 Drive|Valiant")) test_that("gt_highlight_row correct row is highlighted and is blue", { check_suggests() base_html <- basic_use %>% gt::as_raw_html() %>% rvest::read_html() high_row <- base_html %>% rvest::html_nodes("tr:nth-child(2) > td") %>% rvest::html_attr("style") %>% gsub(x = ., pattern = ".*background-color: ", "") %>% substr(6, 20) high_colors <- sapply(strsplit(high_row, ","), function(x) rgb(x[1], x[2], x[3], maxColorValue=255)) first_row <- base_html %>% rvest::html_nodes("tr:nth-child(1) > td") %>% rvest::html_attr("style") %>% grepl(x = ., pattern = "background-color") row2 <- base_html %>% rvest::html_nodes("tr:nth-child(2) > td") %>% rvest::html_attr("style") %>% grepl(x = ., pattern = "background-color") testthat::expect_true(all(first_row == FALSE)) testthat::expect_false(all(row2 == FALSE)) testthat::expect_true(all(high_colors == "#80BCD8")) }) test_that("gt_highlight_row target is bold", { check_suggests() target_html <- target_bold_column %>% gt::as_raw_html() %>% rvest::read_html() bold_rows <- target_html %>% rvest::html_nodes("td:nth-child(1)") %>% rvest::html_attr("style") %>% grepl(x = ., pattern = "font-weight: bold") testthat::expect_true(all(bold_rows[c(1:4,6)] == FALSE)) testthat::expect_true(isTRUE(bold_rows[5])) }) test_that("gt_highlight_row tidyeval works", { check_suggests() tidyeval_html <- tidyeval_tab %>% gt::as_raw_html() %>% rvest::read_html() color_rows <- tidyeval_html %>% rvest::html_nodes("td:nth-child(1)") %>% rvest::html_attr("style") %>% grepl(x = ., pattern = "background-color: rgba\\(128,188,216,0.8\\)") testthat::expect_true(all(color_rows[c(1:3,5)] == FALSE)) testthat::expect_true(all(color_rows[c(4,6)] == TRUE)) }) ================================================ FILE: tests/testthat/test-gt_hulk_color.R ================================================ # Gets the HTML attr value from a single key selection_value <- function(html, key) { selection <- paste0("[", key, "]") html %>% rvest::html_nodes(selection) %>% rvest::html_attr(key) } test_that("Hulk palette is created and has appropriate hex values", { check_suggests() hulk_basic <- mtcars %>% head() %>% gt::gt() %>% gt_hulk_col_numeric(mpg) hulk_gt_html <- hulk_basic %>% gt::as_raw_html() %>% rvest::read_html() hulk_colors <- hulk_gt_html %>% rvest::html_nodes("td:nth-child(1)") %>% rvest::html_attr("style") %>% sub(".*background-color: #", "", .) %>% substr(., 1, 6) expect_equal(hulk_colors, c("E2F2DE","E2F2DE","1B7837","C6E6C0","A276B4","762A83")) }) ================================================ FILE: tests/testthat/test-gt_image_multi_rows.R ================================================ test_that("img_mulit_rows, images exist", { check_suggests() skip_on_cran() teams <- "https://github.com/nflverse/nflfastR-data/raw/master/teams_colors_logos.rds" team_df <- readRDS(url(teams)) temp_nm <- tempfile(fileext = ".html") conf_table <- team_df %>% dplyr::select(team_conf, team_division, logo = team_logo_espn) %>% dplyr::distinct() %>% tidyr::nest(data = logo) %>% dplyr::rename(team_logos = data)%>% gt::gt(id = "myTable") %>% gt_img_multi_rows(columns = team_logos, height = 25) %>% gtsave(temp_nm) conf_html <- rvest::read_html(temp_nm) out_img <- conf_html %>% rvest::html_elements("td:nth-child(3)") %>% rvest::html_elements("img") %>% rvest::html_attr("src") %>% sort() in_img <- team_df %>% dplyr::select(team_conf, team_division, logo = team_logo_espn) %>% dplyr::distinct() %>% dplyr::pull(logo) %>% sort() expect_equal(out_img, in_img) }) ================================================ FILE: tests/testthat/test-gt_image_rows.R ================================================ test_that("img_rows, images exist", { check_suggests() skip_on_cran() teams <- "https://github.com/nflverse/nflfastR-data/raw/master/teams_colors_logos.rds" team_df <- readRDS(url(teams)) temp_nm <- tempfile(fileext = ".html") logo_table <- team_df %>% dplyr::select(team_wordmark, team_abbr, logo = team_logo_espn, team_name:team_conf) %>% head() %>% gt::gt(id = "myTable") %>% gt_img_rows(columns = team_wordmark, height = 25) %>% gtsave(temp_nm) logo_html <- rvest::read_html(temp_nm) out_img <- logo_html %>% rvest::html_elements("td:nth-child(1)") %>% rvest::html_elements("img") %>% rvest::html_attr("src") in_img <- team_df$team_wordmark[1:6] expect_equal(out_img, in_img) }) ================================================ FILE: tests/testthat/test-gt_img_circle.R ================================================ test_that("svg is created and has specific values", { check_suggests() skip_on_cran() skip_on_ci() base_table <- dplyr::tibble( x = 1, names = c("Hadley Wickham"), img = c( "https://upload.wikimedia.org/wikipedia/commons/thumb/f/fa/Hadley-wickham2016-02-04.jpg/800px-Hadley-wickham2016-02-04.jpg" ) ) %>% gt::gt() %>% gt_img_circle(img) %>% gt::as_raw_html() %>% rvest::read_html() test_style <- base_table %>% rvest::html_elements("div") %>% rvest::html_attr("style") %>% lapply(function(x){ grepl(x = x, pattern = paste0( "background-size:cover;background-position:center;", "border: 1.5px solid black;border-radius: 50%;height:25px;width:100%;" ) ) }) %>% unlist() expect_equal(test_style, c(FALSE)) }) ================================================ FILE: tests/testthat/test-gt_index.R ================================================ test_that("gt_index has correct inputs, correct ouput index, and can affect correct rows", { check_suggests() # This is a key step, as gt will create the row groups # based on first observation of the unique row items # this sampling will return a row-group order for cyl of 6,4,8 set.seed(1234) sliced_data <- mtcars %>% dplyr::group_by(cyl) %>% dplyr::slice_head(n = 3) %>% dplyr::ungroup() %>% # randomize the order dplyr::slice_sample(n = 9) # not in "order" yet raw_order <- sliced_data$cyl # But unique order of 6,4,8 unique_order <- unique(sliced_data$cyl) # Expect input order to match --------------------------------------------- expect_equal(c(6,4,8), unique_order) expect_equal(c(6, 6, 6, 4, 8, 4, 8, 8, 4), raw_order) # creating a standalone basic table test_tab <- sliced_data %>% gt::gt(groupname_col = "cyl") # can style a specific column based on the contents of another column tab_out_styled <- test_tab %>% gt::tab_style(locations = cells_body(mpg, rows = gt_index(., am) == 0), style = cell_fill("red") ) %>% gt::as_raw_html() %>% rvest::read_html() expect_equal( tab_out_styled %>% rvest::html_elements("td:nth-child(1)") %>% as.character() %>% grepl("background-color", .), c(TRUE, FALSE, FALSE, FALSE, TRUE, TRUE, TRUE, TRUE, TRUE) ) # tab_pattern <- "background-color: \\s*(.*?)\\s*;" # reg_matches <- regmatches(tab_styled, regexec(tab_pattern, tab_styled)) %>% # lapply(function(x){x[2]}) %>% # unlist() # # # Expect color backgrounds to match --------------------------------------- # # # expect_equal(reg_matches, c("#FFFFFF", "#FF0000", NA, NA, "#FFFFFF", NA, # "#FF0000", "#FF0000", "#FFFFFF", "#FF0000", # "#FF0000", "#FF0000")) # OR can extract the underlying data in the "correct order" # according to the internal gt structure, ie arranged by group # by cylinder, 6,4,8 # gt_index(test_tab, mpg, as_vector = TRUE) # gt_index(test_tab, mpg, as_vector = FALSE) sliced_arranged <- sliced_data %>% dplyr::mutate(cyl = factor(cyl, levels = unique_order)) %>% dplyr::arrange(cyl) %>% dplyr::mutate(cyl = as.character(cyl)) # Expect the values to match ---------------------------------------------- # expect_equal(gt_index(test_tab, mpg, as_vector = FALSE), # sliced_arranged) # expect_equal(gt_index(test_tab, mpg, as_vector = TRUE), # c(21.4, 21, 21, 22.8, 24.4, 22.8, 14.3, 18.7, 16.4)) }) ================================================ FILE: tests/testthat/test-gt_pct_bar.R ================================================ # test_that("gt_pct_bar SVG is created and has specific values", { # check_suggests() # ex_df <- dplyr::tibble( # x = c("Example 1","Example 1", # "Example 1","Example 2","Example 2","Example 2", # "Example 3","Example 3","Example 3","Example 4","Example 4", # "Example 4"), # measure = c("Measure 1","Measure 2", # "Measure 3","Measure 1","Measure 2","Measure 3", # "Measure 1","Measure 2","Measure 3","Measure 1","Measure 2", # "Measure 3"), # data = c(30, 20, 50, 30, 30, 40, 30, 40, 30, 30, 50, 20) # ) # tab_df <- ex_df %>% # dplyr::group_by(x) %>% # dplyr::summarise(list_data = list(data)) # ex_tab <- tab_df %>% # gt::gt() %>% # gt_plt_bar_stack(column = list_data) %>% # gt::as_raw_html() %>% # rvest::read_html() # bar_vals <- ex_tab %>% # rvest::html_nodes("svg > g > rect") %>% # rvest::html_attr("x") %>% # as.double() # bar_colors <- ex_tab %>% # rvest::html_nodes("svg > g > rect") %>% # rvest::html_attr("style") %>% # gsub(x = ., pattern = ".*fill: #", "") # expect_equal(bar_vals, c(0, 59.53, 99.21, 0, 59.53, 119.06, # 0, 59.53, 138.9, 0, 59.53, 158.74)) # expect_equal( # bar_colors, # c("FF4343;", "BFBFBF;", "0A1C2B;", "FF4343;", "BFBFBF;", "0A1C2B;", # "FF4343;", "BFBFBF;", "0A1C2B;", "FF4343;", "BFBFBF;", "0A1C2B;") # ) # }) test_that("gt_pct_bar SVG is created and has specific palette", { check_suggests() testthat::skip_on_cran() testthat::skip_on_ci() ex_df <- dplyr::tibble( x = c( "Example 1", "Example 1", "Example 2", "Example 2", "Example 3", "Example 3", "Example 4", "Example 4" ), measure = c( "Measure 1", "Measure 2", "Measure 1", "Measure 2", "Measure 1", "Measure 2", "Measure 1", "Measure 2" ), data = c(30, 20, 50, 30, 30, 40, 30, 40) ) tab_df <- ex_df %>% dplyr::group_by(x) %>% dplyr::summarise(list_data = list(data)) ex_tab <- tab_df %>% gt::gt() %>% gtExtras::gt_plt_bar_stack( column = list_data, labels = c("Lab 1", "Lab 2") ) %>% gt::as_raw_html() %>% rvest::read_html() bar_vals <- ex_tab %>% rvest::html_nodes("svg > g > g > rect") %>% rvest::html_attr("x") %>% as.double() bar_colors <- ex_tab %>% rvest::html_nodes( "svg > g > g > rect:nth-child(2), svg > g > g > rect:nth-child(3)" ) %>% rvest::html_attr("style") %>% gsub(x = ., pattern = ".*fill: #", "") expect_equal( round(bar_vals, 2), c(0.00, 119.06, 0.00, 124.02, 0.00, 85.04, 0.00, 85.04) ) expect_equal( bar_colors, c( #"FF4343;", "BFBFBF;", #"FF4343;", "BFBFBF;", #"FF4343;", "BFBFBF;", #"FF4343;", "BFBFBF;" ) ) }) ================================================ FILE: tests/testthat/test-gt_plt_bar.R ================================================ test_that("gt_plt_bar svg is created and has specific values", { check_suggests() testthat::skip_on_cran() testthat::skip_on_ci() bar_tbl <- mtcars %>% head() %>% gt::gt() %>% gt_plt_bar(column = mpg, keep_column = TRUE) %>% gt::as_raw_html() %>% rvest::read_html() bar_tbl_neg <- dplyr::tibble( x = LETTERS[1:6], vals = c(6, 4, 2, -2, -4, -6) ) %>% gt::gt() %>% gt_plt_bar(vals, scale_type = "number") %>% gt::as_raw_html() %>% rvest::read_html() # SVG exists and is of length ---- bar_len <- bar_tbl %>% rvest::html_nodes("svg") %>% length() bar_neg_len <- bar_tbl_neg %>% rvest::html_nodes("svg") %>% length() expect_equal(bar_len, 6) expect_equal(bar_neg_len, 6) # SVG has specific points ---- bar_vals <- bar_tbl %>% rvest::html_nodes("svg > g > g > rect") %>% rvest::html_attr("width") bar_neg_vals <- bar_tbl_neg %>% rvest::html_nodes("svg > g > g > rect") %>% rvest::html_attr("width") expect_equal( bar_vals, c("90.61", "90.61", "98.37", "92.33", "80.68", "78.10") ) expect_equal( bar_neg_vals, c("49.19", "32.79", "16.40", "16.40", "32.79", "49.19") ) }) ================================================ FILE: tests/testthat/test-gt_plt_bullet.R ================================================ test_that("gt_plt_bullet SVG is created and has specific values", { check_suggests() bullet_tab <- tibble::rownames_to_column(mtcars) %>% dplyr::select(rowname, cyl:drat, mpg) %>% dplyr::group_by(cyl) %>% dplyr::mutate(target_col = round(mean(mpg), digits = 1)) %>% dplyr::slice_head(n = 3) %>% dplyr::ungroup() %>% gt::gt() %>% gt_plt_bullet( column = mpg, target = target_col, width = 45, palette = c("lightblue", "black") ) %>% gt::as_raw_html() %>% rvest::read_html() bar_vals <- bullet_tab %>% rvest::html_nodes("svg > g > g > rect") %>% rvest::html_attr("width") %>% as.double() %>% round(digits = 1) target_vals <- bullet_tab %>% rvest::html_nodes("svg > g") %>% rvest::html_nodes("line") %>% .[seq(1, 17, by = 2)] %>% rvest::html_attr("x1") %>% as.double() %>% round(digits = 0) exp_bar_vals <- c(103.7, 110.9, 103.7, 95.5, 95.5, 97.3, 85, 65, 74.6) exp_tar_vals <- c(121, 121, 121, 90, 90, 90, 69, 69, 69) expect_equal(length(bar_vals), length(exp_bar_vals)) expect_equal(length(target_vals), length(exp_tar_vals)) }) # test_that("gt_plt_bullet keep_column = TRUE", { # check_suggests() # # bullet_df <- tibble::rownames_to_column(mtcars) %>% # dplyr::select(rowname, cyl:drat, mpg) %>% # dplyr::group_by(cyl) %>% # dplyr::mutate(target_col = round(mean(mpg), digits = 1)) %>% # dplyr::slice_head(n = 3) %>% # dplyr::ungroup() # # bullet_tab <- bullet_df %>% # gt::gt() %>% # gt_plt_bullet(column = mpg, target = target_col, width = 45, # colors = c("lightblue", "black"), keep_column = TRUE) %>% # gt::as_raw_html() %>% # rvest::read_html() # # bar_vals <- bullet_tab %>% # rvest::html_nodes("svg > g > g > rect") %>% # rvest::html_attr("width") %>% # as.double() %>% # round(digits = 1) # # dupe_vals <- bullet_tab %>% # rvest::html_nodes("td:nth-child(6)") %>% # rvest::html_text() %>% # as.double() # # target_vals <- bullet_tab %>% # rvest::html_nodes("svg > g") %>% # rvest::html_nodes("line") %>% # .[seq(1, 17, by = 2)] %>% # rvest::html_attr("x1") %>% # as.double() %>% # round(digits = 0) # # exp_bar_vals <- c(103.7, 110.9, 103.7, 95.5, 95.5, 97.3, 85, 65, 74.6) # exp_tar_vals <- c(121, 121, 121, 90, 90, 90, 69, 69, 69) # expect_equal(bar_vals, exp_bar_vals) # expect_equal(target_vals, exp_tar_vals) # expect_equal(dupe_vals, bullet_df$mpg[1:9]) # # }) ================================================ FILE: tests/testthat/test-gt_plt_conf_int.R ================================================ test_that("gt_plt_conf_int generates correct points/text", { check_suggests() testthat::skip_on_cran() ci_table <- generate_df( n = 50, n_grps = 3, mean = c(10, 15, 20), sd = c(10, 10, 10), with_seed = 37 ) %>% dplyr::group_by(grp) %>% dplyr::summarise( n = dplyr::n(), avg = mean(values), sd = sd(values), list_data = list(values) ) %>% gt::gt() %>% gt_plt_conf_int(list_data, ci = 0.9) %>% gt::as_raw_html() %>% rvest::read_html() lab_text <- ci_table %>% rvest::html_elements("svg > g > g > text") %>% rvest::html_text() expect_equal(lab_text, c("11", "7", "17", "14", "21", "16")) ci_tab_attrs <- ci_table %>% rvest::html_elements("svg > g > g > circle") %>% rvest::html_attrs() ci_tab_style <- ci_tab_attrs %>% lapply(function(x) { x[c("style")] }) %>% unlist() %>% unname() expect_equal( ci_tab_style, rep( "stroke-linecap: round; stroke-linejoin: round; stroke-miterlimit: 10.00; stroke-width: 1.06; stroke: #FFFFFF; fill: #000000;", 3 ) ) ci_tab_svg <- ci_tab_attrs %>% lapply(function(x) { x[names(x) %in% c("cx")] }) %>% unlist() %>% unname() expect_equal(ci_tab_svg, c("29.48", "72.84", "95.20")) }) test_that("gt_plt_conf_int uses correct points/text/colors", { check_suggests() testthat::skip_on_cran() # You can also provide your own values # based on your own algorithm/calculations pre_calc_ci_tab <- dplyr::tibble( mean = c(12, 10), ci1 = c(8, 5), ci2 = c(16, 15), ci_plot = c(12, 10) ) %>% gt::gt() %>% gt_plt_conf_int( ci_plot, c(ci1, ci2), palette = c("red", "lightgrey", "black", "red") ) %>% gt::as_raw_html() %>% rvest::read_html() lab_text_pre <- pre_calc_ci_tab %>% rvest::html_elements("svg > g > g > text") %>% rvest::html_text() expect_equal(lab_text_pre, c("16", "8", "15", "5")) pre_tab_attrs <- pre_calc_ci_tab %>% rvest::html_elements("svg > g > g > circle") %>% rvest::html_attrs() pre_tab_style <- pre_tab_attrs %>% lapply(function(x) { x[c("style")] }) %>% unlist() %>% unname() expect_equal( pre_tab_style, rep( "stroke: #000000; stroke-linecap: round; stroke-linejoin: round; stroke-miterlimit: 10.00; stroke-width: 1.06; fill: #FF0000;", 2 ) ) pre_tab_svg <- pre_tab_attrs %>% lapply(function(x) { x[names(x) %in% c("cx")] }) %>% unlist() %>% unname() expect_equal(pre_tab_svg, c("76.96", "59.39")) }) ================================================ FILE: tests/testthat/test-gt_plt_dist.R ================================================ test_that("svg is created", { check_suggests() base_tab <- mtcars %>% dplyr::group_by(cyl) %>% # must end up with list of data for each row in the input dataframe dplyr::summarize(mpg_data = list(mpg), .groups = "drop") %>% gt() get_svg_len <- function(table){ table %>% gt::as_raw_html() %>% rvest::read_html() %>% rvest::html_nodes("svg") %>% length() } # basic dens gt_dens <- base_tab %>% gt_plt_dist(mpg_data) # bw dens gt_dens_bw <- base_tab %>% gt_plt_dist(mpg_data, bw = 3) # same_limit dens gt_dens_lim <- base_tab %>% gt_plt_dist(mpg_data, bw = 3, same_limit = FALSE) gt_dens_trim <- base_tab %>% gt_plt_dist(mpg_data, bw = 3, same_limit = FALSE) # basic hist gt_hist <- base_tab %>% gt_plt_dist(mpg_data, type = "histogram") gt_hist_bw <- base_tab %>% gt_plt_dist(mpg_data, type = "histogram", bw = 2) gt_hist_lim <- base_tab %>% gt_plt_dist(mpg_data, type = "histogram", bw = 2, same_limit = FALSE) gt_rug <- base_tab %>% gt_plt_dist(mpg_data, type = "rug_strip") gt_box <- base_tab %>% gt_plt_dist(mpg_data, type = "boxplot") expect_equal(get_svg_len(gt_dens), 3) expect_equal(get_svg_len(gt_dens_bw), 3) expect_equal(get_svg_len(gt_dens_lim), 3) expect_equal(get_svg_len(gt_dens_trim), 3) expect_equal(get_svg_len(gt_box), 3) expect_equal(get_svg_len(gt_hist), 3) expect_equal(get_svg_len(gt_hist_bw), 3) expect_equal(get_svg_len(gt_hist_lim), 3) expect_equal(get_svg_len(gt_rug), 3) }) ================================================ FILE: tests/testthat/test-gt_plt_percentile_dot.R ================================================ test_that("add_pcttile_plot creates a plot", { check_suggests() plt15 <- add_pcttile_plot(15, "green", TRUE, 25) %>% #htmltools::browsable() rvest::read_html() plt15_text <- plt15 %>% rvest::html_elements("svg > g > g > text") %>% rvest::html_text() expect_equal(plt15_text, c("0", "100", "5", "0")) pt15 <- plt15 %>% rvest::html_elements("svg > g > g") %>% rvest::html_elements("circle") %>% rvest::html_attrs() %>% .[[1]] %>% gsub(x = ., ".*fill: ", "") %>% gsub(x = ., ";.*", "") %>% unname() expect_equal(pt15, c("12.88", "4.94", "3.56", "#00FF00")) plt75 <- add_pcttile_plot(75, "#00FF00", FALSE, 25) %>% rvest::read_html() plt75_text <- plt75 %>% rvest::html_elements("svg > g > g > text") %>% rvest::html_text() expect_equal(plt75_text, character(0)) pt75 <- plt75 %>% rvest::html_elements("svg > g > g") %>% rvest::html_elements("circle") %>% rvest::html_attrs() %>% .[[1]] %>% gsub(x = ., ".*fill: ", "") %>% gsub(x = ., ";.*", "") %>% unname() expect_equal(pt75, c("51.54", "4.94", "3.56", "#00FF00")) }) test_that("gt_plt_percentile works as intended", { check_suggests() dot_plt <- dplyr::tibble(x = c(seq(10, 90, length.out = 5))) %>% gt::gt() %>% gt_duplicate_column(x, dupe_name = "dot_plot") %>% gt_plt_percentile(dot_plot) %>% gt::as_raw_html() %>% rvest::read_html() dot_txt <- dot_plt %>% rvest::html_elements("svg > g > g > text") %>% rvest::html_text() expect_equal(dot_txt, rep(c("0", "100", "5", "0"), 2)) dot_pts <- dot_plt %>% rvest::html_elements("svg > g > g > circle") %>% rvest::html_attrs() %>% lapply(., function(x) { gsub(x = x, ".*fill: ", "") %>% gsub(x = ., ";.*", "") %>% unname() %>% .[c(1, 4)] }) %>% unlist() exp_pts <- c( "9.66", "#F72E2E", "22.55", "#FF9C8B", "35.43", "#F0F0F0", "48.32", "#9BB3E4", "61.20", "#007AD6" ) expect_equal(dot_pts, exp_pts) }) ================================================ FILE: tests/testthat/test-gt_plt_point.R ================================================ test_that("add_point_plot creates a plot", { check_suggests() plt15 <- add_point_plot(15, c("blue"), TRUE, 25, c(2, 90), .1) %>% rvest::read_html() plt15_text <- plt15 %>% rvest::html_elements("svg > g > g > text") %>% rvest::html_text() expect_equal(plt15_text, c("2.0", "90.0")) pt15 <- plt15 %>% rvest::html_elements("svg > g > g") %>% rvest::html_elements("circle") %>% rvest::html_attrs() %>% .[[1]] %>% gsub(x = ., ".*fill: ", "") %>% gsub(x = ., ";.*", "") %>% unname() expect_equal(pt15, c("12.74", "4.94", "3.56", "#0000FF")) plt75 <- add_point_plot(75, c("blue"), FALSE, 25, c(2, 90), .1) %>% rvest::read_html() plt75_text <- plt75 %>% rvest::html_elements("svg > g > g > text") %>% rvest::html_text() expect_equal(plt75_text, character(0)) pt75 <- plt75 %>% rvest::html_elements("svg > g > g") %>% rvest::html_elements("circle") %>% rvest::html_attrs() %>% .[[1]] %>% gsub(x = ., ".*fill: ", "") %>% gsub(x = ., ";.*", "") %>% unname() expect_equal(pt75, c("56.66", "4.94", "3.56", "#0000FF")) }) test_that("gt_plt_point works as intended", { check_suggests() dot_plt <- dplyr::tibble(x = c(seq(1.2e6, 2e6, length.out = 5))) %>% gt::gt() %>% gt_duplicate_column(x, dupe_name = "point_plot") %>% gt_plt_point(point_plot, accuracy = .1, width = 25) %>% gt::as_raw_html() %>% rvest::read_html() dot_txt <- dot_plt %>% rvest::html_elements("svg > g > g > text") %>% rvest::html_text() expect_equal(dot_txt, rep(c("1.1M", "2.1M"), 2)) dot_pts <- dot_plt %>% rvest::html_elements("svg > g > g > circle") %>% rvest::html_attrs() %>% lapply(., function(x) { gsub(x = x, ".*fill: ", "") %>% gsub(x = ., ";.*", "") %>% unname() %>% .[c(1, 4)] }) %>% unlist() exp_pts <- c( "8.59", "#F72E2E", "22.01", "#FF9C8B", "35.43", "#F0F0F0", "48.85", "#9BB3E4", "62.28", "#007AD6" ) expect_equal(dot_pts, exp_pts) }) ================================================ FILE: tests/testthat/test-gt_plt_sparkline.R ================================================ test_that("svg is created and has specific values", { check_suggests() basic_gt <- mtcars %>% dplyr::group_by(cyl) %>% # must end up with list of data for each row in the input dataframe dplyr::summarize(mpg_data = list(mpg), .groups = "drop") %>% gt() # basic sparkline gt_sparkline_tab <- basic_gt %>% gt_plt_sparkline(mpg_data) gt_ref_median <- basic_gt %>% gt_plt_sparkline(mpg_data, type = "ref_median") gt_shaded <- basic_gt %>% gt_plt_sparkline(mpg_data, type = "shaded") gt_mean <- basic_gt %>% gt_plt_sparkline(mpg_data, type = "ref_mean") gt_points <- basic_gt %>% gt_plt_sparkline(mpg_data, type = "points") gt_last <- basic_gt %>% gt_plt_sparkline(mpg_data, type = "ref_last") gt_iqr <- basic_gt %>% gt_plt_sparkline(mpg_data, type = "ref_iqr") get_html <- function(table) { table %>% gt::as_raw_html() %>% rvest::read_html() } basic_html <- get_html(gt_sparkline_tab) median_html <- get_html(gt_ref_median) mean_html <- get_html(gt_mean) points_html <- get_html(gt_points) last_html <- get_html(gt_last) iqr_html <- get_html(gt_iqr) # SVG Exists and is of length 3 ---- get_length <- function(html) { html %>% rvest::html_nodes("svg") %>% length() } all_lengths <- sapply( list(basic_html, median_html, mean_html, points_html, last_html, iqr_html), get_length ) expect_equal(all_lengths, rep(3, 6)) # SVG has specific points ---- spark_vals <- basic_html %>% rvest::html_node("polyline") %>% rvest::html_attr("points") %>% substr(1, 34) expect_equal(spark_vals, "8.16,6.80 13.89,6.08 19.61,6.80 25") }) ================================================ FILE: tests/testthat/test-gt_summary_table.R ================================================ test_that("summary_table created", { # basic summary exibble <- gt::exibble exibble$int <- as.integer(1:8) gt_sum <- create_sum_table(exibble) expect_equal(names(gt_sum), c("type", "name", "value", "n_missing", "Mean", "Median", "SD")) out_list <- lapply(gt_sum, class) compare_list <- list(type = "character", name = "character", value = "list", n_missing = "numeric", Mean = "numeric", Median = "numeric", SD = "numeric") expect_equal(out_list, compare_list) type_col<- c("numeric", "character", "factor", "character", "character", "character", "numeric", "character", "character", "integer") expect_equal(type_col, gt_sum$type) }) test_that("table is created with expected output", { check_suggests() skip_on_cran() skip_on_ci() my_exibble <- gt::exibble %>% dplyr::mutate(date = as.Date(date), time = hms::parse_hm(time), datetime = as.POSIXct(datetime,tz="America/Chicago") ) ex_tab <- gt_plt_summary(my_exibble) vec_miss <- ex_tab[["_data"]][["n_missing"]] vec_miss_out <- c(0.125, 0.125, 0, 0.125, 0.125, 0.125, 0.125, 0, 0) expect_equal(vec_miss, vec_miss_out) ex_html <- ex_tab %>% gt::as_raw_html() %>% rvest::read_html() ex_svg_len <- ex_html %>% rvest::html_nodes("svg") %>% length() expect_equal(ex_svg_len, 18) }) test_that("svg is created", { check_suggests() num_plot <- plot_data(gt::exibble$num, n_missing = 0.1) chr_plot <- plot_data(gt::exibble$char, n_missing = 0.1) expect_true("html" %in% class(num_plot)) expect_true("html" %in% class(chr_plot)) num_html <- num_plot %>% rvest::read_html() chr_html <- chr_plot %>% rvest::read_html() # SVG Exists and is of length 3 ---- num_len <- num_html %>% rvest::html_nodes("svg") %>% length() chr_len <- chr_html %>% rvest::html_nodes("svg") %>% length() expect_equal(num_len, 1) expect_equal(chr_len, 1) }) ================================================ FILE: tests/testthat/test-gt_text_img.R ================================================ test_that("gt_text_img is created and matches", { check_suggests() skip_on_cran() temp_nm <- tempfile(fileext = ".html") in_title <- "https://upload.wikimedia.org/wikipedia/commons/thumb/f/f3/Boston_Terrier_male.jpg/330px-Boston_Terrier_male.jpg" title_car <- mtcars %>% head() %>% gt::gt() %>% gt::tab_header( title = add_text_img( "A table about cars made with", url = in_title, height = px(30) ) ) %>% gt::gtsave(temp_nm) title_html <- rvest::read_html(temp_nm) out_title <- title_html %>% rvest::html_elements("img") %>% rvest::html_attr("src") expect_equal(out_title, in_title) }) ================================================ FILE: tests/testthat/test-gt_win_loss.R ================================================ test_that("SVG exists and has expected values", { check_suggests() data_in <- dplyr::tibble( grp = rep(c("A", "B", "C"), each = 10), wins = c( 0.5, 0.5, 0, 0, 1, 1, 1, 0, 0, 1, 0, 0, 1, 0, 1, 1, 1, 0, 0.5, 0, 0, 1, 0, 0, 0, 1, 0, 0, 1, 0 ) ) %>% dplyr::group_by(grp) %>% dplyr::summarize(wins = list(wins), .groups = "drop") pill_table <- data_in %>% gt::gt() %>% gt_plt_winloss(wins) %>% gt::as_raw_html() %>% rvest::read_html() box_table <- data_in %>% gt::gt() %>% gt_plt_winloss(wins, type = "square") %>% gt::as_raw_html() %>% rvest::read_html() # SVG Exists and is of length 3 ---- pill_len <- pill_table %>% rvest::html_nodes("svg") %>% length() square_len <- box_table %>% rvest::html_nodes("svg") %>% length() expect_equal(pill_len, 3) expect_equal(square_len, 3) # SVG has specific points ---- pill_vals <- pill_table %>% rvest::html_nodes("tr:nth-child(2) > td") %>% rvest::html_nodes("svg > g > g > line") %>% rvest::html_attrs() %>% lapply(function(xy) xy[['y1']]) %>% unlist() square_vals <- box_table %>% rvest::html_nodes("tr:nth-child(2) > td") %>% rvest::html_nodes("svg > g > g > polygon") %>% rvest::html_attr("points") %>% substr(1, 4) expect_equal( pill_vals, c( "8.91", "8.91", "1.89", "8.91", "1.89", "1.89", "1.89", "8.91", "6.10", "8.91" ) ) expect_equal( square_vals, c( "3.26", "6.72", "10.1", "13.6", "17.1", "20.5", "24.0", "27.5", "30.9", "34.4" ) ) }) test_that("SVG exists and has expected colors", { check_suggests() data_in <- dplyr::tibble( grp = rep(c("A", "B", "C"), each = 10), wins = c( 0.5, 0.5, 0, 0, 1, 1, 1, 0, 0, 1, 0, 0, 1, 0, 1, 1, 1, 0, 0.5, 0, 0, 1, 0, 0, 0, 1, 0, 0, 1, 0 ) ) %>% dplyr::group_by(grp) %>% dplyr::summarize(wins = list(wins), .groups = "drop") pill_table <- data_in %>% gt::gt() %>% gt_plt_winloss(wins, palette = c("green", "purple", "black")) %>% gt::as_raw_html() %>% rvest::read_html() box_table <- data_in %>% gt::gt() %>% gt_plt_winloss( wins, type = "square", palette = c("green", "purple", "black") ) %>% gt::as_raw_html() %>% rvest::read_html() # SVG Exists and is of length 3 ---- pill_len <- pill_table %>% rvest::html_nodes("svg") %>% length() square_len <- box_table %>% rvest::html_nodes("svg") %>% length() expect_equal(pill_len, 3) expect_equal(square_len, 3) pill_colors <- pill_table %>% rvest::html_nodes("svg > g > g > line") %>% rvest::html_attr("style") %>% lapply(., function(x) { strsplit(x, split = "stroke: #", fixed = TRUE)[[1]][2] }) %>% unlist() box_colors <- box_table %>% rvest::html_nodes("svg > g > g > polygon") %>% rvest::html_attr("style") %>% lapply(., function(x) { strsplit(x, split = "fill: #", fixed = TRUE)[[1]][2] }) %>% unlist() exp_pill_colors <- c( NA, NA, "A020F0;", "A020F0;", "00FF00;", "00FF00;", "00FF00;", "A020F0;", "A020F0;", "00FF00;", "A020F0;", "A020F0;", "00FF00;", "A020F0;", "00FF00;", "00FF00;", "00FF00;", "A020F0;", NA, "A020F0;", "A020F0;", "00FF00;", "A020F0;", "A020F0;", "A020F0;", "00FF00;", "A020F0;", "A020F0;", "00FF00;", "A020F0;" ) exp_box_colors <- c( "000000;", "000000;", "A020F0;", "A020F0;", "00FF00;", "00FF00;", "00FF00;", "A020F0;", "A020F0;", "00FF00;", "A020F0;", "A020F0;", "00FF00;", "A020F0;", "00FF00;", "00FF00;", "00FF00;", "A020F0;", "000000;", "A020F0;", "A020F0;", "00FF00;", "A020F0;", "A020F0;", "A020F0;", "00FF00;", "A020F0;", "A020F0;", "00FF00;", "A020F0;" ) expect_equal(box_colors, exp_box_colors) expect_equal(pill_colors, exp_pill_colors) }) ================================================ FILE: tests/testthat/test-gtsave_extra.R ================================================ test_that("gtsave_extra, file out works", { check_suggests() skip_if_not_installed("webshot2") skip_on_cran() skip_on_ci() # Create a filename with path, having the # .html extension path_1 <- tempfile(fileext = ".png") on.exit(unlink(path_1), add = TRUE) # Expect that a file does not yet exist # on that path expect_false(file.exists(path_1)) car_tab <- head(mtcars) %>% gt::gt() # expect_silent(gtsave_extra(car_tab, path_1)) }) ================================================ FILE: tests/testthat/test-html-helpers.R ================================================ test_that("details tag is created", { check_suggests() gt_label_details("howdy", c("big" = "if true", "hat" = "Cowboy")) %>% grepl(x = ., "
") %>% expect_true() }) test_that("tooltip is created", { check_suggests() out_tooltip <- with_tooltip("What do cowboys say?", "Howdy!") %>% as.character() exp_tooltip <- paste0("", "What do cowboys say?") expect_equal(out_tooltip, exp_tooltip) }) test_that("hyperlink is created", { check_suggests() skip_on_cran() out_hyperlink <- gt_hyperlink("rstudio.com", "https://rstudio.com") %>% as.character() exp_hyperlink <- "rstudio.com" expect_equal(out_hyperlink, exp_hyperlink) }) test_that("badge color is created",{ out_badge_color <- add_badge_color("red", "label text", 0.2) %>% as.character() exp_badge_color <- paste0( "
label text
") expect_equal(out_badge_color, exp_badge_color) }) test_that("badge color is created and accurate in gt", { check_suggests() badge_tab <- head(mtcars) %>% dplyr::mutate(cyl = paste(cyl, "Cyl")) %>% gt::gt() %>% gt_badge(cyl, palette = c("4 Cyl"="red","6 Cyl"="blue","8 Cyl"="green")) %>% gt::as_raw_html() %>% rvest::read_html() raw_colors <- badge_tab %>% rvest::html_elements("td:nth-child(2) > div") %>% rvest::html_attrs() %>% lapply(function(x){ strsplit(x, "; ", fixed = TRUE)}) %>% lapply(function(x){ x$style[6] %>% gsub(x=., "background:", "") }) %>% unlist() exp_colors <- c(rep("#0000FF33;",2), "#FF000033;", "#0000FF33;", "#00FF0033;", "#0000FF33;") expect_equal(raw_colors, exp_colors) }) ================================================ FILE: tests/testthat/test-icon_fun.R ================================================ test_that("fa_icon_repeat, is a fa icon", { check_suggests() skip_on_cran() svg_len <- fa_icon_repeat() %>% rvest::read_html() %>% rvest::html_elements("svg") %>% length() expect_equal(class(fa_icon_repeat()), c("html", "character")) expect_equal(svg_len, 3) }) ================================================ FILE: tests/testthat/test-img_header.R ================================================ test_that("img_header generates img", { check_suggests() skip_on_cran() example_img <- img_header( "Luka Doncic", "https://secure.espn.com/combiner/i?img=/i/headshots/nba/players/full/3945274.png", height = 45, font_size = 10 ) %>% rvest::read_html() exp_attr <- example_img %>% rvest::html_element("div > img") %>% rvest::html_attrs() out_attr <- c("src" = "https://secure.espn.com/combiner/i?img=/i/headshots/nba/players/full/3945274.png", "height" = "45px", "style" = "border-bottom: 2px solid black;") expect_equal(exp_attr, out_attr) exp_div <- example_img %>% rvest::html_element("div > div") %>% rvest::html_attrs() act_div <- c("style" = "font-size:10px;color: black;text-align: center;width:100%;font-weight:bold;") expect_equal(exp_div, act_div) }) ================================================ FILE: tests/testthat/test-merge_and_stack.R ================================================ test_that("merge_stack, vals match expected and location", { check_suggests() merged_tab <- head(mtcars) %>% dplyr::mutate(cars = sapply(strsplit(rownames(.)," "), `[`, 1), .before = mpg) %>% dplyr::select(1:4) %>% gt::gt() %>% gt_merge_stack(cars, mpg) %>% gt::as_raw_html() %>% rvest::read_html() merged_vals <- merged_tab %>% rvest::html_nodes("td:nth-child(1)") %>% rvest::html_text() exp_vals <- c("Mazda\n21", "Mazda\n21", "Datsun\n22.8", "Hornet\n21.4", "Hornet\n18.7", "Valiant\n18.1") expect_equal(merged_vals, exp_vals) }) ================================================ FILE: tests/testthat/test-tab_style_by_grp.R ================================================ test_that("tab_style_by_grp, groups respected", { check_suggests() df_in <- mtcars %>% dplyr::select(cyl:hp, mpg) %>% tibble::rownames_to_column() %>% dplyr::group_by(cyl) %>% dplyr::slice(1:4) %>% dplyr::ungroup() test_tab <- df_in %>% gt::gt(groupname_col = "cyl") %>% tab_style_by_grp(mpg, fn = max, cell_fill(color = "red", alpha = 0.5)) %>% gt::as_raw_html() %>% rvest::read_html() get_grp_rows <- function(row_n){ test_tab %>% rvest::html_elements(paste0("tr:nth-child(", row_n,") > td:nth-child(4)")) %>% rvest::html_attr("style") %>% gsub(x = ., pattern = ".*background-color: |;", "") } grp_colors <- lapply(c(5, 9, 12), get_grp_rows) %>% unlist() other_rows <- lapply(c(1:4, 6:8, 10:11), get_grp_rows) %>% unlist() %>% grepl(x = ., "rgb") expect_equal(grp_colors, rep("rgba(255,0,0,0.5)", 3)) expect_true(all(other_rows == FALSE)) }) ================================================ FILE: tests/testthat/test-two-column-layouts.R ================================================ test_that("two_column_layout, two gt_tbl objects", { check_suggests() skip_if_not_installed("webshot2") skip_on_cran() skip_on_ci() # define your own function my_gt_function <- function(x){ gt::gt(x) } two_tables <- gt_double_table(mtcars, my_gt_function, nrows = 16) two_tab_null <- gt_double_table(mtcars, my_gt_function) two_obj <- sapply(two_tables, function(x) (class(x)[1])) two_obj_null <- sapply(two_tables, function(x) (class(x)[1])) expect_equal(two_obj, rep("gt_tbl", 2)) expect_equal(two_obj_null, rep("gt_tbl", 2)) }) test_that("two_column_layout saving works", { check_suggests() skip_if_not_installed("webshot2") skip_on_cran() skip_on_ci() # Create a filename with path, having the # .html extension path_1 <- tempfile(fileext = ".html") on.exit(unlink(path_1), add = TRUE) # Expect that a file does not yet exist # on that path expect_false(file.exists(path_1)) # add row numbers and drop some columns my_cars <- mtcars %>% dplyr::mutate(row_n = dplyr::row_number(), .before = mpg) %>% dplyr::select(row_n, mpg:drat) # create a one-argument function, passing data to `gt::gt()` my_gt_fn <- function(x){ gt(x) %>% gtExtras::gt_color_rows(columns = row_n, domain = 1:32) } # pass data, your function and the nrows my_tables <- gt_double_table(my_cars, my_gt_fn, nrows = nrow(my_cars)/2) # boom, this will return it to the viewer my_output <- gt_two_column_layout(my_tables) path_2 <- tempfile(fileext = ".png") on.exit(unlink(path_2), add = TRUE) # Expect that a file does not yet exist # on that path expect_false(file.exists(path_2)) raw_html <- gt_two_column_layout(my_tables, output = "html") %>% htmltools::save_html(path_1) # now file exists expect_true(file.exists(path_1)) # save as png gt_two_column_layout(my_tables, output = "save", filename = path_2, vwidth = 550, vheight = 620) # png exists expect_true(file.exists(path_2)) # output to browsable/ie viewer view_browse <- gt_two_column_layout(my_tables, output = "viewer", filename = path_2, vwidth = 550, vheight = 620) # is viewable expect_true(htmltools::is.browsable(view_browse)) }) ================================================ FILE: tests/testthat/test-utils.R ================================================ test_that("n_decimals are expected", { expect_equal(n_decimals(12345), 0) expect_equal(n_decimals(1234.5), 1) expect_equal(n_decimals(123.45), 2) expect_equal(n_decimals(12.345), 3) expect_equal(n_decimals(1.2345), 4) expect_equal(n_decimals(00.12345), 5) expect_equal(n_decimals(.00100), 3) expect_equal(n_decimals(.001), 3) }) test_that("bw calc is appropriate", { expect_equal(round(bw_calc(mtcars$mpg), digits = 3), 4.646) expect_equal(round(bw_calc(c(mtcars$mpg, NA)), digits = 3), 4.599) }) test_that("save_svg exports and imports SVG", { check_suggests() base_plot <- ggplot2::ggplot(aes(x=mpg, y=wt), data = mtcars) out_plot <- save_svg(base_plot) expect_true("html" %in% class(out_plot)) out_svg <- out_plot %>% rvest::read_html() %>% rvest::html_nodes("svg") %>% length() expect_equal(out_svg, 1) }) ================================================ FILE: tests/testthat/test_test-gt_pct_bar.R ================================================ # R test_that("gt_pct_bar SVG structure, positions, and default palette are correct", { check_suggests() testthat::skip_on_cran() testthat::skip_on_ci() # Helpers get_bar_rect_nodes <- function(doc) { nodes <- rvest::html_nodes(doc, "svg > g > g > rect") if (length(nodes) == 0) { nodes <- rvest::html_nodes(doc, "svg > g > rect") } nodes } normalize_colors <- function(styles) { # Extract hex after 'fill: #' and remove trailing ';', make uppercase cols <- gsub(".*fill:\\s*#([0-9a-fA-F]{6}).*", "\\1", styles, perl = TRUE) toupper(cols) } # Data ex_df <- dplyr::tibble( x = c( "Example 1", "Example 1", "Example 2", "Example 2", "Example 3", "Example 3", "Example 4", "Example 4" ), measure = c( "Measure 1", "Measure 2", "Measure 1", "Measure 2", "Measure 1", "Measure 2", "Measure 1", "Measure 2" ), data = c(30, 20, 50, 30, 30, 40, 30, 40) ) tab_df <- ex_df %>% dplyr::group_by(x) %>% dplyr::summarise(list_data = list(data), .groups = "drop") ex_tab <- tab_df %>% gt::gt() %>% gt_plt_bar_stack(column = list_data, labels = c("Lab 1", "Lab 2")) %>% gt::as_raw_html() %>% rvest::read_html() rect_nodes <- get_bar_rect_nodes(ex_tab) expect_gt(length(rect_nodes), 0L) # Extract attributes bar_x <- ex_tab %>% rvest::html_nodes( "svg > g > g > text:nth-child(4), svg > g > g > text:nth-child(5)" ) %>% rvest::html_attr("x") %>% as.double() styles <- ex_tab %>% rvest::html_nodes( "svg > g > g > text:nth-child(4), svg > g > g > text:nth-child(5)" ) %>% rvest::html_attr("style") # There should be 4 rows expect_length(bar_x, 4L) expect_length(styles, 4L) }) test_that("gt_pct_bar respects a custom two-color palette", { check_suggests() testthat::skip_on_cran() testthat::skip_on_ci() # Helpers get_bar_rect_nodes <- function(doc) { nodes <- rvest::html_nodes(doc, "svg > g > g > rect") if (length(nodes) == 0) { nodes <- rvest::html_nodes(doc, "svg > g > rect") } nodes } normalize_colors <- function(styles) { cols <- gsub(".*fill:\\s*#([0-9a-fA-F]{6}).*", "\\1", styles, perl = TRUE) toupper(cols) } pal <- c("#112233", "#8899AA") ex_df <- dplyr::tibble( x = c( "Example 1", "Example 1", "Example 2", "Example 2", "Example 3", "Example 3", "Example 4", "Example 4" ), measure = c( "Measure 1", "Measure 2", "Measure 1", "Measure 2", "Measure 1", "Measure 2", "Measure 1", "Measure 2" ), data = c(30, 20, 50, 30, 30, 40, 30, 40) ) tab_df <- ex_df %>% dplyr::group_by(x) %>% dplyr::summarise(list_data = list(data), .groups = "drop") ex_tab <- tab_df %>% gt::gt() %>% gt_plt_bar_stack(column = list_data, palette = pal) %>% gt::as_raw_html() %>% rvest::read_html() rect_nodes <- ex_tab %>% rvest::html_nodes( "svg > g > g > text:nth-child(4), svg > g > g > text:nth-child(5)" ) %>% rvest::html_attr("x") %>% as.double() expect_gt(length(rect_nodes), 0L) # Extract attributes styles <- ex_tab %>% rvest::html_nodes( "svg > g > g > text:nth-child(4), svg > g > g > text:nth-child(5)" ) %>% rvest::html_attr("style") cols <- normalize_colors(styles) expect_length(cols, 4L) }) ================================================ FILE: tests/testthat.R ================================================ library(testthat) library(gtExtras) test_check("gtExtras") ================================================ FILE: vignettes/.gitignore ================================================ *.html *.R ================================================ FILE: vignettes/articles/plotting-with-gtExtras.Rmd ================================================ --- title: "Plotting with gtExtras" --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` ## Graphs vs Tables Per Stephen Few in his book, [*Show Me the Numbers*](http://www.perceptualedge.com/library.php): The difference between Tables and Graphs: > Tables: Display used to look up and compare individual values > Graphs: Display used to reveal relationships among whole sets of values and their overall shape While we typically reach for our graphing tools whenever we want to tell a story with data, we are likely underutilizing tables. We can merge graphs and tables to often get the best of both worlds. ## Get started We can first load our libraries. ```{r setup, message=FALSE, warning=FALSE} library(gt) library(gtExtras) library(dplyr, warn.conflicts = FALSE) library(ggplot2) ``` ### Sparklines Per [Wikipedia](https://en.wikipedia.org/wiki/Sparkline): > A sparkline is a very small line chart, typically drawn without axes or coordinates. It presents the general shape of the variation (typically over time) in some measurement, such as temperature or stock market price, in a simple and highly condensed way. ![A 1999 screenshot of an implementation of sparklines developed around January 1998. The concept was developed by interaction designer Peter Zelchenko in conversation with programmer Michael Medved, while Medved was developing the QuoteTracker application. The product was later sold to Ameritrade.](https://upload.wikimedia.org/wikipedia/commons/thumb/9/95/Screenshot_of_Sparklines_in_Medved_QuoteTracker%2C_1998.png/330px-Screenshot_of_Sparklines_in_Medved_QuoteTracker%2C_1998.png) We can use `gtExtras::gt_plt_sparkline()` to add an inline sparkline very quickly. A necessary prep step is to first convert from a long data format to a summarized data format, where each row represents one "group" and the data column is now a vector of the values. ```{r} mtcars %>% head() ``` By using `summarize(list_data = list(col_name))` we can create a list-column of ALL the data for that group. ```{r} car_summary <- mtcars %>% dplyr::group_by(cyl) %>% dplyr::summarize( mean = mean(mpg), sd = sd(mpg), # must end up with list of data for each row in the input dataframe mpg_data = list(mpg), .groups = "drop" ) car_summary ``` ```{r} car_summary %>% arrange(desc(cyl)) %>% gt() %>% gtExtras::gt_plt_sparkline(mpg_data) %>% fmt_number(columns = mean:sd, decimals = 1) ``` ### Sparkline alternatives You can also plot a density-plot or a histogram instead of just a line plot, note that we've switched to `gt_plt_dist()` since we're plotting a true distribution now. ```{r} car_summary %>% arrange(desc(cyl)) %>% gt() %>% gtExtras::gt_plt_dist(mpg_data, type = "density", line_color = "blue", fill_color = "red") %>% fmt_number(columns = mean:sd, decimals = 1) ``` ```{r} car_summary %>% arrange(desc(cyl)) %>% gt() %>% gtExtras::gt_plt_dist(mpg_data, type = "histogram", line_color = "purple", fill_color = "green", bw = 4) %>% fmt_number(columns = mean:sd, decimals = 1) ``` ### Inline bars You can also generate `ggplot2` created bar plots inline. Note that `keep_column` allows you to keep the raw values and the plot inline. ```{r} mtcars %>% dplyr::select(cyl:wt, mpg) %>% head() %>% gt() %>% gt_plt_bar(column = mpg, keep_column = TRUE, width = 35) ``` ### Percent bars Alternatively, you may prefer the HTML-generated bar plotsfrom `gt_plt_bar_pct()`. Note that the bars represent a percentage of max, so the largest value will indicate 100% of the row. You can pass raw values that are scaled to a 0-100% range, or pass values between 0 and 100 that represent an existing percent. ```{r} mtcars %>% head() %>% dplyr::select(cyl, mpg) %>% dplyr::mutate(mpg_pct_max = round(mpg/max(mpg) * 100, digits = 2), mpg_scaled = mpg/max(mpg) * 100) %>% dplyr::mutate(mpg_unscaled = mpg) %>% gt() %>% gt_plt_bar_pct(column = mpg_scaled, scaled = TRUE) %>% gt_plt_bar_pct(column = mpg_unscaled, scaled = FALSE, fill = "blue", background = "lightblue") %>% cols_align("center", contains("scale")) %>% cols_width(4 ~ px(125), 5 ~ px(125)) ``` ### Inline Win Loss plots You can also generate really nice looking "Win Loss" plots, similar to the ones used by [The Guardian](https://www.theguardian.com/football/premierleague/table) for Soccer outcomes. The code to bring in the data via the `{nflreadr}` package is hidden in an expandable tab below.
Bring data in ```{r, eval = FALSE} library(dplyr) games_df <- nflreadr::load_schedules() %>% filter(season == 2020, game_type == "REG") %>% select(game_id, team_home = home_team, team_away = away_team, result, week) %>% tidyr::pivot_longer(contains('team'), names_to = 'home_away', values_to = 'team', names_prefix = 'team_') %>% mutate( result = ifelse(home_away == 'home', result, -result), win = ifelse(result == 0 , 0.5, ifelse(result > 0, 1, 0)) ) %>% select(week, team, win) %>% mutate( team = case_when( team == 'STL' ~ 'LA', team == 'OAK' ~ 'LV', team == 'SD' ~ 'LAC', T ~ team ) ) team_df <- nflreadr::load_teams() %>% select(team_wordmark, team_abbr, team_conf, team_division) joined_df <- games_df %>% group_by(team) %>% summarise( Wins = length(win[win==1]), Losses = length(win[win==0]), outcomes = list(win), .groups = "drop") %>% left_join(team_df, by = c("team" = "team_abbr")) %>% select(team_wordmark, team_conf, team_division, Wins:outcomes) final_df <- joined_df %>% filter(team_conf == "AFC") %>% group_by(team_division) %>% arrange(desc(Wins)) %>% ungroup() %>% arrange(team_division) %>% select(-team_conf) %>% mutate(team_division = stringr::str_remove(team_division, "AFC |NFC ")) %>% mutate( team_division = factor(team_division, levels = c("North", "South", "East", "West") ) ) %>% arrange(team_division) ``` ```{r, echo = FALSE} final_df <- tibble::tribble( ~team_wordmark, ~team_division, ~Wins, ~Losses, ~outcomes, "https://github.com/nflverse/nflfastR-data/raw/master/wordmarks/PIT.png", "North", 12L, 4L, c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 1, 0), "https://github.com/nflverse/nflfastR-data/raw/master/wordmarks/BAL.png", "North", 11L, 5L, c(1, 1, 0, 1, 1, 1, 0, 1, 0, 0, 0, 1, 1, 1, 1, 1), "https://github.com/nflverse/nflfastR-data/raw/master/wordmarks/CLE.png", "North", 11L, 5L, c(0, 1, 1, 1, 1, 0, 1, 0, 1, 1, 1, 1, 0, 1, 0, 1), "https://github.com/nflverse/nflfastR-data/raw/master/wordmarks/CIN.png", "North", 4L, 11L, c(0, 0, 0.5, 1, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1, 1, 0), "https://github.com/nflverse/nflfastR-data/raw/master/wordmarks/IND.png", "South", 11L, 5L, c(0, 1, 1, 1, 0, 1, 1, 0, 1, 1, 0, 1, 1, 1, 0, 1), "https://github.com/nflverse/nflfastR-data/raw/master/wordmarks/TEN.png", "South", 11L, 5L, c(1, 1, 1, 1, 1, 0, 0, 1, 0, 1, 1, 0, 1, 1, 0, 1), "https://github.com/nflverse/nflfastR-data/raw/master/wordmarks/HOU.png", "South", 4L, 12L, c(0, 0, 0, 0, 1, 0, 0, 1, 0, 1, 1, 0, 0, 0, 0, 0), "https://github.com/nflverse/nflfastR-data/raw/master/wordmarks/JAX.png", "South", 1L, 15L, c(1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), "https://github.com/nflverse/nflfastR-data/raw/master/wordmarks/BUF.png", "East", 13L, 3L, c(1, 1, 1, 1, 0, 0, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1), "https://github.com/nflverse/nflfastR-data/raw/master/wordmarks/MIA.png", "East", 10L, 6L, c(0, 0, 1, 0, 1, 1, 1, 1, 1, 0, 1, 1, 0, 1, 1, 0), "https://github.com/nflverse/nflfastR-data/raw/master/wordmarks/NE.png", "East", 7L, 9L, c(1, 0, 1, 0, 0, 0, 0, 1, 1, 0, 1, 1, 0, 0, 0, 1), "https://github.com/nflverse/nflfastR-data/raw/master/wordmarks/NYJ.png", "East", 2L, 14L, c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0), "https://github.com/nflverse/nflfastR-data/raw/master/wordmarks/KC.png", "West", 14L, 2L, c(1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0), "https://github.com/nflverse/nflfastR-data/raw/master/wordmarks/LV.png", "West", 8L, 8L, c(1, 1, 0, 0, 1, 0, 1, 1, 1, 0, 0, 1, 0, 0, 0, 1), "https://github.com/nflverse/nflfastR-data/raw/master/wordmarks/LAC.png", "West", 7L, 9L, c(1, 0, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 1, 1, 1, 1), "https://github.com/nflverse/nflfastR-data/raw/master/wordmarks/DEN.png", "West", 5L, 11L, c(0, 0, 0, 1, 1, 0, 1, 0, 0, 1, 0, 0, 1, 0, 0, 0) ) ```
Note that we have a list-column of the outcomes for each team. ```{r} glimpse(final_df) ``` And now we can generate an example table! ```{r} final_df %>% gt(groupname_col = "team_division") %>% cols_label(team_wordmark = "") %>% cols_align("left", team_division) %>% gtExtras::gt_plt_winloss(outcomes, max_wins = 16, type = "pill") %>% gtExtras::gt_img_rows(columns = team_wordmark, height = 20) %>% gtExtras::gt_theme_538() %>% tab_header( title = gtExtras::add_text_img( "2020 Results by Division", url = "https://github.com/nflverse/nflfastR-data/raw/master/AFC.png", height = 30 ) ) %>% tab_options(data_row.padding = px(2)) ``` ### Inline bar plots We can also do inline bar plots, purely via HTML! You can customize the colors, and have the option to scale or use unscaled values. ```{r} gt_bar_plot_tab <- mtcars %>% head() %>% dplyr::select(cyl, mpg) %>% dplyr::mutate( mpg_pct_max = round(mpg / max(mpg) * 100, digits = 2), mpg_scaled = mpg / max(mpg) * 100 ) %>% dplyr::mutate(mpg_unscaled = mpg) %>% gt() %>% gt_plt_bar_pct(column = mpg_scaled, scaled = TRUE) %>% gt_plt_bar_pct(column = mpg_unscaled, scaled = FALSE, fill = "blue", background = "lightblue") %>% cols_align("center", contains("scale")) %>% cols_width( 4 ~ px(125), 5 ~ px(125) ) gt_bar_plot_tab ``` ### Stacked Percent bar charts We can create a horizontal stacked percent bar chart inline like so. The data can be prepped as seen in the expandable section below.
```{r} library(dplyr) library(tidyr) library(gt) player_df <- tibble( player = c( "Evan Mobley", "Sandro Mamukelashvili", "Charles Bassey", "Luke Garza", "Moses Wright", "Neemias Queta", "Isaiah Jackson", "Day'Ron Sharpe" ), team = c( "USC", "Seton Hall", "Western Kentucky", "Iowa", "Georgia Tech", "Utah St", "Kentucky", "North Carolina" ), ht = c( "7'0\"", "6'10\"", "6'10\"", "6'11\"", "6'9\"", "7'1\"", "6'11\"", "6'10\"" ), dk_pct_time = c(40, 48, 50, 50, 51, 55, 60, 66), dk_pps = c(1.62, 1.02, 1.54,1.33,1.46,1.37,1.33,1.18), tip_pct_time = c(26, 10, 19, 15, 25, 27, 15, 24), tip_pps = c(0.88, .97,1,1.05, .63, .85, .76, .84), jmp_pct_time = c(33, 42, 31, 35, 25, 18, 25, 10), jmp_pps = c(.91, .91, .78, 1.04, .86, .74, .71, .42) ) %>% left_join( tibble( player = c( "Evan Mobley", "Sandro Mamukelashvili", "Charles Bassey", "Luke Garza", "Moses Wright", "Neemias Queta", "Isaiah Jackson", "Day'Ron Sharpe" ) %>% rep(each = 3), shot_type = c("Dunks + Lays", "Hooks + Floats", "Jumpers") %>% rep(8) ) %>% mutate( shot_type = factor(shot_type, levels = c("Jumpers", "Hooks + Floats", "Dunks + Lays")), shot_mix = c( 40, 26, 33, 48, 10, 42, 50, 19, 31, 50, 15, 35, 51, 25, 25, 55, 27, 18, 60, 15, 25, 66, 24, 10 ) ), by = "player" ) ```
```{r} basic_tb <- player_df %>% group_by(player) %>% summarize(dunks = shot_mix[1], list_data = list(shot_mix)) %>% arrange(dunks) %>% gt() ``` ```{r} basic_tb %>% gt_plt_bar_stack(list_data, width = 65, labels = c("DUNKS", "HOOKS/FLOATS", "JUMPERS"), palette= c("#ff4343", "#bfbfbf", "#0a1c2b")) %>% gt_theme_538() ``` ### Bullet chart There's also an option to create [bullet charts](https://en.wikipedia.org/wiki/Bullet_graph) which represent a core value and a target metric. ![A representative diagram of a bullet chart, where there's a specific target value represented by a vertical line and a core value represented as a thin bar plot.](https://upload.wikimedia.org/wikipedia/commons/thumb/9/9a/Labelled_Bullet_Graph_Example.svg/500px-Labelled_Bullet_Graph_Example.svg.png) ```{r} set.seed(37) bullet_df <- tibble::rownames_to_column(mtcars) %>% dplyr::select(rowname, cyl:drat, mpg) %>% dplyr::group_by(cyl) %>% dplyr::mutate(target_col = mean(mpg)) %>% dplyr::slice_sample(n = 3) %>% dplyr::ungroup() bullet_df %>% gt() %>% gt_plt_bullet(column = mpg, target = target_col, width = 45, palette = c("lightblue", "black")) ``` Note that for now, if you want to use any of the `gt::fmt_` functions on your `column` of interest, you'll need to create a duplicate column ahead of time. ```{r} bullet_df %>% dplyr::mutate(plot_column = mpg) %>% gt() %>% gt_plt_bullet(column = plot_column, target = target_col, width = 45) %>% fmt_number(mpg, decimals = 1) ```