Showing preview only (545K chars total). Download the full file or copy to clipboard to get everything.
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 <https://gist.github.com/mrcaseb/f0f85b48df7957c27c4205cafccbc5a2>
* 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(
'<div><span style=" display:inline-block; text-align:right; width:{max_int}ch"> {int_prefix} </span>',
"{sep}",
'<span style=" display:inline-block; text-align:left; width:{max_dec}ch"> {dec_suffix} </span></div>'
)
}
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("<span style='color:grey;'><1%</span>")
}
})
}
) %>%
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,
"<span style='color: transparent;'>", symbol, suffix,"</span>"
) %>% 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("<bold style='color:#d3d3d3;'>--</bold>"))
} 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
#' #> <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
#' #> 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(
"<div style='{css_styles}'>",
"<span style='{span_styles}'>{label}</span></div>"
)
} 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(
"<div style='{css_styles}'>",
"<span style='{span_styles}'>{label}</span></div>"
)
}
} else if (!is.na(x)) {
glue::glue(
"<div style='background:{fill};width:{scaled_value}%;height:{height}px;'></div>" # no labels added
)
} else if (is.na(x)) {
"<div style='background:transparent;width:0%;height:{height}px;'></div>" # no labels added
}
})
chart <- lapply(bar, function(bar) {
glue::glue(
"<div style='flex-grow:1;margin-left:8px;background:{background};'>{bar}</div>"
)
})
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(
"<div style='background:{fill};width:{scaled_value}%;height:4px;border-radius: 2px'></div>"
)
})
chart <- lapply(bar, function(bar) {
glue::glue(
"<div style='flex-grow:1;margin-left:0px;'>{bar}</div>"
) %>%
as.character() %>%
gt::html()
})
chart
}
color_dots <- function(x) {
if (x %in% c("NA", "NULL")) {
return("<div></div>")
}
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("<div></div>")
}
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(
"<span style='color:{lab_pal1}'><b>{lab1}</b></span>",
"||",
"<span style='color:{lab_pal2}'><b>{lab2}</b></span>"
) %>%
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(
"<div><span style='color:{lab_pal1}'><b>{lab1}</b></span>",
"||",
"<span style='color:{lab_pal2}'><b>{lab2}</b></span>",
"||",
"<span style='color:{lab_pal3}'><b>{lab3}</b></span></div>"
) %>%
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("<div></div>")
}
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("<div></div>")
}
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("<div></div>")
}
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("<div></div>")
}
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("<div></div>")
}
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("<div></div>")
} 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("<div></div>")
}
# 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(
"<div style='max-width: 150px;'>
<details style='font-weight: normal !important;'>
<summary style='font-weight: bold !important;'>{name}</summary>
{glue::glue_collapse(value_count, ', ', last = ' and ')}
</details></div>"
)
)
} 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
#' #> <chr> <chr> <list> <dbl> <dbl> <dbl> <dbl>
#' #> 1 numeric Sepal.Length <dbl [150]> 0 5.84 5.8 0.828
#' #> 2 numeric Sepal.Width <dbl [150]> 0 3.06 3 0.436
#' #> 3 numeric Petal.Length <dbl [150]> 0 3.76 4.35 1.77
#' #> 4 numeric Petal.Width <dbl [150]> 0 1.20 1.3 0.762
#' #> 5 factor Species <fct [150]> 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("<div></div>")
}
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("<div style='display:inline;vertical-align: top;'>{text}</div>")
img_div <- glue::glue("<div style='display:inline;margin-left:10px'>{web_image(url = url, height = height)}</div>")
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),
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
Condensed preview — 185 files, each showing path, character count, and a content snippet. Download the .json file or copy for the full structured content (553K chars).
[
{
"path": ".Rbuildignore",
"chars": 258,
"preview": "^.*\\.Rproj$\n^\\.Rproj\\.user$\n^README\\.Rmd$\n^LICENSE\\.md$\n^doc$\n^docs$\n^images$\n^Meta$\n^codecov\\.yml$\n^_pkgdown\\.yaml$\n^.c"
},
{
"path": ".github/.gitignore",
"chars": 7,
"preview": "*.html\n"
},
{
"path": ".github/ISSUE_TEMPLATE/bug.md",
"chars": 1663,
"preview": "---\nname: Bug\nabout: Something is wrong with gtExtras.\ntitle: ''\nlabels: 'Type: ☹︎ Bug'\nassignees: jthomasmock\n---\n\n## P"
},
{
"path": ".github/ISSUE_TEMPLATE/feature.md",
"chars": 682,
"preview": "---\nname: New feature\nabout: Suggest a new feature.\ntitle: ''\nlabels: 'Type: ★ Enhancement'\nassignees: jthomasmock\n---\n\n"
},
{
"path": ".github/ISSUE_TEMPLATE/question.md",
"chars": 1393,
"preview": "---\nname: Question\nabout: Ask a question.\ntitle: ''\nlabels: 'Type: ⁇ Question'\nassignees: ''\n---\n\n## Prework\n\n* [ ] If t"
},
{
"path": ".github/workflows/R-CMD-check.yaml",
"chars": 1255,
"preview": "# Workflow derived from https://github.com/r-lib/actions/tree/master/examples\n# Need help debugging build failures? Star"
},
{
"path": ".github/workflows/pkgdown.yaml",
"chars": 1261,
"preview": "# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples\n# Need help debugging build failures? Start at"
},
{
"path": ".gitignore",
"chars": 184,
"preview": ".Rproj.user\n.covrignore\n.Rhistory\n.RData\n.Ruserdata\n.Rdata\n.httr-oauth\n.DS_Store\ngtExtras.Rproj\ninst/doc\n/doc/\n/Meta/\ndo"
},
{
"path": "DESCRIPTION",
"chars": 1525,
"preview": "Type: Package\nPackage: gtExtras\nTitle: Extending 'gt' for Beautiful HTML Tables\nVersion: 0.6.2\nAuthors@R: c(\n person("
},
{
"path": "LICENSE",
"chars": 41,
"preview": "YEAR: 2022\nCOPYRIGHT HOLDER: Thomas Mock\n"
},
{
"path": "LICENSE.md",
"chars": 1070,
"preview": "# MIT License\n\nCopyright (c) 2022 Thomas Mock\n\nPermission is hereby granted, free of charge, to any person obtaining a c"
},
{
"path": "NAMESPACE",
"chars": 2582,
"preview": "# Generated by roxygen2: do not edit by hand\n\nexport(\"%>%\")\nexport(add_text_img)\nexport(all_of)\nexport(any_of)\nexport(co"
},
{
"path": "NEWS.md",
"chars": 8590,
"preview": "# gtExtras 0.6.1\n\n* Resolve issues with ggplot2 v4\n\n# gtExtras 0.6.0\n\n* Handle interquartile range of zero in `gt_plt_su"
},
{
"path": "R/fmt_pad_num.R",
"chars": 2210,
"preview": "#' Format numeric columns to align at decimal point without trailing zeroes\n#'\n#' @description\n#' This function removes "
},
{
"path": "R/fmt_pct_extra.R",
"chars": 1069,
"preview": "#' Convert to percent and show less than 1% as <1% in grey\n#'\n#' @param gt_object An existing gt table\n#' @param columns"
},
{
"path": "R/fmt_symbol_first.R",
"chars": 6089,
"preview": "#' Aligning first-row text only\n#' @description\n#' This is an experimental function that allows you to apply a suffix/sy"
},
{
"path": "R/fontawesome-icons.R",
"chars": 15210,
"preview": "# #' Repeat `{fontawesome}` icons based on an integer.\n# #' @description\n# #' `r lifecycle::badge(\"deprecated\")`\n# #' Th"
},
{
"path": "R/generate_df.R",
"chars": 2620,
"preview": "#' Generate pseudorandom dataframes with specific parameters\n#' @description This function is a small utility to create "
},
{
"path": "R/get_row_index.R",
"chars": 4149,
"preview": "#' Get underlying row index for gt tables\n#' @description Provides underlying row index for grouped or ungrouped\n#' `gt`"
},
{
"path": "R/gt-bar-html.R",
"chars": 7584,
"preview": "#' Add HTML-based bar plots into rows of a `gt` table\n#' @description\n#' The `gt_plt_bar_pct` function takes an existing"
},
{
"path": "R/gtExtras-package.R",
"chars": 644,
"preview": "#' @keywords internal\n#' @import dplyr glue ggplot2 gt htmltools paletteer rlang scales\n#' @importFrom fontawesome fa\n\"_"
},
{
"path": "R/gt_add_divider.R",
"chars": 2343,
"preview": "#' Add a dividing border to an existing `gt` table.\n#' @description\n#' The `gt_add_divider` function takes an existing `"
},
{
"path": "R/gt_alert_icon.R",
"chars": 3080,
"preview": "#' Insert an alert icon to a specific column\n#'\n#' @param gt_object An existing gt table object of class `gt_tbl`\n#' @pa"
},
{
"path": "R/gt_color_box.R",
"chars": 3807,
"preview": "#' @title Add a small color box relative to the cell value.\n#' @description Create `PFF`-style colorboxes in a `gt` tabl"
},
{
"path": "R/gt_color_rows.R",
"chars": 3369,
"preview": "#' Add scaled colors according to numeric values or categories/factors\n#' @description\n#' The `gt_color_rows` function t"
},
{
"path": "R/gt_dot_bar.R",
"chars": 4278,
"preview": "#' @title Add a color dot and thin bar chart to a table\n#' @description This function takes a data column and a categori"
},
{
"path": "R/gt_dt__.R",
"chars": 266,
"preview": "# vendored code with attribution from gt\n# https://github.com/rstudio/gt/blob/7929072221b059901a1649fe7f83d725521fb02a/R"
},
{
"path": "R/gt_dt_data.R",
"chars": 1059,
"preview": "# Vendored gt code with attribution\n# https://github.com/rstudio/gt/blob/7929072221b059901a1649fe7f83d725521fb02a/R/dt_d"
},
{
"path": "R/gt_duplicate_column.R",
"chars": 2032,
"preview": "#' Duplicate an existing column in a gt table\n#' @description This function takes an existing gt table and will duplicat"
},
{
"path": "R/gt_highlight_cols.R",
"chars": 2177,
"preview": "#' Add color highlighting to a specific column(s)\n#' @description\n#' The `gt_highlight_cols` function takes an existing "
},
{
"path": "R/gt_highlight_rows.R",
"chars": 3684,
"preview": "#' Add color highlighting to a specific row\n#' @description\n#' The `gt_highlight_rows` function takes an existing `gt_tb"
},
{
"path": "R/gt_hulk_color.R",
"chars": 2068,
"preview": "#' Apply 'hulk' palette to specific columns in a gt table.\n#' @description\n#' The hulk name comes from the idea of a div"
},
{
"path": "R/gt_image_multi_rows.R",
"chars": 3662,
"preview": "#' Add multiple local or web images into rows of a `gt` table\n#' @description\n#' The `gt_multi_img_rows` function takes "
},
{
"path": "R/gt_image_rows.R",
"chars": 2892,
"preview": "#' Add local or web images into rows of a `gt` table\n#' @description\n#' The `gt_img_rows` function takes an existing `gt"
},
{
"path": "R/gt_img_circle.R",
"chars": 4971,
"preview": "# Create a circular border around a image\n#\n# @param value The source image\n# @param height The height in pixels of the "
},
{
"path": "R/gt_index.R",
"chars": 3537,
"preview": "#' Return the underlying data, arranged by the internal index\n#' @description This is a utility function to extract the "
},
{
"path": "R/gt_pct_bar.R",
"chars": 7034,
"preview": "#' Add a percent stacked barchart in place of existing data.\n#' @description\n#' The `gt_plt_bar_stack` function takes an"
},
{
"path": "R/gt_plt_bar.R",
"chars": 5979,
"preview": "#' Add bar plots into rows of a `gt` table\n#' @description\n#' The `gt_plt_bar` function takes an existing `gt_tbl` objec"
},
{
"path": "R/gt_plt_bullet.R",
"chars": 5031,
"preview": "#' Create an inline 'bullet chart' in a gt table\n#'\n#' @param gt_object An existing gt table object of class `gt_tbl`\n#'"
},
{
"path": "R/gt_plt_conf_int.R",
"chars": 8348,
"preview": "#' Plot a confidence interval around a point\n#'\n#' @param gt_object An existing gt table\n#' @param column The column tha"
},
{
"path": "R/gt_plt_dist.R",
"chars": 11688,
"preview": "#' Add distribution plots into rows of a `gt` table\n#' @description\n#' The `gt_plt_dist` function takes an existing `gt_"
},
{
"path": "R/gt_plt_dumbbell.R",
"chars": 4664,
"preview": "#' Add a dumbbell plot in place of two columns\n#'\n#' @param gt_object an existing gt_tbl or pipeline\n#' @param col1 colu"
},
{
"path": "R/gt_plt_percentile_dot.R",
"chars": 4196,
"preview": "#' Create a dot plot from 0 to 100\n#' @param data The single value that will be used to plot the point.\n#' @param palett"
},
{
"path": "R/gt_plt_point.R",
"chars": 5079,
"preview": "#' Create a dot plot from any range - add_point_plot\n#'\n#' @param data The single value that will be used to plot the po"
},
{
"path": "R/gt_plt_sparkline.R",
"chars": 10537,
"preview": "#' Add sparklines into rows of a `gt` table\n#' @description\n#' The `gt_plt_sparkline` function takes an existing `gt_tbl"
},
{
"path": "R/gt_reprex_image.R",
"chars": 959,
"preview": "#' Render 'gt' Table to Temporary png File\n#'\n#' Saves a gt table to a temporary png image file and uses\n#' `knitr::incl"
},
{
"path": "R/gt_resolver.R",
"chars": 12024,
"preview": "# vendored code with attribution from gt\n# https://github.com/rstudio/gt/blob/ec97f7385166946d7a964ef31b7f6508ccd56550/R"
},
{
"path": "R/gt_summary_table.R",
"chars": 11490,
"preview": "#' Create a summary table from a dataframe\n#' @description Create a summary table from a dataframe with inline\n#' histog"
},
{
"path": "R/gt_text_img.R",
"chars": 1391,
"preview": "#' Add text and an image to the left or right of it\n#' @description\n#' The `add_text_img` function takes an existing `gt"
},
{
"path": "R/gt_theme_538.R",
"chars": 3336,
"preview": "#' Apply FiveThirtyEight theme to a gt table\n#'\n#' @param gt_object An existing gt table object of class `gt_tbl`\n#' @pa"
},
{
"path": "R/gt_theme_dark.R",
"chars": 1958,
"preview": "#' Apply dark theme to a `gt` table\n#'\n#' @param gt_object An existing gt table object of class `gt_tbl`\n#' @param ... O"
},
{
"path": "R/gt_theme_dot_matrix.R",
"chars": 2383,
"preview": "#' Apply dot matrix theme to a gt table\n#'\n#' @param gt_object An existing gt table object of class `gt_tbl`\n#' @param ."
},
{
"path": "R/gt_theme_espn.R",
"chars": 1173,
"preview": "#' Apply ESPN theme to a gt table\n#'\n#' @param gt_object An existing gt table object of class `gt_tbl`\n#' @param ... Opt"
},
{
"path": "R/gt_theme_excel.R",
"chars": 3344,
"preview": "#' Apply Excel-style theme to an existing gt table\n#'\n#' @param gt_object An existing gt table object of class `gt_tbl`\n"
},
{
"path": "R/gt_theme_guardian.R",
"chars": 2712,
"preview": "#' Apply Guardian theme to a `gt` table\n#'\n#' @param gt_object An existing gt table object of class `gt_tbl`\n#' @param ."
},
{
"path": "R/gt_theme_nytimes.R",
"chars": 1818,
"preview": "#' Apply NY Times theme to a `gt` table\n#'\n#' @param gt_object An existing gt table object of class `gt_tbl`\n#' @param ."
},
{
"path": "R/gt_theme_pff.R",
"chars": 6088,
"preview": "#' Apply a table theme like PFF\n#'\n#' @param gt_object an existing gt_tbl object\n#' @param ... Additional arguments pass"
},
{
"path": "R/gt_vendor.R",
"chars": 25828,
"preview": "# gt internal functions vendored with attribution from:\n\n### ----\n### https://github.com/rstudio/gt/blob/fcabb414c55b70c"
},
{
"path": "R/gt_win_loss.R",
"chars": 5459,
"preview": "\n#' Add win loss point plot into rows of a `gt` table\n#' @description\n#' The `gt_plt_winloss` function takes an existing"
},
{
"path": "R/gtsave_extra.R",
"chars": 2342,
"preview": "#' Use webshot2 to save a gt table as a PNG\n#' @description Takes existing HTML content, typically additional HTML inclu"
},
{
"path": "R/html-helpers.R",
"chars": 5224,
"preview": "#' Add a simple table with column names and matching labels\n#'\n#' @param label A string representing the label for the d"
},
{
"path": "R/icon_fun.R",
"chars": 3792,
"preview": "#' Repeat `{fontawesome}` icons and convert to HTML\n#' @description\n#' The `fa_icon_repeat` function takes an [fontaweso"
},
{
"path": "R/img_header.R",
"chars": 1512,
"preview": "#' Add images as the column label for a table\n#'\n#' @param label A string indicating the label of the column.\n#' @param "
},
{
"path": "R/last_row_id.R",
"chars": 222,
"preview": "#' Get last row id/index even by group\n#'\n#' @param gt_object An existing gt table object of class `gt_tbl`\n\nlast_row_id"
},
{
"path": "R/merge_and_stack.R",
"chars": 6905,
"preview": "#' Merge and stack text from two columns in `gt`\n#'\n#' @description\n#' The `gt_merge_stack()` function takes an existing"
},
{
"path": "R/pad_fn.R",
"chars": 1754,
"preview": "#' Pad a vector of numbers to align on the decimal point.\n#' @description\n#' This helper function adds whitespace to num"
},
{
"path": "R/reexports.R",
"chars": 868,
"preview": "# dplyr ------------------------------------------------------------------------\n#' @export\n#' @importFrom dplyr %>%\ndpl"
},
{
"path": "R/tab_style_by_grp.R",
"chars": 2471,
"preview": "#' Add table styling to specific rows by group\n#' @description\n#' The `tab_style_by_grp` function takes an existing `gt_"
},
{
"path": "R/two-column-layouts.R",
"chars": 12117,
"preview": "#' Take data, a gt-generating function, and create a list of two tables\n#'\n#' @description The `gt_double_table` functio"
},
{
"path": "R/utils.R",
"chars": 2468,
"preview": "#' Count number of decimals\n#'\n#' @param x A value to count decimals from\n#'\n#' @return an integer\n#' @export\n#'\nn_decim"
},
{
"path": "README.Rmd",
"chars": 1998,
"preview": "---\noutput: github_document\n---\n\n<!-- README.md is generated from README.Rmd. Please edit that file -->\n\n```{r setup, in"
},
{
"path": "README.md",
"chars": 1815,
"preview": "\n<!-- README.md is generated from README.Rmd. Please edit that file -->\n\n# gtExtras <a href=\"https://jthomasmock.github."
},
{
"path": "_pkgdown.yml",
"chars": 3078,
"preview": "url: https://jthomasmock.github.io/gtExtras/\nhome:\n title: Additional features for creating beautiful tables with gt\n "
},
{
"path": "codecov.yml",
"chars": 232,
"preview": "comment: false\n\ncoverage:\n status:\n project:\n default:\n target: auto\n threshold: 1%\n infor"
},
{
"path": "cran-comments.md",
"chars": 607,
"preview": "## Submission details\n\n- This is an update to solve a few bugs as indicated by users and CRAN maintainers.\n\n## R CMD che"
},
{
"path": "data-raw/x06-css-colors.R",
"chars": 5954,
"preview": "css_colors <-\n dplyr::tribble(\n ~color_name, ~hexadecimal, ~category,\n \"IndianRed\", \"#CD5C5C\", \"Reds\",\n \"Light"
},
{
"path": "data-raw/zz_process_datasets_ext.R",
"chars": 169,
"preview": "library(usethis)\n\nsource(\"data-raw/x06-css-colors.R\")\n\n# Create internal datasets (`sysdata.rda`)\nusethis::use_data(\n c"
},
{
"path": "man/add_badge_color.Rd",
"chars": 424,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/html-helpers.R\n\\name{add_badge_color}\n\\ali"
},
{
"path": "man/add_pcttile_plot.Rd",
"chars": 637,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_plt_percentile_dot.R\n\\name{add_pcttile_"
},
{
"path": "man/add_point_plot.Rd",
"chars": 1028,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_plt_point.R\n\\name{add_point_plot}\n\\alia"
},
{
"path": "man/add_text_img.Rd",
"chars": 2285,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_text_img.R\n\\name{add_text_img}\n\\alias{a"
},
{
"path": "man/create_sum_table.Rd",
"chars": 914,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_summary_table.R\n\\name{create_sum_table}"
},
{
"path": "man/fa_icon_repeat.Rd",
"chars": 4215,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/icon_fun.R\n\\name{fa_icon_repeat}\n\\alias{fa"
},
{
"path": "man/fmt_pad_num.Rd",
"chars": 2283,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/fmt_pad_num.R\n\\name{fmt_pad_num}\n\\alias{fm"
},
{
"path": "man/fmt_pct_extra.Rd",
"chars": 1587,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/fmt_pct_extra.R\n\\name{fmt_pct_extra}\n\\alia"
},
{
"path": "man/fmt_symbol_first.Rd",
"chars": 2997,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/fmt_symbol_first.R\n\\name{fmt_symbol_first}"
},
{
"path": "man/generate_df.Rd",
"chars": 2298,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/generate_df.R\n\\name{generate_df}\n\\alias{ge"
},
{
"path": "man/get_row_index.Rd",
"chars": 3668,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/get_row_index.R\n\\name{get_row_index}\n\\alia"
},
{
"path": "man/gtExtras-package.Rd",
"chars": 1029,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gtExtras-package.R\n\\docType{package}\n\\name"
},
{
"path": "man/gt_add_divider.Rd",
"chars": 2761,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_add_divider.R\n\\name{gt_add_divider}\n\\al"
},
{
"path": "man/gt_alert_icon.Rd",
"chars": 1779,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_alert_icon.R\n\\name{gt_alert_icon}\n\\alia"
},
{
"path": "man/gt_badge.Rd",
"chars": 2316,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/html-helpers.R\n\\name{gt_badge}\n\\alias{gt_b"
},
{
"path": "man/gt_color_box.Rd",
"chars": 2315,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_color_box.R\n\\name{gt_color_box}\n\\alias{"
},
{
"path": "man/gt_color_rows.Rd",
"chars": 3376,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_color_rows.R\n\\name{gt_color_rows}\n\\alia"
},
{
"path": "man/gt_double_table.Rd",
"chars": 3081,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/two-column-layouts.R\n\\name{gt_double_table"
},
{
"path": "man/gt_duplicate_column.Rd",
"chars": 2030,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_duplicate_column.R\n\\name{gt_duplicate_c"
},
{
"path": "man/gt_fa_rank_change.Rd",
"chars": 2852,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/fontawesome-icons.R\n\\name{gt_fa_rank_chang"
},
{
"path": "man/gt_fa_rating.Rd",
"chars": 2216,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/fontawesome-icons.R\n\\name{gt_fa_rating}\n\\a"
},
{
"path": "man/gt_highlight_cols.Rd",
"chars": 2777,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_highlight_cols.R\n\\name{gt_highlight_col"
},
{
"path": "man/gt_highlight_rows.Rd",
"chars": 3826,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_highlight_rows.R\n\\name{gt_highlight_row"
},
{
"path": "man/gt_hulk_col_numeric.Rd",
"chars": 2440,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_hulk_color.R\n\\name{gt_hulk_col_numeric}"
},
{
"path": "man/gt_hyperlink.Rd",
"chars": 434,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/html-helpers.R\n\\name{gt_hyperlink}\n\\alias{"
},
{
"path": "man/gt_img_border.Rd",
"chars": 2466,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_img_circle.R\n\\name{gt_img_border}\n\\alia"
},
{
"path": "man/gt_img_circle.Rd",
"chars": 2431,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_img_circle.R\n\\name{gt_img_circle}\n\\alia"
},
{
"path": "man/gt_img_multi_rows.Rd",
"chars": 2656,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_image_multi_rows.R\n\\name{gt_img_multi_r"
},
{
"path": "man/gt_img_rows.Rd",
"chars": 2601,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_image_rows.R\n\\name{gt_img_rows}\n\\alias{"
},
{
"path": "man/gt_index.Rd",
"chars": 3312,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_index.R\n\\name{gt_index}\n\\alias{gt_index"
},
{
"path": "man/gt_label_details.Rd",
"chars": 621,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/html-helpers.R\n\\name{gt_label_details}\n\\al"
},
{
"path": "man/gt_merge_stack.Rd",
"chars": 3288,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/merge_and_stack.R\n\\name{gt_merge_stack}\n\\a"
},
{
"path": "man/gt_merge_stack_color.Rd",
"chars": 2887,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/merge_and_stack.R\n\\name{gt_merge_stack_col"
},
{
"path": "man/gt_plt_bar.Rd",
"chars": 2550,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_plt_bar.R\n\\name{gt_plt_bar}\n\\alias{gt_p"
},
{
"path": "man/gt_plt_bar_pct.Rd",
"chars": 3730,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt-bar-html.R\n\\name{gt_plt_bar_pct}\n\\alias"
},
{
"path": "man/gt_plt_bar_stack.Rd",
"chars": 3260,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_pct_bar.R\n\\name{gt_plt_bar_stack}\n\\alia"
},
{
"path": "man/gt_plt_bullet.Rd",
"chars": 2058,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_plt_bullet.R\n\\name{gt_plt_bullet}\n\\alia"
},
{
"path": "man/gt_plt_conf_int.Rd",
"chars": 3053,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_plt_conf_int.R\n\\name{gt_plt_conf_int}\n\\"
},
{
"path": "man/gt_plt_dist.Rd",
"chars": 3204,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_plt_dist.R\n\\name{gt_plt_dist}\n\\alias{gt"
},
{
"path": "man/gt_plt_dot.Rd",
"chars": 1978,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_dot_bar.R\n\\name{gt_plt_dot}\n\\alias{gt_p"
},
{
"path": "man/gt_plt_dumbbell.Rd",
"chars": 1353,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_plt_dumbbell.R\n\\name{gt_plt_dumbbell}\n\\"
},
{
"path": "man/gt_plt_percentile.Rd",
"chars": 1789,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_plt_percentile_dot.R\n\\name{gt_plt_perce"
},
{
"path": "man/gt_plt_point.Rd",
"chars": 1995,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_plt_point.R\n\\name{gt_plt_point}\n\\alias{"
},
{
"path": "man/gt_plt_sparkline.Rd",
"chars": 2926,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_plt_sparkline.R\n\\name{gt_plt_sparkline}"
},
{
"path": "man/gt_plt_summary.Rd",
"chars": 989,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_summary_table.R\n\\name{gt_plt_summary}\n\\"
},
{
"path": "man/gt_plt_winloss.Rd",
"chars": 2545,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_win_loss.R\n\\name{gt_plt_winloss}\n\\alias"
},
{
"path": "man/gt_reprex_image.Rd",
"chars": 669,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_reprex_image.R\n\\name{gt_reprex_image}\n\\"
},
{
"path": "man/gt_theme_538.Rd",
"chars": 1224,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_theme_538.R\n\\name{gt_theme_538}\n\\alias{"
},
{
"path": "man/gt_theme_dark.Rd",
"chars": 1093,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_theme_dark.R\n\\name{gt_theme_dark}\n\\alia"
},
{
"path": "man/gt_theme_dot_matrix.Rd",
"chars": 1436,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_theme_dot_matrix.R\n\\name{gt_theme_dot_m"
},
{
"path": "man/gt_theme_espn.Rd",
"chars": 1034,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_theme_espn.R\n\\name{gt_theme_espn}\n\\alia"
},
{
"path": "man/gt_theme_excel.Rd",
"chars": 1284,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_theme_excel.R\n\\name{gt_theme_excel}\n\\al"
},
{
"path": "man/gt_theme_guardian.Rd",
"chars": 1076,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_theme_guardian.R\n\\name{gt_theme_guardia"
},
{
"path": "man/gt_theme_nytimes.Rd",
"chars": 1126,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_theme_nytimes.R\n\\name{gt_theme_nytimes}"
},
{
"path": "man/gt_theme_pff.Rd",
"chars": 3260,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_theme_pff.R\n\\name{gt_theme_pff}\n\\alias{"
},
{
"path": "man/gt_two_column_layout.Rd",
"chars": 6569,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/two-column-layouts.R\n\\name{gt_two_column_l"
},
{
"path": "man/gtsave_extra.Rd",
"chars": 2174,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gtsave_extra.R\n\\name{gtsave_extra}\n\\alias{"
},
{
"path": "man/img_header.Rd",
"chars": 2015,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/img_header.R\n\\name{img_header}\n\\alias{img_"
},
{
"path": "man/last_row_id.Rd",
"chars": 343,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/last_row_id.R\n\\name{last_row_id}\n\\alias{la"
},
{
"path": "man/n_decimals.Rd",
"chars": 297,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/utils.R\n\\name{n_decimals}\n\\alias{n_decimal"
},
{
"path": "man/pad_fn.Rd",
"chars": 2086,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/pad_fn.R\n\\name{pad_fn}\n\\alias{pad_fn}\n\\tit"
},
{
"path": "man/plot_data.Rd",
"chars": 587,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/gt_summary_table.R\n\\name{plot_data}\n\\alias"
},
{
"path": "man/reexports.Rd",
"chars": 1110,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/reexports.R\n\\docType{import}\n\\name{reexpor"
},
{
"path": "man/tab_style_by_grp.Rd",
"chars": 2249,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/tab_style_by_grp.R\n\\name{tab_style_by_grp}"
},
{
"path": "man/with_tooltip.Rd",
"chars": 482,
"preview": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/html-helpers.R\n\\name{with_tooltip}\n\\alias{"
},
{
"path": "tests/testthat/helper.R",
"chars": 98,
"preview": "check_suggests <- function() {\n skip_if_not_installed(\"rvest\")\n skip_if_not_installed(\"xml2\")\n}\n"
},
{
"path": "tests/testthat/test-fmt_pad_num.R",
"chars": 559,
"preview": "test_that(\"gt_fmt_pad_num test that padding is correct\", {\n check_suggests()\n skip_on_cran()\n\n padded_tab <- data.fra"
},
{
"path": "tests/testthat/test-fmt_pct_extra.R",
"chars": 830,
"preview": "test_that(\"fmt_pct_extra generates expected output and colors\", {\n check_suggests()\n skip_on_cran()\n testthat::skip_i"
},
{
"path": "tests/testthat/test-fmt_symbol_first.R",
"chars": 2295,
"preview": "test_gt_by_col <- function(col_n, row_first = TRUE, expectation) {\n check_suggests()\n skip_on_cran()\n\n\n ex_gt <- gt::"
},
{
"path": "tests/testthat/test-fontawesome-icons.R",
"chars": 5527,
"preview": "test_that(\"fontawesome, test ratings all R and colors/numbers match\", {\n check_suggests()\n skip_on_cran()\n skip_on_ci"
},
{
"path": "tests/testthat/test-generate_df.R",
"chars": 834,
"preview": "test_df <- generate_df(\n 100L,\n n_grps = 5,\n mean = seq(10, 50, length.out = 5),\n with_seed = 37\n) %>%\n dplyr::grou"
},
{
"path": "tests/testthat/test-gt-bar-html.R",
"chars": 1258,
"preview": "test_that(\"gt_plt_bar_pct HTML is created and has specific values\", {\n check_suggests()\n\n\n gt_bar_plot_tab <- mtcars %"
},
{
"path": "tests/testthat/test-gt_add_divider.R",
"chars": 2518,
"preview": "test_that(\"divider has border and type\", {\n check_suggests()\n\n divide_html <- head(mtcars) %>%\n gt::gt() %>%\n gt"
},
{
"path": "tests/testthat/test-gt_color_box.R",
"chars": 1926,
"preview": "test_that(\"gt_color_box palettes are created and have appropriate hex values\", {\n check_suggests()\n\n test_data <- dply"
},
{
"path": "tests/testthat/test-gt_color_rows.R",
"chars": 2102,
"preview": "test_that(\"gt_color_rows palettes are created and have appropriate hex values\", {\n check_suggests()\n\n base_red <- mtc"
},
{
"path": "tests/testthat/test-gt_dot_bar.R",
"chars": 948,
"preview": "test_that(\"gt_plt_bullet SVG is created and has specific values\", {\n check_suggests()\n\n dot_bar_tab <- mtcars %>%\n "
},
{
"path": "tests/testthat/test-gt_duplicate_column.R",
"chars": 1139,
"preview": "test_that(\"duplicate column, confirm column exists and matches\", {\n check_suggests()\n\n dupe_table <- head(mtcars) %>%\n"
},
{
"path": "tests/testthat/test-gt_highlight_cols.R",
"chars": 485,
"preview": "test_that(\"gt_highlight_row correct row is highlighted and is blue\", {\n check_suggests()\n\n basic_col <- gt::gt(head(m"
},
{
"path": "tests/testthat/test-gt_highlight_rows.R",
"chars": 2250,
"preview": "my_car <- head(mtcars[,1:5]) %>%\n tibble::rownames_to_column(\"car\")\n\nbasic_use <- gt::gt(my_car) %>%\n gt_highlight_row"
},
{
"path": "tests/testthat/test-gt_hulk_color.R",
"chars": 721,
"preview": "# Gets the HTML attr value from a single key\nselection_value <- function(html, key) {\n\n selection <- paste0(\"[\", key, \""
},
{
"path": "tests/testthat/test-gt_image_multi_rows.R",
"chars": 954,
"preview": "test_that(\"img_mulit_rows, images exist\", {\n check_suggests()\n skip_on_cran()\n\n teams <- \"https://github.com/nflverse"
},
{
"path": "tests/testthat/test-gt_image_rows.R",
"chars": 743,
"preview": "test_that(\"img_rows, images exist\", {\n check_suggests()\n skip_on_cran()\n\n teams <- \"https://github.com/nflverse/nflfa"
},
{
"path": "tests/testthat/test-gt_img_circle.R",
"chars": 819,
"preview": "test_that(\"svg is created and has specific values\", {\n check_suggests()\n skip_on_cran()\n skip_on_ci()\n base_table <-"
},
{
"path": "tests/testthat/test-gt_index.R",
"chars": 2588,
"preview": "test_that(\"gt_index has correct inputs, correct ouput index, and can affect correct rows\", {\n check_suggests()\n\n # Thi"
},
{
"path": "tests/testthat/test-gt_pct_bar.R",
"chars": 2930,
"preview": "# test_that(\"gt_pct_bar SVG is created and has specific values\", {\n# check_suggests()\n\n# ex_df <- dplyr::tibble(\n# "
},
{
"path": "tests/testthat/test-gt_plt_bar.R",
"chars": 1203,
"preview": "test_that(\"gt_plt_bar svg is created and has specific values\", {\n check_suggests()\n testthat::skip_on_cran()\n testtha"
},
{
"path": "tests/testthat/test-gt_plt_bullet.R",
"chars": 2529,
"preview": "test_that(\"gt_plt_bullet SVG is created and has specific values\", {\n check_suggests()\n\n bullet_tab <- tibble::rownames"
},
{
"path": "tests/testthat/test-gt_plt_conf_int.R",
"chars": 2601,
"preview": "test_that(\"gt_plt_conf_int generates correct points/text\", {\n check_suggests()\n testthat::skip_on_cran()\n\n ci_table <"
},
{
"path": "tests/testthat/test-gt_plt_dist.R",
"chars": 1547,
"preview": "test_that(\"svg is created\", {\n check_suggests()\n\n base_tab <- mtcars %>%\n dplyr::group_by(cyl) %>%\n # must end u"
},
{
"path": "tests/testthat/test-gt_plt_percentile_dot.R",
"chars": 2049,
"preview": "test_that(\"add_pcttile_plot creates a plot\", {\n check_suggests()\n\n plt15 <- add_pcttile_plot(15, \"green\", TRUE, 25) %>"
},
{
"path": "tests/testthat/test-gt_plt_point.R",
"chars": 2061,
"preview": "test_that(\"add_point_plot creates a plot\", {\n check_suggests()\n\n plt15 <- add_point_plot(15, c(\"blue\"), TRUE, 25, c(2,"
},
{
"path": "tests/testthat/test-gt_plt_sparkline.R",
"chars": 1683,
"preview": "test_that(\"svg is created and has specific values\", {\n check_suggests()\n\n basic_gt <- mtcars %>%\n dplyr::group_by(c"
},
{
"path": "tests/testthat/test-gt_summary_table.R",
"chars": 1959,
"preview": "test_that(\"summary_table created\", {\n\n # basic summary\n exibble <- gt::exibble\n exibble$int <- as.integer(1:8)\n gt_s"
},
{
"path": "tests/testthat/test-gt_text_img.R",
"chars": 677,
"preview": "test_that(\"gt_text_img is created and matches\", {\n check_suggests()\n skip_on_cran()\n temp_nm <- tempfile(fileext = \"."
},
{
"path": "tests/testthat/test-gt_win_loss.R",
"chars": 4493,
"preview": "test_that(\"SVG exists and has expected values\", {\n check_suggests()\n\n data_in <- dplyr::tibble(\n grp = rep(c(\"A\", \""
},
{
"path": "tests/testthat/test-gtsave_extra.R",
"chars": 466,
"preview": "test_that(\"gtsave_extra, file out works\", {\n check_suggests()\n skip_if_not_installed(\"webshot2\")\n skip_on_cran()\n sk"
},
{
"path": "tests/testthat/test-html-helpers.R",
"chars": 2069,
"preview": "test_that(\"details tag is created\", {\n\n check_suggests()\n gt_label_details(\"howdy\", c(\"big\" = \"if true\", \"hat\" = \"Cowb"
},
{
"path": "tests/testthat/test-icon_fun.R",
"chars": 288,
"preview": "test_that(\"fa_icon_repeat, is a fa icon\", {\n check_suggests()\n skip_on_cran()\n\n svg_len <- fa_icon_repeat() %>%\n r"
},
{
"path": "tests/testthat/test-img_header.R",
"chars": 826,
"preview": "test_that(\"img_header generates img\", {\n check_suggests()\n skip_on_cran()\n example_img <- img_header(\n \"Luka Donci"
},
{
"path": "tests/testthat/test-merge_and_stack.R",
"chars": 615,
"preview": "test_that(\"merge_stack, vals match expected and location\", {\n check_suggests()\n\n merged_tab <- head(mtcars) %>%\n dp"
},
{
"path": "tests/testthat/test-tab_style_by_grp.R",
"chars": 933,
"preview": "test_that(\"tab_style_by_grp, groups respected\", {\n check_suggests()\n\n df_in <- mtcars %>%\n dplyr::select(cyl:hp, mp"
},
{
"path": "tests/testthat/test-two-column-layouts.R",
"chars": 2257,
"preview": "test_that(\"two_column_layout, two gt_tbl objects\", {\n check_suggests()\n skip_if_not_installed(\"webshot2\")\n skip_on_cr"
},
{
"path": "tests/testthat/test-utils.R",
"chars": 869,
"preview": "test_that(\"n_decimals are expected\", {\n\n expect_equal(n_decimals(12345), 0)\n expect_equal(n_decimals(1234.5), 1)\n exp"
},
{
"path": "tests/testthat/test_test-gt_pct_bar.R",
"chars": 3499,
"preview": "# R\n\ntest_that(\"gt_pct_bar SVG structure, positions, and default palette are correct\", {\n check_suggests()\n testthat::"
},
{
"path": "tests/testthat.R",
"chars": 60,
"preview": "library(testthat)\nlibrary(gtExtras)\n\ntest_check(\"gtExtras\")\n"
},
{
"path": "vignettes/.gitignore",
"chars": 11,
"preview": "*.html\n*.R\n"
},
{
"path": "vignettes/articles/plotting-with-gtExtras.Rmd",
"chars": 13600,
"preview": "---\ntitle: \"Plotting with gtExtras\"\n---\n\n```{r, include = FALSE}\nknitr::opts_chunk$set(\n collapse = TRUE,\n comment = \""
}
]
// ... and 1 more files (download for full content)
About this extraction
This page contains the full source code of the jthomasmock/gtExtras GitHub repository, extracted and formatted as plain text for AI agents and large language models (LLMs). The extraction includes 185 files (502.5 KB), approximately 158.9k tokens. Use this with OpenClaw, Claude, ChatGPT, Cursor, Windsurf, or any other AI tool that accepts text input. You can copy the full output to your clipboard or download it as a .txt file.
Extracted by GitExtract — free GitHub repo to text converter for AI. Built by Nikandr Surkov.