├── .Rbuildignore ├── .github ├── .gitignore └── workflows │ ├── R-CMD-check.yaml │ ├── pkgdown.yaml │ ├── pr-commands.yaml │ └── test-coverage.yaml ├── .gitignore ├── DESCRIPTION ├── LICENSE ├── LICENSE.md ├── Makefile ├── NAMESPACE ├── R ├── compat-purrr.R ├── config.R ├── data-type.R ├── datasets.R ├── eval.R ├── mark.R ├── multiviews.R ├── scale.R ├── selection.R ├── transform-server.R ├── transform.R ├── utils-pipe.R ├── utils-vegawidget.R ├── utils.R ├── vega.R └── zzz.R ├── README.Rmd ├── README.html ├── README.md ├── codecov.yml ├── data-raw ├── aklhousingprice.R └── melbweather.R ├── data ├── aklhousingprice.rda └── melbweather.rda ├── demo ├── aggregate.R ├── basics.R ├── facet.R ├── scale.R ├── selections.R ├── timeunit.R └── transform.R ├── man ├── aklhousingprice.Rd ├── concat.Rd ├── enc.Rd ├── encode_if.Rd ├── entitle.Rd ├── facet_views.Rd ├── figures │ ├── README-basic-scatter-1.png │ ├── readme-circle.png │ ├── readme-hconcat.png │ └── readme-histogram.png ├── image.Rd ├── knit_print.vegaspec.Rd ├── melbweather.Rd ├── pipe.Rd ├── resolve_views.Rd ├── vega-config.Rd ├── vega-input.Rd ├── vega-marks.Rd ├── vega-scales.Rd ├── vega-selection.Rd ├── vega-seralise.Rd ├── vega.Rd ├── vg-aggregate.Rd ├── vg-timeunit.Rd ├── vg-window.Rd └── vw_set_base_url.Rd ├── pkgdown ├── _pkgdown.yml └── extra.css ├── vignettes ├── .gitignore ├── gallery │ ├── gapminder-animate.Rmd │ ├── gapminder-animate.png │ ├── gapminder-model-drilldown.Rmd │ ├── gapminder-model-drilldown.png │ ├── index.Rmd │ ├── linked-highlighting.Rmd │ ├── linked-highlighting.png │ ├── minimap.Rmd │ └── minimap.png ├── selections.Rmd ├── transition.Rmd └── virgo.Rmd └── virgo.Rproj /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^virgo\.Rproj$ 2 | ^\.Rproj\.user$ 3 | ^demo$ 4 | ^data-raw$ 5 | ^README\.Rmd$ 6 | ^LICENSE\.md$ 7 | ^codecov\.yml$ 8 | ^\.github$ 9 | ^_pkgdown\.yml$ 10 | ^docs$ 11 | ^pkgdown$ 12 | ^vignettes/articles$ 13 | $Makefile$ 14 | -------------------------------------------------------------------------------- /.github/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | -------------------------------------------------------------------------------- /.github/workflows/R-CMD-check.yaml: -------------------------------------------------------------------------------- 1 | # NOTE: This workflow is overkill for most R packages 2 | # check-standard.yaml is likely a better choice 3 | # usethis::use_github_action("check-standard") will install it. 4 | # 5 | # For help debugging build failures open an issue on the RStudio community with the 'github-actions' tag. 6 | # https://community.rstudio.com/new-topic?category=Package%20development&tags=github-actions 7 | on: 8 | push: 9 | branches: 10 | - main 11 | - master 12 | pull_request: 13 | branches: 14 | - main 15 | - master 16 | 17 | name: R-CMD-check 18 | 19 | jobs: 20 | R-CMD-check: 21 | runs-on: ${{ matrix.config.os }} 22 | 23 | name: ${{ matrix.config.os }} (${{ matrix.config.r }}) 24 | 25 | strategy: 26 | fail-fast: false 27 | matrix: 28 | config: 29 | - {os: macOS-latest, r: 'release'} 30 | - {os: windows-latest, r: 'release'} 31 | - {os: windows-latest, r: '3.6'} 32 | - {os: ubuntu-16.04, r: 'devel', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest", http-user-agent: "R/4.0.0 (ubuntu-16.04) R (4.0.0 x86_64-pc-linux-gnu x86_64 linux-gnu) on GitHub Actions" } 33 | - {os: ubuntu-16.04, r: 'release', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"} 34 | - {os: ubuntu-16.04, r: 'oldrel', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"} 35 | - {os: ubuntu-16.04, r: '3.5', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"} 36 | - {os: ubuntu-16.04, r: '3.4', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"} 37 | - {os: ubuntu-16.04, r: '3.3', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"} 38 | 39 | env: 40 | R_REMOTES_NO_ERRORS_FROM_WARNINGS: true 41 | RSPM: ${{ matrix.config.rspm }} 42 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 43 | 44 | steps: 45 | - uses: actions/checkout@v2 46 | 47 | - uses: r-lib/actions/setup-r@v1 48 | with: 49 | r-version: ${{ matrix.config.r }} 50 | http-user-agent: ${{ matrix.config.http-user-agent }} 51 | 52 | - uses: r-lib/actions/setup-pandoc@v1 53 | 54 | - name: Query dependencies 55 | run: | 56 | install.packages('remotes') 57 | saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2) 58 | writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version") 59 | shell: Rscript {0} 60 | 61 | - name: Cache R packages 62 | if: runner.os != 'Windows' 63 | uses: actions/cache@v2 64 | with: 65 | path: ${{ env.R_LIBS_USER }} 66 | key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }} 67 | restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1- 68 | 69 | - name: Install system dependencies 70 | if: runner.os == 'Linux' 71 | run: | 72 | while read -r cmd 73 | do 74 | eval sudo $cmd 75 | done < <(Rscript -e 'writeLines(remotes::system_requirements("ubuntu", "16.04"))') 76 | 77 | - name: Install dependencies 78 | run: | 79 | remotes::install_deps(dependencies = TRUE) 80 | remotes::install_cran("rcmdcheck") 81 | shell: Rscript {0} 82 | 83 | - name: Session info 84 | run: | 85 | options(width = 100) 86 | pkgs <- installed.packages()[, "Package"] 87 | sessioninfo::session_info(pkgs, include_base = TRUE) 88 | shell: Rscript {0} 89 | 90 | - name: Check 91 | env: 92 | _R_CHECK_CRAN_INCOMING_: false 93 | run: rcmdcheck::rcmdcheck(args = c("--no-manual", "--as-cran"), error_on = "warning", check_dir = "check") 94 | shell: Rscript {0} 95 | 96 | - name: Show testthat output 97 | if: always() 98 | run: find check -name 'testthat.Rout*' -exec cat '{}' \; || true 99 | shell: bash 100 | 101 | - name: Upload check results 102 | if: failure() 103 | uses: actions/upload-artifact@main 104 | with: 105 | name: ${{ runner.os }}-r${{ matrix.config.r }}-results 106 | path: check 107 | -------------------------------------------------------------------------------- /.github/workflows/pkgdown.yaml: -------------------------------------------------------------------------------- 1 | on: 2 | push: 3 | branches: 4 | - main 5 | - master 6 | 7 | name: pkgdown 8 | 9 | jobs: 10 | pkgdown: 11 | runs-on: macOS-latest 12 | env: 13 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 14 | steps: 15 | - uses: actions/checkout@v2 16 | 17 | - uses: r-lib/actions/setup-r@v1 18 | 19 | - uses: r-lib/actions/setup-pandoc@v1 20 | 21 | - name: Query dependencies 22 | run: | 23 | install.packages('remotes') 24 | saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2) 25 | writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version") 26 | shell: Rscript {0} 27 | 28 | - name: Cache R packages 29 | uses: actions/cache@v2 30 | with: 31 | path: ${{ env.R_LIBS_USER }} 32 | key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }} 33 | restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1- 34 | 35 | - name: Install dependencies 36 | run: | 37 | remotes::install_deps(dependencies = TRUE) 38 | install.packages("pkgdown", type = "binary") 39 | shell: Rscript {0} 40 | 41 | - name: Install package 42 | run: R CMD INSTALL . 43 | 44 | - name: Deploy package 45 | run: | 46 | git config --local user.email "actions@github.com" 47 | git config --local user.name "GitHub Actions" 48 | Rscript -e 'pkgdown::deploy_to_branch(new_process = FALSE)' 49 | -------------------------------------------------------------------------------- /.github/workflows/pr-commands.yaml: -------------------------------------------------------------------------------- 1 | on: 2 | issue_comment: 3 | types: [created] 4 | name: Commands 5 | jobs: 6 | document: 7 | if: startsWith(github.event.comment.body, '/document') 8 | name: document 9 | runs-on: macOS-latest 10 | env: 11 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 12 | steps: 13 | - uses: actions/checkout@v2 14 | - uses: r-lib/actions/pr-fetch@v1 15 | with: 16 | repo-token: ${{ secrets.GITHUB_TOKEN }} 17 | - uses: r-lib/actions/setup-r@v1 18 | - name: Install dependencies 19 | run: Rscript -e 'install.packages(c("remotes", "roxygen2"))' -e 'remotes::install_deps(dependencies = TRUE)' 20 | - name: Document 21 | run: Rscript -e 'roxygen2::roxygenise()' 22 | - name: commit 23 | run: | 24 | git config --local user.email "actions@github.com" 25 | git config --local user.name "GitHub Actions" 26 | git add man/\* NAMESPACE 27 | git commit -m 'Document' 28 | - uses: r-lib/actions/pr-push@v1 29 | with: 30 | repo-token: ${{ secrets.GITHUB_TOKEN }} 31 | style: 32 | if: startsWith(github.event.comment.body, '/style') 33 | name: style 34 | runs-on: macOS-latest 35 | env: 36 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 37 | steps: 38 | - uses: actions/checkout@v2 39 | - uses: r-lib/actions/pr-fetch@v1 40 | with: 41 | repo-token: ${{ secrets.GITHUB_TOKEN }} 42 | - uses: r-lib/actions/setup-r@v1 43 | - name: Install dependencies 44 | run: Rscript -e 'install.packages("styler")' 45 | - name: Style 46 | run: Rscript -e 'styler::style_pkg()' 47 | - name: commit 48 | run: | 49 | git config --local user.email "actions@github.com" 50 | git config --local user.name "GitHub Actions" 51 | git add \*.R 52 | git commit -m 'Style' 53 | - uses: r-lib/actions/pr-push@v1 54 | with: 55 | repo-token: ${{ secrets.GITHUB_TOKEN }} 56 | -------------------------------------------------------------------------------- /.github/workflows/test-coverage.yaml: -------------------------------------------------------------------------------- 1 | on: 2 | push: 3 | branches: 4 | - main 5 | - master 6 | pull_request: 7 | branches: 8 | - main 9 | - master 10 | 11 | name: test-coverage 12 | 13 | jobs: 14 | test-coverage: 15 | runs-on: macOS-latest 16 | env: 17 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 18 | steps: 19 | - uses: actions/checkout@v2 20 | 21 | - uses: r-lib/actions/setup-r@v1 22 | 23 | - uses: r-lib/actions/setup-pandoc@v1 24 | 25 | - name: Query dependencies 26 | run: | 27 | install.packages('remotes') 28 | saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2) 29 | writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version") 30 | shell: Rscript {0} 31 | 32 | - name: Cache R packages 33 | uses: actions/cache@v2 34 | with: 35 | path: ${{ env.R_LIBS_USER }} 36 | key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }} 37 | restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1- 38 | 39 | - name: Install dependencies 40 | run: | 41 | install.packages(c("remotes")) 42 | remotes::install_deps(dependencies = TRUE) 43 | remotes::install_cran("covr") 44 | shell: Rscript {0} 45 | 46 | - name: Test coverage 47 | run: covr::codecov() 48 | shell: Rscript {0} 49 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | inst/doc 6 | docs 7 | .DS_Store 8 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: virgo 2 | Title: A Domain Specific Language for Layered Grammar of 3 | Interactive Graphics 4 | Version: 0.0.0.9000 5 | Authors@R: 6 | c(person(given = "Earo", 7 | family = "Wang", 8 | role = c("aut", "cre"), 9 | email = "earo.wang@gmail.com", 10 | comment = c(ORCID = "0000-0001-6448-5260")), 11 | person(given = "Stuart", 12 | family = "Lee", 13 | role = "aut", 14 | email = "stuart.andrew.lee@gmail.com", 15 | comment = c(ORCID = "0000-0003-1179-8436")), 16 | person(given = "Vega/Vega-Lite Developers", 17 | role = c("ctb", "cph"))) 18 | Description: An implementation of a grammar of interactive 19 | graphics using 'vega' in R. 20 | License: MIT + file LICENSE 21 | Depends: 22 | R (>= 2.10) 23 | Imports: 24 | jsonlite, 25 | rlang, 26 | scales, 27 | tidyselect, 28 | vctrs, 29 | vegawidget (>= 0.3.2), 30 | stats 31 | Suggests: 32 | covr, 33 | dplyr, 34 | knitr, 35 | lubridate, 36 | palmerpenguins, 37 | rmarkdown, 38 | gapminder, 39 | tidyr 40 | VignetteBuilder: 41 | knitr 42 | Encoding: UTF-8 43 | LazyData: true 44 | Roxygen: list(markdown = TRUE) 45 | RoxygenNote: 7.1.1 46 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | YEAR: 2021 2 | COPYRIGHT HOLDER: Earo Wang 3 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | # MIT License 2 | 3 | Copyright (c) 2021 Earo Wang 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | document: 2 | Rscript -e "devtools::document()" 3 | 4 | readme: 5 | Rscript -e "rmarkdown::render('README.Rmd')" 6 | 7 | build: 8 | Rscript -e "devtools::build()" 9 | 10 | test: 11 | Rscript -e "devtools::test()" 12 | 13 | check: 14 | Rscript -e "devtools::check()" 15 | 16 | install: 17 | Rscript -e "devtools::install(dependencies = FALSE)" 18 | 19 | winbuild: 20 | Rscript -e "devtools::check_win_devel(quiet = TRUE)" 21 | 22 | pkgdown: 23 | Rscript -e "pkgdown::build_site(run_dont_run = TRUE)" 24 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method(Ops,virgo_selection) 4 | S3method(as.list,virgo) 5 | S3method(as.list,virgo_concat) 6 | S3method(as_vegaspec,virgo) 7 | S3method(as_vegaspec,virgo_concat) 8 | S3method(format,virgo) 9 | S3method(print,virgo) 10 | S3method(print,virgo_aggregate) 11 | S3method(print,virgo_selection) 12 | S3method(print,virgo_timeunit) 13 | S3method(print,virgo_window) 14 | export("%>%") 15 | export(config) 16 | export(config_ggplot) 17 | export(enc) 18 | export(encode_if) 19 | export(entitle) 20 | export(facet_views) 21 | export(hconcat) 22 | export(input_checkbox) 23 | export(input_color) 24 | export(input_colour) 25 | export(input_date) 26 | export(input_datetime) 27 | export(input_month) 28 | export(input_radio) 29 | export(input_select) 30 | export(input_slider) 31 | export(input_textbox) 32 | export(input_week) 33 | export(knit_print.vegaspec) 34 | export(knit_print.virgo) 35 | export(mark_arc) 36 | export(mark_area) 37 | export(mark_bar) 38 | export(mark_bin2d) 39 | export(mark_blank) 40 | export(mark_boxplot) 41 | export(mark_circle) 42 | export(mark_density) 43 | export(mark_errorband) 44 | export(mark_errorbar) 45 | export(mark_histogram) 46 | export(mark_image) 47 | export(mark_line) 48 | export(mark_mosaic) 49 | export(mark_point) 50 | export(mark_rect) 51 | export(mark_ribbon) 52 | export(mark_rule) 53 | export(mark_smooth) 54 | export(mark_square) 55 | export(mark_step) 56 | export(mark_streamgraph) 57 | export(mark_text) 58 | export(mark_tick) 59 | export(mark_trail) 60 | export(resolve_views) 61 | export(scale_color) 62 | export(scale_colour) 63 | export(scale_shape) 64 | export(scale_size) 65 | export(scale_x) 66 | export(scale_y) 67 | export(select_bind) 68 | export(select_domain) 69 | export(select_interval) 70 | export(select_legend) 71 | export(select_multi) 72 | export(select_single) 73 | export(vconcat) 74 | export(vega) 75 | export(vega_serialise_data) 76 | export(vega_serialize_data) 77 | export(vg_argmax) 78 | export(vg_argmin) 79 | export(vg_count) 80 | export(vg_cume_dist) 81 | export(vg_cummean) 82 | export(vg_cumsum) 83 | export(vg_date) 84 | export(vg_day) 85 | export(vg_dayofyear) 86 | export(vg_dense_rank) 87 | export(vg_distinct) 88 | export(vg_hours) 89 | export(vg_lag) 90 | export(vg_lead) 91 | export(vg_max) 92 | export(vg_mean) 93 | export(vg_median) 94 | export(vg_milliseconds) 95 | export(vg_min) 96 | export(vg_minutes) 97 | export(vg_month) 98 | export(vg_ntile) 99 | export(vg_percent_rank) 100 | export(vg_quarter) 101 | export(vg_rank) 102 | export(vg_row_number) 103 | export(vg_seconds) 104 | export(vg_sum) 105 | export(vg_week) 106 | export(vg_window_count) 107 | export(vg_window_mean) 108 | export(vg_window_rank) 109 | export(vg_window_sum) 110 | export(vg_year) 111 | export(vg_yearmonth) 112 | export(vw_set_base_url) 113 | export(vw_to_bitmap) 114 | export(vw_to_svg) 115 | export(vw_write_png) 116 | export(vw_write_svg) 117 | import(rlang) 118 | import(tidyselect) 119 | import(vctrs) 120 | importFrom(jsonlite,write_json) 121 | importFrom(scales,date_trans) 122 | importFrom(scales,expand_range) 123 | importFrom(scales,log10_trans) 124 | importFrom(scales,sqrt_trans) 125 | importFrom(stats,complete.cases) 126 | importFrom(stats,lag) 127 | importFrom(vegawidget,"%>%") 128 | importFrom(vegawidget,as_vegaspec) 129 | importFrom(vegawidget,knit_print.vegaspec) 130 | importFrom(vegawidget,vega_embed) 131 | importFrom(vegawidget,vega_schema) 132 | importFrom(vegawidget,vegawidget) 133 | importFrom(vegawidget,vw_set_base_url) 134 | importFrom(vegawidget,vw_to_bitmap) 135 | importFrom(vegawidget,vw_to_svg) 136 | importFrom(vegawidget,vw_write_png) 137 | importFrom(vegawidget,vw_write_svg) 138 | -------------------------------------------------------------------------------- /R/compat-purrr.R: -------------------------------------------------------------------------------- 1 | # nocov start - compat-purrr (last updated: rlang 0.3.2.9000) 2 | 3 | # This file serves as a reference for compatibility functions for 4 | # purrr. They are not drop-in replacements but allow a similar style 5 | # of programming. This is useful in cases where purrr is too heavy a 6 | # package to depend on. Please find the most recent version in rlang's 7 | # repository. 8 | 9 | map <- function(.x, .f, ...) { 10 | lapply(.x, .f, ...) 11 | } 12 | map_mold <- function(.x, .f, .mold, ...) { 13 | out <- vapply(.x, .f, .mold, ..., USE.NAMES = FALSE) 14 | names(out) <- names(.x) 15 | out 16 | } 17 | map_lgl <- function(.x, .f, ...) { 18 | map_mold(.x, .f, logical(1), ...) 19 | } 20 | map_int <- function(.x, .f, ...) { 21 | map_mold(.x, .f, integer(1), ...) 22 | } 23 | map_dbl <- function(.x, .f, ...) { 24 | map_mold(.x, .f, double(1), ...) 25 | } 26 | map_chr <- function(.x, .f, ...) { 27 | map_mold(.x, .f, character(1), ...) 28 | } 29 | map_cpl <- function(.x, .f, ...) { 30 | map_mold(.x, .f, complex(1), ...) 31 | } 32 | 33 | walk <- function(.x, .f, ...) { 34 | map(.x, .f, ...) 35 | invisible(.x) 36 | } 37 | 38 | pluck <- function(.x, .f) { 39 | map(.x, `[[`, .f) 40 | } 41 | pluck_lgl <- function(.x, .f) { 42 | map_lgl(.x, `[[`, .f) 43 | } 44 | pluck_int <- function(.x, .f) { 45 | map_int(.x, `[[`, .f) 46 | } 47 | pluck_dbl <- function(.x, .f) { 48 | map_dbl(.x, `[[`, .f) 49 | } 50 | pluck_chr <- function(.x, .f) { 51 | map_chr(.x, `[[`, .f) 52 | } 53 | pluck_cpl <- function(.x, .f) { 54 | map_cpl(.x, `[[`, .f) 55 | } 56 | 57 | map2 <- function(.x, .y, .f, ...) { 58 | out <- mapply(.f, .x, .y, MoreArgs = list(...), SIMPLIFY = FALSE) 59 | if (length(out) == length(.x)) { 60 | set_names(out, names(.x)) 61 | } else { 62 | set_names(out, NULL) 63 | } 64 | } 65 | map2_lgl <- function(.x, .y, .f, ...) { 66 | as.vector(map2(.x, .y, .f, ...), "logical") 67 | } 68 | map2_int <- function(.x, .y, .f, ...) { 69 | as.vector(map2(.x, .y, .f, ...), "integer") 70 | } 71 | map2_dbl <- function(.x, .y, .f, ...) { 72 | as.vector(map2(.x, .y, .f, ...), "double") 73 | } 74 | map2_chr <- function(.x, .y, .f, ...) { 75 | as.vector(map2(.x, .y, .f, ...), "character") 76 | } 77 | map2_cpl <- function(.x, .y, .f, ...) { 78 | as.vector(map2(.x, .y, .f, ...), "complex") 79 | } 80 | 81 | args_recycle <- function(args) { 82 | lengths <- map_int(args, length) 83 | n <- max(lengths) 84 | 85 | stopifnot(all(lengths == 1L | lengths == n)) 86 | to_recycle <- lengths == 1L 87 | args[to_recycle] <- map(args[to_recycle], function(x) rep.int(x, n)) 88 | 89 | args 90 | } 91 | pmap <- function(.l, .f, ...) { 92 | args <- args_recycle(.l) 93 | do.call("mapply", c( 94 | FUN = list(quote(.f)), 95 | args, MoreArgs = quote(list(...)), 96 | SIMPLIFY = FALSE, USE.NAMES = FALSE 97 | )) 98 | } 99 | 100 | probe <- function(.x, .p, ...) { 101 | if (is_logical(.p)) { 102 | stopifnot(length(.p) == length(.x)) 103 | .p 104 | } else { 105 | map_lgl(.x, .p, ...) 106 | } 107 | } 108 | 109 | keep <- function(.x, .f, ...) { 110 | .x[probe(.x, .f, ...)] 111 | } 112 | discard <- function(.x, .p, ...) { 113 | sel <- probe(.x, .p, ...) 114 | .x[is.na(sel) | !sel] 115 | } 116 | map_if <- function(.x, .p, .f, ...) { 117 | matches <- probe(.x, .p) 118 | .x[matches] <- map(.x[matches], .f, ...) 119 | .x 120 | } 121 | 122 | compact <- function(.x) { 123 | Filter(length, .x) 124 | } 125 | 126 | transpose <- function(.l) { 127 | inner_names <- names(.l[[1]]) 128 | if (is.null(inner_names)) { 129 | fields <- seq_along(.l[[1]]) 130 | } else { 131 | fields <- set_names(inner_names) 132 | } 133 | 134 | map(fields, function(i) { 135 | map(.l, .subset2, i) 136 | }) 137 | } 138 | 139 | every <- function(.x, .p, ...) { 140 | for (i in seq_along(.x)) { 141 | if (!rlang::is_true(.p(.x[[i]], ...))) return(FALSE) 142 | } 143 | TRUE 144 | } 145 | some <- function(.x, .p, ...) { 146 | for (i in seq_along(.x)) { 147 | if (rlang::is_true(.p(.x[[i]], ...))) return(TRUE) 148 | } 149 | FALSE 150 | } 151 | negate <- function(.p) { 152 | function(...) !.p(...) 153 | } 154 | 155 | reduce <- function(.x, .f, ..., .init) { 156 | f <- function(x, y) .f(x, y, ...) 157 | Reduce(f, .x, init = .init) 158 | } 159 | reduce_right <- function(.x, .f, ..., .init) { 160 | f <- function(x, y) .f(y, x, ...) 161 | Reduce(f, .x, init = .init, right = TRUE) 162 | } 163 | accumulate <- function(.x, .f, ..., .init) { 164 | f <- function(x, y) .f(x, y, ...) 165 | Reduce(f, .x, init = .init, accumulate = TRUE) 166 | } 167 | accumulate_right <- function(.x, .f, ..., .init) { 168 | f <- function(x, y) .f(y, x, ...) 169 | Reduce(f, .x, init = .init, right = TRUE, accumulate = TRUE) 170 | } 171 | 172 | detect <- function(.x, .f, ..., .right = FALSE, .p = is_true) { 173 | for (i in index(.x, .right)) { 174 | if (.p(.f(.x[[i]], ...))) { 175 | return(.x[[i]]) 176 | } 177 | } 178 | NULL 179 | } 180 | detect_index <- function(.x, .f, ..., .right = FALSE, .p = is_true) { 181 | for (i in index(.x, .right)) { 182 | if (.p(.f(.x[[i]], ...))) { 183 | return(i) 184 | } 185 | } 186 | 0L 187 | } 188 | index <- function(x, right = FALSE) { 189 | idx <- seq_along(x) 190 | if (right) { 191 | idx <- rev(idx) 192 | } 193 | idx 194 | } 195 | 196 | imap <- function(.x, .f, ...) { 197 | map2(.x, vec_index(.x), .f, ...) 198 | } 199 | vec_index <- function(x) { 200 | names(x) %||% seq_along(x) 201 | } 202 | 203 | 204 | # nocov end 205 | -------------------------------------------------------------------------------- /R/config.R: -------------------------------------------------------------------------------- 1 | #' Vega theme configurations 2 | #' 3 | #' @param v A `vega()` object. 4 | #' @param background A plot background. 5 | #' @param axis,axis_x,axis_y A named list to define axis. 6 | #' @param header,legend,title,view,facet A named list. 7 | #' @param ... Other parameters. 8 | #' 9 | #' @rdname vega-config 10 | #' @export 11 | config <- function(v, background = "white", axis = list(), axis_x = list(), 12 | axis_y = list(), header = list(), legend = list(), title = list(), 13 | view = list(), facet = list(), ...) { 14 | default <- config_ggplot(v)$config 15 | 16 | fn <- function(x) { 17 | vec_set_names(x, standardise_names(names(x))) 18 | } 19 | 20 | axis <- replace(default$axis, names(axis), fn(axis)) 21 | axis_x <- replace(default$axis_x, names(axis_x), fn(axis_x)) 22 | axis_y <- replace(default$axis_y, names(axis_y), fn(axis_y)) 23 | header <- replace(default$header, names(header), fn(header)) 24 | legend <- replace(default$legend, names(legend), fn(legend)) 25 | title <- replace(default$title, names(title), fn(title)) 26 | view <- replace(default$view, names(view), fn(view)) 27 | # concat <- replace(default$concat, names(concat), fn(concat)) 28 | facet <- replace(default$facet, names(facet), fn(facet)) 29 | 30 | res <- list( 31 | background = background, 32 | axis = axis, 33 | axisX = axis_x, 34 | axisY = axis_y, 35 | header = header, 36 | legend = legend, 37 | title = title, 38 | view = view, 39 | # concat = concat, 40 | facet = facet, 41 | ... 42 | ) 43 | old <- default[!vec_in(names(default), names(res))] 44 | new_virgo(c(unclass(v), list(config = c(old, res)))) 45 | } 46 | 47 | #' @rdname vega-config 48 | #' @export 49 | config_ggplot <- function(v) { 50 | abort_if_not_virgo(v) 51 | # mark props 52 | mark_color <- "#000" 53 | point <- circle <- square <- list(color = mark_color, opacity = 1, size = 60) 54 | line <- tick <- trail <- geoshape <- list(color = mark_color) 55 | bar <- area <- rect <- list(fill = "#595959") 56 | # box-plot uses bar so default will be black instead of usual white 57 | 58 | # axis props 59 | axis <- list( 60 | domain = FALSE, 61 | domainColor = "#FFFFFFF", 62 | grid = TRUE, 63 | gridColor = "#FFFFFF", 64 | gridOpacity = 1, 65 | labelColor = "#7F7F7F", 66 | labelPadding = 4, 67 | tickColor = "#7F7F7F", 68 | tickSize = 5.67 69 | ) 70 | 71 | legend <- list( 72 | orient = "right", 73 | padding = 1 74 | ) 75 | 76 | new_virgo(c(unclass(v), list(config = list( 77 | view = list(fill = "#e5e5e5"), # sets inner view to grey, 78 | facet = list(spacing = 5), 79 | headerRow = list(labelOrient = "right", titleOrient = "right"), 80 | circle = circle, 81 | point = point, 82 | line = line, 83 | trail = trail, 84 | tick = tick, 85 | geoshape = geoshape, 86 | square = square, 87 | rect = rect, 88 | area = area, 89 | bar = bar, 90 | axis = axis, 91 | axisX = list(), 92 | axisY = list(), 93 | header = list(), 94 | legend = legend, 95 | title = list() 96 | # concat = list() 97 | )))) 98 | } 99 | 100 | 101 | -------------------------------------------------------------------------------- /R/data-type.R: -------------------------------------------------------------------------------- 1 | data_type <- function(x) { 2 | UseMethod("data_type") 3 | } 4 | 5 | data_type.numeric <- function(x) { 6 | list(type = "quantitative") 7 | } 8 | 9 | data_type.character <- function(x) { 10 | list(type = "nominal") 11 | } 12 | 13 | data_type.logical <- data_type.character 14 | 15 | data_type.factor <- function(x) { 16 | list(type = "nominal", sort = levels(x)) 17 | } 18 | 19 | data_type.ordered <- function(x) { 20 | list(type = "ordinal", sort = levels(x)) 21 | } 22 | 23 | data_type.POSIXt <- function(x) { 24 | list(type = "temporal") 25 | } 26 | 27 | data_type.Date <- data_type.POSIXt 28 | 29 | data_type.NULL <- function(x) { 30 | NULL 31 | } 32 | -------------------------------------------------------------------------------- /R/datasets.R: -------------------------------------------------------------------------------- 1 | #' Melbourne microclimate measurements 2 | #' 3 | #' @details This data comes from the [Melbourne Open Data Portal](https://data.melbourne.vic.gov.au/Environment/Microclimate-Sensor-Readings/u4vh-84j8) 4 | #' and contains measurements from microclimate sensors around the city. Here 5 | #' we have restricted the data to contain measurements from January 2020 and June 2020. There are five sites where measurements are taken 6 | #' every 15 minutes. 7 | #' 8 | #' @format A tibble with 32,253 rows and 12 variables: 9 | #' * `site`: Site identifier, this is the location of the weather sensor, 10 | #' there are five sites located around the city. 11 | #' * `site_address`: The address of the site 12 | #' * `longitude, latitude`: The spatial coordinates of the measurement sites 13 | #' * `date_time`: The local date time that a sensor made a recording 14 | #' * `date`: Date associated with `date_time` 15 | #' * `ambient_temperature`: The value of the ambient air temperature in degrees Celsius. 16 | #' * `relative_humidity`: The percent value of the relative humidity (no units) 17 | #' * `barometric_pressure`: The barometric pressure in hectopascals (hPa) 18 | #' * `wind_speed`: The wind speed in kilometers per hour (km/h) 19 | #' * `pm2.5,pm10`: The mass density of particulate matter in the air less than 2.5 (10) micrometers in diameter. Measured in micrograms per cubic meter. 20 | #' 21 | #' @source [Melbourne Open Data Portal](https://data.melbourne.vic.gov.au/Environment/Microclimate-Sensor-Readings/u4vh-84j8) 22 | "melbweather" 23 | 24 | #' Auckland housing price 25 | #' 26 | #' @details This data is scraped from the [interest.co.nz](https://www.interest.co.nz) 27 | #' and contains Auckland auction prices between 2018 and 2021. 28 | #' 29 | #' @format A tibble with 8,011 rows and 10 variables: 30 | #' * `region`: "Auckland" 31 | #' * `district`: Auckland districts 32 | #' * `property_address`: Property address 33 | #' * `lon`: Latitude of the property 34 | #' * `lat`: Longitude of the property 35 | #' * `auction_price`: Auction price 36 | #' * `auction_dates`: Auction date 37 | #' * `bedrooms`: The number of bedrooms 38 | #' * `bathrooms`: The number of bathrooms 39 | #' * `car_parking`: The number of parkings 40 | #' * `rating_value`: Rating price 41 | #' * `rating_dates`: Rating dates 42 | #' 43 | #' @source [interest.co.nz](https://www.interest.co.nz) 44 | "aklhousingprice" 45 | -------------------------------------------------------------------------------- /R/eval.R: -------------------------------------------------------------------------------- 1 | #' Map data variables to visual encodings 2 | #' 3 | #' @param x,y,... A set of name-value pairs to describe the mappings of data 4 | #' variables to visual encodings in `vega()` and individual mark layers `mark_*()`. 5 | #' Use `NULL` to disable a layer encoding to inherit from its parent encodings. 6 | #' 7 | #' @return A list of quosures or constants. 8 | #' @export 9 | #' @examples 10 | #' enc(x = mpg, y = wt) 11 | #' enc(colour = cyl) 12 | #' enc(color = cyl) 13 | #' enc(x = NULL) 14 | enc <- function(x, y, ...) { 15 | encoding <- enquos(x = x, y = y, ..., .ignore_empty = "all") 16 | s_names <- standardise_encodings(names(encoding)) 17 | vec_set_names(encoding, s_names) 18 | } 19 | 20 | simple_select <- function(x) { 21 | x <- enexpr(x) 22 | if (is_call(x, "c")) { 23 | args <- call_args(x) 24 | map_chr(args, as_string) 25 | } else if (is.null(x)) { 26 | NULL 27 | } else { 28 | as_string(x) 29 | } 30 | } 31 | 32 | eval_enc <- function(data, encoding, encoding_name) { 33 | if (encoding_name == "tooltip") { # column names only, no functions 34 | cols <- names(eval_select(encoding, data)) 35 | map(cols, function(x) encoding_spec(data[[x]], sym(x), "tooltip")) 36 | } else { 37 | spec <- eval_tidy(encoding, data = data) 38 | encoding_spec(spec, field = encoding, encoding_name = encoding_name, 39 | data = data) 40 | } 41 | } 42 | 43 | eval_encoding <- function(data, encoding) { 44 | map2(encoding, names(encoding), function(x, y) eval_enc(data, x, y)) 45 | } 46 | 47 | eval_condition <- function(data, selection, encoding) { 48 | selection_cp <- selection 49 | n_sel <- length(selection_cp) 50 | res <- vec_init(list(), n = n_sel) 51 | for (i in seq_len(n_sel)) { 52 | selection <- selection_cp[[i]] 53 | cond_true <- selection$true 54 | cond_false <- selection$false 55 | selection <- selection$selection 56 | eval_true <- eval_tidy(cond_true, data = data) 57 | eval_false <- eval_tidy(cond_false, data = data) 58 | if (quo_is_symbol(cond_true) || quo_is_call(cond_true)) { 59 | def_true <- encoding_spec(eval_true, cond_true, encoding) 60 | } else { 61 | def_true <- list(value = eval_true) 62 | } 63 | if (quo_is_symbol(cond_false) || quo_is_call(cond_false)) { 64 | def_false <- encoding_spec(eval_false, cond_false, encoding) 65 | } else { 66 | def_false <- list(value = eval_false) 67 | } 68 | res[[i]] <- list2(!!encoding[i] := list2( 69 | condition = list2( 70 | selection = selection_composition(selection), 71 | !!!def_true), 72 | !!!def_false 73 | )) 74 | } 75 | vec_c(!!!res) 76 | } 77 | 78 | as_field_rhs <- function(quo) { 79 | if (is_quosure(quo)) { 80 | if (quo_is_null(quo)) { 81 | NULL 82 | } else if (quo_is_call(quo)) { 83 | fn <- call_name(quo) 84 | if (vec_in(fn, "vg_count")) { 85 | "" 86 | } else if (vec_in(fn, "ac")){ 87 | "" 88 | } else if (vec_in(fn, virgo_op())) { 89 | as_label(call_args(quo)[[1]]) 90 | } else { 91 | as_label(quo) 92 | } 93 | } else { 94 | as_label(quo) 95 | } 96 | } else { 97 | as_label(quo) 98 | } 99 | 100 | } 101 | 102 | as_field <- function(quo) { 103 | square_brackets(as_field_rhs(quo)) 104 | } 105 | 106 | encoding_spec <- function(x, field, ...) { 107 | UseMethod("encoding_spec") 108 | } 109 | 110 | encoding_spec.default <- function(x, field, ...) { 111 | type <- data_type(x) 112 | list2(field = as_field(field), !!!type) 113 | } 114 | 115 | encoding_spec.Date <- function(x, field, encoding_name, ...) { 116 | type <- data_type(x) 117 | res <- list2(field = as_field(field), !!!type) 118 | if (any(vec_in(c("x", "y"), encoding_name))) { 119 | res <- list2(!!!res, scale = list(padding = 10)) 120 | } 121 | res 122 | } 123 | 124 | encoding_spec.numeric <- function(x, field, encoding_name, ...) { 125 | type <- data_type(x) 126 | res <- list2(field = as_field(field), !!!type) 127 | if (any(vec_in(c("x", "x2", "y", "y2"), encoding_name))) { 128 | res <- list2(!!!res, scale = list(domain = expand_domain(x)), 129 | axis = list(tickCount = 5)) 130 | } 131 | res 132 | } 133 | 134 | encoding_spec.factor <- function(x, field, encoding_name, ...) { 135 | type <- data_type(x) 136 | res <- list2(field = as_field(field), !!!type) 137 | ncat <- length(vec_unique(x)) 138 | if (any(vec_in(c("color", "fill"), encoding_name))) { 139 | res <- list2(!!!res, scale = list(range = scales::hue_pal()(ncat))) 140 | } 141 | res$scale$paddingOuter <- 0.2 142 | res 143 | } 144 | 145 | encoding_spec.character <- encoding_spec.factor 146 | 147 | encoding_spec.logical <- encoding_spec.factor 148 | 149 | encoding_spec.virgo_aggregate <- function(x, field, encoding_name, ...) { 150 | data <- dots_list(...)$data 151 | aggregate <- x$aggregate 152 | type <- data_type(data[[as_field(field)]]) 153 | if (vec_in(aggregate, c("argmin", "argmax"))) { 154 | arg_field <- as_string(call_args(field)[[2]]) 155 | res <- list2( 156 | field = as_field(field), aggregate = list2(!!aggregate := arg_field), 157 | !!!type) 158 | } else { 159 | res <- list2(field = as_field(field), aggregate = aggregate, !!!type) 160 | } 161 | if (any(vec_in(c("x", "x2", "y", "y2"), encoding_name))) { 162 | res <- list2(!!!res, scale = list(zero = FALSE, padding = 10)) 163 | } 164 | res 165 | } 166 | 167 | encoding_spec.virgo_timeunit <- function(x, field, encoding_name, ...) { 168 | res <- list2(field = as_field(field), timeUnit = unclass(x), type = "temporal") 169 | if (any(vec_in(c("x", "x2", "y", "y2"), encoding_name))) { 170 | res <- list2(!!!res, scale = list(padding = 10)) 171 | } 172 | res 173 | } 174 | 175 | encoding_spec.virgo_combinator <- function(x, field, encoding_name, ...) { 176 | data <- dots_list(...)$data 177 | cols <- x(data) 178 | encoders <- map(names(cols), 179 | function(x) encoding_spec(data[[x]], sym(x), encoding_name)) 180 | 181 | types <- reduce(map_chr(encoders, function(x) x$type), union) 182 | 183 | if (length(types) != 1L) { 184 | abort("Repeated fields must evaluate to same type") 185 | } 186 | 187 | if (!encoding_name %in% c("x", "y")) { 188 | abort("Repeated fields must be encoded to x or y") 189 | } 190 | where <- c(x = "column", y = "row") 191 | list2( 192 | field = list("repeat" = unname(where[encoding_name])), 193 | type = types, 194 | scale = list(zero = FALSE, padding = 10), 195 | axis = list(tickCount = 5) 196 | ) 197 | } 198 | 199 | encoding_spec.virgo_bin <- function(x, field, encoding_name, ...) { 200 | res <- list2(field = as_field(field), bin = unclass(x)) 201 | if (any(vec_in(c("x", "x2", "y", "y2"), encoding_name))) { 202 | res <- list2(!!!res, scale = list(padding = 10)) 203 | } 204 | res 205 | } 206 | 207 | encoding_spec.virgo_window <- function(x, field, ...) { 208 | abort("`encoding` specs don't know how to handle `vg_window()`.") 209 | } 210 | 211 | ac <- function(...) { 212 | selector <- function(.data) { 213 | tidyselect::eval_select(expr(c(...)), .data) 214 | } 215 | 216 | structure(.Data = selector, class = c("virgo_combinator", "function")) 217 | } 218 | 219 | virgo_encoding_env <- function() { 220 | ops <- c(virgo_op(), "encode_if") 221 | fns <- map(ops, function(op) function(x, ...) { 222 | if (is_missing(x) || is_virgo_selection(x)) { # vg_count() with missing arg 223 | NULL 224 | } 225 | else { 226 | x 227 | } 228 | }) 229 | new_environment(vec_set_names(fns, ops)) 230 | } 231 | 232 | new_virgo_mask <- function(data, env = virgo_encoding_env()) { 233 | bottom <- as_environment(data, parent = env) 234 | new_data_mask(bottom, top = env) 235 | } 236 | 237 | eval_encoding_mask <- function(data, quo, encoding_name) { 238 | names <- names(quo) 239 | data_mask <- new_virgo_mask(data) 240 | for (i in seq_along(names)) { 241 | if (quo_is_call(quo[[i]], "ac")) { 242 | next 243 | } 244 | data[[names[i]]] <- eval_tidy(quo[[i]], data = data_mask) 245 | } 246 | data 247 | } 248 | 249 | 250 | eval_repeater <- function(data, quo, encoding_name) { 251 | res <- list() 252 | names <- names(quo) 253 | data_mask <- new_virgo_mask(data) 254 | where <- c("x" = "column", "y" = "row") 255 | for (i in seq_along(names)) { 256 | if (quo_is_call(quo[[i]], "ac")) { 257 | 258 | .selector <- eval_tidy(quo[[i]], data = data_mask) 259 | cols <- .selector(data) 260 | res[[unname(where[encoding_name[[i]]])]] <- names(cols) 261 | } 262 | } 263 | res 264 | } 265 | -------------------------------------------------------------------------------- /R/mark.R: -------------------------------------------------------------------------------- 1 | vega_layer <- function(v, layer = list(), encoding = NULL, data = NULL, 2 | selection = NULL, na.rm = TRUE) { 3 | fields <- encoding <- merge_encoding(c(v$encoding, encoding)) 4 | is_data_inherit <- is.null(data) 5 | data <- data %||% v$data$values 6 | if (!is.null(selection)) { 7 | if (inherits(selection, "AsIs")) { 8 | layer <- c(layer, list(selection = unclass(selection))) 9 | } else { 10 | filter <- list(filter = list(selection = selection_composition(selection))) 11 | trans <- selection %@% "transform" 12 | if (is.null(trans)) { 13 | trans_spec <- list(filter) 14 | } else { 15 | new_vars <- map_chr(trans, function(x) x$as) 16 | old_vars <- map_chr(trans, function(x) x$field) 17 | for (i in seq_along(new_vars)) { 18 | data[[new_vars[i]]] <- eval_tidy(parse_expr(old_vars[i]), data) 19 | } 20 | trans_res <- map(trans, function(x) x[["x"]]) 21 | trans_spec <- list(filter, vec_c(!!!trans_res)) 22 | } 23 | layer <- c(layer, 24 | list(selection = unclass(selection)), 25 | list(transform = trans_spec)) 26 | } 27 | } 28 | 29 | if (!is.null(encoding)) { 30 | which_selection <- map_lgl(encoding, function(x) quo_is_call(x, "encode_if")) 31 | encoding_sel <- encoding[which_selection] 32 | layer <- c(layer, list( 33 | encoding = eval_encoding(data, encoding[!which_selection]))) 34 | 35 | if (has_length(encoding_sel)) { 36 | selection <- map(encoding_sel, eval_tidy, data = data) 37 | trues <- map(selection, function(x) x$true) 38 | falses <- map(selection, function(x) x$false) 39 | fields <- c(fields, trues, falses) 40 | condition <- eval_condition(data, selection, names(encoding_sel)) 41 | layer$encoding <- c(layer$encoding, condition) 42 | selection <- vec_c(!!!map(selection, function(x) unclass(x$selection)), 43 | .name_spec = "{inner}") 44 | layer <- c(list(selection = selection), layer) 45 | } 46 | } 47 | 48 | # data needs updating 49 | fields <- vec_set_names(fields, map_chr(fields, as_field_rhs)) 50 | data <- eval_encoding_mask(data, fields, names(encoding)) 51 | # missing data 52 | pos_fields <- names(fields[vec_in(names(encoding), c("x", "y", "x2", "y2"))]) 53 | pos_fields <- vec_slice(pos_fields, !vec_in(pos_fields, "")) 54 | nna_lgl <- complete.cases(data[pos_fields]) 55 | n_na <- vec_size(data) - sum(nna_lgl) 56 | if (na.rm) { 57 | if (n_na > 0) { 58 | inform(sprintf("Removed %s rows containing missing values.", n_na)) 59 | } 60 | data <- vec_slice(data, nna_lgl) 61 | } 62 | if (is_data_inherit) { 63 | v$data$values <- data 64 | } else { 65 | layer <- c(list(data = list(values = data)), layer) 66 | } 67 | 68 | # check for presence of repeat 69 | repeat_spec <- eval_repeater(data, fields, names(encoding)) 70 | 71 | if (length(repeat_spec) > 0) { 72 | v$`repeat` <- repeat_spec 73 | } 74 | 75 | spec <- build_layer(v, add_layer(v$layer, layer)) 76 | new_virgo(spec) 77 | } 78 | 79 | merge_encoding <- function(x) { 80 | x <- rev(x) 81 | names_x <- names(x) 82 | x <- rev(x[vec_match(vec_unique(names_x), names_x)]) 83 | x[!map_lgl(x, quo_is_null)] 84 | } 85 | 86 | build_layer <- function(v, layer) { 87 | v <- remove_layer(v) 88 | c(v, list(layer = layer)) 89 | } 90 | 91 | remove_layer <- function(v) { 92 | v$layer <- NULL 93 | v 94 | } 95 | 96 | add_layer <- function(layer, new_layer) { 97 | c(layer, list(new_layer)) 98 | } 99 | 100 | nlayer <- function(v) { 101 | length(v$layer) 102 | } 103 | 104 | mark_properties <- function(...) { 105 | dots <- dots_list(..., .named = TRUE, .homonyms = "error") 106 | dots <- vec_set_names(dots, standardise_encodings(names(dots))) 107 | input_lgl <- map_lgl(dots, is_virgo_input) 108 | params <- vec_init(list(), n = sum(input_lgl)) 109 | for (i in seq_along(params)) { 110 | if (is_virgo_input(dots[input_lgl][[i]])) { 111 | input <- dots[input_lgl][[i]] 112 | dots[input_lgl][[i]] <- list(expr = input$name) 113 | params[[i]] <- list(name = input$name, value = input %@% "init", 114 | bind = unclass(input)) 115 | } 116 | } 117 | if (!(has_name(dots, "tooltip"))) { # enable tooltip by default 118 | dots$tooltip <- TRUE 119 | } 120 | if (!has_name(dots, "clip")) { 121 | dots$clip <- TRUE 122 | } 123 | list(props = dots, params = params) 124 | } 125 | 126 | # use vega options name but in snake_case 127 | mark_factory <- function(type = "point") { 128 | force(type) 129 | function(v, encoding = NULL, data = NULL, selection = NULL, ..., 130 | na.rm = TRUE) { 131 | abort_if_not_virgo(v) 132 | marks <- mark_properties(...) 133 | v$params <- marks$params 134 | layer <- list(mark = list2(type = type, !!!marks$props)) 135 | vega_layer(v, layer, encoding, data, selection, na.rm = na.rm) 136 | } 137 | } 138 | 139 | #' Add new marks to `vega()` visualisation 140 | #' 141 | #' @param v A `vega()` object. 142 | #' @param encoding An aesthetic mapping via `enc()`. 143 | #' @param data A data frame for the layer. 144 | #' @param selection A selection object. 145 | #' @param ... Additional mark properties. 146 | #' @param na.rm If `TRUE`, missing values are removed with a message. 147 | #' If `FALSE`, missing values are included. 148 | #' 149 | #' @rdname vega-marks 150 | #' @export 151 | mark_arc <- mark_factory(type = "arc") 152 | 153 | #' @rdname vega-marks 154 | #' @export 155 | mark_ribbon <- mark_factory(type = "area") 156 | 157 | #' @rdname vega-marks 158 | #' @export 159 | mark_boxplot <- mark_factory(type = "boxplot") 160 | 161 | #' @rdname vega-marks 162 | #' @export 163 | mark_circle <- mark_factory(type = "point") 164 | 165 | #' @rdname vega-marks 166 | #' @export 167 | mark_errorband <- mark_factory(type = "errorband") 168 | # mark_geoshape <- mark_factory(type = "geoshape") 169 | 170 | #' @rdname vega-marks 171 | #' @export 172 | mark_image <- mark_factory(type = "image") 173 | 174 | #' @rdname vega-marks 175 | #' @export 176 | mark_line <- mark_factory(type = "line") 177 | 178 | #' @rdname vega-marks 179 | #' @export 180 | mark_point <- mark_factory(type = "circle") 181 | 182 | #' @rdname vega-marks 183 | #' @export 184 | mark_rect <- mark_factory(type = "rect") 185 | 186 | #' @rdname vega-marks 187 | #' @export 188 | mark_rule <- mark_factory(type = "rule") 189 | 190 | #' @rdname vega-marks 191 | #' @export 192 | mark_square <- mark_factory(type = "square") 193 | 194 | #' @rdname vega-marks 195 | #' @export 196 | mark_text <- mark_factory(type = "text") 197 | 198 | #' @rdname vega-marks 199 | #' @export 200 | mark_tick <- mark_factory(type = "tick") 201 | 202 | #' @rdname vega-marks 203 | #' @export 204 | mark_trail <- mark_factory(type = "trail") 205 | 206 | position_to_stack <- function(position = "stack") { 207 | position <- arg_match(position, c("identity", "stack", "fill")) 208 | if (position == "identity") { 209 | FALSE 210 | } else if (position == "stack") { 211 | TRUE 212 | } else if (position == "fill") { 213 | "normalize" 214 | # } else if (position == "dodge") { 215 | # v$facet$column <- v$layer[[last]]$encoding$column 216 | # v$layer[[last]]$encoding$column <- NULL 217 | # stack <- FALSE 218 | } 219 | } 220 | 221 | #' @param position One of "identity", "stack", "fill". 222 | #' @rdname vega-marks 223 | #' @export 224 | mark_area <- function(v, encoding = NULL, data = NULL, selection = NULL, 225 | position = "stack", ..., na.rm = TRUE) { 226 | abort_if_not_virgo(v) 227 | marks <- mark_properties(...) 228 | v$params <- marks$params 229 | layer <- list(mark = list2(type = "area", !!!marks$props)) 230 | v <- vega_layer(v, layer, encoding, data, selection, na.rm) 231 | last <- nlayer(v) 232 | v$layer[[last]]$encoding$y$stack <- position_to_stack(position) 233 | v$layer[[last]]$encoding$y$scale$zero <- TRUE 234 | v 235 | } 236 | 237 | #' @rdname vega-marks 238 | #' @export 239 | mark_bar <- function(v, encoding = NULL, data = NULL, selection = NULL, 240 | position = "stack", ..., na.rm = TRUE) { 241 | abort_if_not_virgo(v) 242 | marks <- mark_properties(...) 243 | v$params <- marks$params 244 | layer <- list(mark = list2(type = "bar", !!!marks$props)) 245 | v <- vega_layer(v, layer, encoding, data, selection, na.rm) 246 | last <- nlayer(v) 247 | v$layer[[last]]$encoding$x$scale$domain <- NULL 248 | v$layer[[last]]$encoding$y$scale$zero <- TRUE 249 | v$layer[[last]]$encoding$y$stack <- position_to_stack(position) 250 | v 251 | } 252 | 253 | #' @rdname vega-marks 254 | #' @export 255 | mark_errorbar <- function(v, encoding = NULL, data = NULL, selection = NULL, 256 | ..., na.rm = TRUE) { 257 | abort_if_not_virgo(v) 258 | marks <- mark_properties(ticks = TRUE, ...) 259 | v$params <- marks$params 260 | layer <- list(mark = list2(type = "errorbar", !!!marks$props)) 261 | vega_layer(v, layer, encoding, data, selection, na.rm) 262 | } 263 | 264 | #' @rdname vega-marks 265 | #' @export 266 | mark_histogram <- function(v, encoding = NULL, data = NULL, selection = NULL, 267 | position = "stack", ..., bin = TRUE, na.rm = TRUE) { # bin = list() opts 268 | v <- mark_bar(v, encoding, data, selection, position = position, ..., 269 | na.rm = na.rm) 270 | last <- nlayer(v) 271 | v$layer[[last]]$encoding$x$scale$padding <- 10 272 | x <- v$layer[[last]]$encoding$x 273 | y <- v$layer[[last]]$encoding$y 274 | v$layer[[last]]$encoding$x <- c(x, list(bin = bin)) 275 | v$layer[[last]]$encoding$y <- c(y, aggregate = "count") 276 | v 277 | } 278 | 279 | #' @rdname vega-marks 280 | #' @export 281 | mark_step <- function(v, encoding = NULL, data = NULL, selection = NULL, ..., 282 | na.rm = TRUE) { 283 | abort_if_not_virgo(v) 284 | marks <- mark_properties(interpolate = "step-after", ...) 285 | v$params <- marks$params 286 | layer <- list(mark = list2(type = "line", !!!marks$props)) 287 | vega_layer(v, layer, encoding, data, selection, na.rm) 288 | } 289 | 290 | #' @param density Density parameters. 291 | #' @rdname vega-marks 292 | #' @export 293 | mark_density <- function(v, encoding = NULL, data = NULL, selection = NULL, 294 | position = "identity", ..., density = list(), na.rm = TRUE) { 295 | v <- mark_area(v, encoding, data, selection, position = position, ..., 296 | na.rm = na.rm) 297 | last <- nlayer(v) 298 | enc <- v$layer[[last]]$encoding 299 | density_field <- enc$x$field 300 | groupby <- as.list(unique(c(enc$color$field, enc$fill$field, enc$detail$field, 301 | enc$stroke$field))) 302 | dens <- list2(density = density_field, groupby = groupby, !!!density, 303 | extent = v$layer[[last]]$encoding$x$scale$domain) 304 | trans <- vec_c(!!!v$layer[[last]]$transform) 305 | if (is.null(trans)) { 306 | v$layer[[last]]$transform <- list(dens) 307 | } else { 308 | v$layer[[last]]$transform <- list(trans, dens) 309 | } 310 | v$layer[[last]]$encoding$x$field <- "value" 311 | v$layer[[last]]$encoding$x$scale$padding <- .5 312 | v$layer[[last]]$encoding$y <- c(enc$y, field = "density", type = "quantitative") 313 | v 314 | } 315 | 316 | #' @param bin A list of `bin` parameters. 317 | #' @rdname vega-marks 318 | #' @export 319 | mark_bin2d <- function(v, encoding = NULL, data = NULL, selection = NULL, ..., 320 | bin = list(x = TRUE, y = TRUE), na.rm = TRUE) { 321 | # list(x = list(maxbins = 10)) 322 | abort_if_not_virgo(v) 323 | marks <- mark_properties(...) 324 | v$params <- marks$params 325 | layer <- list(mark = list2(type = "rect", !!!marks$props)) 326 | v <- vega_layer(v, layer, encoding, data, selection, na.rm) 327 | last <- nlayer(v) 328 | x <- v$layer[[last]]$encoding$x 329 | y <- v$layer[[last]]$encoding$y 330 | v$layer[[last]]$encoding$x <- c(x, list(bin = bin$x)) 331 | v$layer[[last]]$encoding$y <- c(y, list(bin = bin$y)) 332 | v 333 | } 334 | 335 | #' @rdname vega-marks 336 | #' @export 337 | mark_streamgraph <- function(v, encoding = NULL, data = NULL, selection = NULL, 338 | ..., na.rm = TRUE) { 339 | abort_if_not_virgo(v) 340 | marks <- mark_properties(...) 341 | v$params <- marks$params 342 | layer <- list(mark = list2(type = "area", !!!marks$props)) 343 | v <- vega_layer(v, layer, encoding, data, selection, na.rm) 344 | last <- nlayer(v) 345 | v$layer[[last]]$encoding$y$stack <- "center" 346 | # remove y axis as y values not important 347 | v$layer[[last]]$encoding$y <- c(v$layer[[last]]$encoding$y, list(axis = NULL)) 348 | v 349 | } 350 | 351 | #' @param method One of "lm" or "loess". 352 | #' @param formula One of: 353 | #' * y ~ x 354 | #' * y ~ x^2 355 | #' * y ~ x^[order] 356 | #' * y ~ log(x) 357 | #' * y ~ exp(x) 358 | #' @param bandwidth Degree of smoother. 359 | #' @rdname vega-marks 360 | #' @export 361 | mark_smooth <- function(v, encoding = NULL, data = NULL, selection = NULL, ..., 362 | method = "lm", formula = y ~ x, bandwidth = 0.3, na.rm = TRUE) { 363 | abort_if_not_virgo(v) 364 | marks <- mark_properties(...) 365 | v$params <- marks$params 366 | method <- arg_match(method, c("lm", "loess")) 367 | method <- if (method == "lm") "regression" else "loess" 368 | layer <- list(mark = list2(type = "line", !!!marks$props)) 369 | v <- vega_layer(v, layer, encoding, data, selection, na.rm) 370 | last <- nlayer(v) 371 | enc <- v$layer[[last]]$encoding 372 | groupby <- as.list(unique(c(enc$color$field, enc$fill$field, enc$detail$field, 373 | enc$stroke$field))) 374 | f <- interpret_formula(formula) 375 | smooth_fn <- list2(!!method := enc$y$field, on = enc$x$field, 376 | groupby = groupby, !!!f, bandwidth = bandwidth) 377 | trans <- vec_c(!!!v$layer[[last]]$transform) 378 | if (is.null(trans)) { 379 | v$layer[[last]]$transform <- list(smooth_fn) 380 | } else { 381 | v$layer[[last]]$transform <- list(trans, smooth_fn) 382 | } 383 | v 384 | } 385 | 386 | interpret_formula <- function(formula) { 387 | # TODO: 388 | # 1. abort if more than one calls in the specified formula 389 | # 2. no support for "pow" option, don't know how to distinguish pow and poly 390 | rhs <- f_rhs(formula) 391 | if (is_symbol(rhs)) { 392 | list(method = "linear") 393 | } else if (is_call(rhs, "log")) { 394 | list(method = "log") 395 | } else if (is_call(rhs, "exp")) { 396 | list(method = "exp") 397 | } else if (is_call(rhs, "^")) { 398 | order <- call_args(rhs)[[2]] 399 | if (order == 2) { 400 | list(method = "quad") 401 | } else { 402 | list(method = "poly", order = order) 403 | } 404 | } 405 | } 406 | 407 | 408 | #' @rdname vega-marks 409 | #' @export 410 | mark_mosaic <- function(v, encoding = NULL, data = NULL, selection = NULL, ..., 411 | na.rm = TRUE) { 412 | v <- mark_rect(v, encoding, data, selection, ..., na.rm = na.rm) 413 | last <- nlayer(v) 414 | enc <- v$layer[[last]]$encoding 415 | 416 | stack <- vg_mosaic(enc) 417 | 418 | trans <- vec_c(!!!v$layer[[last]]$transform) 419 | if (is.null(trans)) { 420 | v$layer[[last]]$transform <- stack 421 | } else { 422 | v$layer[[last]]$transform <- c(list(trans), stack) 423 | } 424 | 425 | # override encodings 426 | v$layer[[last]]$encoding$x <- list( 427 | field = "nx", 428 | type = "quantitative", 429 | axis = NA, 430 | scale = list(padding = 0.2) 431 | ) 432 | 433 | v$layer[[last]]$encoding$y <- list( 434 | field = "ny", 435 | type = "quantitative", 436 | axis = NA, 437 | scale = list(padding = 0.2) 438 | ) 439 | 440 | v$layer[[last]]$encoding$x2 <- list(field = "nx2") 441 | v$layer[[last]]$encoding$y2 <- list(field = "ny2") 442 | v 443 | } 444 | 445 | #' @rdname vega-marks 446 | #' @export 447 | mark_blank <- function(v, encoding = NULL, data = NULL, selection = NULL, ..., 448 | na.rm = TRUE) { 449 | marks <- mark_properties(color = "transparent", ...) 450 | v$params <- marks$params 451 | layer <- list(mark = list2(type = "point", !!!marks$props)) 452 | vega_layer(v, layer, encoding, data, selection, na.rm) 453 | } 454 | -------------------------------------------------------------------------------- /R/multiviews.R: -------------------------------------------------------------------------------- 1 | #' Facet data views by rows and columns 2 | #' 3 | #' @param v A `vega()` object. 4 | #' @param row,column A set of data variables to define facetted views on the 5 | #' rows and columns grid. 6 | #' 7 | #' @export 8 | facet_views <- function(v, row = NULL, column = NULL) { 9 | # No facet_wrap() since vega `layer` doesn't handle `facet` encoding 10 | abort_if_not_virgo(v) 11 | v$facet <- list() 12 | row <- enexpr(row) 13 | column <- enexpr(column) 14 | if (!is.null(row)) { 15 | v$facet <- c(v$facet, list(row = list(field = simple_select(!!row)))) 16 | } 17 | if (!is.null(column)) { 18 | v$facet <- c(v$facet, list(column = list(field = simple_select(!!column)))) 19 | } 20 | v 21 | } 22 | 23 | #' Concatenate views 24 | #' 25 | #' `hconcat()` for horizontal concatenation, and `vconcat()` for vertical 26 | #' concatenation 27 | #' 28 | #' @param ... A list of `vega()` objects. 29 | #' 30 | #' @rdname concat 31 | #' @export 32 | hconcat <- function(...) { 33 | lst <- list2(...) 34 | map(lst, abort_if_not_virgo) 35 | lst <- map(lst, function(x) { x$encoding <- NULL; as_vegaspec(x) }) 36 | spec <- list(hconcat = list2(!!!lst)) 37 | new_virgo_concat(spec) 38 | } 39 | 40 | #' @rdname concat 41 | #' @export 42 | vconcat <- function(...) { 43 | lst <- list2(...) 44 | map(lst, abort_if_not_virgo) 45 | lst <- map(lst, function(x) { x$encoding <- NULL; as_vegaspec(x) }) 46 | spec <- list(vconcat = list2(!!!lst)) 47 | new_virgo_concat(spec) 48 | } 49 | 50 | new_virgo_concat <- function(spec) { 51 | structure(spec, class = c("virgo_concat", "virgo")) 52 | } 53 | 54 | #' Resolve scale and guide for layered and multi-view displays 55 | #' 56 | #' @inheritParams facet_views 57 | #' @param scale A named list of every channel to define either "shared" or 58 | #' "independent". 59 | #' @param axis A named list of positional channels like `x` and `y`. 60 | #' @param legend A named list of non-positional channels, such as `color`/`colour`, 61 | #' `opacity`, `shape`, and `size`. 62 | #' 63 | #' @export 64 | resolve_views <- function(v, scale = list(), axis = list(), legend = list()) { 65 | abort_if_not_virgo(v) 66 | scale <- vec_set_names(scale, standardise_names(names(scale))) 67 | axis <- vec_set_names(axis, standardise_names(names(axis))) 68 | legend <- vec_set_names(legend, standardise_names(names(legend))) 69 | v$resolve <- list(scale = scale, axis = axis, legend = legend) 70 | v 71 | } 72 | -------------------------------------------------------------------------------- /R/scale.R: -------------------------------------------------------------------------------- 1 | #' @importFrom scales log10_trans sqrt_trans date_trans expand_range 2 | #' @title Vega scales 3 | #' 4 | #' @param v A `vega()` object. 5 | #' @param name A string for an axis label. `zap()` is the default label. 6 | #' `NULL` removes the label. 7 | #' @param domain A vector of two elements to define the range. 8 | #' @param type One of "linear", "log", "sqrt", "temporal", "band", "category" scale types. 9 | #' @param breaks One of: 10 | #' * `NULL` for no breaks 11 | #' * `zap()` for default breaks 12 | #' * A vector for custom breaks 13 | #' @param orient One of "bottom" and "top" for `scale_x()`. One of "left" and "right" 14 | #' for `scale_y()`. 15 | #' @param range Custom range specification for colour, opacity, and size. 16 | #' @param ... Other parameters passed to vega specs. 17 | #' 18 | #' @rdname vega-scales 19 | #' @export 20 | scale_x <- function(v, name = zap(), domain = zap(), type = "linear", 21 | breaks = zap(), orient = "bottom", ...) { 22 | abort_if_not_virgo(v) 23 | for (i in seq_along(v$layer)) { 24 | v$layer[[i]]$encoding$x$scale$type <- type 25 | data <- v$layer[[i]]$data$values %||% v$data$values 26 | field <- v$layer[[i]]$encoding$x$field 27 | v$layer[[i]]$encoding$x$scale$domain <- rescale_domain(data[[field]], type) 28 | if (!is_zap(breaks)) { 29 | if (is.null(breaks)) { 30 | breaks <- list() 31 | } 32 | v$layer[[i]]$encoding$x$axis$values <- breaks 33 | } 34 | if (!is_zap(name)) { 35 | title <- list(title = name) # special case for name = NULL 36 | v$layer[[i]]$encoding$x <- c(v$layer[[i]]$encoding$x, title) 37 | } 38 | if (!is_zap(domain)) { 39 | # rescale_domain(domain, type) includes points outside of specified domain 40 | v$layer[[i]]$encoding$x$scale$domain <- interpret_domain(domain) 41 | } 42 | v$layer[[i]]$encoding$x$axis$orient <- orient 43 | } 44 | v 45 | } 46 | 47 | #' @rdname vega-scales 48 | #' @export 49 | scale_y <- function(v, name = zap(), domain = zap(), type = "linear", 50 | breaks = zap(), orient = "left", ...) { 51 | abort_if_not_virgo(v) 52 | for (i in seq_along(v$layer)) { 53 | v$layer[[i]]$encoding$y$scale$type <- type 54 | data <- v$layer[[i]]$data$values %||% v$data$values 55 | field <- v$layer[[i]]$encoding$y$field 56 | v$layer[[i]]$encoding$y$scale$domain <- rescale_domain(data[[field]], type) 57 | if (!is_zap(breaks)) { 58 | if (is.null(breaks)) { 59 | breaks <- list() 60 | } 61 | v$layer[[i]]$encoding$y$axis$values <- breaks 62 | } 63 | if (!is_zap(name)) { 64 | title <- list(title = name) 65 | v$layer[[i]]$encoding$y <- c(v$layer[[i]]$encoding$y, title) 66 | } 67 | if (!is_zap(domain)) { 68 | v$layer[[i]]$encoding$y$scale$domain <- interpret_domain(domain) 69 | } 70 | v$layer[[i]]$encoding$y$axis$orient <- orient 71 | } 72 | v 73 | } 74 | 75 | #' @param scheme Colour scheme. 76 | #' @param guide If `FALSE`, remove the legend. 77 | #' @rdname vega-scales 78 | #' @export 79 | scale_color <- function(v, name = zap(), range = zap(), scheme = zap(), 80 | guide = TRUE, ...) { 81 | abort_if_not_virgo(v) 82 | dots <- dots_list(..., .named = TRUE, .homonyms = "error") 83 | dots <- vec_set_names(dots, standardise_names(names(dots))) 84 | for (i in seq_along(v$layer)) { 85 | if (!is_zap(name)) { 86 | title <- list(title = name) 87 | v$layer[[i]]$encoding$color <- c(v$layer[[i]]$encoding$color, title) 88 | } 89 | if (!is_zap(range)) { 90 | v$layer[[i]]$encoding$color$scale$range <- range 91 | } 92 | if (!is_zap(scheme)) { 93 | v$layer[[i]]$encoding$color$scale$range <- NULL 94 | v$layer[[i]]$encoding$color$scale$scheme <- scheme 95 | } 96 | if (!guide) { 97 | legend <- list(legend = NULL) 98 | v$layer[[i]]$encoding$color <- c(v$layer[[i]]$encoding$color, legend) 99 | } 100 | v$layer[[i]]$encoding$color$scale <- c(v$layer[[i]]$encoding$color$scale, dots) 101 | } 102 | v 103 | } 104 | 105 | #' @rdname vega-scales 106 | #' @export 107 | scale_colour <- scale_color 108 | 109 | #' @rdname vega-scales 110 | #' @export 111 | scale_size <- function(v, name = zap(), range = zap(), type = "linear", 112 | guide = TRUE, ...) { 113 | abort_if_not_virgo(v) 114 | dots <- dots_list(..., .named = TRUE, .homonyms = "error") 115 | dots <- vec_set_names(dots, standardise_names(names(dots))) 116 | for (i in seq_along(v$layer)) { 117 | if (!is_zap(name)) { 118 | title <- list(title = name) 119 | v$layer[[i]]$encoding$size <- c(v$layer[[i]]$encoding$size, title) 120 | } 121 | if (!is_zap(range)) { 122 | v$layer[[i]]$encoding$size$scale$range <- range 123 | } 124 | v$layer[[i]]$encoding$size$scale$type <- type 125 | if (!guide) { 126 | legend <- list(legend = NULL) 127 | v$layer[[i]]$encoding$size <- c(v$layer[[i]]$encoding$size, legend) 128 | } 129 | v$layer[[i]]$encoding$size$scale <- c(v$layer[[i]]$encoding$size$scale, dots) 130 | } 131 | v 132 | } 133 | 134 | scale_opacity <- function(v, name = zap(), range = zap(), type = "linear", 135 | guide = TRUE, ...) { 136 | abort_if_not_virgo(v) 137 | dots <- dots_list(..., .named = TRUE, .homonyms = "error") 138 | dots <- vec_set_names(dots, standardise_names(names(dots))) 139 | for (i in seq_along(v$layer)) { 140 | if (!is_zap(name)) { 141 | title <- list(title = name) 142 | v$layer[[i]]$encoding$opacity <- c(v$layer[[i]]$encoding$opacity, title) 143 | } 144 | if (!is_zap(range)) { 145 | v$layer[[i]]$encoding$opacity$scale$range <- range 146 | } 147 | v$layer[[i]]$encoding$opacity$scale$type <- type 148 | if (!guide) { 149 | legend <- list(legend = NULL) 150 | v$layer[[i]]$encoding$opacity <- c(v$layer[[i]]$encoding$opacity, legend) 151 | } 152 | v$layer[[i]]$encoding$opacity$scale <- c(v$layer[[i]]$encoding$opacity$scale, 153 | dots) 154 | } 155 | v 156 | } 157 | 158 | #' @rdname vega-scales 159 | #' @export 160 | scale_shape <- function(v, name = zap(), guide = TRUE, ...) { 161 | abort_if_not_virgo(v) 162 | dots <- dots_list(..., .named = TRUE, .homonyms = "error") 163 | dots <- vec_set_names(dots, standardise_names(names(dots))) 164 | for (i in seq_along(v$layer)) { 165 | if (!is_zap(name)) { 166 | title <- list(title = name) 167 | v$layer[[i]]$encoding$shape <- c(v$layer[[i]]$encoding$shape, title) 168 | } 169 | if (!guide) { 170 | legend <- list(legend = NULL) 171 | v$layer[[i]]$encoding$shape <- c(v$layer[[i]]$encoding$shape, legend) 172 | } 173 | v$layer[[i]]$encoding$shape$scale <- c(v$layer[[i]]$encoding$shape$scale, 174 | dots) 175 | } 176 | v 177 | } 178 | 179 | rescale_domain <- function(x, type = "linear") { 180 | UseMethod("rescale_domain") 181 | } 182 | 183 | rescale_domain.default <- function(x, type = "linear") { 184 | switch(type, 185 | "log" = log10_trans()$inverse(expand_domain(log10_trans()$transform(x))), 186 | "sqrt" = sqrt_trans()$inverse(expand_domain(sqrt_trans()$transform(x))), 187 | expand_domain(x) 188 | ) 189 | } 190 | 191 | rescale_domain.Date <- function(x, type = "time") { 192 | domain <- date_trans()$inverse(expand_domain(date_trans()$transform(x))) 193 | interpret_domain(domain) 194 | } 195 | 196 | rescale_domain.character <- function(x, type = "ordinal") { 197 | NULL 198 | } 199 | 200 | rescale_domain.factor <- rescale_domain.character 201 | 202 | expand_domain <- function(x) { 203 | rng <- range(x, na.rm = TRUE) 204 | expand_range(rng, mul = 0.05) 205 | } 206 | 207 | interpret_domain <- function(x) { 208 | UseMethod("interpret_domain") 209 | } 210 | 211 | interpret_domain.default <- function(x) { 212 | x 213 | } 214 | 215 | interpret_domain.virgo_selection <- function(x) { 216 | list(selection = selection_composition(x)) 217 | } 218 | 219 | interpret_domain.Date <- function(x) { 220 | lst <- as.POSIXlt(x) 221 | map(lst, function(x) 222 | list(year = 1900 + x$year, month = x$mon + 1, date = x$mday)) 223 | } 224 | 225 | interpret_domain.POSIXt <- function(x) { 226 | lst <- as.POSIXlt(x) 227 | map(lst, function(x) 228 | list(year = 1900 + x$year, month = x$mon + 1, date = x$mday, 229 | hours = x$hour, minutes = x$min, seconds = x$sec %/% 1, 230 | milliseconds = (x$sec %% 1 * 1000) %/% 1)) 231 | } 232 | -------------------------------------------------------------------------------- /R/selection.R: -------------------------------------------------------------------------------- 1 | # selection perhaps can be implemented as delayed reactives 2 | # it will never be evaluated in console mode 3 | # a random id needs to be assigned when it's created for composition 4 | 5 | new_virgo_input <- function(x, init = NULL) { 6 | structure(x, init = init, class = "virgo_input") 7 | } 8 | 9 | # inputs that are bound to an HTML element are special case of 10 | # single selection 11 | input_factory <- function(input) { 12 | force(input) 13 | function(init = NULL, ...) { 14 | new_virgo_input(list(input = input, ...), init = init) 15 | } 16 | } 17 | 18 | #' HTML elements that bind to selections 19 | #' 20 | #' @param name Name of the HTML input. 21 | #' @param min,max Minimum and maximum values. 22 | #' @param step Incremental step. 23 | #' @param init An initial value. 24 | #' @param choices A (named) vector of options. 25 | #' @param ... Not sure. 26 | #' 27 | #' @rdname vega-input 28 | #' @export 29 | input_slider <- function(name = NULL, min, max, step, init = NULL) { 30 | new_virgo_input( 31 | list(input = "range", min = min, max = max, step = step, name = name), 32 | init = init 33 | ) 34 | } 35 | 36 | #' @rdname vega-input 37 | #' @export 38 | input_radio <- function(name = NULL, choices, init = NULL) { 39 | new_virgo_input( 40 | list(input = "radio", options = choices, labels = names(choices), 41 | name = name), init = init) 42 | } 43 | 44 | #' @rdname vega-input 45 | #' @export 46 | input_select <- function(name = NULL, choices, init = NULL) { 47 | new_virgo_input( 48 | list(input = "select", options = choices, labels = names(choices), 49 | name = name), init = init) 50 | } 51 | 52 | #' @rdname vega-input 53 | #' @export 54 | input_textbox <- input_factory("text") 55 | 56 | #' @rdname vega-input 57 | #' @export 58 | input_checkbox <- input_factory("checkbox") 59 | 60 | #' @rdname vega-input 61 | #' @export 62 | input_color <- input_factory("color") 63 | 64 | #' @rdname vega-input 65 | #' @export 66 | input_colour <- input_factory("color") 67 | 68 | #' @rdname vega-input 69 | #' @export 70 | input_date <- input_factory("date") 71 | 72 | #' @rdname vega-input 73 | #' @export 74 | input_datetime <- input_factory("datetime") 75 | 76 | #' @rdname vega-input 77 | #' @export 78 | input_month <- input_factory("month") 79 | 80 | #' @rdname vega-input 81 | #' @export 82 | input_week <- input_factory("week") 83 | 84 | #' @export 85 | print.virgo_selection <- function(x, ...) { 86 | lst <- map(x, function(x) paste(paste0(" ", fmt_bullets(x)), sep = "\n")) 87 | map2(names(lst), lst, function(x, y) cat(x, y, sep = "\n")) 88 | invisible(x) 89 | } 90 | 91 | #' Initiate a selection 92 | #' 93 | #' @section Composing Multiple Selections: 94 | #' A set of operations ... 95 | #' 96 | #' @param encodings A character vector of encoding channels, such as "x" and "y". 97 | #' @param fields A character vector of data fields. 98 | #' @param init An initial value upon selection. 99 | #' @param nearest If `FALSE`, data values must be interacted with directly to 100 | #' be added to the selection. 101 | #' @param on,clear An event type that triggers/clears the selection. Options are 102 | #' "click", "dblclick", "dragenter", "dragleave", "dragover", "keydown", "keypress", 103 | #' "keyup", "mousedown", "mouseover", "mousemove", "mouseout", "mouseup", 104 | #' "mousewheel", "touchend", "touchmove", "touchstart", "wheel". 105 | #' @param empty An empty selection includes "all" or "none" data values. 106 | #' @param resolve One of "global", "union", "intersect" options to resolve 107 | #' ambiguity for layered and multi-view displays. 108 | #' @param toggle A logical to control whether data values should be toggled or 109 | #' only ever inserted into multi selections. 110 | #' @param mark A named vector of mark properties for brushed rectangle. 111 | #' @param translate A string or logical to interactively move an interval 112 | #' selection back-and-forth. 113 | #' @param zoom If `TRUE`, interactively resize an interval selection. 114 | #' @param ... A set of name-value pairs with data variables on the LHS and 115 | #' `input_*()` on the RHS. 116 | #' 117 | #' @rdname vega-selection 118 | #' @export 119 | select_single <- function(encodings = NULL, fields = NULL, init = NULL, 120 | nearest = FALSE, on = "click", clear = "dblclick", empty = "all", 121 | resolve = "global") { 122 | if (!is.null(fields)) { 123 | fields <- as.list(fields) 124 | } 125 | new_virgo_selection(list2(!!rand_id() := list( 126 | type = "single", encodings = encodings, fields = fields, init = init, 127 | nearest = nearest, on = on, clear = clear, empty = empty, 128 | resolve = resolve))) 129 | } 130 | 131 | #' @rdname vega-selection 132 | #' @export 133 | select_multi <- function(encodings = NULL, fields = NULL, init = NULL, 134 | toggle = TRUE, nearest = FALSE, on = "click", clear = "dblclick", 135 | empty = "all", resolve = "global") { 136 | if (!is.null(fields)) { 137 | fields <- as.list(fields) 138 | } 139 | new_virgo_selection(list2(!!rand_id() := list( 140 | type = "multi", encodings = encodings, fields = fields, init = init, 141 | toggle = toggle, nearest = nearest, on = on, clear = clear, empty = empty, 142 | resolve = resolve))) 143 | } 144 | 145 | #' @rdname vega-selection 146 | #' @export 147 | select_interval <- function(encodings = c("x", "y"), init = NULL, 148 | mark = NULL, on = "[mousedown, window:mouseup] > window:mousemove!", 149 | clear = "dblclick", translate = on, empty = "all", zoom = TRUE, 150 | resolve = "global") { 151 | if (!is.null(mark)) { 152 | mark <- vec_set_names(mark, standardise_names(names(mark))) 153 | } 154 | mark <- as.list(mark) 155 | new_virgo_selection(list2(!!rand_id() := list( 156 | type = "interval", encodings = encodings, init = init, mark = mark, 157 | on = on, clear = clear, translate = translate, empty = empty, zoom = zoom, 158 | resolve = resolve))) 159 | } 160 | 161 | #' @rdname vega-selection 162 | #' @export 163 | select_legend <- function(fields, on = "click", clear = "dblclick") { 164 | # vega only supports legend bindings for one field or channel 165 | fields <- as.list(simple_select(!!enexpr(fields))) 166 | stopifnot(has_length(fields, 1)) 167 | new_virgo_selection(list2(!!rand_id() := list( 168 | type = "multi", fields = fields, bind = "legend"))) 169 | } 170 | 171 | #' @rdname vega-selection 172 | #' @export 173 | select_domain <- function() { 174 | new_virgo_selection(list2(!!rand_id() := list( 175 | type = "interval", bind = "scales"))) 176 | } 177 | 178 | #' @rdname vega-selection 179 | #' @export 180 | select_bind <- function(...) { 181 | elements <- map(enquos(..., .named = TRUE), eval_tidy) 182 | # FIXME: expect the same type of inputs 183 | stopifnot(all(map_lgl(elements, is_virgo_input))) 184 | fields <- list(names(elements)) 185 | inits <- map(elements, function(.) attr(., "init")) 186 | # init does not work unless all elements are specified 187 | if (any(map_lgl(inits, is.null))) { 188 | inits <- NULL 189 | } 190 | binds <- map(elements, unclass) 191 | new_virgo_selection( 192 | list2(!!rand_id() := list(type = "single", fields = fields, bind = binds, 193 | init = inits))) 194 | } 195 | 196 | new_virgo_selection <- function(x, composition = NULL, transform = NULL, 197 | groupby = NULL) { 198 | structure(x, composition = composition, transform = transform, 199 | groupby = groupby, class = "virgo_selection") 200 | } 201 | 202 | #' @export 203 | Ops.virgo_selection <- function(e1, e2) { 204 | e1_comp <- selection_composition(e1) 205 | if (.Generic == "&") { 206 | new_virgo_selection(c(e1, e2), 207 | composition = list(and = c(e1_comp, selection_composition(e2)))) 208 | } else if (.Generic == "|") { 209 | new_virgo_selection(c(e1, e2), 210 | composition = list(or = c(e1_comp, selection_composition(e2)))) 211 | } else if (.Generic == "!") { 212 | new_virgo_selection(e1, composition = list(not = e1_comp)) 213 | } else { 214 | abort("Oops") 215 | } 216 | } 217 | 218 | selection_composition <- function(x) { 219 | (x %@% "composition") %||% names(x) 220 | } 221 | 222 | rand_id <- function() { 223 | rand <- c("id", as.character(as.hexmode(sample(256, 4, replace = TRUE) - 1))) 224 | paste0(rand, collapse = "") 225 | } 226 | 227 | #' Conditional encoding selection 228 | #' 229 | #' @param selection A selection or selection compositions. 230 | #' @param true,false Values for true/false element of `selection`. 231 | #' 232 | #' @export 233 | encode_if <- function(selection, true, false) { 234 | stopifnot(is_virgo_selection(selection)) 235 | new_virgo_condition(list(selection = selection, 236 | true = enquo(true), false = enquo(false))) 237 | } 238 | 239 | new_virgo_condition <- function(x) { 240 | structure(x, class = "virgo_condition") 241 | } 242 | 243 | is_virgo_selection <- function(x) { 244 | inherits(x, "virgo_selection") 245 | } 246 | 247 | is_virgo_condition <- function(x) { 248 | inherits(x, "virgo_condition") 249 | } 250 | 251 | is_virgo_input <- function(x) { 252 | inherits(x, "virgo_input") 253 | } 254 | 255 | selection_union <- function(x) { 256 | # remove duplicated seletions and move all selections to the top layer 257 | names_sel <- vec_c(!!!map(x, function(x) names(x$selection))) 258 | if (is.null(names_sel)) { return(x) } 259 | unique_idx <- vec_match(vec_unique(names_sel), names_sel) 260 | unnamed_sel <- vec_c(!!!map(x, function(x) x$selection))[unique_idx] 261 | x[[1]]$selection <- vec_set_names(unnamed_sel, names_sel[unique_idx]) 262 | x <- c(x[1], map(x[-1], function(x) { x$selection <- NULL; x })) 263 | x 264 | } 265 | 266 | group_by.virgo_selection <- function(.data, ...) { 267 | vars <- list(map_chr(enexprs(...), as_string)) 268 | new_virgo_selection(unclass(.data), .data %@% "composition", 269 | .data %@% "transform", groupby = vars) 270 | } 271 | 272 | mutate.virgo_selection <- function(.data, ...) { 273 | quos <- enquos(..., .named = TRUE) 274 | fields <- names(quos) 275 | lst <- eval_trans_mask(quos) 276 | by <- .data %@% "groupby" 277 | res <- vec_init_along(lst) 278 | for (i in seq_along(res)) { 279 | res[[i]] <- translate(lst[[i]], quos[[i]], fields[[i]], by) 280 | } 281 | new_virgo_selection(unclass(.data), .data %@% "composition", res) 282 | } 283 | 284 | summarise.virgo_selection <- function(.data, ...) { 285 | quos <- enquos(..., .named = TRUE) 286 | fields <- names(quos) 287 | lst <- eval_trans_mask(quos) 288 | by <- .data %@% "groupby" 289 | res <- vec_init_along(lst) 290 | for (i in seq_along(res)) { 291 | res[[i]] <- translate_aggregate(lst[[i]], quos[[i]], fields[[i]], by) 292 | } 293 | new_virgo_selection(unclass(.data), .data %@% "composition", res) 294 | } 295 | 296 | summarize.virgo_selection <- summarise.virgo_selection 297 | 298 | translate_aggregate <- function(x, quo, field, by) { 299 | x$aggregate <- list( 300 | list(op = x$aggregate, field = as_field(quo), as = field)) 301 | x$groupby <- by 302 | list(x = unclass(x), as = field, field = as_field(quo)) 303 | } 304 | 305 | translate <- function(x, quo, field, by) { 306 | UseMethod("translate") 307 | } 308 | 309 | translate.virgo_window <- function(x, quo, field, by) { 310 | x$window <- list( 311 | list(op = x$window$op, field = as_field(quo), as = field)) 312 | x$groupby <- by 313 | list(x = unclass(x), as = field, field = as_field(quo)) 314 | } 315 | 316 | translate.virgo_aggregate <- function(x, quo, field, by) { 317 | x$joinaggregate <- list( 318 | list(op = x$aggregate, field = as_field(quo), as = field)) 319 | x$groupby <- by 320 | x$aggregate <- NULL 321 | list(x = unclass(x), as = field, field = as_field(quo)) 322 | } 323 | 324 | translate.virgo_bin <- function(x, quo, field, by) { 325 | list(x = list(bin = unclass(x), field = as_field(quo), as = field), 326 | as = field, field = as_field(quo)) 327 | } 328 | 329 | translate.default <- function(x, quo, field, by) { 330 | list(x = list(calculate = x, as = field), as = field, field = as_field(quo)) 331 | } 332 | 333 | virgo_trans_env <- function() { 334 | ops <- c("+", "-", "*", "/", "^", "==", "!=", ">", ">=", "<", "<=") 335 | fns <- map(ops, function(op) function(e1, e2) { 336 | if (catch_symbol(e1)) { 337 | e1 <- paste0("datum.", deparse(substitute(e1))) 338 | } 339 | if (catch_symbol(e2)) { 340 | e2 <- paste0("datum.", deparse(substitute(e2))) 341 | } 342 | paste(e1, op, e2) 343 | }) 344 | new_environment(vec_set_names(fns, ops)) 345 | } 346 | 347 | eval_trans_mask <- function(quo) { 348 | data_mask <- new_virgo_mask(list(), virgo_trans_env()) 349 | map(quo, function(x) eval_tidy(x, data_mask)) 350 | } 351 | 352 | catch_symbol <- function(x) { 353 | tryCatch(is_symbol(x), error = function(e) TRUE) 354 | } 355 | -------------------------------------------------------------------------------- /R/transform-server.R: -------------------------------------------------------------------------------- 1 | # Rather than transforming data on the vegaside 2 | # we could compose statistical transformations directly in R 3 | # this would give the option to eventually make them reactive via shiny 4 | 5 | # A naive mosaic estimator 6 | stack_count <- function(x, n, id, type = "normalize") { 7 | stopifnot(is.data.frame(x)) 8 | n <- enquo(n) 9 | id <- enquo(id) 10 | type <- arg_match(type, c("normalize", "sum")) 11 | 12 | stack_n <- list( 13 | left = function(n) cumsum(lag(n, default = 0)), 14 | right = cumsum 15 | ) 16 | 17 | divider <- identity 18 | if (type == "normalize") { 19 | divider <- function(n) sum(n) 20 | } 21 | 22 | mutate( 23 | x, 24 | "stack_count_left_{{id}}" := stack_n$left({{n}}) / divider({{n}}), 25 | "stack_count_right_{{id}}" := stack_n$right({{n}}) / divider({{n}}) 26 | ) 27 | 28 | } 29 | 30 | transform_mosaic <- function(data, enc) { 31 | # count x,y encodings 32 | # arrange by x encoding 33 | # stack x 34 | # find min counts within each x 35 | # arrange by y 36 | # stack y 37 | # create offsets 38 | data %>% 39 | count(!!!unname(enc)) %>% 40 | arrange(!!enc$x) %>% 41 | stack_count(n = n, id = x) %>% 42 | mutate(rank_x = dense_rank(!!enc$x)) %>% 43 | group_by(!!enc$x) %>% 44 | mutate( 45 | x = min(stack_count_left_x), 46 | x2 = max(stack_count_right_x), 47 | rank_y = dense_rank(!!enc$y), 48 | distinct_y = n_distinct(!!enc$y) 49 | ) %>% 50 | arrange(!!enc$y, .by_group = TRUE) %>% 51 | stack_count(n = n, id = y )%>% 52 | ungroup() %>% 53 | mutate( 54 | nx = x + (rank_x-1)* 0.01, 55 | nx2 = x2 + (rank_x - 1) * 0.01, 56 | ny = stack_count_left_y + (rank_y - 1) * 0.01 + distinct_y * 0.01 / max(distinct_y), 57 | ny2 = stack_count_right_y + (rank_y - 1) * 0.01 + distinct_y * 0.01 / max(distinct_y), 58 | xc = (nx + nx2) / 2, 59 | yc = (ny + ny2) / 2 60 | ) 61 | } 62 | -------------------------------------------------------------------------------- /R/transform.R: -------------------------------------------------------------------------------- 1 | new_virgo_op <- function(x, ..., class) { 2 | structure(x, ..., class = c(class, "virgo_op")) 3 | } 4 | 5 | is_virgo_op <- function(x) { 6 | inherits(x, "virgo_op") 7 | } 8 | 9 | virgo_op <- function() { 10 | c("vg_sum", "vg_mean", "vg_count", "vg_distinct", "vg_median", "vg_min", 11 | "vg_max", "vg_argmin", "vg_argmax", "vg_bin", 12 | "vg_window_mean", "vg_window_sum", "vg_window_rank", "vg_window_count", 13 | "vg_cumsum", "vg_cummean", "vg_lead", "vg_lag", "vg_ntile", "vg_row_number", 14 | "vg_rank", "vg_dense_rank", "vg_percent_rank", "vg_cume_dist", 15 | "vg_year", "vg_quarter", "vg_month", "vg_yearmonth", "vg_date", "vg_week", 16 | "vg_day", "vg_dayofyear", "vg_hours", "vg_minutes", "vg_seconds", 17 | "vg_milliseconds") 18 | } 19 | 20 | virgo_aggregate_factory <- function(aggregate) { 21 | function(x) { 22 | new_virgo_op(list(aggregate = aggregate), class = "virgo_aggregate") 23 | } 24 | } 25 | 26 | #' @export 27 | print.virgo_aggregate <- function(x, ...) { 28 | cat(fmt_bullets(x), sep = "\n") 29 | invisible(x) 30 | } 31 | 32 | #' Interactive aggregation operations 33 | #' 34 | #' @param x A data variable, used in conjunction with `enc()` or dplyr verbs. 35 | #' `vg_count()` can accept an empty input. 36 | #' @param y A data variable that maxmises/minimises `x` in `vg_argmin()` and 37 | #' `vg_argmax()`. 38 | #' 39 | #' @rdname vg-aggregate 40 | #' @export 41 | vg_sum <- virgo_aggregate_factory("sum") 42 | 43 | #' @rdname vg-aggregate 44 | #' @export 45 | vg_min <- virgo_aggregate_factory("min") 46 | 47 | #' @rdname vg-aggregate 48 | #' @export 49 | vg_max <- virgo_aggregate_factory("max") 50 | 51 | #' @rdname vg-aggregate 52 | #' @export 53 | vg_mean <- virgo_aggregate_factory("mean") 54 | 55 | #' @rdname vg-aggregate 56 | #' @export 57 | vg_median <- virgo_aggregate_factory("median") 58 | 59 | #' @rdname vg-aggregate 60 | #' @export 61 | vg_count <- virgo_aggregate_factory("count") 62 | 63 | #' @rdname vg-aggregate 64 | #' @export 65 | vg_distinct <- virgo_aggregate_factory("distinct") 66 | 67 | #' @rdname vg-aggregate 68 | #' @export 69 | vg_argmin <- function(x, y) { 70 | new_virgo_op(list(y = y, aggregate = "argmin"), class = "virgo_aggregate") 71 | } 72 | 73 | #' @rdname vg-aggregate 74 | #' @export 75 | vg_argmax <- function(x, y) { 76 | new_virgo_op(list(y = y, aggregate = "argmax"), class = "virgo_aggregate") 77 | } 78 | 79 | virgo_timeunit_factory <- function(unit) { 80 | force(unit) 81 | function(x, step = 1, utc = FALSE) { 82 | stopifnot(!is_missing(x)) 83 | new_virgo_op(list(unit = unit, step = step, utc = utc), 84 | class = "virgo_timeunit") 85 | } 86 | } 87 | 88 | #' @export 89 | print.virgo_timeunit <- print.virgo_aggregate 90 | 91 | #' Interactive time unit operations 92 | #' 93 | #' @inheritParams vg_sum 94 | #' @param step An integer to define the number of time steps. 95 | #' @param utc If `TRUE`, parse data in UTC time, otherwise in local time. 96 | #' 97 | #' @rdname vg-timeunit 98 | #' @export 99 | vg_year <- virgo_timeunit_factory("year") 100 | 101 | #' @rdname vg-timeunit 102 | #' @export 103 | vg_quarter <- virgo_timeunit_factory("quarter") 104 | 105 | #' @rdname vg-timeunit 106 | #' @export 107 | vg_month <- virgo_timeunit_factory("month") 108 | 109 | #' @rdname vg-timeunit 110 | #' @export 111 | vg_yearmonth <- virgo_timeunit_factory("yearmonth") 112 | 113 | #' @rdname vg-timeunit 114 | #' @export 115 | vg_date <- virgo_timeunit_factory("date") 116 | 117 | #' @rdname vg-timeunit 118 | #' @export 119 | vg_week <- virgo_timeunit_factory("week") 120 | 121 | #' @rdname vg-timeunit 122 | #' @export 123 | vg_day <- virgo_timeunit_factory("day") 124 | 125 | #' @rdname vg-timeunit 126 | #' @export 127 | vg_dayofyear <- virgo_timeunit_factory("dayofyear") 128 | 129 | #' @rdname vg-timeunit 130 | #' @export 131 | vg_hours <- virgo_timeunit_factory("hours") 132 | 133 | #' @rdname vg-timeunit 134 | #' @export 135 | vg_minutes <- virgo_timeunit_factory("minutes") 136 | 137 | #' @rdname vg-timeunit 138 | #' @export 139 | vg_seconds <- virgo_timeunit_factory("seconds") 140 | 141 | #' @rdname vg-timeunit 142 | #' @export 143 | vg_milliseconds <- virgo_timeunit_factory("milliseconds") 144 | 145 | virgo_window_factory <- function(op) { 146 | force(op) 147 | function(x, frame = list(NULL, 0), sort = NULL) { 148 | sort <- simple_sort(!!enexpr(sort)) 149 | if (is.null(sort)) { 150 | res <- list(window = list(op = op), frame = frame) 151 | } else { 152 | res <- list(window = list(op = op), frame = frame, sort = list(sort)) 153 | } 154 | new_virgo_op(res, class = "virgo_window") 155 | } 156 | } 157 | 158 | #' @export 159 | print.virgo_window <- print.virgo_aggregate 160 | 161 | #' Interactive window operations 162 | #' 163 | #' @param x A data variable, used in conjunction with `dplyr::mutate()`. 164 | #' @param frame A list/vector of two elements to indicate the number of data values 165 | #' preceding and following the current data object. `NULL` gives unbounded elements 166 | #' proceding or following the current position. 167 | #' @param sort A variable for sorting data within a window in ascending order. 168 | #' `-` before the variable gives descending order. `NULL` disables sorting. 169 | #' 170 | #' @rdname vg-window 171 | #' @export 172 | vg_window_sum <- virgo_window_factory("sum") 173 | 174 | #' @rdname vg-window 175 | #' @export 176 | vg_window_mean <- virgo_window_factory("mean") 177 | 178 | #' @rdname vg-window 179 | #' @export 180 | vg_window_rank <- virgo_window_factory("rank") 181 | 182 | #' @rdname vg-window 183 | #' @export 184 | vg_window_count <- virgo_window_factory("count") 185 | 186 | #' @rdname vg-window 187 | #' @export 188 | vg_cumsum <- function(x, sort = NULL) { 189 | vg_window_sum(x, sort = !!enexpr(sort)) 190 | } 191 | 192 | #' @rdname vg-window 193 | #' @export 194 | vg_cummean <- function(x, sort = NULL) { 195 | vg_window_mean(x, sort = !!enexpr(sort)) 196 | } 197 | 198 | vg_ranking <- function(x, n = 1, sort = NULL, op) { 199 | sort <- simple_sort(!!enexpr(sort)) 200 | if (is.null(sort)) { 201 | res <- list(window = list(op = op, param = n)) 202 | } else { 203 | res <- list(window = list(op = op, param = n), sort = list(sort)) 204 | } 205 | new_virgo_op(res, class = "virgo_window") 206 | } 207 | 208 | #' @rdname vg-window 209 | #' @export 210 | vg_row_number <- function(x, sort = NULL) { 211 | vg_ranking(x, n = 0, sort = !!enexpr(sort), "row_number") 212 | } 213 | 214 | #' @rdname vg-window 215 | #' @export 216 | vg_rank <- function(x, sort = NULL) { 217 | vg_ranking(x, n = 0, sort = !!enexpr(sort), "rank") 218 | } 219 | 220 | #' @rdname vg-window 221 | #' @export 222 | vg_dense_rank <- function(x, sort = NULL) { 223 | vg_ranking(x, n = 0, sort = !!enexpr(sort), "dense_rank") 224 | } 225 | 226 | #' @rdname vg-window 227 | #' @export 228 | vg_percent_rank <- function(x, sort = NULL) { 229 | vg_ranking(x, n = 0, sort = !!enexpr(sort), "percent_rank") 230 | } 231 | 232 | #' @rdname vg-window 233 | #' @export 234 | vg_cume_dist <- function(x, sort = NULL) { 235 | vg_ranking(x, n = 0, sort = !!enexpr(sort), "cume_dist") 236 | } 237 | 238 | #' @param n The number of elements. 239 | #' 240 | #' @rdname vg-window 241 | #' @export 242 | vg_ntile <- function(x, n = 1, sort = NULL) { 243 | vg_ranking(x, n = n, sort = !!enexpr(sort), "ntile") 244 | } 245 | 246 | #' @rdname vg-window 247 | #' @export 248 | vg_lead <- function(x, n = 1, sort = NULL) { 249 | vg_ranking(x, n = n, sort = !!enexpr(sort), "lead") 250 | } 251 | 252 | #' @rdname vg-window 253 | #' @export 254 | vg_lag <- function(x, n = 1, sort = NULL) { 255 | vg_ranking(x, n = n, sort = !!enexpr(sort), "lag") 256 | } 257 | 258 | simple_sort <- function(x) { 259 | x <- enexpr(x) 260 | if (is.null(x)) { 261 | NULL 262 | } else if (is_call(x, "-")) { 263 | list(field = as_string(call_args(x)[[1]]), order = "descending") 264 | } else if (!is_call(x, "c")) { 265 | list(field = as_string(x), order = "ascending") 266 | } else { 267 | map(call_args(x), simple_sort) 268 | } 269 | } 270 | 271 | vg_bin <- function(x, base = 10, divide = c(5, 2), extent = NULL, maxbins = 10, 272 | nice = TRUE, step = NULL) { 273 | bin <- list(base = base, divide = divide, extent = extent, maxbins = maxbins, 274 | nice = nice, step = step) 275 | new_virgo_op(bin, class = "virgo_bin") 276 | } 277 | 278 | # mosaic transform, could probably be simplified 279 | vg_mosaic <- function(enc) { 280 | # the somewhat complex mosaic transform 281 | list( 282 | list( 283 | aggregate = list(list(op = "count", as = "stack_count_x")), 284 | groupby = list(enc$x$field, enc$y$field) 285 | ), 286 | list( 287 | stack = "stack_count_x", 288 | groupby = list(), 289 | as = list("stack_count_x_left", "stack_count_x_right"), 290 | offset = "normalize", 291 | sort = list(list(field = enc$x$field, order = "ascending")) 292 | ), 293 | list( 294 | window = list( 295 | list(op = "min", field = "stack_count_x_left", as = "x"), 296 | list(op = "max", field = "stack_count_x_right", as = "x2"), 297 | list(op = "dense_rank", as = "rank_y"), 298 | list(op = "distinct", field = enc$y$field, as = "distinct_y") 299 | ), 300 | groupby = list(enc$x$field), 301 | frame = c(NA, NA), 302 | sort = list(list(field = enc$y$field, order = "ascending")) 303 | ), 304 | list( 305 | window = list( 306 | list(op = "dense_rank", as = "rank_x") 307 | ), 308 | frame = c(NA, NA), 309 | sort = list(list(field = enc$x$field, order = "ascending")) 310 | ), 311 | list( 312 | stack = "stack_count_x", 313 | groupby = list(enc$x$field), 314 | as = list("y", "y2"), 315 | offset = "normalize", 316 | sort = list(list(field = enc$y$field, order = "ascending")) 317 | ), 318 | list( 319 | calculate = "datum.x + (datum.rank_x - 1) * 0.01", 320 | as = "nx" 321 | ), 322 | list( 323 | calculate = "datum.x2 + (datum.rank_x - 1) * 0.01", 324 | as = "nx2" 325 | ), 326 | list( 327 | calculate = "datum.y + (datum.rank_y - 1) * datum.distinct_y * 0.01 / max(datum.distinct_y)", 328 | as = "ny" 329 | ), 330 | list( 331 | calculate = "datum.y2 + (datum.rank_y - 1) * datum.distinct_y * 0.01 / max(datum.distinct_y)", 332 | as = "ny2" 333 | ), 334 | list( 335 | calculate = "(datum.nx + datum.nx2) / 2", 336 | as = "xc" 337 | ), 338 | list( 339 | calculate = "(datum.ny + datum.ny2) / 2", 340 | as = "yc" 341 | ) 342 | ) 343 | } 344 | -------------------------------------------------------------------------------- /R/utils-pipe.R: -------------------------------------------------------------------------------- 1 | #' Pipe operator 2 | #' 3 | #' See \code{magrittr::\link[magrittr:pipe]{\%>\%}} for details. 4 | #' 5 | #' @name %>% 6 | #' @rdname pipe 7 | #' @keywords internal 8 | #' @export 9 | #' @importFrom vegawidget %>% 10 | #' @usage lhs \%>\% rhs 11 | NULL 12 | -------------------------------------------------------------------------------- /R/utils-vegawidget.R: -------------------------------------------------------------------------------- 1 | # nocov start 2 | 3 | #### vegaspec functions #### 4 | #### print functions #### 5 | 6 | #' Knit-print method 7 | #' 8 | #' See \code{vegawidget::\link[vegawidget]{knit_print.vegaspec}} for details, 9 | #' particularly on additional packages that may have to be installed. 10 | #' 11 | #' @name knit_print.vegaspec 12 | #' @rdname knit_print.vegaspec 13 | #' @importFrom vegawidget knit_print.vegaspec 14 | #' @export 15 | #' 16 | NULL 17 | 18 | #' Set base URL 19 | #' 20 | #' See \code{vegawidget::\link[vegawidget]{vw_set_base_url}} for details. 21 | #' 22 | #' @name vw_set_base_url 23 | #' @rdname vw_set_base_url 24 | #' @importFrom vegawidget vw_set_base_url 25 | #' @export 26 | #' 27 | NULL 28 | 29 | #### image functions #### 30 | 31 | #' Create or write image 32 | #' 33 | #' See \code{vegawidget::\link[vegawidget]{image}} for details. 34 | #' 35 | #' @name image 36 | #' @importFrom vegawidget 37 | #' vw_to_svg vw_to_bitmap vw_write_png vw_write_svg 38 | #' @aliases vw_to_svg vw_to_bitmap vw_write_png vw_write_svg 39 | #' @export vw_to_svg vw_to_bitmap vw_write_png vw_write_svg 40 | #' 41 | NULL 42 | 43 | 44 | # nocov end 45 | -------------------------------------------------------------------------------- /R/utils.R: -------------------------------------------------------------------------------- 1 | standardise_encodings <- function(x) { 2 | if (vec_in("alpha", x)) { 3 | abort(c("`alpha` is an invalid property.", i = "Do you mean `opacity`?")) 4 | } 5 | x[vec_match("group", x)] <- "detail" 6 | x[vec_match("colour", x)] <- "color" 7 | abort_if_camelCase(x) 8 | x <- standardise_names(valid_encodings(x)) 9 | x 10 | } 11 | 12 | standardise_names <- function(x) { 13 | abort_if_camelCase(x) 14 | gsub('\\_(\\w?)', '\\U\\1', x, perl = TRUE) 15 | } 16 | 17 | abort_if_camelCase <- function(x) { 18 | camel_lgl <- grepl("[[:upper:]]", x, perl = TRUE) 19 | if (any(camel_lgl)) { 20 | camel_x <- x[camel_lgl][1] 21 | err <- sprintf("`%s` is an invalid property.", camel_x) 22 | hint <- gsub("([a-z])([A-Z])", "\\1\\_\\L\\2", camel_x, perl = TRUE) 23 | abort(c(err, i = sprintf("Do you mean `%s`?", hint))) 24 | } 25 | } 26 | 27 | valid_encodings <- function(x) { 28 | props <- c("x", "y", "x2", "y2", "detail", "fill", "fill_opacity", "color", 29 | "size", "opacity", "shape", "angle", "tooltip", "url", "radius", "radius2", 30 | "stroke", "stroke_opacity", "stroke_cap", "stroke_dash", "stroke_join", 31 | "stroke_width", "text", "theta", "theta2", "href", "description", "cursor", 32 | "interpolate", "order", "dx", "dy", "offset_x", "offset_y") 33 | lgl <- vec_in(x, props) 34 | if (!all(lgl)) { 35 | abort(c("Invalid property:", x[!lgl])) 36 | } 37 | x 38 | } 39 | 40 | square_brackets <- function(x) { 41 | if (is.null(x)) { 42 | x 43 | } else if (grepl("\\.", x)) { 44 | paste0("[", x, "]") 45 | } else { 46 | x 47 | } 48 | } 49 | 50 | fmt_bullets <- function(x) { 51 | paste(paste("*", names(x)), x, sep = ": ") 52 | } 53 | -------------------------------------------------------------------------------- /R/vega.R: -------------------------------------------------------------------------------- 1 | #' @import rlang tidyselect vctrs 2 | #' @importFrom vegawidget as_vegaspec vega_embed vega_schema vegawidget 3 | #' @importFrom jsonlite write_json 4 | #' @importFrom stats complete.cases lag 5 | 6 | new_virgo <- function(spec) { 7 | structure(spec, class = "virgo") 8 | } 9 | 10 | #' Create a new vega visualisation 11 | #' 12 | #' @param data A data frame. 13 | #' @param encoding A list of aethetic encodings via [`enc()`]. 14 | #' @param width,height Data plotting width and height. 15 | #' 16 | #' @export 17 | vega <- function(data = NULL, encoding = enc(), width = 300, height = 300) { 18 | spec <- list( 19 | data = list(values = data), encoding = encoding, 20 | width = width, height = height) 21 | new_virgo(spec) 22 | } 23 | 24 | #' @export 25 | as.list.virgo <- function(x, ...) { 26 | unclass(as_vegaspec(x, ...)) 27 | } 28 | 29 | #' @export 30 | as.list.virgo_concat <- function(x, ...) { 31 | unclass(as_vegaspec(x, ...)) 32 | } 33 | 34 | #' @export 35 | as_vegaspec.virgo_concat <- function(spec, ...) { 36 | spec_header <- list(`$schema` = vega_schema()) 37 | # vega concat can only use one config 38 | config <- spec[[1]][[1]]$config 39 | # clean duplicates 40 | spec[[1]] <- map(spec[[1]], function(x) {x$config <- NULL; x}) 41 | spec[[1]] <- map(spec[[1]], function(x) {x$`$schema` <- NULL; x}) 42 | # vega concat can only use one config 43 | spec$config <- config 44 | as_vegaspec(c(spec_header, spec)) 45 | } 46 | 47 | #' @export 48 | as_vegaspec.virgo <- function(spec, ...) { 49 | if (!has_name(spec, "layer")) { 50 | spec <- mark_blank(spec) 51 | } 52 | spec_header <- list(`$schema` = vega_schema()) 53 | spec$data$dir <- NULL 54 | if (!has_name(spec, "config")) { 55 | spec <- config_ggplot(spec) 56 | } 57 | spec <- unclass(spec) 58 | if (is.null(spec$data$values) && is.null(spec$data$url)) { 59 | spec$data <- NULL 60 | } 61 | # remove top-level encoding & transform, since it already applies to each layer 62 | spec$encoding <- spec$transform <- NULL 63 | # unify default scale domains 64 | layer <- spec$layer 65 | xs <- map(layer, function(x) 66 | c(x$encoding$x$scale$domain, x$encoding$x2$scale$domain)) 67 | ys <- map(layer, function(x) 68 | c(x$encoding$y$scale$domain, x$encoding$y2$scale$domain)) 69 | xrng <- vec_c(!!!xs) 70 | yrng <- vec_c(!!!ys) 71 | if (!is.null(xrng) && !has_name(xrng, "selection") && !is_bare_list(xrng)) { 72 | xrng <- range(xrng) 73 | } 74 | if (!is.null(yrng) && !has_name(yrng, "selection") && !is_bare_list(yrng)) { 75 | yrng <- range(yrng) 76 | } 77 | for (i in seq_along(layer)) { 78 | if (!is.null(layer[[i]]$encoding$x$scale$domain)) { 79 | spec$layer[[i]]$encoding$x$scale$domain <- xrng 80 | } 81 | if (!is.null(layer[[i]]$encoding$y$scale$domain)) { 82 | spec$layer[[i]]$encoding$y$scale$domain <- yrng 83 | } 84 | } 85 | spec$layer <- selection_union(spec$layer) 86 | # facet is used 87 | if (has_name(spec, "facet")) { 88 | data <- spec$data$values 89 | rowvars <- spec$facet$row$field 90 | colvars <- spec$facet$col$field 91 | nrows <- vec_unique_count(data[rowvars]) 92 | ncols <- vec_unique_count(data[colvars]) 93 | spec$layer <- map(layer, function(x) { x$data <- NULL; x }) 94 | spec$spec$layer <- spec$layer 95 | spec$spec$width <- spec$width / ncols 96 | spec$spec$height <- spec$height / nrows 97 | spec$layer <- NULL 98 | } 99 | 100 | # ac has been used 101 | if (has_name(spec, "repeat")) { 102 | spec_header$`repeat` <- spec$`repeat` 103 | spec_header$config <- spec$config 104 | pos <- which(names(spec) %in% c("repeat", "config")) 105 | spec <- list(spec = spec[-pos]) 106 | } 107 | 108 | as_vegaspec(c(spec_header, spec)) 109 | } 110 | 111 | #' @export 112 | print.virgo <- function(x, renderer = "canvas", ...) { 113 | renderer <- arg_match(renderer, c("canvas", "svg")) 114 | print(vegawidget(as_vegaspec(x), 115 | embed = vega_embed(renderer = renderer, actions = FALSE), 116 | base_url = x$data$dir), ...) 117 | invisible(x) 118 | } 119 | 120 | #' @export 121 | format.virgo <- function(x, ...) { 122 | x <- as_vegaspec(x) 123 | format(x, ...) 124 | } 125 | 126 | #' @param spec vega spec. 127 | #' @param ... Options passed to knitr. 128 | #' @param renderer One of "svg" or "canvas". 129 | #' @param options Options. 130 | #' @rdname knit_print.vegaspec 131 | #' @export 132 | knit_print.virgo <- function(spec, ..., renderer = "canvas", options = NULL) { 133 | spec <- vegawidget(as_vegaspec(spec), 134 | embed = vega_embed(renderer = renderer, actions = FALSE), 135 | base_url = spec$data$dir) 136 | knitr::knit_print(spec, ..., options = options) 137 | } 138 | 139 | #' Modify vega title, subtitle, and description 140 | #' 141 | #' @param v A `vega()` object. 142 | #' @param title,subtitle,description Strings. 143 | #' 144 | #' @export 145 | entitle <- function(v, title = NULL, subtitle = NULL, description = NULL) { 146 | # NOTE: leave all styling properties to `config()` 147 | abort_if_not_virgo(v) 148 | v$title <- list(text = title, subtitle = subtitle) 149 | v$description <- description 150 | v 151 | } 152 | 153 | is_virgo <- function(v) { 154 | inherits(v, "virgo") 155 | } 156 | 157 | abort_if_not_virgo <- function(v) { 158 | if (!is_virgo(v)) { 159 | abort("Must be a `vega()` object.") 160 | } 161 | } 162 | 163 | #' Serialise data 164 | #' 165 | #' @inheritParams entitle 166 | #' @param path Directory to save inlining data to external data files. 167 | #' 168 | #' @rdname vega-seralise 169 | #' @export 170 | vega_serialise_data <- function(v, path = NULL) { 171 | # TODO: args for iso datetime? 172 | abort_if_not_virgo(v) 173 | seq_layer <- seq_along(v$layer) 174 | if (is.null(path)) { 175 | path <- tempdir() 176 | top_file <- tempfile("data0", path, ".json") 177 | layer_file <- tempfile(paste0("data", seq_layer), path, ".json") 178 | } else { 179 | path <- normalizePath(path) 180 | top_file <- file.path(path, "data0.json") 181 | layer_file <- file.path(path, paste0("data", seq_layer, ".json")) 182 | } 183 | v <- write_out_to(v, top_file) # top-level 184 | for (i in seq_layer) { 185 | v$layer[[i]] <- write_out_to(v$layer[[i]], layer_file[i]) 186 | } 187 | v$data$dir <- path 188 | v 189 | } 190 | 191 | #' @rdname vega-seralise 192 | #' @export 193 | vega_serialize_data <- vega_serialise_data 194 | 195 | write_out_to <- function(layer, path) { 196 | if (is.null(layer$data$values)) return(layer) 197 | 198 | if (file.exists(path)) { 199 | abort("File exists!") 200 | } 201 | write_json(layer$data$values, path) 202 | layer$data$values <- NULL 203 | layer$data$url <- basename(path) 204 | layer 205 | } 206 | -------------------------------------------------------------------------------- /R/zzz.R: -------------------------------------------------------------------------------- 1 | # nocov start 2 | .onLoad <- function(...) { 3 | s3_register("dplyr::mutate", "virgo_selection") 4 | s3_register("dplyr::summarise", "virgo_selection") 5 | s3_register("dplyr::summarize", "virgo_selection") 6 | s3_register("dplyr::group_by", "virgo_selection") 7 | s3_register("knitr::knit_print", "virgo") 8 | } 9 | # nocov end 10 | -------------------------------------------------------------------------------- /README.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | output: github_document 3 | --- 4 | 5 | 6 | 7 | ```{r, include = FALSE} 8 | knitr::opts_chunk$set( 9 | collapse = TRUE, 10 | comment = "#>", 11 | fig.path = "man/figures/README-", 12 | eval = FALSE, 13 | dev = "png" 14 | ) 15 | ``` 16 | 17 | # virgo 18 | 19 | 20 | [![Codecov test coverage](https://codecov.io/gh/vegawidget/virgo/branch/master/graph/badge.svg)](https://codecov.io/gh/vegawidget/virgo?branch=master) 21 | [![R build status](https://github.com/vegawidget/virgo/workflows/R-CMD-check/badge.svg)](https://github.com/vegawidget/virgo/actions) 22 | 23 | 24 | The **virgo** package enables the creation of interactive graphics for 25 | exploratory data analysis. It is an _idiomatic and opinionated_ R interface to 26 | the grammar of graphics implemented by [**Vega-Lite**](https://vega.github.io/vega-lite/) which 27 | defines the following elements: 28 | 29 | * aesthetic mappings/encodings via `enc()` 30 | * graphical elements like `mark_point()`, with the `mark_*` family of functions 31 | * interactive objects, such as brushes (using `select_interval()`) and sliders (using `input_slider()`), via the `select_*` and `input_*` family of functions 32 | * interactive calculations, for example mean (using `vg_mean()`), via the `vg_*` family of functions 33 | * data transformations on selection objects for rich interactivity, with {dplyr} verbs 34 | * plot composition via faceting and concatenation using `facet_views()`, `hconcat()` and `vconcat()` 35 | 36 | 37 | ## Installation 38 | 39 | 47 | 48 | You can install the development version of **virgo** 49 | from [GitHub](https://github.com/) with: 50 | 51 | ``` r 52 | # install.packages("remotes") 53 | remotes::install_github("vegawidget/virgo") 54 | ``` 55 | 56 | ## Get started 57 | 58 | For most graphics using **virgo**, you start off by passing data to 59 | the `vega()` function, add graphical elements with marks like `mark_point()`, 60 | and specify variables within a mark using encodings `enc()`. You can add more 61 | layers by specifying additional marks like `mark_smooth()`, or include small 62 | multiples with `facet_views()` or combine plots or 63 | add interactive elements with selections. 64 | 65 | Let's see an example, here we show how we can compose a simple scatter plot 66 | and gradually build up to a scatter plot with brushing, to a side by side scatter plot. 67 | 68 | ```{r basic-scatter, eval = TRUE, out.width = "50%"} 69 | library(virgo) 70 | library(palmerpenguins) 71 | p <- penguins %>% 72 | vega() %>% 73 | mark_circle( 74 | enc( 75 | x = bill_length_mm, 76 | y = bill_depth_mm 77 | ) 78 | ) 79 | p 80 | ``` 81 | 82 | Interactive elements are generated using selections, for example, 83 | we can generate a rectangular brush with `select_interval()` and 84 | then highlight points that fall into the brush using `encode_if()`: 85 | 86 | ```{r brushed-scatter} 87 | selection <- select_interval() 88 | 89 | p <- penguins %>% 90 | vega() %>% 91 | mark_circle( 92 | enc( 93 | x = bill_length_mm, 94 | y = bill_depth_mm, 95 | color = encode_if(selection, species, "black") 96 | ) 97 | ) 98 | p 99 | ``` 100 | 101 | ![](man/figures/readme-circle.png) 102 | 103 | Once a selection is created, it can be passed into other marks, in order to 104 | perform a filter. Here, we create a chart with two histogram layers, 105 | the first will represent the overall distribution of penguin body masses, while 106 | the latter will be the distribution conditional on the selection, and will 107 | be shown in purple. We also overlay a vertical line to demonstrate the interactive average 108 | given the selection. 109 | 110 | ```{r right-scatter} 111 | p_right <- penguins %>% 112 | vega(enc(x = body_mass_g)) %>% 113 | mark_histogram(bin = list(maxbins = 20)) %>% 114 | mark_histogram(color = "purple", bin = list(maxbins = 20), 115 | selection = selection) %>% 116 | mark_rule(enc(x = vg_mean(body_mass_g)), color = "red", size = 4, 117 | selection = selection) 118 | p_right 119 | ``` 120 | 121 | ![](man/figures/readme-histogram.png) 122 | 123 | By itself, this histogram isn't too exciting but if we place along side 124 | the scatter plot of penguin bill measurements, we can see how the body mass 125 | counts change as we brush over the scatter plot. All we have do is simple 126 | concatenate the plots horizontally! 127 | 128 | ```{r linked-brushed-scatter} 129 | hconcat(p, p_right) 130 | ``` 131 | 132 | ![](man/figures/readme-hconcat.png) 133 | 134 | From this, we learn that the chinstrap and adelie penguins are generally 135 | lighter and are less variable in their body mass compared to gentoo penguins. 136 | The gentoo penguins are heavier, but also have a larger range of masses. 137 | 138 | ## Learning more 139 | 140 | - [Example gallery](articles/gallery/index.html) 141 | - [Using **virgo** to explore Melbourne's microclimate](articles/virgo.html) 142 | - [Guide to **virgo** for **ggplot2** users](articles/transition.html) 143 | - [Composing plot interactions with selections]() 144 | 145 | ## Lifecycle 146 | 147 | [![Lifecycle: experimental](https://img.shields.io/badge/lifecycle-experimental-orange.svg)](https://www.tidyverse.org/lifecycle/#experimental) 148 | 149 | The **virgo** package is under rapid development and we are still working 150 | through our ideas for incorporating interactive graphics 151 | into exploratory data analysis. If you have feedback we would love to hear it! 152 | 153 | ## Related works 154 | 155 | * [{ggvis}](http://ggvis.rstudio.com) 156 | * [{vegalite}](https://github.com/hrbrmstr/vegalite) 157 | * [{g2r}](https://g2r.opifex.org) 158 | * [{ggiraph}](https://davidgohel.github.io/ggiraph/) 159 | 160 | ## Acknowledgements 161 | 162 | - Vega/Vega-Lite developers 163 | - Ian Lyttle, Hayley Jepson and Alicia Schep for their foundational 164 | work in the [**vegawidget**](https://vegawidget.github.io/vegawidget/) package 165 | 166 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | # virgo 5 | 6 | 7 | 8 | [![Codecov test 9 | coverage](https://codecov.io/gh/vegawidget/virgo/branch/master/graph/badge.svg)](https://codecov.io/gh/vegawidget/virgo?branch=master) 10 | [![R build 11 | status](https://github.com/vegawidget/virgo/workflows/R-CMD-check/badge.svg)](https://github.com/vegawidget/virgo/actions) 12 | 13 | 14 | The **virgo** package enables the creation of interactive graphics for 15 | exploratory data analysis. It is an *idiomatic and opinionated* R 16 | interface to the grammar of graphics implemented by 17 | [**Vega-Lite**](https://vega.github.io/vega-lite/) which defines the 18 | following elements: 19 | 20 | - aesthetic mappings/encodings via `enc()` 21 | - graphical elements like `mark_point()`, with the `mark_*` family of 22 | functions 23 | - interactive objects, such as brushes (using `select_interval()`) and 24 | sliders (using `input_slider()`), via the `select_*` and `input_*` 25 | family of functions 26 | - interactive calculations, for example mean (using `vg_mean()`), via 27 | the `vg_*` family of functions 28 | - data transformations on selection objects for rich interactivity, 29 | with {dplyr} verbs 30 | - plot composition via faceting and concatenation using 31 | `facet_views()`, `hconcat()` and `vconcat()` 32 | 33 | ## Installation 34 | 35 | 43 | 44 | You can install the development version of **virgo** from 45 | [GitHub](https://github.com/) with: 46 | 47 | ``` r 48 | # install.packages("remotes") 49 | remotes::install_github("vegawidget/virgo") 50 | ``` 51 | 52 | ## Get started 53 | 54 | For most graphics using **virgo**, you start off by passing data to the 55 | `vega()` function, add graphical elements with marks like 56 | `mark_point()`, and specify variables within a mark using encodings 57 | `enc()`. You can add more layers by specifying additional marks like 58 | `mark_smooth()`, or include small multiples with `facet_views()` or 59 | combine plots or add interactive elements with selections. 60 | 61 | Let’s see an example, here we show how we can compose a simple scatter 62 | plot and gradually build up to a scatter plot with brushing, to a side 63 | by side scatter plot. 64 | 65 | ``` r 66 | library(virgo) 67 | library(palmerpenguins) 68 | p <- penguins %>% 69 | vega() %>% 70 | mark_circle( 71 | enc( 72 | x = bill_length_mm, 73 | y = bill_depth_mm 74 | ) 75 | ) 76 | p 77 | ``` 78 | 79 | 80 | 81 | Interactive elements are generated using selections, for example, we can 82 | generate a rectangular brush with `select_interval()` and then highlight 83 | points that fall into the brush using `encode_if()`: 84 | 85 | ``` r 86 | selection <- select_interval() 87 | 88 | p <- penguins %>% 89 | vega() %>% 90 | mark_circle( 91 | enc( 92 | x = bill_length_mm, 93 | y = bill_depth_mm, 94 | color = encode_if(selection, species, "black") 95 | ) 96 | ) 97 | p 98 | ``` 99 | 100 | ![](man/figures/readme-circle.png) 101 | 102 | Once a selection is created, it can be passed into other marks, in order 103 | to perform a filter. Here, we create a chart with two histogram layers, 104 | the first will represent the overall distribution of penguin body 105 | masses, while the latter will be the distribution conditional on the 106 | selection, and will be shown in purple. We also overlay a vertical line 107 | to demonstrate the interactive average given the selection. 108 | 109 | ``` r 110 | p_right <- penguins %>% 111 | vega(enc(x = body_mass_g)) %>% 112 | mark_histogram(bin = list(maxbins = 20)) %>% 113 | mark_histogram(color = "purple", bin = list(maxbins = 20), 114 | selection = selection) %>% 115 | mark_rule(enc(x = vg_mean(body_mass_g)), color = "red", size = 4, 116 | selection = selection) 117 | p_right 118 | ``` 119 | 120 | ![](man/figures/readme-histogram.png) 121 | 122 | By itself, this histogram isn’t too exciting but if we place along side 123 | the scatter plot of penguin bill measurements, we can see how the body 124 | mass counts change as we brush over the scatter plot. All we have do is 125 | simple concatenate the plots horizontally! 126 | 127 | ``` r 128 | hconcat(p, p_right) 129 | ``` 130 | 131 | ![](man/figures/readme-hconcat.png) 132 | 133 | From this, we learn that the chinstrap and adelie penguins are generally 134 | lighter and are less variable in their body mass compared to gentoo 135 | penguins. The gentoo penguins are heavier, but also have a larger range 136 | of masses. 137 | 138 | ## Learning more 139 | 140 | - [Example gallery](articles/gallery/index.html) 141 | - [Using **virgo** to explore Melbourne’s 142 | microclimate](articles/virgo.html) 143 | - [Guide to **virgo** for **ggplot2** users](articles/transition.html) 144 | - [Composing plot interactions with selections]() 145 | 146 | ## Lifecycle 147 | 148 | [![Lifecycle: 149 | experimental](https://img.shields.io/badge/lifecycle-experimental-orange.svg)](https://www.tidyverse.org/lifecycle/#experimental) 150 | 151 | The **virgo** package is under rapid development and we are still 152 | working through our ideas for incorporating interactive graphics into 153 | exploratory data analysis. If you have feedback we would love to hear 154 | it! 155 | 156 | ## Related works 157 | 158 | - [{ggvis}](http://ggvis.rstudio.com) 159 | - [{vegalite}](https://github.com/hrbrmstr/vegalite) 160 | - [{g2r}](https://g2r.opifex.org) 161 | - [{ggiraph}](https://davidgohel.github.io/ggiraph/) 162 | 163 | ## Acknowledgements 164 | 165 | - Vega/Vega-Lite developers 166 | - Ian Lyttle, Hayley Jepson and Alicia Schep for their foundational 167 | work in the 168 | [**vegawidget**](https://vegawidget.github.io/vegawidget/) package 169 | -------------------------------------------------------------------------------- /codecov.yml: -------------------------------------------------------------------------------- 1 | comment: false 2 | 3 | coverage: 4 | status: 5 | project: 6 | default: 7 | target: auto 8 | threshold: 1% 9 | informational: true 10 | patch: 11 | default: 12 | target: auto 13 | threshold: 1% 14 | informational: true 15 | -------------------------------------------------------------------------------- /data-raw/aklhousingprice.R: -------------------------------------------------------------------------------- 1 | # remotes::install_github("Tina-ye112/kiaora") 2 | 3 | library(tidyverse) 4 | library(lubridate) 5 | 6 | aklhousingprice <- kiaora::nzhousingprice %>% 7 | filter( 8 | year(auction_dates) < 2021, 9 | region == "Auckland" 10 | ) %>% 11 | select(-region) %>% 12 | left_join(kiaora::nzpropertygeo) %>% 13 | relocate(c(lon, lat), .after = property_address) 14 | 15 | usethis::use_data(aklhousingprice, overwrite = TRUE) 16 | -------------------------------------------------------------------------------- /data-raw/melbweather.R: -------------------------------------------------------------------------------- 1 | ## code to prepare `melbweather` dataset goes here 2 | # update once rwalkr gets put up on cran 3 | # remotes::install_github("earowang/rwalkr@d528e7b") 4 | # well we use January and June 2020 5 | library(rwalkr) 6 | library(dplyr) 7 | 8 | extract_measurements <- function(month_rng) { 9 | # extract regular measurements, not any averaged forms 10 | # variables are temperature, relative humidity, barometric pressure, 11 | # particular matter 2.5 and 10, and wind speed 12 | sensors <- c("TPH.TEMP", 13 | "TPH.RH", 14 | "TPH.PRESSURE", 15 | "PM2.5", 16 | "PM10", 17 | "WS") 18 | 19 | sensors_clean <- c("ambient_temperature", 20 | "relative_humidity", 21 | "barometric_pressure", 22 | "pm2.5", 23 | "pm10", 24 | "wind_speed") 25 | 26 | names(sensors_clean) <- sensors 27 | 28 | start <- month_rng[1] 29 | end <- month_rng[2] 30 | 31 | # download data from start and end, 32 | # filter to relevant sensors and pivot to wide form 33 | melb_weather(start, end) %>% 34 | filter(sensor_type %in% sensors) %>% 35 | mutate( 36 | sensor_type = sensors_clean[sensor_type], 37 | value = as.numeric(value) 38 | ) %>% 39 | tidyr::pivot_wider( 40 | id_cols = c("site", "date_time", "date"), 41 | names_from = sensor_type 42 | ) 43 | } 44 | 45 | months <- list( 46 | jan = c(as.Date("2020-01-01"), as.Date("2020-01-31")), 47 | jun = c(as.Date("2020-06-01"), as.Date("2020-06-30")) 48 | ) 49 | 50 | melbweather <- bind_rows(lapply(months, extract_measurements)) 51 | 52 | # pull in the sites coordinates and description 53 | sites <- select(pull_weather_sensors(), 54 | site_id, description, longitude, latitude) 55 | 56 | melbweather <- melbweather %>% 57 | left_join(sites, by = c("site" = "site_id")) %>% 58 | select(site, site_address = description, longitude, latitude, date_time, date, everything()) 59 | 60 | usethis::use_data(melbweather, overwrite = TRUE) 61 | -------------------------------------------------------------------------------- /data/aklhousingprice.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vegawidget/virgo/0c594d47eecc7fde7928f6abafc2ef8ea8fa4ca3/data/aklhousingprice.rda -------------------------------------------------------------------------------- /data/melbweather.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vegawidget/virgo/0c594d47eecc7fde7928f6abafc2ef8ea8fa4ca3/data/melbweather.rda -------------------------------------------------------------------------------- /demo/aggregate.R: -------------------------------------------------------------------------------- 1 | library(dplyr) 2 | 3 | # trying out some nse trickery 4 | population <- jsonlite::read_json( 5 | "https://vega.github.io/vega-editor/app/data/population.json" 6 | ) %>% 7 | bind_rows() 8 | 9 | population %>% 10 | filter(year == 2000) %>% 11 | vega() %>% 12 | mark_bar(enc(x = vg_sum(people))) 13 | 14 | # FIXED 15 | population %>% 16 | filter(year == 2000) %>% 17 | vega() %>% 18 | mark_bar(enc(y = vg_sum(people))) 19 | 20 | # FIXME: abort for nested calls 21 | population %>% 22 | filter(year == 2000) %>% 23 | vega() %>% 24 | mark_point(enc(x = vg_sum(as.numeric(people)))) 25 | 26 | population %>% 27 | filter(year == 2000) %>% 28 | vega() %>% 29 | mark_bar(enc(x = vg_sum(people), y = ordered(age))) 30 | 31 | population %>% 32 | filter(year == 2000) %>% 33 | vega() %>% 34 | mark_bar(enc(x = ordered(age), y = vg_sum(people), color = factor(sex))) 35 | 36 | population %>% 37 | filter(year == 2000) %>% 38 | vega() %>% 39 | mark_bar(enc(x = ordered(age), y = vg_sum(people), color = factor(sex)), 40 | opacity = .7, position = "identity") 41 | 42 | population %>% 43 | filter(year == 2000) %>% 44 | vega(enc(x = ordered(age), y = vg_sum(people), color = factor(sex))) %>% 45 | mark_bar(position = "fill") 46 | 47 | # population %>% 48 | # filter(year == 2000) %>% 49 | # vega(enc(x = factor(age), y = vg_sum(people), color = factor(sex))) %>% 50 | # mark_bar(enc(column = ordered(sex)), position = "dodge") 51 | 52 | population %>% 53 | filter(year == 2000) %>% 54 | group_by(age, sex) %>% 55 | mutate(people = sum(people)) %>% 56 | ggplot(aes(x = factor(age), y = people, fill = factor(sex))) + 57 | geom_col(position = "dodge") 58 | 59 | population %>% 60 | filter(year == 2000) %>% 61 | vega() %>% 62 | mark_bar(enc(x = ordered(age), y = vg_count(age))) 63 | 64 | 65 | # mosaic currently broken 66 | cars <- 67 | jsonlite::fromJSON("https://vega.github.io/vega-editor/app/data/cars.json") 68 | 69 | 70 | 71 | selection <- select_interval(encodings = "x") 72 | 73 | hist <- vega(cars, enc(x = Miles_per_Gallon, color = Origin)) %>% 74 | mark_histogram(selection = I(selection)) 75 | 76 | mosaic <- cars %>% 77 | vega(enc(x= Origin, y = Cylinders)) %>% 78 | mark_mosaic(enc(color = Origin), selection = selection) 79 | 80 | hconcat(hist, mosaic) 81 | 82 | # this doesn't work 83 | tips <- readr::read_csv("http://ggobi.org/book/data/tips.csv") 84 | 85 | paintbrush <- select_interval() 86 | 87 | amounts <- vega(tips, enc(x = tip)) %>% 88 | mark_histogram( 89 | enc(color = encode_if(paintbrush, "orange", "black")), 90 | bin = list(step = 0.1, extent = c(0,10)) 91 | ) 92 | 93 | mosaic <- vega(tips, enc(x = smoker, y = sex)) %>% 94 | mark_mosaic( 95 | selection = paintbrush 96 | ) 97 | 98 | hconcat(amounts, mosaic) 99 | -------------------------------------------------------------------------------- /demo/basics.R: -------------------------------------------------------------------------------- 1 | library(dplyr) 2 | 3 | mtcars %>% 4 | vega(encoding = enc(x = wt, y = mpg)) 5 | 6 | mtcars %>% 7 | vega(encoding = enc(x = wt)) 8 | 9 | mtcars %>% 10 | mutate(cyl = factor(cyl)) %>% 11 | vega(encoding = enc(x = wt, y = mpg, fill = cyl, fill_opacity = gear)) %>% 12 | mark_point() 13 | 14 | mtcars %>% 15 | mutate(cyl = factor(cyl)) %>% 16 | vega(encoding = enc(x = wt, y = mpg, fill = cyl)) %>% 17 | mark_point() %>% 18 | config(axis_x = list(orient = "top")) 19 | 20 | mtcars %>% 21 | vega(encoding = enc(x = wt, y = mpg, fill = factor(cyl))) %>% 22 | mark_point(fill_opacity = .3) 23 | 24 | mtcars %>% 25 | vega(encoding = enc(x = wt, y = mpg, fill2 = factor(cyl), fill3 = cyl)) %>% 26 | mark_point(fill_opacity = .3) 27 | 28 | mtcars %>% 29 | mutate(cyl = factor(cyl)) %>% 30 | vega(encoding = enc(x = wt, y = mpg, group = cyl)) %>% 31 | mark_line() 32 | 33 | iris %>% 34 | vega(encoding = enc(x = Sepal.Length, y = Sepal.Width)) %>% 35 | mark_point() 36 | 37 | mtcars %>% 38 | vega(encoding = enc(x = wt, y = mpg, tooltip = wt)) %>% 39 | mark_point() 40 | 41 | mtcars %>% 42 | vega(encoding = enc(x = wt, y = mpg, tooltip = c(wt, cyl))) %>% 43 | mark_point() 44 | 45 | mtcars %>% 46 | vega(encoding = enc(x = wt, y = mpg, tooltip = ac({wt*cyl}))) %>% 47 | mark_point() 48 | 49 | mtcars %>% 50 | vega(encoding = enc(x = wt, y = mpg, color = factor(cyl))) %>% 51 | mark_point() 52 | 53 | mtcars %>% 54 | mutate(cyl = factor(cyl, levels = c(8, 6, 4))) %>% 55 | vega(encoding = enc(x = wt, y = mpg, color = cyl)) %>% 56 | mark_point() 57 | 58 | mtcars %>% 59 | vega(encoding = enc(x = wt, y = mpg, 60 | color = factor(cyl, levels = c(8, 6, 4)))) %>% 61 | mark_point() 62 | 63 | mtcars %>% 64 | mutate(cyl = factor(cyl)) %>% 65 | vega() %>% 66 | mark_point(encoding = enc(x = wt, y = mpg, color = cyl)) 67 | 68 | vega() %>% 69 | mark_point(encoding = enc(x = wt, y = mpg), data = mtcars) 70 | 71 | vega(data = iris) %>% 72 | mark_point(encoding = enc(x = wt, y = mpg), data = mtcars) %>% 73 | vega_serialise_data(path = "~/Downloads") 74 | 75 | mtcars %>% 76 | mutate(cyl = factor(cyl)) %>% 77 | vega(encoding = enc(x = wt, y = mpg)) %>% 78 | mark_point(encoding = enc(color = cyl)) %>% 79 | vega_serialise_data() 80 | 81 | mtcars %>% 82 | mutate(cyl = factor(cyl)) %>% 83 | vega(encoding = enc(x = wt, y = mpg)) %>% 84 | mark_point(encoding = enc(color = cyl)) 85 | 86 | mtcars %>% 87 | mutate(cyl = factor(cyl)) %>% 88 | vega(encoding = enc(x = wt, y = mpg)) %>% 89 | mark_point(encoding = enc(size = cyl)) # shape (ok) 90 | 91 | mtcars %>% 92 | vega() %>% 93 | mark_point(encoding = enc(x = wt)) 94 | 95 | mtcars %>% 96 | vega() %>% 97 | mark_point(encoding = enc(y = wt)) 98 | 99 | mtcars %>% 100 | vega() %>% 101 | mark_point(enc(x = wt, y = mpg), size = 160) 102 | 103 | mtcars %>% 104 | vega() %>% 105 | mark_circle(enc(x = wt, y = mpg), size = 160) 106 | 107 | mtcars %>% 108 | vega() %>% 109 | mark_square(enc(x = wt, y = mpg)) 110 | 111 | mtcars %>% 112 | mutate(cyl = factor(cyl)) %>% 113 | vega() %>% 114 | mark_tick(enc(x = wt, y = cyl)) 115 | 116 | mtcars %>% 117 | mutate(cyl = factor(cyl)) %>% 118 | vega(encoding = enc(x = cyl, y = wt)) %>% 119 | mark_boxplot(tooltip = FALSE) 120 | # vegalite: boxplot not working with null tooltip and selection 121 | 122 | mtcars %>% 123 | mutate(cyl = factor(cyl)) %>% 124 | vega(encoding = enc(x = cyl, y = vg_count())) %>% 125 | mark_bar() 126 | 127 | mtcars %>% 128 | mutate(cyl = factor(cyl)) %>% 129 | vega(encoding = enc(x = wt, colour = cyl)) %>% 130 | mark_density() 131 | 132 | mtcars %>% 133 | vega(encoding = enc(x = wt)) %>% 134 | mark_density() 135 | 136 | huron <- tibble( 137 | year = 1875:1972, level = as.vector(LakeHuron), 138 | ymin = 500, ymean = 550) 139 | 140 | huron %>% 141 | vega(enc(x = year)) %>% 142 | mark_ribbon(enc(y = ymin, y2 = level)) %>% 143 | mark_line(enc(y = 550), colour = "red") 144 | 145 | vega() %>% 146 | mark_ribbon(enc(x = year, y = ymin, y2 = level), data = huron) %>% 147 | mark_line(enc(x = year, y = ymean), data = huron) 148 | 149 | vega(enc(x = year), data = huron) %>% 150 | mark_ribbon(enc(y = ymin, y2 = level)) %>% 151 | mark_rule(enc(x = NULL, y = ymean)) # use NULL to not inherit encoding 152 | 153 | vega() %>% 154 | mark_ribbon(enc(x = year, y = ymin, y2 = level), data = huron) 155 | 156 | # FIXED 157 | vega(encoding = enc(x = year)) %>% 158 | mark_ribbon(enc(y = ymin, y2 = level), data = huron) %>% 159 | mark_line(enc(y = ymean), data = huron) 160 | 161 | huron %>% 162 | vega() %>% 163 | mark_histogram(enc(x = level)) 164 | 165 | # FIXED 166 | huron %>% 167 | vega(enc(x = level)) %>% 168 | mark_histogram() 169 | 170 | huron %>% 171 | vega() %>% 172 | mark_histogram(enc(x = level), bin = list(maxbins = 2)) 173 | 174 | df <- data.frame( 175 | trt = factor(c(1, 1, 2, 2)), 176 | resp = c(1, 5, 3, 4), 177 | group = factor(c(1, 2, 1, 2)), 178 | upper = c(1.1, 5.3, 3.3, 4.2), 179 | lower = c(0.8, 4.6, 2.4, 3.6) 180 | ) 181 | 182 | df %>% 183 | vega(enc(x = trt, color = group)) %>% 184 | mark_linerange(enc(y = lower, y2 = upper)) 185 | 186 | df %>% 187 | vega(enc(x = trt, color = group)) %>% 188 | mark_errorbar(enc(y = lower, y2 = upper)) 189 | 190 | library(ggplot2) 191 | recent <- economics[economics$date > as.Date("2013-01-01"), ] 192 | vega(recent, enc(date, unemploy)) %>% 193 | mark_step() 194 | 195 | # scale_x(domain, type = "band", range) 196 | # scale_color(domain, type = "category", range) 197 | 198 | industries <- jsonlite::read_json( 199 | "https://vega.github.io/vega-editor/app/data/unemployment-across-industries.json" 200 | ) %>% 201 | bind_rows() 202 | industries %>% 203 | vega() %>% 204 | mark_streamgraph( 205 | enc(x = vg_yearmonth(date), y = vg_sum(count), colour = series)) 206 | 207 | img <- jsonlite::fromJSON('[ 208 | {"x": 0.5, "y": 0.5, "img": "https://vega.github.io/vega-editor/app/data/ffox.png"}, 209 | {"x": 1.5, "y": 1.5, "img": "https://vega.github.io/vega-editor/app/data/gimp.png"}, 210 | {"x": 2.5, "y": 2.5, "img": "https://vega.github.io/vega-editor/app/data/7zip.png"} 211 | ]') 212 | 213 | img %>% 214 | vega(enc(x, y, url = img)) %>% 215 | mark_image(width = 50, height = 50) %>% 216 | scale_x(domain = c(0, 3)) 217 | 218 | neg_bar <- jsonlite::fromJSON('[ 219 | {"a": "A", "b": -28}, {"a": "B", "b": 55}, {"a": "C", "b": -33}, 220 | {"a": "D", "b": 91}, {"a": "E", "b": 81}, {"a": "F", "b": 53}, 221 | {"a": "G", "b": -19}, {"a": "H", "b": 87}, {"a": "I", "b": 52} 222 | ]') 223 | neg_bar %>% 224 | vega(enc(a, b)) %>% 225 | mark_bar() 226 | -------------------------------------------------------------------------------- /demo/facet.R: -------------------------------------------------------------------------------- 1 | mtcars %>% 2 | vega(encoding = enc(x = wt, y = mpg)) %>% 3 | mark_point() %>% 4 | facet_views(row = cyl) %>% 5 | vega_set_height(height = 900) 6 | 7 | mtcars %>% 8 | vega(encoding = enc(x = wt, y = mpg)) %>% 9 | mark_point(data = mtcars) %>% 10 | facet_views(row = cyl) 11 | 12 | mtcars %>% 13 | vega(encoding = enc(x = wt, y = mpg)) %>% 14 | mark_point() %>% 15 | facet_views(column = cyl) 16 | 17 | # different width/height defaults for facets? 18 | mtcars %>% 19 | vega(encoding = enc(x = wt, y = mpg)) %>% 20 | mark_point() %>% 21 | facet_views(row = cyl, column = gear) 22 | 23 | mtcars %>% 24 | vega(encoding = enc(x = wt, y = mpg)) %>% 25 | mark_point() %>% 26 | facet_views(row = cyl, column = gear) 27 | 28 | mtcars %>% 29 | vega(enc(x = ac(c(1,3)))) %>% 30 | mark_histogram(enc(color = factor(cyl))) 31 | 32 | mtcars %>% 33 | vega(enc(x = ac(c(mpg, wt)), y = ac(c(wt, disp, mpg)))) %>% 34 | mark_point() 35 | 36 | selection <- select_interval() 37 | 38 | mtcars %>% 39 | vega(enc(x = ac(c(mpg, wt)), y = ac(c(wt, disp, mpg)))) %>% 40 | mark_point(selection = I(selection)) 41 | 42 | mtcars %>% 43 | vega(enc(x = ac(c(mpg, wt)), y = ac(c(wt, disp, mpg)))) %>% 44 | mark_point(enc(color = encode_if(selection, factor(cyl), "black"))) 45 | 46 | 47 | 48 | 49 | -------------------------------------------------------------------------------- /demo/scale.R: -------------------------------------------------------------------------------- 1 | df <- tibble(x = 0:7, y = 10 ^ x) 2 | df %>% 3 | vega() %>% 4 | mark_point(enc(x, y)) %>% 5 | scale_y(type = "log") 6 | 7 | df %>% 8 | vega() %>% 9 | mark_point(enc(y, x)) %>% 10 | scale_x(type = "log") 11 | 12 | tibble(x = 0:7, y = 2 ^ x) %>% 13 | vega() %>% 14 | mark_point(enc(x, y)) %>% 15 | scale_y(type = "sqrt") 16 | 17 | tibble(x = 0:7, y = 2 ^ x) %>% 18 | vega() %>% 19 | mark_point(enc(x, y)) %>% 20 | scale_x(breaks = seq(1, 8, by = 2)) 21 | 22 | stocks <- readr::read_csv( 23 | "https://vega.github.io/vega-editor/app/data/stocks.csv" 24 | ) %>% 25 | mutate(date = lubridate::mdy(date)) 26 | 27 | library(ggplot2) 28 | ggplot(stocks) + 29 | geom_line(aes(date, price, colour = symbol)) 30 | 31 | stocks %>% 32 | vega(enc(x = date, y = price)) %>% 33 | mark_line(enc(colour = symbol), clip = FALSE) %>% 34 | scale_x(domain = c(as.Date("2002-01-01"), as.Date("2008-01-01"))) 35 | 36 | mtcars %>% 37 | mutate(cyl = factor(cyl)) %>% 38 | vega(encoding = enc(x = wt, y = mpg)) %>% 39 | mark_point() %>% 40 | scale_x(domain = c(2, 4)) 41 | 42 | mtcars %>% 43 | mutate(cyl = factor(cyl)) %>% 44 | vega(encoding = enc(x = wt, y = mpg)) %>% 45 | mark_point() %>% 46 | scale_x(orient = "top") %>% 47 | scale_y(orient = "right") 48 | 49 | mtcars %>% 50 | mutate(cyl = factor(cyl)) %>% 51 | vega(encoding = enc(x = wt, y = mpg)) %>% 52 | mark_point() %>% 53 | scale_x(domain = c(2, 4)) 54 | 55 | mtcars %>% 56 | mutate(cyl = factor(cyl)) %>% 57 | vega(encoding = enc(x = wt, y = mpg, colour = cyl)) %>% 58 | mark_point() %>% 59 | scale_color(guide = FALSE) 60 | 61 | mtcars %>% 62 | vega(enc(x = wt, y = mpg, colour = factor(cyl))) %>% 63 | mark_point() %>% 64 | scale_colour(name = "Cylinders", 65 | range = c("purple", "#ff0000", "teal")) 66 | 67 | mtcars %>% 68 | vega(enc(x = wt, y = mpg, colour = factor(cyl))) %>% 69 | mark_point() %>% 70 | scale_colour(scheme = "category20b") 71 | 72 | mtcars %>% 73 | vega(enc(x = wt, y = mpg, colour = hp)) %>% 74 | mark_point() %>% 75 | scale_colour(range = "diverging", domain_mid = 300) 76 | -------------------------------------------------------------------------------- /demo/selections.R: -------------------------------------------------------------------------------- 1 | library(dplyr) 2 | 3 | selection <- select_interval() 4 | 5 | mtcars %>% 6 | vega() %>% 7 | mark_circle( 8 | encoding = enc(x = wt, y = mpg, color = factor(cyl)), 9 | selection = selection) 10 | 11 | vega() %>% 12 | mark_circle( 13 | encoding = enc(x = wt, y = mpg, 14 | color = encode_if(select_single(), factor(cyl), "grey")), 15 | data = mtcars) 16 | 17 | vega() %>% 18 | mark_circle( 19 | encoding = enc(x = wt, y = mpg, color = factor(cyl)), 20 | data = mtcars, selection = select_single(fields = "cyl")) 21 | 22 | mtcars %>% 23 | vega() %>% 24 | mark_circle( 25 | encoding = enc(x = wt, y = mpg, color = factor(cyl)), 26 | selection = I(selection)) 27 | 28 | mtcars %>% 29 | vega() %>% 30 | mark_circle( 31 | encoding = enc(x = wt, y = mpg, color = factor(cyl)), 32 | selection = select_interval(init = list(x = c(2, 4), y = c(15, 25)))) 33 | 34 | 35 | mtcars %>% 36 | vega() %>% 37 | mark_point(enc( 38 | x = wt, y = mpg, 39 | colour = encode_if(selection, factor(cyl), "grey"))) 40 | 41 | mtcars %>% 42 | vega() %>% 43 | mark_point(enc( 44 | x = wt, y = mpg, 45 | colour = encode_if(selection, factor(cyl), "grey"), 46 | size = encode_if(selection, 180, 60))) 47 | 48 | p1 <- mtcars %>% 49 | mutate(cyl = factor(cyl)) %>% 50 | vega(encoding = enc(x = wt, y = mpg)) %>% 51 | mark_point(enc(colour = encode_if(selection, factor(cyl), "grey"))) 52 | p2 <- mtcars %>% 53 | vega() %>% 54 | mark_point(enc( 55 | x = disp, y = hp, 56 | colour = encode_if(selection, factor(cyl), "#99d8c9"))) 57 | hconcat(p1, p2) 58 | 59 | p3 <- mtcars %>% 60 | vega() %>% 61 | mark_point( 62 | encoding = enc(x = disp, y = hp), 63 | selection = selection) 64 | hconcat(p1, p3) 65 | vconcat(hconcat(p1, p3), p2) 66 | 67 | p1 %>% 68 | mark_rule( 69 | encoding = enc(x = NULL, y = vg_mean(mpg), colour = factor(cyl)), 70 | size = 3, selection = selection) 71 | 72 | p1 %>% 73 | mark_rule( 74 | encoding = enc(x = NULL, y = avg, colour = cyl), 75 | size = 3, 76 | selection = selection %>% 77 | group_by(cyl) %>% 78 | summarise(avg = vg_mean(mpg))) 79 | 80 | p1 %>% 81 | mark_rule( 82 | encoding = enc(x = NULL, y = avg, colour = factor(cyl)), 83 | size = 3, 84 | selection = selection %>% 85 | group_by(cyl) %>% 86 | mutate(avg = vg_mean(mpg))) 87 | 88 | p1 %>% 89 | mark_rule( 90 | encoding = enc(x = NULL, y = avg, colour = factor(cyl)), 91 | size = 3, 92 | selection = selection %>% 93 | group_by(cyl) %>% 94 | mutate(avg = vg_window_mean(mpg, frame = list(NULL, NULL)))) 95 | 96 | p1 %>% 97 | mark_rule( 98 | encoding = enc(x = NULL, y = avg), 99 | size = 3, 100 | selection = selection %>% 101 | mutate(avg = vg_cumsum(mpg))) 102 | 103 | p1 %>% 104 | mark_rule( 105 | encoding = enc(x = NULL, y = avg), 106 | size = 3, 107 | selection = selection %>% mutate(avg = mpg + 2)) 108 | 109 | selection_lag <- selection %>% mutate(lag_wt = vg_lag(wt, sort = wt)) 110 | p4 <- mtcars %>% 111 | vega() %>% 112 | mark_point(enc(x = wt, y = lag_wt), selection = selection_lag) 113 | hconcat(p1, p4) 114 | 115 | mtcars %>% 116 | vega(encoding = enc(x = wt, y = mpg)) %>% 117 | mark_point() %>% 118 | mark_rule( 119 | encoding = enc(x = NULL, y = vg_mean(mpg), colour = factor(cyl)), 120 | size = 3, data = mtcars[mtcars$cyl %in% c(4, 6), ], selection = selection) 121 | 122 | # vg_window() 123 | 124 | p_bar <- mtcars %>% 125 | vega(enc(x = disp)) %>% 126 | # mark_histogram() %>% 127 | mark_histogram(selection = selection, colour = "red") 128 | hconcat(p1, p_bar) 129 | 130 | p_box <- mtcars %>% 131 | vega(enc(x = factor(cyl), y = mpg)) %>% 132 | mark_boxplot() %>% 133 | mark_boxplot(selection = selection, colour = "red") 134 | hconcat(p1, p_box) 135 | 136 | evt <- "[mousedown[!event.shiftKey], mouseup] > mousemove" 137 | a <- select_interval(on = evt) 138 | b <- select_interval( 139 | on = "[mousedown[event.shiftKey], mouseup] > mousemove", 140 | mark = c("fill" = "#fdbb84", "fill_opacity" = 0.5, "stroke" = "#e34a33")) 141 | selection_composition(a & b) 142 | selection_composition(a | b) 143 | selection_composition(a | !b) 144 | selection_composition(!(a & b)) 145 | selection_composition(!(a & b) & select_interval()) 146 | 147 | p4 <- mtcars %>% 148 | vega() %>% 149 | mark_point(enc( 150 | x = wt, y = mpg, 151 | color = encode_if(a | b, factor(cyl), "grey"))) 152 | p4 153 | 154 | mtcars %>% 155 | vega() %>% 156 | mark_point(enc( 157 | x = wt, y = mpg, 158 | color = encode_if(!(a | b), factor(cyl), "grey"))) 159 | 160 | mtcars %>% 161 | vega() %>% 162 | mark_point(enc( 163 | x = wt, y = mpg, 164 | color = encode_if(a, factor(cyl), "grey"), 165 | size = encode_if(b, 180, 60))) 166 | 167 | p5 <- mtcars %>% 168 | vega() %>% 169 | mark_point( 170 | encoding = enc(x = disp, y = hp, 171 | color = encode_if(a | b, factor(cyl), "#99d8c9"))) 172 | hconcat(p4, p5) 173 | 174 | mtcars %>% 175 | mutate(cyl = factor(cyl)) %>% 176 | vega() %>% 177 | mark_circle( 178 | encoding = enc(x = wt, y = mpg, color = cyl, 179 | tooltip = c(hp, cyl), 180 | size = encode_if(select_legend(cyl), 100, 20))) 181 | 182 | mtcars %>% 183 | mutate(gear = factor(gear)) %>% 184 | vega() %>% 185 | mark_circle( 186 | encoding = enc(x = wt, y = mpg, color = factor(cyl), shape = gear, 187 | opacity = encode_if(select_legend(gear), 1, .2))) 188 | 189 | mtcars %>% 190 | vega() %>% 191 | mark_circle( 192 | encoding = enc(x = wt, y = mpg, color = factor(cyl)), 193 | selection = select_domain()) 194 | 195 | sp500 <- readr::read_csv("https://vega.github.io/vega-editor/app/data/sp500.csv") %>% 196 | mutate(date = lubridate::mdy(date)) 197 | brush <- select_interval(encodings = "x") 198 | v1 <- sp500 %>% 199 | vega(enc(x = date, y = price), height = 200) %>% 200 | mark_area() %>% 201 | scale_x(name = NULL, domain = brush) 202 | v2 <- sp500 %>% 203 | vega(enc(x = date, y = price), height = 100) %>% 204 | mark_area(selection = I(brush)) 205 | vconcat(v1, v2) 206 | 207 | # input element binding 208 | 209 | alpha <- input_slider(min = 0, max = 1, step = 0.1, init = 0.3, name = "alpha") 210 | 211 | mtcars %>% 212 | mutate(cyl = factor(cyl)) %>% 213 | vega() %>% 214 | mark_circle(enc(x = hp, y = mpg), colour = "red", opacity = alpha) 215 | 216 | select_cyl <- 217 | select_bind( 218 | cyl = input_radio("Cylinders", choices = levels(factor(mtcars$cyl)))) 219 | 220 | mtcars %>% 221 | mutate(cyl = factor(cyl)) %>% 222 | vega() %>% 223 | mark_circle( 224 | enc(x = hp, y = mpg, 225 | color = encode_if(select_cyl, cyl, "black") 226 | )) 227 | 228 | select_cyl <- 229 | select_bind(cyl = input_select(choices = levels(factor(mtcars$cyl)))) 230 | 231 | mtcars %>% 232 | mutate(cyl = factor(cyl)) %>% 233 | vega() %>% 234 | mark_circle( 235 | enc(x = hp, y = mpg, 236 | color = encode_if(select_cyl, cyl, "black") 237 | )) 238 | 239 | slider <- select_bind( 240 | carb = input_slider(min = 1, max = 8, step = 1) 241 | ) 242 | 243 | 244 | mtcars %>% 245 | vega() %>% 246 | mark_circle( 247 | enc(x = hp, y = mpg, colour = encode_if(slider, factor(cyl), "grey")) 248 | ) 249 | 250 | slider <- select_bind( 251 | carb = input_slider(min = 1, max = 8, step = 1, init = 8) 252 | ) 253 | mtcars %>% 254 | vega() %>% 255 | mark_circle( 256 | enc(x = hp, y = mpg, color = encode_if(slider, factor(cyl), "grey")) 257 | ) 258 | 259 | double_slider <- select_bind( 260 | cyl = input_select(choices = levels(factor(mtcars$cyl))) 261 | ) 262 | 263 | mtcars %>% 264 | vega() %>% 265 | mark_circle( 266 | enc(x = hp, y = mpg, 267 | colour = encode_if(slider | double_slider, factor(cyl), "grey"), 268 | size = encode_if(slider | double_slider, 100, 50))) 269 | 270 | stocks <- readr::read_csv( 271 | "https://vega.github.io/vega-editor/app/data/stocks.csv" 272 | ) %>% 273 | mutate(date = lubridate::mdy(date)) 274 | 275 | hover <- select_single(on = "mouseover", empty = "all", init = list(symbol = "AAPL")) 276 | stocks %>% 277 | filter(symbol != "IBM") %>% 278 | vega(enc(x = date, y = price)) %>% 279 | mark_line(enc( 280 | colour = encode_if(hover, symbol, "grey"), 281 | opacity = encode_if(hover, 1, 0.2))) %>% 282 | mark_text( 283 | encoding = enc(x = vg_max(date), y = vg_argmax(price, date), text = symbol), 284 | dx = 4, align = "left", clip = FALSE) 285 | -------------------------------------------------------------------------------- /demo/timeunit.R: -------------------------------------------------------------------------------- 1 | library(dplyr) 2 | 3 | weather <- readr::read_csv("https://vega.github.io/vega-editor/app/data/seattle-weather.csv") 4 | 5 | weather %>% 6 | vega(enc(x = vg_month(date), y = vg_mean(temp_max))) %>% 7 | mark_line() %>% 8 | mark_point() 9 | 10 | weather %>% 11 | vega(enc(x = vg_month(date))) %>% 12 | mark_ribbon( 13 | enc(y = vg_mean(temp_max), y2 = vg_mean(temp_min)), 14 | opacity = .3) %>% 15 | mark_line(enc(y = vg_mean(precipitation)), interpolate = "monotone") %>% 16 | resolve_views(scale = list(y = "independent")) 17 | 18 | stocks <- readr::read_csv("https://vega.github.io/vega-editor/app/data/stocks.csv") 19 | 20 | stocks %>% 21 | mutate(symbol = factor(symbol)) %>% 22 | vega(enc(x = vg_year(date), y = vg_mean(price), color = symbol)) %>% 23 | mark_line() %>% 24 | mark_point() 25 | 26 | data <- jsonlite::fromJSON('[ 27 | {"date": "Sun, 01 Jan 2012 00:00:00", "distance": 1}, 28 | {"date": "Sun, 01 Jan 2012 00:01:00", "distance": 1}, 29 | {"date": "Sun, 01 Jan 2012 00:02:00", "distance": 2}, 30 | {"date": "Sun, 01 Jan 2012 00:03:00", "distance": 1}, 31 | {"date": "Sun, 01 Jan 2012 00:04:00", "distance": 4}, 32 | {"date": "Sun, 01 Jan 2012 00:05:00", "distance": 2}, 33 | {"date": "Sun, 01 Jan 2012 00:06:00", "distance": 5}, 34 | {"date": "Sun, 01 Jan 2012 00:07:00", "distance": 2}, 35 | {"date": "Sun, 01 Jan 2012 00:08:00", "distance": 6}, 36 | {"date": "Sun, 01 Jan 2012 00:09:00", "distance": 4}, 37 | {"date": "Sun, 01 Jan 2012 00:10:00", "distance": 1}, 38 | {"date": "Sun, 01 Jan 2012 00:11:00", "distance": 1}, 39 | {"date": "Sun, 01 Jan 2012 00:12:00", "distance": 3}, 40 | {"date": "Sun, 01 Jan 2012 00:13:00", "distance": 0}, 41 | {"date": "Sun, 01 Jan 2012 00:14:00", "distance": 2}, 42 | {"date": "Sun, 01 Jan 2012 00:15:00", "distance": 3} 43 | ]') 44 | 45 | data %>% 46 | vega(enc(x = vg_minutes(date, step = 5), y = vg_sum(distance))) %>% 47 | mark_bar() 48 | -------------------------------------------------------------------------------- /demo/transform.R: -------------------------------------------------------------------------------- 1 | library(dplyr) 2 | 3 | movies <- jsonlite::read_json( 4 | "https://vega.github.io/vega-editor/app/data/movies.json" 5 | , simplifyVector = TRUE) 6 | 7 | as_tibble(movies) %>% 8 | vega(enc(x = Rotten_Tomatoes_Rating, y = IMDB_Rating)) %>% 9 | mark_point(enc(colour = vg_bin(IMDB_Rating, step = 3))) 10 | 11 | movies %>% 12 | vega() %>% 13 | mark_bar(enc(x = vg_argmax(Production_Budget, US_Gross), y = Major_Genre)) 14 | 15 | as_tibble(movies) %>% 16 | vega(enc(x = Rotten_Tomatoes_Rating, y = IMDB_Rating)) %>% 17 | mark_point() %>% 18 | mark_smooth(enc(colour = Major_Genre)) 19 | 20 | as_tibble(movies) %>% 21 | vega(enc(x = Rotten_Tomatoes_Rating, y = IMDB_Rating)) %>% 22 | mark_point() %>% 23 | mark_smooth(colour = "firebrick", formula = y ~ x^3) 24 | 25 | as_tibble(movies) %>% 26 | vega(enc(x = Rotten_Tomatoes_Rating, y = IMDB_Rating)) %>% 27 | mark_point() %>% 28 | mark_smooth(colour = "firebrick", method = "loess") 29 | 30 | as_tibble(movies) %>% 31 | vega(enc(x = Rotten_Tomatoes_Rating, y = IMDB_Rating)) %>% 32 | mark_point() %>% 33 | mark_smooth(colour = "firebrick", selection = !select_interval()) 34 | 35 | as_tibble(movies) %>% 36 | vega(enc(x = IMDB_Rating, y = Rotten_Tomatoes_Rating, colour = vg_count())) %>% 37 | mark_bin2d(bin = list(x = list(maxbins = 60), y = list(maxbins = 40))) 38 | 39 | # missing data 40 | library(dplyr) 41 | movies <- jsonlite::read_json( 42 | "https://vega.github.io/vega-editor/app/data/movies.json" 43 | , simplifyVector = TRUE) 44 | movies <- movies %>% 45 | mutate(missing = is.na(IMDB_Rating) | is.na(Rotten_Tomatoes_Rating)) 46 | movies %>% 47 | vega(enc(IMDB_Rating, Rotten_Tomatoes_Rating, colour = missing)) %>% 48 | mark_point(na.rm = FALSE) %>% 49 | config(mark = list(invalid = NULL)) 50 | 51 | movies %>% 52 | vega(enc(IMDB_Rating, Rotten_Tomatoes_Rating)) %>% 53 | mark_point() 54 | 55 | movies %>% 56 | vega(enc(IMDB_Rating, Rotten_Tomatoes_Rating)) %>% 57 | mark_point(na.rm = FALSE) 58 | 59 | palmerpenguins::penguins %>% 60 | vega(enc(x = body_mass_g, colour = species)) %>% 61 | mark_density() 62 | -------------------------------------------------------------------------------- /man/aklhousingprice.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/datasets.R 3 | \docType{data} 4 | \name{aklhousingprice} 5 | \alias{aklhousingprice} 6 | \title{Auckland housing price} 7 | \format{ 8 | A tibble with 8,011 rows and 10 variables: 9 | \itemize{ 10 | \item \code{region}: "Auckland" 11 | \item \code{district}: Auckland districts 12 | \item \code{property_address}: Property address 13 | \item \code{lon}: Latitude of the property 14 | \item \code{lat}: Longitude of the property 15 | \item \code{auction_price}: Auction price 16 | \item \code{auction_dates}: Auction date 17 | \item \code{bedrooms}: The number of bedrooms 18 | \item \code{bathrooms}: The number of bathrooms 19 | \item \code{car_parking}: The number of parkings 20 | \item \code{rating_value}: Rating price 21 | \item \code{rating_dates}: Rating dates 22 | } 23 | } 24 | \source{ 25 | \href{https://www.interest.co.nz}{interest.co.nz} 26 | } 27 | \usage{ 28 | aklhousingprice 29 | } 30 | \description{ 31 | Auckland housing price 32 | } 33 | \details{ 34 | This data is scraped from the \href{https://www.interest.co.nz}{interest.co.nz} 35 | and contains Auckland auction prices between 2018 and 2021. 36 | } 37 | \keyword{datasets} 38 | -------------------------------------------------------------------------------- /man/concat.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/multiviews.R 3 | \name{hconcat} 4 | \alias{hconcat} 5 | \alias{vconcat} 6 | \title{Concatenate views} 7 | \usage{ 8 | hconcat(...) 9 | 10 | vconcat(...) 11 | } 12 | \arguments{ 13 | \item{...}{A list of \code{vega()} objects.} 14 | } 15 | \description{ 16 | \code{hconcat()} for horizontal concatenation, and \code{vconcat()} for vertical 17 | concatenation 18 | } 19 | -------------------------------------------------------------------------------- /man/enc.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/eval.R 3 | \name{enc} 4 | \alias{enc} 5 | \title{Map data variables to visual encodings} 6 | \usage{ 7 | enc(x, y, ...) 8 | } 9 | \arguments{ 10 | \item{x, y, ...}{A set of name-value pairs to describe the mappings of data 11 | variables to visual encodings in \code{vega()} and individual mark layers \verb{mark_*()}. 12 | Use \code{NULL} to disable a layer encoding to inherit from its parent encodings.} 13 | } 14 | \value{ 15 | A list of quosures or constants. 16 | } 17 | \description{ 18 | Map data variables to visual encodings 19 | } 20 | \examples{ 21 | enc(x = mpg, y = wt) 22 | enc(colour = cyl) 23 | enc(color = cyl) 24 | enc(x = NULL) 25 | } 26 | -------------------------------------------------------------------------------- /man/encode_if.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/selection.R 3 | \name{encode_if} 4 | \alias{encode_if} 5 | \title{Conditional encoding selection} 6 | \usage{ 7 | encode_if(selection, true, false) 8 | } 9 | \arguments{ 10 | \item{selection}{A selection or selection compositions.} 11 | 12 | \item{true, false}{Values for true/false element of \code{selection}.} 13 | } 14 | \description{ 15 | Conditional encoding selection 16 | } 17 | -------------------------------------------------------------------------------- /man/entitle.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/vega.R 3 | \name{entitle} 4 | \alias{entitle} 5 | \title{Modify vega title, subtitle, and description} 6 | \usage{ 7 | entitle(v, title = NULL, subtitle = NULL, description = NULL) 8 | } 9 | \arguments{ 10 | \item{v}{A \code{vega()} object.} 11 | 12 | \item{title, subtitle, description}{Strings.} 13 | } 14 | \description{ 15 | Modify vega title, subtitle, and description 16 | } 17 | -------------------------------------------------------------------------------- /man/facet_views.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/multiviews.R 3 | \name{facet_views} 4 | \alias{facet_views} 5 | \title{Facet data views by rows and columns} 6 | \usage{ 7 | facet_views(v, row = NULL, column = NULL) 8 | } 9 | \arguments{ 10 | \item{v}{A \code{vega()} object.} 11 | 12 | \item{row, column}{A set of data variables to define facetted views on the 13 | rows and columns grid.} 14 | } 15 | \description{ 16 | Facet data views by rows and columns 17 | } 18 | -------------------------------------------------------------------------------- /man/figures/README-basic-scatter-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vegawidget/virgo/0c594d47eecc7fde7928f6abafc2ef8ea8fa4ca3/man/figures/README-basic-scatter-1.png -------------------------------------------------------------------------------- /man/figures/readme-circle.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vegawidget/virgo/0c594d47eecc7fde7928f6abafc2ef8ea8fa4ca3/man/figures/readme-circle.png -------------------------------------------------------------------------------- /man/figures/readme-hconcat.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vegawidget/virgo/0c594d47eecc7fde7928f6abafc2ef8ea8fa4ca3/man/figures/readme-hconcat.png -------------------------------------------------------------------------------- /man/figures/readme-histogram.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vegawidget/virgo/0c594d47eecc7fde7928f6abafc2ef8ea8fa4ca3/man/figures/readme-histogram.png -------------------------------------------------------------------------------- /man/image.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/utils-vegawidget.R 3 | \name{image} 4 | \alias{image} 5 | \alias{vw_to_svg} 6 | \alias{vw_to_bitmap} 7 | \alias{vw_write_png} 8 | \alias{vw_write_svg} 9 | \title{Create or write image} 10 | \description{ 11 | See \code{vegawidget::\link[vegawidget]{image}} for details. 12 | } 13 | -------------------------------------------------------------------------------- /man/knit_print.vegaspec.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/utils-vegawidget.R, R/vega.R 3 | \name{knit_print.vegaspec} 4 | \alias{knit_print.vegaspec} 5 | \alias{knit_print.virgo} 6 | \title{Knit-print method} 7 | \usage{ 8 | knit_print.virgo(spec, ..., renderer = "canvas", options = NULL) 9 | } 10 | \arguments{ 11 | \item{spec}{vega spec.} 12 | 13 | \item{...}{Options passed to knitr.} 14 | 15 | \item{renderer}{One of "svg" or "canvas".} 16 | 17 | \item{options}{Options.} 18 | } 19 | \description{ 20 | See \code{vegawidget::\link[vegawidget]{knit_print.vegaspec}} for details, 21 | particularly on additional packages that may have to be installed. 22 | } 23 | -------------------------------------------------------------------------------- /man/melbweather.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/datasets.R 3 | \docType{data} 4 | \name{melbweather} 5 | \alias{melbweather} 6 | \title{Melbourne microclimate measurements} 7 | \format{ 8 | A tibble with 32,253 rows and 12 variables: 9 | \itemize{ 10 | \item \code{site}: Site identifier, this is the location of the weather sensor, 11 | there are five sites located around the city. 12 | \item \code{site_address}: The address of the site 13 | \item \verb{longitude, latitude}: The spatial coordinates of the measurement sites 14 | \item \code{date_time}: The local date time that a sensor made a recording 15 | \item \code{date}: Date associated with \code{date_time} 16 | \item \code{ambient_temperature}: The value of the ambient air temperature in degrees Celsius. 17 | \item \code{relative_humidity}: The percent value of the relative humidity (no units) 18 | \item \code{barometric_pressure}: The barometric pressure in hectopascals (hPa) 19 | \item \code{wind_speed}: The wind speed in kilometers per hour (km/h) 20 | \item \verb{pm2.5,pm10}: The mass density of particulate matter in the air less than 2.5 (10) micrometers in diameter. Measured in micrograms per cubic meter. 21 | } 22 | } 23 | \source{ 24 | \href{https://data.melbourne.vic.gov.au/Environment/Microclimate-Sensor-Readings/u4vh-84j8}{Melbourne Open Data Portal} 25 | } 26 | \usage{ 27 | melbweather 28 | } 29 | \description{ 30 | Melbourne microclimate measurements 31 | } 32 | \details{ 33 | This data comes from the \href{https://data.melbourne.vic.gov.au/Environment/Microclimate-Sensor-Readings/u4vh-84j8}{Melbourne Open Data Portal} 34 | and contains measurements from microclimate sensors around the city. Here 35 | we have restricted the data to contain measurements from January 2020 and June 2020. There are five sites where measurements are taken 36 | every 15 minutes. 37 | } 38 | \keyword{datasets} 39 | -------------------------------------------------------------------------------- /man/pipe.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/utils-pipe.R 3 | \name{\%>\%} 4 | \alias{\%>\%} 5 | \title{Pipe operator} 6 | \usage{ 7 | lhs \%>\% rhs 8 | } 9 | \description{ 10 | See \code{magrittr::\link[magrittr:pipe]{\%>\%}} for details. 11 | } 12 | \keyword{internal} 13 | -------------------------------------------------------------------------------- /man/resolve_views.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/multiviews.R 3 | \name{resolve_views} 4 | \alias{resolve_views} 5 | \title{Resolve scale and guide for layered and multi-view displays} 6 | \usage{ 7 | resolve_views(v, scale = list(), axis = list(), legend = list()) 8 | } 9 | \arguments{ 10 | \item{v}{A \code{vega()} object.} 11 | 12 | \item{scale}{A named list of every channel to define either "shared" or 13 | "independent".} 14 | 15 | \item{axis}{A named list of positional channels like \code{x} and \code{y}.} 16 | 17 | \item{legend}{A named list of non-positional channels, such as \code{color}/\code{colour}, 18 | \code{opacity}, \code{shape}, and \code{size}.} 19 | } 20 | \description{ 21 | Resolve scale and guide for layered and multi-view displays 22 | } 23 | -------------------------------------------------------------------------------- /man/vega-config.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/config.R 3 | \name{config} 4 | \alias{config} 5 | \alias{config_ggplot} 6 | \title{Vega theme configurations} 7 | \usage{ 8 | config( 9 | v, 10 | background = "white", 11 | axis = list(), 12 | axis_x = list(), 13 | axis_y = list(), 14 | header = list(), 15 | legend = list(), 16 | title = list(), 17 | view = list(), 18 | facet = list(), 19 | ... 20 | ) 21 | 22 | config_ggplot(v) 23 | } 24 | \arguments{ 25 | \item{v}{A \code{vega()} object.} 26 | 27 | \item{background}{A plot background.} 28 | 29 | \item{axis, axis_x, axis_y}{A named list to define axis.} 30 | 31 | \item{header, legend, title, view, facet}{A named list.} 32 | 33 | \item{...}{Other parameters.} 34 | } 35 | \description{ 36 | Vega theme configurations 37 | } 38 | -------------------------------------------------------------------------------- /man/vega-input.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/selection.R 3 | \name{input_slider} 4 | \alias{input_slider} 5 | \alias{input_radio} 6 | \alias{input_select} 7 | \alias{input_textbox} 8 | \alias{input_checkbox} 9 | \alias{input_color} 10 | \alias{input_colour} 11 | \alias{input_date} 12 | \alias{input_datetime} 13 | \alias{input_month} 14 | \alias{input_week} 15 | \title{HTML elements that bind to selections} 16 | \usage{ 17 | input_slider(name = NULL, min, max, step, init = NULL) 18 | 19 | input_radio(name = NULL, choices, init = NULL) 20 | 21 | input_select(name = NULL, choices, init = NULL) 22 | 23 | input_textbox(init = NULL, ...) 24 | 25 | input_checkbox(init = NULL, ...) 26 | 27 | input_color(init = NULL, ...) 28 | 29 | input_colour(init = NULL, ...) 30 | 31 | input_date(init = NULL, ...) 32 | 33 | input_datetime(init = NULL, ...) 34 | 35 | input_month(init = NULL, ...) 36 | 37 | input_week(init = NULL, ...) 38 | } 39 | \arguments{ 40 | \item{name}{Name of the HTML input.} 41 | 42 | \item{min, max}{Minimum and maximum values.} 43 | 44 | \item{step}{Incremental step.} 45 | 46 | \item{init}{An initial value.} 47 | 48 | \item{choices}{A (named) vector of options.} 49 | 50 | \item{...}{Not sure.} 51 | } 52 | \description{ 53 | HTML elements that bind to selections 54 | } 55 | -------------------------------------------------------------------------------- /man/vega-marks.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mark.R 3 | \name{mark_arc} 4 | \alias{mark_arc} 5 | \alias{mark_ribbon} 6 | \alias{mark_boxplot} 7 | \alias{mark_circle} 8 | \alias{mark_errorband} 9 | \alias{mark_image} 10 | \alias{mark_line} 11 | \alias{mark_point} 12 | \alias{mark_rect} 13 | \alias{mark_rule} 14 | \alias{mark_square} 15 | \alias{mark_text} 16 | \alias{mark_tick} 17 | \alias{mark_trail} 18 | \alias{mark_area} 19 | \alias{mark_bar} 20 | \alias{mark_errorbar} 21 | \alias{mark_histogram} 22 | \alias{mark_step} 23 | \alias{mark_density} 24 | \alias{mark_bin2d} 25 | \alias{mark_streamgraph} 26 | \alias{mark_smooth} 27 | \alias{mark_mosaic} 28 | \alias{mark_blank} 29 | \title{Add new marks to \code{vega()} visualisation} 30 | \usage{ 31 | mark_arc(v, encoding = NULL, data = NULL, selection = NULL, ..., na.rm = TRUE) 32 | 33 | mark_ribbon( 34 | v, 35 | encoding = NULL, 36 | data = NULL, 37 | selection = NULL, 38 | ..., 39 | na.rm = TRUE 40 | ) 41 | 42 | mark_boxplot( 43 | v, 44 | encoding = NULL, 45 | data = NULL, 46 | selection = NULL, 47 | ..., 48 | na.rm = TRUE 49 | ) 50 | 51 | mark_circle( 52 | v, 53 | encoding = NULL, 54 | data = NULL, 55 | selection = NULL, 56 | ..., 57 | na.rm = TRUE 58 | ) 59 | 60 | mark_errorband( 61 | v, 62 | encoding = NULL, 63 | data = NULL, 64 | selection = NULL, 65 | ..., 66 | na.rm = TRUE 67 | ) 68 | 69 | mark_image( 70 | v, 71 | encoding = NULL, 72 | data = NULL, 73 | selection = NULL, 74 | ..., 75 | na.rm = TRUE 76 | ) 77 | 78 | mark_line(v, encoding = NULL, data = NULL, selection = NULL, ..., na.rm = TRUE) 79 | 80 | mark_point( 81 | v, 82 | encoding = NULL, 83 | data = NULL, 84 | selection = NULL, 85 | ..., 86 | na.rm = TRUE 87 | ) 88 | 89 | mark_rect(v, encoding = NULL, data = NULL, selection = NULL, ..., na.rm = TRUE) 90 | 91 | mark_rule(v, encoding = NULL, data = NULL, selection = NULL, ..., na.rm = TRUE) 92 | 93 | mark_square( 94 | v, 95 | encoding = NULL, 96 | data = NULL, 97 | selection = NULL, 98 | ..., 99 | na.rm = TRUE 100 | ) 101 | 102 | mark_text(v, encoding = NULL, data = NULL, selection = NULL, ..., na.rm = TRUE) 103 | 104 | mark_tick(v, encoding = NULL, data = NULL, selection = NULL, ..., na.rm = TRUE) 105 | 106 | mark_trail( 107 | v, 108 | encoding = NULL, 109 | data = NULL, 110 | selection = NULL, 111 | ..., 112 | na.rm = TRUE 113 | ) 114 | 115 | mark_area( 116 | v, 117 | encoding = NULL, 118 | data = NULL, 119 | selection = NULL, 120 | position = "stack", 121 | ..., 122 | na.rm = TRUE 123 | ) 124 | 125 | mark_bar( 126 | v, 127 | encoding = NULL, 128 | data = NULL, 129 | selection = NULL, 130 | position = "stack", 131 | ..., 132 | na.rm = TRUE 133 | ) 134 | 135 | mark_errorbar( 136 | v, 137 | encoding = NULL, 138 | data = NULL, 139 | selection = NULL, 140 | ..., 141 | na.rm = TRUE 142 | ) 143 | 144 | mark_histogram( 145 | v, 146 | encoding = NULL, 147 | data = NULL, 148 | selection = NULL, 149 | position = "stack", 150 | ..., 151 | bin = TRUE, 152 | na.rm = TRUE 153 | ) 154 | 155 | mark_step(v, encoding = NULL, data = NULL, selection = NULL, ..., na.rm = TRUE) 156 | 157 | mark_density( 158 | v, 159 | encoding = NULL, 160 | data = NULL, 161 | selection = NULL, 162 | position = "identity", 163 | ..., 164 | density = list(), 165 | na.rm = TRUE 166 | ) 167 | 168 | mark_bin2d( 169 | v, 170 | encoding = NULL, 171 | data = NULL, 172 | selection = NULL, 173 | ..., 174 | bin = list(x = TRUE, y = TRUE), 175 | na.rm = TRUE 176 | ) 177 | 178 | mark_streamgraph( 179 | v, 180 | encoding = NULL, 181 | data = NULL, 182 | selection = NULL, 183 | ..., 184 | na.rm = TRUE 185 | ) 186 | 187 | mark_smooth( 188 | v, 189 | encoding = NULL, 190 | data = NULL, 191 | selection = NULL, 192 | ..., 193 | method = "lm", 194 | formula = y ~ x, 195 | bandwidth = 0.3, 196 | na.rm = TRUE 197 | ) 198 | 199 | mark_mosaic( 200 | v, 201 | encoding = NULL, 202 | data = NULL, 203 | selection = NULL, 204 | ..., 205 | na.rm = TRUE 206 | ) 207 | 208 | mark_blank( 209 | v, 210 | encoding = NULL, 211 | data = NULL, 212 | selection = NULL, 213 | ..., 214 | na.rm = TRUE 215 | ) 216 | } 217 | \arguments{ 218 | \item{v}{A \code{vega()} object.} 219 | 220 | \item{encoding}{An aesthetic mapping via \code{enc()}.} 221 | 222 | \item{data}{A data frame for the layer.} 223 | 224 | \item{selection}{A selection object.} 225 | 226 | \item{...}{Additional mark properties.} 227 | 228 | \item{na.rm}{If \code{TRUE}, missing values are removed with a message. 229 | If \code{FALSE}, missing values are included.} 230 | 231 | \item{position}{One of "identity", "stack", "fill".} 232 | 233 | \item{bin}{A list of \code{bin} parameters.} 234 | 235 | \item{density}{Density parameters.} 236 | 237 | \item{method}{One of "lm" or "loess".} 238 | 239 | \item{formula}{One of: 240 | \itemize{ 241 | \item y ~ x 242 | \item y ~ x^2 243 | \item y ~ x^\link{order} 244 | \item y ~ log(x) 245 | \item y ~ exp(x) 246 | }} 247 | 248 | \item{bandwidth}{Degree of smoother.} 249 | } 250 | \description{ 251 | Add new marks to \code{vega()} visualisation 252 | } 253 | -------------------------------------------------------------------------------- /man/vega-scales.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/scale.R 3 | \name{scale_x} 4 | \alias{scale_x} 5 | \alias{scale_y} 6 | \alias{scale_color} 7 | \alias{scale_colour} 8 | \alias{scale_size} 9 | \alias{scale_shape} 10 | \title{Vega scales} 11 | \usage{ 12 | scale_x( 13 | v, 14 | name = zap(), 15 | domain = zap(), 16 | type = "linear", 17 | breaks = zap(), 18 | orient = "bottom", 19 | ... 20 | ) 21 | 22 | scale_y( 23 | v, 24 | name = zap(), 25 | domain = zap(), 26 | type = "linear", 27 | breaks = zap(), 28 | orient = "left", 29 | ... 30 | ) 31 | 32 | scale_color(v, name = zap(), range = zap(), scheme = zap(), guide = TRUE, ...) 33 | 34 | scale_colour(v, name = zap(), range = zap(), scheme = zap(), guide = TRUE, ...) 35 | 36 | scale_size(v, name = zap(), range = zap(), type = "linear", guide = TRUE, ...) 37 | 38 | scale_shape(v, name = zap(), guide = TRUE, ...) 39 | } 40 | \arguments{ 41 | \item{v}{A \code{vega()} object.} 42 | 43 | \item{name}{A string for an axis label. \code{zap()} is the default label. 44 | \code{NULL} removes the label.} 45 | 46 | \item{domain}{A vector of two elements to define the range.} 47 | 48 | \item{type}{One of "linear", "log", "sqrt", "temporal", "band", "category" scale types.} 49 | 50 | \item{breaks}{One of: 51 | \itemize{ 52 | \item \code{NULL} for no breaks 53 | \item \code{zap()} for default breaks 54 | \item A vector for custom breaks 55 | }} 56 | 57 | \item{orient}{One of "bottom" and "top" for \code{scale_x()}. One of "left" and "right" 58 | for \code{scale_y()}.} 59 | 60 | \item{...}{Other parameters passed to vega specs.} 61 | 62 | \item{range}{Custom range specification for colour, opacity, and size.} 63 | 64 | \item{scheme}{Colour scheme.} 65 | 66 | \item{guide}{If \code{FALSE}, remove the legend.} 67 | } 68 | \description{ 69 | Vega scales 70 | } 71 | -------------------------------------------------------------------------------- /man/vega-selection.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/selection.R 3 | \name{select_single} 4 | \alias{select_single} 5 | \alias{select_multi} 6 | \alias{select_interval} 7 | \alias{select_legend} 8 | \alias{select_domain} 9 | \alias{select_bind} 10 | \title{Initiate a selection} 11 | \usage{ 12 | select_single( 13 | encodings = NULL, 14 | fields = NULL, 15 | init = NULL, 16 | nearest = FALSE, 17 | on = "click", 18 | clear = "dblclick", 19 | empty = "all", 20 | resolve = "global" 21 | ) 22 | 23 | select_multi( 24 | encodings = NULL, 25 | fields = NULL, 26 | init = NULL, 27 | toggle = TRUE, 28 | nearest = FALSE, 29 | on = "click", 30 | clear = "dblclick", 31 | empty = "all", 32 | resolve = "global" 33 | ) 34 | 35 | select_interval( 36 | encodings = c("x", "y"), 37 | init = NULL, 38 | mark = NULL, 39 | on = "[mousedown, window:mouseup] > window:mousemove!", 40 | clear = "dblclick", 41 | translate = on, 42 | empty = "all", 43 | zoom = TRUE, 44 | resolve = "global" 45 | ) 46 | 47 | select_legend(fields, on = "click", clear = "dblclick") 48 | 49 | select_domain() 50 | 51 | select_bind(...) 52 | } 53 | \arguments{ 54 | \item{encodings}{A character vector of encoding channels, such as "x" and "y".} 55 | 56 | \item{fields}{A character vector of data fields.} 57 | 58 | \item{init}{An initial value upon selection.} 59 | 60 | \item{nearest}{If \code{FALSE}, data values must be interacted with directly to 61 | be added to the selection.} 62 | 63 | \item{on, clear}{An event type that triggers/clears the selection. Options are 64 | "click", "dblclick", "dragenter", "dragleave", "dragover", "keydown", "keypress", 65 | "keyup", "mousedown", "mouseover", "mousemove", "mouseout", "mouseup", 66 | "mousewheel", "touchend", "touchmove", "touchstart", "wheel".} 67 | 68 | \item{empty}{An empty selection includes "all" or "none" data values.} 69 | 70 | \item{resolve}{One of "global", "union", "intersect" options to resolve 71 | ambiguity for layered and multi-view displays.} 72 | 73 | \item{toggle}{A logical to control whether data values should be toggled or 74 | only ever inserted into multi selections.} 75 | 76 | \item{mark}{A named vector of mark properties for brushed rectangle.} 77 | 78 | \item{translate}{A string or logical to interactively move an interval 79 | selection back-and-forth.} 80 | 81 | \item{zoom}{If \code{TRUE}, interactively resize an interval selection.} 82 | 83 | \item{...}{A set of name-value pairs with data variables on the LHS and 84 | \verb{input_*()} on the RHS.} 85 | } 86 | \description{ 87 | Initiate a selection 88 | } 89 | \section{Composing Multiple Selections}{ 90 | 91 | A set of operations ... 92 | } 93 | 94 | -------------------------------------------------------------------------------- /man/vega-seralise.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/vega.R 3 | \name{vega_serialise_data} 4 | \alias{vega_serialise_data} 5 | \alias{vega_serialize_data} 6 | \title{Serialise data} 7 | \usage{ 8 | vega_serialise_data(v, path = NULL) 9 | 10 | vega_serialize_data(v, path = NULL) 11 | } 12 | \arguments{ 13 | \item{v}{A \code{vega()} object.} 14 | 15 | \item{path}{Directory to save inlining data to external data files.} 16 | } 17 | \description{ 18 | Serialise data 19 | } 20 | -------------------------------------------------------------------------------- /man/vega.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/vega.R 3 | \name{vega} 4 | \alias{vega} 5 | \title{Create a new vega visualisation} 6 | \usage{ 7 | vega(data = NULL, encoding = enc(), width = 300, height = 300) 8 | } 9 | \arguments{ 10 | \item{data}{A data frame.} 11 | 12 | \item{encoding}{A list of aethetic encodings via \code{\link[=enc]{enc()}}.} 13 | 14 | \item{width, height}{Data plotting width and height.} 15 | } 16 | \description{ 17 | Create a new vega visualisation 18 | } 19 | -------------------------------------------------------------------------------- /man/vg-aggregate.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/transform.R 3 | \name{vg_sum} 4 | \alias{vg_sum} 5 | \alias{vg_min} 6 | \alias{vg_max} 7 | \alias{vg_mean} 8 | \alias{vg_median} 9 | \alias{vg_count} 10 | \alias{vg_distinct} 11 | \alias{vg_argmin} 12 | \alias{vg_argmax} 13 | \title{Interactive aggregation operations} 14 | \usage{ 15 | vg_sum(x) 16 | 17 | vg_min(x) 18 | 19 | vg_max(x) 20 | 21 | vg_mean(x) 22 | 23 | vg_median(x) 24 | 25 | vg_count(x) 26 | 27 | vg_distinct(x) 28 | 29 | vg_argmin(x, y) 30 | 31 | vg_argmax(x, y) 32 | } 33 | \arguments{ 34 | \item{x}{A data variable, used in conjunction with \code{enc()} or dplyr verbs. 35 | \code{vg_count()} can accept an empty input.} 36 | 37 | \item{y}{A data variable that maxmises/minimises \code{x} in \code{vg_argmin()} and 38 | \code{vg_argmax()}.} 39 | } 40 | \description{ 41 | Interactive aggregation operations 42 | } 43 | -------------------------------------------------------------------------------- /man/vg-timeunit.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/transform.R 3 | \name{vg_year} 4 | \alias{vg_year} 5 | \alias{vg_quarter} 6 | \alias{vg_month} 7 | \alias{vg_yearmonth} 8 | \alias{vg_date} 9 | \alias{vg_week} 10 | \alias{vg_day} 11 | \alias{vg_dayofyear} 12 | \alias{vg_hours} 13 | \alias{vg_minutes} 14 | \alias{vg_seconds} 15 | \alias{vg_milliseconds} 16 | \title{Interactive time unit operations} 17 | \usage{ 18 | vg_year(x, step = 1, utc = FALSE) 19 | 20 | vg_quarter(x, step = 1, utc = FALSE) 21 | 22 | vg_month(x, step = 1, utc = FALSE) 23 | 24 | vg_yearmonth(x, step = 1, utc = FALSE) 25 | 26 | vg_date(x, step = 1, utc = FALSE) 27 | 28 | vg_week(x, step = 1, utc = FALSE) 29 | 30 | vg_day(x, step = 1, utc = FALSE) 31 | 32 | vg_dayofyear(x, step = 1, utc = FALSE) 33 | 34 | vg_hours(x, step = 1, utc = FALSE) 35 | 36 | vg_minutes(x, step = 1, utc = FALSE) 37 | 38 | vg_seconds(x, step = 1, utc = FALSE) 39 | 40 | vg_milliseconds(x, step = 1, utc = FALSE) 41 | } 42 | \arguments{ 43 | \item{x}{A data variable, used in conjunction with \code{enc()} or dplyr verbs. 44 | \code{vg_count()} can accept an empty input.} 45 | 46 | \item{step}{An integer to define the number of time steps.} 47 | 48 | \item{utc}{If \code{TRUE}, parse data in UTC time, otherwise in local time.} 49 | } 50 | \description{ 51 | Interactive time unit operations 52 | } 53 | -------------------------------------------------------------------------------- /man/vg-window.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/transform.R 3 | \name{vg_window_sum} 4 | \alias{vg_window_sum} 5 | \alias{vg_window_mean} 6 | \alias{vg_window_rank} 7 | \alias{vg_window_count} 8 | \alias{vg_cumsum} 9 | \alias{vg_cummean} 10 | \alias{vg_row_number} 11 | \alias{vg_rank} 12 | \alias{vg_dense_rank} 13 | \alias{vg_percent_rank} 14 | \alias{vg_cume_dist} 15 | \alias{vg_ntile} 16 | \alias{vg_lead} 17 | \alias{vg_lag} 18 | \title{Interactive window operations} 19 | \usage{ 20 | vg_window_sum(x, frame = list(NULL, 0), sort = NULL) 21 | 22 | vg_window_mean(x, frame = list(NULL, 0), sort = NULL) 23 | 24 | vg_window_rank(x, frame = list(NULL, 0), sort = NULL) 25 | 26 | vg_window_count(x, frame = list(NULL, 0), sort = NULL) 27 | 28 | vg_cumsum(x, sort = NULL) 29 | 30 | vg_cummean(x, sort = NULL) 31 | 32 | vg_row_number(x, sort = NULL) 33 | 34 | vg_rank(x, sort = NULL) 35 | 36 | vg_dense_rank(x, sort = NULL) 37 | 38 | vg_percent_rank(x, sort = NULL) 39 | 40 | vg_cume_dist(x, sort = NULL) 41 | 42 | vg_ntile(x, n = 1, sort = NULL) 43 | 44 | vg_lead(x, n = 1, sort = NULL) 45 | 46 | vg_lag(x, n = 1, sort = NULL) 47 | } 48 | \arguments{ 49 | \item{x}{A data variable, used in conjunction with \code{dplyr::mutate()}.} 50 | 51 | \item{frame}{A list/vector of two elements to indicate the number of data values 52 | preceding and following the current data object. \code{NULL} gives unbounded elements 53 | proceding or following the current position.} 54 | 55 | \item{sort}{A variable for sorting data within a window in ascending order. 56 | \code{-} before the variable gives descending order. \code{NULL} disables sorting.} 57 | 58 | \item{n}{The number of elements.} 59 | } 60 | \description{ 61 | Interactive window operations 62 | } 63 | -------------------------------------------------------------------------------- /man/vw_set_base_url.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/utils-vegawidget.R 3 | \name{vw_set_base_url} 4 | \alias{vw_set_base_url} 5 | \title{Set base URL} 6 | \description{ 7 | See \code{vegawidget::\link[vegawidget]{vw_set_base_url}} for details. 8 | } 9 | -------------------------------------------------------------------------------- /pkgdown/_pkgdown.yml: -------------------------------------------------------------------------------- 1 | template: 2 | params: 3 | bootswatch: sandstone 4 | 5 | development: 6 | mode: auto 7 | 8 | navbar: 9 | title: "virgo" 10 | left: 11 | - icon: fa-home fa-lg 12 | href: index.html 13 | - text: "Getting Started" 14 | href: articles/virgo.html 15 | - text: "Example Gallery" 16 | href: articles/gallery/index.html 17 | - text: "Reference" 18 | href: reference/index.html 19 | - text: "Articles" 20 | menu: 21 | - text: "A guide to virgo for ggplot2 users" 22 | href: articles/transition.html 23 | - text: "Using selections to make interactive graphics with virgo" 24 | href: articles/selections.html 25 | right: 26 | - icon: fa-github fa-lg 27 | href: https://github.com/vegawidget/vegawidget 28 | 29 | reference: 30 | - title: "virgo basics" 31 | desc: > 32 | To create a virgo graphic pass your data into `vega()`, and supply some 33 | visual encodings `enc()`. You can then add layers with the `%>%`, 34 | and write the results to a file. 35 | contents: 36 | - vega 37 | - enc 38 | - title: "Layers" 39 | desc: > 40 | To add visual layers to a graphic, you need to specify a mark which 41 | depends on your data and visual encoding. 42 | contents: 43 | - starts_with("mark_") 44 | - title: "Scales" 45 | desc: > 46 | To modify how encodings are translated from the data to the visual 47 | appearance of a graphic you need to specify a scale. 48 | contents: 49 | - starts_with("scale_") 50 | - title: "Facets and Concatenation" 51 | desc: > 52 | To generate small multiples and display different subsets of the data, 53 | you need to facet. To layout graphics along side one another you need 54 | to concatenate 55 | contents: 56 | - facet_views 57 | - vconcat 58 | - hconcat 59 | - resolve_views 60 | - title: "Interactivity" 61 | desc: > 62 | Interactivity allows you to manipulate a **virgo** graphic, either through 63 | direct selection using the `select_` functions or by binding data to an 64 | interface like a button or slider with the `input_` functions. These 65 | selections can drive aesthetic transformations of a graphic or the data. See 66 | `vignette("selections.Rmd")` for details 67 | contents: 68 | - encode_if 69 | - starts_with("select_") 70 | - starts_with("input_") 71 | - title: "Data transformations" 72 | desc: > 73 | Data transformations can performed directly on the client with the 74 | `vg_` family of functions. 75 | contents: 76 | - starts_with("vg_") 77 | - title: "Customisation" 78 | desc: > 79 | The appearance of a **virgo** graphic can be configured to modify 80 | all the non-data elements of a chart. 81 | contents: 82 | - config 83 | - title: "Data" 84 | desc: > 85 | **virgo** comes built in with the following data sets 86 | contents: 87 | - melbweather 88 | - title: "Utilities" 89 | desc: > 90 | To assist with using **virgo** in R Markdown or packages. 91 | contents: 92 | - vega_serialise_data 93 | - starts_with("vw") 94 | -------------------------------------------------------------------------------- /pkgdown/extra.css: -------------------------------------------------------------------------------- 1 | .gallery { 2 | display: flex; 3 | flex-wrap: wrap; 4 | margin: 0 -12px; 5 | margin-top: 0; 6 | margin-right: -12px; 7 | margin-bottom: 0; 8 | margin-left: -12px; 9 | } 10 | 11 | .gallery .virgo-group { 12 | display: inline-block; 13 | position: relative; 14 | margin: 12px 18px; 15 | margin-top: 12px; 16 | margin-right: 18px; 17 | margin-bottom: 12px; 18 | margin-left: 18px; 19 | } 20 | 21 | .gallery .virgo-group { 22 | display: inline-block; 23 | position: relative; 24 | width: calc(25% - 36px); 25 | margin: 12px 18px; 26 | margin-top: 12px; 27 | margin-right: 18px; 28 | margin-bottom: 12px; 29 | margin-left: 18px; 30 | } 31 | 32 | .gallery .display { 33 | display: block; 34 | width: 100%; 35 | padding-bottom: 75%; 36 | background-repeat: no-repeat; 37 | margin-bottom: 5px; 38 | overflow: hidden; 39 | transition: background-position 2s; 40 | } 41 | 42 | .gallery .display-title { 43 | font-size: 0.95em; 44 | } 45 | 46 | 47 | 48 | 49 | 50 | -------------------------------------------------------------------------------- /vignettes/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | *.R 3 | -------------------------------------------------------------------------------- /vignettes/gallery/gapminder-animate.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Interactive scatter plot of gapminder data" 3 | --- 4 | 5 | ```{r, include = FALSE} 6 | knitr::opts_chunk$set( 7 | collapse = TRUE, 8 | comment = "#>" 9 | ) 10 | ``` 11 | 12 | This example is an adaptation of the 13 | [interactive global development scatter plot](https://vega.github.io/vega-lite/examples/interactive_global_development.html) 14 | from the Vega-Lite documentation. We create two selection objects: the first is 15 | a slider that is bound to the years in the gapminder data, 16 | and another that corresponds to hovering over nearest points. 17 | 18 | 19 | ```{r} 20 | library(virgo) 21 | library(gapminder) 22 | 23 | slide_year <- select_bind( 24 | year = input_slider("Year", 25 | min = min(gapminder$year), 26 | max = max(gapminder$year), 27 | step = 5, 28 | init = 1982) 29 | ) 30 | 31 | nearest_country <- select_single( 32 | fields = "country", 33 | on = "mouseover", 34 | empty = "none" 35 | ) 36 | ``` 37 | 38 | Next we initialise our graphic by creating a scatter plot for GDP against 39 | life expectancy, where the view is filtered by the current year selected 40 | in the slider. We then add lines, circles, and text marks that reveal the 41 | trajectory of a countries GDP per capita and life expectancy over 42 | time when you hover a point. Finally, we place the x-axis on a log scale. 43 | 44 | ```{r} 45 | gapminder %>% 46 | vega(enc(x = gdpPercap, y = lifeExp), width = 400, height = 400) %>% 47 | mark_point( 48 | enc(color = continent, group = country), 49 | selection = slide_year 50 | ) %>% 51 | mark_line( 52 | enc( 53 | group = country, 54 | order = year, 55 | opacity = encode_if(nearest_country, 0.8, 0) 56 | ), 57 | color = "#9e9ac8", 58 | size = 4, 59 | stroke_cap = "round" 60 | ) %>% 61 | mark_circle(selection = nearest_country) %>% 62 | mark_text( 63 | enc(text = year), 64 | selection = nearest_country, 65 | color = "black", 66 | dx = 12, 67 | dy = 8 68 | ) %>% 69 | scale_x(type = "log") 70 | ``` 71 | -------------------------------------------------------------------------------- /vignettes/gallery/gapminder-animate.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vegawidget/virgo/0c594d47eecc7fde7928f6abafc2ef8ea8fa4ca3/vignettes/gallery/gapminder-animate.png -------------------------------------------------------------------------------- /vignettes/gallery/gapminder-model-drilldown.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Model checking with filtering selections" 3 | --- 4 | 5 | ```{r, include = FALSE} 6 | knitr::opts_chunk$set( 7 | collapse = TRUE, 8 | comment = "#>" 9 | ) 10 | ``` 11 | 12 | ```{r setup} 13 | library(virgo) 14 | library(dplyr) 15 | library(tidyr) 16 | library(gapminder) 17 | ``` 18 | 19 | This example is inspired by the [Many Models](https://r4ds.had.co.nz/many-models.html#gapminder) example in R for Data Science by Grolemund and Wickham. 20 | 21 | To begin we create a drop down menu with each continent 22 | using `input_select()` and then we create a line plot for each country's life expectancy over time. Here the selection modifies 23 | the opacity of each line, so we can compare countries within a continent to each other: 24 | ```{r} 25 | selection <- select_bind( 26 | continent = input_select( 27 | name = "Select Continent:", 28 | choices = c(NA, levels(gapminder$continent))) 29 | ) 30 | 31 | lex <- gapminder %>% 32 | vega(enc(x = year, y = lifeExp, group = country)) %>% 33 | mark_line( 34 | enc(opacity = encode_if(selection, 0.5, 0.1)) 35 | ) 36 | lex 37 | ``` 38 | 39 | We see that for most countries life expectancy is generally increasing, however several countries from Africa and Asia have dips in their life expectancies. 40 | 41 | Next for each country we can estimate a simple linear model to summarise the relationship of how life expectancy has changed over time. We will use $R^2$ to assess the quality of the fit 42 | and link that back to our raw data 43 | 44 | ```{r} 45 | # we could do this with broom but this seems 46 | # ok for now 47 | gapminder_augmented <- gapminder %>% 48 | group_nest(continent, country) %>% 49 | mutate( 50 | model = lapply(data, function(x) lm(lifeExp ~ year, data = x)), 51 | r2 = vapply(model, function(x) summary(x)$r.squared, numeric(1)), 52 | ) %>% 53 | unnest(data) %>% 54 | select(-model) 55 | 56 | gapminder_augmented 57 | ``` 58 | 59 | Now we can create a plot driven selection, that will display the 60 | $R^2$ values within each continent: 61 | 62 | ```{r} 63 | select_r2 <- select_interval("y") 64 | 65 | tick_plot <- gapminder_augmented %>% 66 | vega(enc(x = continent, y = r2)) %>% 67 | mark_tick( 68 | enc(opacity = encode_if(select_r2, 1, 0.1)) 69 | ) 70 | tick_plot 71 | ``` 72 | 73 | 74 | New we can overlay the real data alongside the model $R^2$ values to 75 | identify which countries have poor fits. First, we modify the color scale 76 | to match the provided `gapminder::country_colors` and then produce a line plot. 77 | 78 | ```{r} 79 | palette <- country_colors[sort(names(country_colors))] 80 | 81 | country_fits <- gapminder_augmented %>% 82 | vega(enc(x = year, y = lifeExp, color = country)) %>% 83 | mark_line(selection = select_r2) %>% 84 | scale_color(range = palette ,guide = FALSE) 85 | 86 | country_fits 87 | ``` 88 | 89 | Next we combine them together to see which countries have poor fits. 90 | 91 | ```{r} 92 | hconcat(tick_plot, country_fits) 93 | ``` 94 | The countries with $R^2$ below 0.2 have strong non-linear trends in life expectancies 95 | hovering over the lines identifies them to be countries affected by genocide 96 | (Rwanda) or the HIV/AIDS epidemic (Botswana, Lesotho, Swaziland, Zambia, Zimbabwe). 97 | 98 | -------------------------------------------------------------------------------- /vignettes/gallery/gapminder-model-drilldown.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vegawidget/virgo/0c594d47eecc7fde7928f6abafc2ef8ea8fa4ca3/vignettes/gallery/gapminder-model-drilldown.png -------------------------------------------------------------------------------- /vignettes/gallery/index.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Example Gallery" 3 | output: 4 | rmarkdown::html_document: 5 | css: extra.css 6 | --- 7 | 8 | This page shows worked examples of using **virgo** to produce graphics 9 | for data analysis. 10 | 11 | 12 | ```{r setup, echo = FALSE} 13 | library(htmltools) 14 | span_display <- function(img_path) { 15 | span(class = "display", 16 | style = paste0("background-image:url(", img_path, ");", 17 | "background-size: auto 105%;", 18 | "background-position: center center !important;") 19 | ) 20 | } 21 | 22 | add_example <- function(href, img_path, title) { 23 | a(class = "virgo-group", href = href, 24 | span_display(img_path), 25 | span(class = "display-title", title) 26 | ) 27 | } 28 | 29 | span(class = "gallery", 30 | add_example("linked-highlighting.html", 31 | "linked-highlighting.png", 32 | "Linked Highlighting"), 33 | add_example("gapminder-model-drilldown.html", 34 | "gapminder-model-drilldown.png", 35 | "Model checking with filtering selections"), 36 | add_example("gapminder-animate.html", 37 | "gapminder-animate.png", 38 | "Connected scatterplot with slider"), 39 | add_example("minimap.html", 40 | "minimap.png", 41 | "Minimap bar charts") 42 | ) 43 | ``` 44 | -------------------------------------------------------------------------------- /vignettes/gallery/linked-highlighting.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Linked Highlighting" 3 | --- 4 | 5 | ```{r, include = FALSE} 6 | knitr::opts_chunk$set( 7 | collapse = TRUE, 8 | comment = "#>" 9 | ) 10 | ``` 11 | 12 | ```{r setup} 13 | library(virgo) 14 | library(palmerpenguins) 15 | ``` 16 | 17 | ```{r brushed-scatter} 18 | selection <- select_interval() 19 | 20 | p <- penguins %>% 21 | vega() %>% 22 | mark_circle( 23 | enc( 24 | x = bill_length_mm, 25 | y = bill_depth_mm, 26 | color = encode_if(selection, species, "black") 27 | ) 28 | ) 29 | p 30 | ``` 31 | 32 | ```{r right-scatter} 33 | p_right <- penguins %>% 34 | vega(enc(x = body_mass_g)) %>% 35 | mark_histogram(bin = list(maxbins = 20)) %>% 36 | mark_histogram(color = "purple", bin = list(maxbins = 20), 37 | selection = selection) %>% 38 | mark_rule(enc(x = vg_mean(body_mass_g)), color = "red", size = 4, 39 | selection = selection) 40 | p_right 41 | ``` 42 | 43 | ```{r linked-brushed-scatter} 44 | hconcat(p, p_right) 45 | ``` 46 | 47 | -------------------------------------------------------------------------------- /vignettes/gallery/linked-highlighting.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vegawidget/virgo/0c594d47eecc7fde7928f6abafc2ef8ea8fa4ca3/vignettes/gallery/linked-highlighting.png -------------------------------------------------------------------------------- /vignettes/gallery/minimap.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Bar Chart with a Minimap" 3 | --- 4 | 5 | ```{r, include = FALSE} 6 | knitr::opts_chunk$set( 7 | collapse = TRUE, 8 | comment = "#>" 9 | ) 10 | ``` 11 | 12 | This example has been adapted from [Vega-Lite](https://vega.github.io/vega-lite/examples/bar_count_minimap.html). 13 | 14 | Brush on the right-hand side to zoom in on the bar chart on the left. 15 | 16 | ```{r brushed-bar} 17 | library(dplyr) 18 | library(jsonlite) 19 | library(virgo) 20 | 21 | selection <- select_interval(encodings = "y") 22 | 23 | cars <- fromJSON("https://vega.github.io/vega-editor/app/data/cars.json") %>% 24 | count(Name) %>% 25 | mutate(Name = reorder(Name, -n)) 26 | 27 | minimap <- cars %>% 28 | vega(width = 50, height = 200) %>% 29 | mark_bar( 30 | enc( 31 | x = n, 32 | y = Name, 33 | ), 34 | selection = I(selection), 35 | ) %>% 36 | scale_y(name = NULL, breaks = NULL) %>% 37 | scale_x(name = NULL, breaks = NULL) 38 | 39 | bar <- cars %>% 40 | vega(height = 800) %>% 41 | mark_bar( 42 | enc( 43 | x = n, 44 | y = Name, 45 | ), 46 | selection = selection, 47 | ) %>% 48 | scale_x(name = "Count", domain = c(0,6), orient = "top") %>% 49 | scale_y(name = NULL) 50 | 51 | hconcat(bar, minimap) 52 | ``` 53 | -------------------------------------------------------------------------------- /vignettes/gallery/minimap.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vegawidget/virgo/0c594d47eecc7fde7928f6abafc2ef8ea8fa4ca3/vignettes/gallery/minimap.png -------------------------------------------------------------------------------- /vignettes/selections.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Composing interactive graphics via selections" 3 | output: rmarkdown::html_vignette 4 | vignette: > 5 | %\VignetteIndexEntry{Composing interactive graphics via selections} 6 | %\VignetteEngine{knitr::rmarkdown} 7 | %\VignetteEncoding{UTF-8} 8 | --- 9 | 10 | ```{r, include = FALSE} 11 | knitr::opts_chunk$set( 12 | collapse = TRUE, 13 | comment = "#>" 14 | ) 15 | ``` 16 | 17 | ```{r setup} 18 | library(virgo) 19 | ``` 20 | -------------------------------------------------------------------------------- /vignettes/transition.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "virgo guide for ggplot2 users" 3 | output: rmarkdown::html_vignette 4 | vignette: > 5 | %\VignetteIndexEntry{virgo guide for ggplot2 users} 6 | %\VignetteEngine{knitr::rmarkdown} 7 | %\VignetteEncoding{UTF-8} 8 | --- 9 | 10 | ```{r, include = FALSE} 11 | knitr::opts_chunk$set( 12 | collapse = TRUE, 13 | comment = "#>" 14 | ) 15 | ``` 16 | 17 | If you're familiar with **ggplot2** this vignette provides a quick guide to getting up to speed with **virgo**. The following table provides 18 | a mapping between **ggplot2** concepts and **virgo** functions. 19 | 20 | | Concept | **ggplot2** function | **virgo** function | 21 | |-----------------------------|------------------------------------------------------|------------------------------------------------------| 22 | | Initialisation | `ggplot()` | `vega()` | 23 | | Aesthetic mappings | `aes()` | `enc()` | 24 | | Layers | `geom_*` | `mark_*` | 25 | | Adding layers | `+` | `%>%` | 26 | | Facets (grid layouts) | `facet_grid()` | `facet_views()` | 27 | | Scales | `scale_{aesthetic}_type()` | `scale_{encoding}(type = type)` | 28 | | Statistical transformations | `stat_()` | Performed client side with `vg` family of functions. | 29 | | Coordinates | `coord_*` | Not directly supported | 30 | | View concatenation | See **patchwork** package | `hconcat()`, `vconcat()` | 31 | | Interactivity | Not directly supported, but see `plotly::ggplotly()` | `select_*()` | 32 | 33 | As you can see most of the grammar elements in **ggplot2** have equivalents 34 | in **virgo**. 35 | 36 | # Caveats 37 | 38 | Compared to **ggplot2**, **virgo** has fewer available layers (one that 39 | we wish was available is hex binning) and less support for spatial visualisations. 40 | 41 | Unlike **ggplot2**, the sizing of a **virgo** visualisation has to 42 | be declared in `vega()`. Here the width and height determine the 43 | pixel dimensions on the canvas/Rstudio Viewer. By default, we set these to 300. 44 | When faceting plots, **virgo** the height/width refers to dimensions of the 45 | entire view not each subplot. 46 | 47 | To save a static visualisation with **virgo**, use the **vegawidget** functions 48 | `vw_write_png()` or `vw_write_svg()`. 49 | -------------------------------------------------------------------------------- /vignettes/virgo.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Introducing virgo for interactive exploratory graphics" 3 | author: "Stuart Lee and Earo Wang" 4 | output: rmarkdown::html_vignette 5 | vignette: > 6 | %\VignetteIndexEntry{Introducing virgo for interactive exploratory graphics} 7 | %\VignetteEngine{knitr::rmarkdown} 8 | %\VignetteEncoding{UTF-8} 9 | --- 10 | 11 | ```{r, include = FALSE} 12 | knitr::opts_chunk$set( 13 | collapse = TRUE, 14 | comment = "#>", 15 | eval = FALSE 16 | ) 17 | ``` 18 | 19 | # About virgo 20 | 21 | The **virgo** package extends the grammar of interactive graphics based on the **Vega-Lite** library in Javascript, using the design principles of the **tidyverse** suite of packages. It is built on top of the **vegawidget** package, which handles the actual drawing of a **virgo** graphic. 22 | 23 | ## Melbourne's microclimate 24 | 25 | Throughout this vignette we will be exploring three months of microclimate sensor data collected from December 2019 until February 2020 from Melbourne City Council. This data is built into to **virgo** and consists of measurements for things like temperature and relative humidity at 5 different locations across the city. 26 | ```{r setup, echo = TRUE} 27 | library(virgo) 28 | library(lubridate) 29 | library(dplyr) 30 | melbweather 31 | ``` 32 | 33 | ## Data, Encodings and Marks 34 | 35 | To construct a visualisation, we begin with tidy data and map columns to visual elements using encodings: 36 | 37 | ```{r} 38 | melbweather %>% 39 | filter(date == "2019-12-01") %>% 40 | vega(encoding = enc(x = ambient_temperature)) 41 | ``` 42 | 43 | The data is piped into the `vega()` function and aesthetic mappings are 44 | specified with the `enc()`. Valid encodings depend on the **mark** or graphical element being used. As there are no marks for this **virgo** chart, blank canvas is printed. The `vega()` function is required to be called in order to produce a valid visualisation, however as well we see later both data and marks can be specified elsewhere. 45 | 46 | To produce interesting charts, we can add **marks** which are visual layers that are added to the chart. 47 | 48 | Let's go back to our data: 49 | 50 | ```{r} 51 | melbweather 52 | ``` 53 | 54 | To begin, we will collapse our quarter hourly 55 | measurements for each site to hourly averages using **dplyr**: 56 | 57 | ```{r, message = FALSE} 58 | hourly_weather <- melbweather %>% 59 | group_by(site, date, hour_of_day = hour(date_time) ) %>% 60 | summarise( 61 | across( 62 | c(ambient_temperature:pm10), 63 | mean, 64 | na.rm = TRUE 65 | ) 66 | ) %>% 67 | ungroup() 68 | 69 | hourly_weather 70 | ``` 71 | Suppose we are interested in the relationship between ambient temperature and relative humidity. It is theorised that as ambient temperature increases, relative humidity decreases. 72 | 73 | We can check whether this is the case with our data by creating a scatter plot. 74 | 75 | ```{r} 76 | hourly_weather %>% 77 | vega() %>% 78 | mark_point(enc(x = ambient_temperature, y = relative_humidity)) 79 | ``` 80 | 81 | For users, of **ggplot2** the above incantation should look somewhat familiar. We specify our data at the top level using `vega()` and then add layers using the pipe `%>% ` in combination with marks. Inside the `mark_point()` function we specify the aesthetic mapping or **encoding** that says the x axis should correspond to ambient temperature and the y axis should correspond to relative humidity. 82 | 83 | The **virgo** library will automatically add legends depending on the type of encoding and input variable. If we color by a continuous variable a scale is automatically determined and placed on the right hand side of the plot. 84 | 85 | ```{r} 86 | hourly_weather %>% 87 | vega() %>% 88 | mark_point( 89 | enc( 90 | x = ambient_temperature, 91 | y = relative_humidity, 92 | color = wind_speed 93 | ) 94 | ) 95 | ``` 96 | 97 | Likewise, we can evaluate expressions inside of the encoding function, for example, evaluating the month of the date column 98 | with **lubridate**: 99 | 100 | ```{r} 101 | hourly_weather %>% 102 | vega() %>% 103 | mark_point( 104 | enc( 105 | x = ambient_temperature, 106 | y = relative_humidity, 107 | color = month(date, label = TRUE) 108 | ) 109 | ) 110 | ``` 111 | 112 | 113 | It appears that there is a slight non-linear and negative relationship between ambient temperature and relative humidity, however, there is a lot over-plotting in the first example, so perhaps it would be best to add some opacity to the previous scatter plot. Graphical elements that don't depend on columns of the data can be added via extra arguments to the mark function: 114 | 115 | 116 | ```{r} 117 | hourly_weather %>% 118 | vega() %>% 119 | mark_point( 120 | enc(x = ambient_temperature, y = relative_humidity), 121 | opacity = 0.1 122 | ) 123 | ``` 124 | 125 | Multiple marks can be added to a visualisation by piping a sequence of marks together. We can take our previous scatter plot and draw a loess regression line on top. 126 | 127 | ```{r} 128 | p <- hourly_weather %>% 129 | vega(enc(x = ambient_temperature, y = relative_humidity)) %>% 130 | mark_point(opacity = 0.1) %>% 131 | mark_smooth(method = "loess", color = "blue") 132 | p 133 | ``` 134 | 135 | Here we've specified the encoding at the top level with the `vega()` function, so they are available to all downstream layers. We can have layer specific encodings, by passing the `enc()` to any mark in the sequence. In addition to a single regression line, we could generate separate lines for each measurement within each month of the year: 136 | 137 | ```{r} 138 | p %>% 139 | mark_smooth( 140 | enc(color = month(date, label = TRUE)), 141 | method = "loess" 142 | ) 143 | ``` 144 | 145 | ## Facets 146 | 147 | Sometimes we want to visualise multiple categorical variables at the same time, by creating small multiples (facets) views. Say we were interested in the distribution of wind speed, we could 148 | create a histogram: 149 | 150 | ```{r} 151 | ws <- hourly_weather %>% 152 | vega() %>% 153 | mark_histogram(enc(x = wind_speed), bin = list(step = 1)) 154 | ws 155 | ``` 156 | 157 | How similar are the wind speeds across each measurement site? We can facet by site to find out: 158 | 159 | ```{r} 160 | ws %>% 161 | facet_views(row = site) 162 | ``` 163 | 164 | Faceting requires specifying a row and/or column encoding, that determines how the subplots are drawn on the canvas. 165 | There appears to be a suspiciously large number of records in site "arc1045" that have recorded an average wind speed between 4-5km. 166 | 167 | 168 | ## Multiple Views 169 | 170 | Often it is helpful to place views side by side that shows all 171 | of the data rather than subplots like those produced by faceting. 172 | 173 | **virgo** provides functions to align plots horizontally or vertically with the `hconcat()` or `vconcat()` functions. 174 | 175 | ```{r} 176 | left <- hourly_weather %>% 177 | vega() %>% 178 | mark_point(enc(x = ambient_temperature, y = relative_humidity), 179 | opacity = 0.1) 180 | right <- hourly_weather %>% 181 | vega() %>% 182 | mark_point(enc(x = wind_speed, y = ambient_temperature), 183 | opacity = 0.1) 184 | hconcat(left, right) 185 | ``` 186 | 187 | 188 | ## Client side data transformations 189 | 190 | The **virgo** package exports special functions that are computed directly by **Vega-Lite** rather than R. These functions are prefixed with `vg`, and are always be called inside of `enc()`. 191 | 192 | 193 | By using the `vg` functions, we can get **Vega-Lite** to perform 194 | data transformations or aggregations without the use of **tidyverse**. Suppose we were interested in finding out the hour of the day, where the 195 | average temperature across all sites reaches its max: 196 | 197 | ```{r} 198 | hourly_temp <- melbweather %>% 199 | vega( 200 | enc( 201 | x = vg_hours(date_time), 202 | y = vg_mean(ambient_temperature) 203 | ) 204 | ) %>% 205 | mark_point() %>% 206 | mark_line() 207 | hourly_temp 208 | ``` 209 | 210 | In the above code, the `vg_hours()` function extract the hour from the date time variable and groups the data within each our block. The y-axis is then average ambient temperature within each hour pooled across all days and sites. We could get a more granular view by using an alternative mark like a boxplot to view the distribution over each hour instead of just the average: 211 | 212 | ```{r} 213 | hourly_dist_temp <- melbweather %>% 214 | vega( 215 | enc( 216 | x = vg_hours(date_time), 217 | y = ambient_temperature 218 | ), 219 | width = 600 220 | ) %>% 221 | mark_boxplot() 222 | hourly_dist_temp 223 | ``` 224 | 225 | Generally, we believe it is best to perform data transformations outside of the visualisation environment as the transformations are explicit (i.e. when using the **tidyverse**). However, as we will see later these client side transformations become especially useful when combined with interactivity. 226 | 227 | ## Interactivity via selections 228 | 229 | Selections are how a **virgo** graphic defines interactions, and are strongly influenced by the **Vega-Lite** javascript API. There are several types of selection, but to begin we will create an interval selection: 230 | 231 | ```{r} 232 | selection <- select_interval() 233 | ``` 234 | 235 | By default, an interval selection will specify a rectangular region, that is generated by dragging the mouse over the view. Each mark can accept a selection object, which will filter the data when the region is active: 236 | 237 | ```{r} 238 | p <- hourly_weather %>% 239 | vega(enc(x = ambient_temperature, y = relative_humidity)) %>% 240 | mark_point(opacity = 0.1, selection = selection) 241 | p 242 | ``` 243 | 244 | If you just want to draw the selection without performing the filter, you can specify it as an identity selection 245 | 246 | ```{r} 247 | p <- hourly_weather %>% 248 | vega(enc(x = ambient_temperature, y = relative_humidity)) %>% 249 | mark_point(opacity = 0.1, selection = I(selection)) 250 | p 251 | ``` 252 | 253 | Rather than filtering the data, you may want to conditionally encode a visual element based on whether data falls into a selection. The `encode_if()` function allows an encoding to depend on one (or more) selections. We could rewrite the above plot so the points that fall inside of the selection are given an opacity of 0.5, while those outside are given an opacity of 0.1. 254 | 255 | ```{r} 256 | p <- hourly_weather %>% 257 | vega(enc(x = ambient_temperature, y = relative_humidity)) %>% 258 | mark_point( 259 | enc(opacity = encode_if(selection, 0.5, 0.1)) 260 | ) 261 | p 262 | ``` 263 | 264 | Instead of using values, the conditional encoding can depend on a variable instead: 265 | 266 | ```{r} 267 | p <- hourly_weather %>% 268 | vega(enc(x = ambient_temperature, y = relative_humidity)) %>% 269 | mark_point( 270 | enc( 271 | color = encode_if(selection, wind_speed > 10, "grey"), 272 | opacity = encode_if(selection, 0.5, 0.01) 273 | ) 274 | ) 275 | p 276 | ``` 277 | 278 | Interval selections can be restricted to a single axis, so a brush only moves in one direction. The following produces a line plot of the maximum daily temperature, with a brush over the x-axis 279 | 280 | ```{r} 281 | x_selection <- select_interval(encodings = "x") 282 | 283 | overview <- melbweather %>% 284 | vega( 285 | enc( 286 | x = date, 287 | y = vg_max(ambient_temperature) 288 | ), 289 | width = 600 290 | ) %>% 291 | mark_line() %>% 292 | mark_point( 293 | selection = I(x_selection) 294 | ) 295 | overview 296 | ``` 297 | 298 | Interval selections can also be bound to a scale and then composed with another 299 | view to produce a zooming effect. 300 | After concatenating the two views, dragging the x-axis on the bottom graphic will zoom in on the top view: 301 | 302 | ```{r} 303 | context <- melbweather %>% 304 | vega( 305 | enc( 306 | x = date, 307 | y = vg_max(ambient_temperature) 308 | ), 309 | width = 600, 310 | height = 200 311 | ) %>% 312 | mark_line() %>% 313 | mark_point() %>% 314 | scale_x(name = NULL, domain = x_selection) 315 | 316 | vconcat(context, overview) 317 | ``` 318 | 319 | Selections can also be used to filter data in multi-view plots. For example we could view the trail of temperature measurements that each site recorded over the highlighted period in the overview plot. 320 | ```{r} 321 | active_sensor <- melbweather %>% 322 | vega(enc(x = ambient_temperature, y = site), height = 200) %>% 323 | mark_tick(selection = x_selection) 324 | vconcat(overview, active_sensor) 325 | ``` 326 | 327 | This is just the beginning of what is possible to achieve with selections, for more detail see the selections vignette. 328 | 329 | ## Sizing and saving 330 | 331 | The sizing of a plot is controlled inside the `vega()` function with the height and width arguments. These arguments refer to the pixel dimensions of the view. 332 | 333 | **virgo** graphics can be saved with the **vegawidget** package using the `vg_write_png()` or `vg_write_svg()` functions. 334 | -------------------------------------------------------------------------------- /virgo.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: No 4 | SaveWorkspace: No 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: knitr 13 | LaTeX: pdfLaTeX 14 | 15 | AutoAppendNewline: Yes 16 | StripTrailingWhitespace: Yes 17 | LineEndingConversion: Posix 18 | 19 | BuildType: Package 20 | PackageUseDevtools: Yes 21 | PackageInstallArgs: --no-multiarch --with-keep.source 22 | PackageRoxygenize: rd,collate,namespace 23 | --------------------------------------------------------------------------------