├── .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 | [](https://codecov.io/gh/vegawidget/virgo?branch=master)
21 | [](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 | 
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 | 
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 | 
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 | [](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 | [](https://codecov.io/gh/vegawidget/virgo?branch=master)
10 | [](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 | 
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 | 
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 | 
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 | [](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 |
--------------------------------------------------------------------------------