diff --git a/.Rbuildignore b/.Rbuildignore index faca41cf..1a0c31e5 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1,3 +1,4 @@ +readme_website.md .github ^.*\.Rproj$ ^\.Rproj\.user$ diff --git a/.github/workflows/tests.yaml b/.github/workflows/tests.yaml index 639d670c..660dfbd9 100644 --- a/.github/workflows/tests.yaml +++ b/.github/workflows/tests.yaml @@ -13,13 +13,6 @@ jobs: fail-fast: false matrix: test-suite: [ renderer1,renderer2,renderer3,renderer4,renderer5,compiler,CRAN] - - # services: - # selenium: - # image: selenium/standalone-firefox-debug:2.53.0 - # ports: - # - 5900:5900 - # - 4444:4444 name: Test Suite ${{ matrix.test-suite }} env: @@ -41,6 +34,12 @@ jobs: - name: install package run: R CMD INSTALL . + + - name: git config user.name + run: git config --global user.name "GitHub Actions" + + - name: git config user.email + run: git config --global user.email toby.hocking@r-project.org - name: run tests run: if [ "$TEST_SUITE" == "CRAN" ];then bash build.sh;else Rscript -e "source('tests/testthat.R', chdir = TRUE)";fi diff --git a/DESCRIPTION b/DESCRIPTION index caa58e79..1e2d6512 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: animint2 Title: Animated Interactive Grammar of Graphics -Version: 2023.6.11 +Version: 2023.11.15 URL: https://animint.github.io/animint2/ BugReports: https://github.com/animint/animint2/issues Authors@R: c( @@ -76,6 +76,7 @@ Imports: methods Suggests: servr, + gert, gitcreds, gh, sp, gistr (>= 0.2), shiny, @@ -269,12 +270,13 @@ Collate: 'z_animintHelpers.R' 'z_facets.R' 'z_geoms.R' - 'z_gist.R' 'z_helperFunctions.R' 'z_knitr.R' + 'z_pages.R' 'z_print.R' 'z_scales.R' 'z_theme_animint.R' 'z_transformShape.R' RoxygenNote: 7.2.3 Config/Needs/website: tidyverse/tidytemplate +VignetteBuilder: knitr diff --git a/NAMESPACE b/NAMESPACE index 1e99920b..7e73786a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -214,7 +214,7 @@ export(aes_string) export(alpha) export(animint) export(animint2dir) -export(animint2gist) +export(animint2pages) export(animintOutput) export(annotate) export(annotation_custom) @@ -489,6 +489,7 @@ export(theme_void) export(toRGB) export(transform_position) export(unit) +export(update_gallery) export(update_geom_defaults) export(update_labels) export(update_stat_defaults) diff --git a/NEWS.md b/NEWS.md index 4a9de4c2..67b929df 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,24 @@ +# Changes in 2023.11.15 + +- New function `animint2pages(viz,"new_github_repo")` for + publishing/sharing animints, replacement for animint2gist, which + stopped working recently. +- New option `animint(source="http://path.to/source.R")` which should + be the URL of data viz source code, used to display a link below the + rendered viz. +- New function `update_gallery("path/to/gallery_repo")` for updating + galleries such as https://animint.github.io/gallery/ +- Bugfix: geom_text renders color as svg fill style (was rendering as + stroke style, a regression introduced by the initial implementation + of `fill_off`). +- re-organization of animint.js in order to reduce duplication / + emphasize similarities and differences between geoms. +- geom rect and tile now default to color="black" instead of + transparent, for consistency with other geoms (and for the case of + using clickSelects, which defaults to black color for selected, and + transparent for not). To get the old behavior, specify + color="transparent" (for non-clickSelects). + # Changes in 2023.10.6 - User-configurable selection style - fill_off. diff --git a/R/data.R b/R/data.R index e45a1b64..2f442f0d 100644 --- a/R/data.R +++ b/R/data.R @@ -164,7 +164,7 @@ #' All built-in \code{\link{colors}()} translated into Luv colour space. #' #' @format A data frame with 657 observations and 4 variables: -#' \itemize{ +#' \describe{ #' \item{L,u,v}{Position in Luv colour space} #' \item{col}{Colour name} #' } @@ -176,7 +176,7 @@ #' real estate center, \url{https://www.recenter.tamu.edu/}. #' #' @format A data frame with 8602 observations and 9 variables: -#' \itemize{ +#' \describe{ #' \item{city}{Name of MLS area} #' \item{year,month,date}{Date} #' \item{sales}{Number of sales} diff --git a/R/geom-.r b/R/geom-.r index 68aa8a04..f7d75dd4 100644 --- a/R/geom-.r +++ b/R/geom-.r @@ -305,7 +305,6 @@ Geom <- gganimintproto("Geom", processed_values <- l$geom$pre_process(g, g.data, ranges) g <- processed_values$g g.data <- processed_values$g.data - ## Check g.data for color/fill - convert to hexadecimal so JS can parse correctly. for(color.var in c("colour", "color", "fill", "colour_off", "color_off", "fill_off")){ if(color.var %in% names(g.data)){ diff --git a/R/geom-histogram.r b/R/geom-histogram.r index a6eeaf20..ff207768 100644 --- a/R/geom-histogram.r +++ b/R/geom-histogram.r @@ -65,10 +65,6 @@ #' # Use origin = 0, to make sure we don't take sqrt of negative values #' m + geom_histogram(origin = 0) + coord_trans(x = "sqrt") #' -#' # You can also transform the y axis. Remember that the base of the bars -#' # has value 0, so log transformations are not appropriate -#' m <- ggplot(movies, aes(x = rating)) -#' m + geom_histogram(binwidth = 0.5) + scale_y_sqrt() #' } #' rm(movies) geom_histogram <- function(mapping = NULL, data = NULL, diff --git a/R/geom-tile.r b/R/geom-tile.r index 3d39ddbb..c50b7f91 100644 --- a/R/geom-tile.r +++ b/R/geom-tile.r @@ -95,7 +95,7 @@ GeomTile <- gganimintproto("GeomTile", GeomRect, ) }, - default_aes = aes(fill = "grey20", colour = NA, size = 0.1, linetype = 1, + default_aes = aes(fill = "grey20", colour = "black", size = 0.1, linetype = 1, alpha = NA), required_aes = c("x", "y"), @@ -104,9 +104,6 @@ GeomTile <- gganimintproto("GeomTile", GeomRect, pre_process = function(g, g.data, ...) { g$geom <- "rect" - if(is.null(g$params$colour)){ - g$params$colour <- "transparent" - } return(list(g = g, g.data = g.data)) } ) diff --git a/R/plot-build.r b/R/plot-build.r index 59828432..a3b617dd 100644 --- a/R/plot-build.r +++ b/R/plot-build.r @@ -132,7 +132,6 @@ layer_grob <- function(plot, i = 1L) { #' a ggplot2 plot. #' @return a \code{\link{gtable}} object #' @keywords internal -#' @param plot plot object #' @param data plot data generated by \code{\link{ggplot_build}} #' @export ggplot_gtable <- function(data) { diff --git a/R/scale-.r b/R/scale-.r index f7254203..197f3211 100644 --- a/R/scale-.r +++ b/R/scale-.r @@ -119,6 +119,10 @@ Scale <- gganimintproto("Scale", NULL, } }, + range_is_zero = function(self, limits) { + isTRUE(scales::zero_range(as.numeric(limits))) + }, + # The physical size of the scale. # This always returns a numeric vector of length 2, giving the physical # dimensions of a scale. @@ -206,15 +210,13 @@ ScaleContinuous <- gganimintproto("ScaleContinuous", Scale, get_breaks = function(self, limits = self$get_limits()) { if (self$is_empty()) return(numeric()) - # Limits in transformed space need to be converted back to data space limits <- self$trans$inverse(limits) - if (is.null(self$breaks)) { return(NULL) } else if (identical(self$breaks, NA)) { stop("Invalid breaks specification. Use NULL, not NA") - } else if (zero_range(as.numeric(limits))) { + } else if (self$range_is_zero(limits)) { breaks <- limits[1] } else if (is.waive(self$breaks)) { breaks <- self$trans$breaks(limits) @@ -240,7 +242,7 @@ ScaleContinuous <- gganimintproto("ScaleContinuous", Scale, }, get_breaks_minor = function(self, n = 2, b = self$break_positions(), limits = self$get_limits()) { - if (zero_range(as.numeric(limits))) { + if (self$range_is_zero(limits)) { return() } diff --git a/R/z_animint.R b/R/z_animint.R index 510bbb6a..c6879580 100644 --- a/R/z_animint.R +++ b/R/z_animint.R @@ -285,6 +285,10 @@ animint2dir <- function(plot.list, out.dir = NULL, if(!is.null(plot.list$out.dir)){ plot.list$out.dir <- NULL } + if(is.character(plot.list[["source"]])){ + meta$source <- plot.list[["source"]] + plot.list$source <- NULL + } ## Extract essential info from ggplots, reality checks. for(list.name in names(plot.list)){ @@ -631,8 +635,8 @@ animint2dir <- function(plot.list, out.dir = NULL, file.copy(style.file, file.path(out.dir, "styles.css"), overwrite=TRUE) } file.copy(to.copy, out.dir, overwrite=TRUE, recursive=TRUE) - export.names <- - c("geoms", "time", "duration", "selectors", "plots", "title") + export.names <- c( + "geoms", "time", "duration", "selectors", "plots", "title", "source") export.data <- list() for(export.name in export.names){ if(export.name %in% ls(meta)){ diff --git a/R/z_gist.R b/R/z_gist.R deleted file mode 100644 index 994961c9..00000000 --- a/R/z_gist.R +++ /dev/null @@ -1,80 +0,0 @@ -#' Convert a list of ggplots to an interactive animation and post files as a gist -#' -#' Before using this function set your appropriate 'github.username' and 'github.password' \link{options} -#' -#' @param plot.list a named list of ggplots and option lists. -#' @param description Brief description of gist. -#' This becomes the plot title on the bl.ocks/username page. -#' @param browse logical. Prompt browser to view viz on bl.ocks.org -#' @param ... options passed onto \code{animint2dir} and \code{gistr::gist_create} -#' @export -#' -#' @examples -#' \dontrun{ -#' library(animint) -#' iris$id <- 1:nrow(iris) -#' viz <- list(petal=ggplot()+ -#' geom_point(aes(Petal.Width, Petal.Length, fill=Species, -#' clickSelects=id), data=iris), -#' sepal=ggplot()+ -#' geom_point(aes(Sepal.Width, Sepal.Length, fill=Species, -#' clickSelects=id), data=iris)) -#' animint2gist(viz, description = "My animint plot") -#' } -animint2gist <- function(plot.list, description = plot.list$title, - browse = TRUE, ...) { - if (!is.character(description) || length(description) == 0) description <- "" - if (length(description) > 1) description <- description[[1]] - res <- animint2dir(plot.list, open.browser = FALSE, ...) - if (!requireNamespace("gistr")) { - stop("Please run \n", - "devtools::install_github('rOpenSci/gistr')", - "before using this function") - } - # use a flat file structure! - vendor.path <- file.path(res$out.dir, "vendor") - vendor.files <- list.files(vendor.path) - vendor.path.files <- file.path(vendor.path, vendor.files) - copied <- file.copy(vendor.path.files, file.path(res$out.dir, vendor.files)) - file.remove(vendor.path.files) - file.remove(vendor.path) - # reflect script path in index.html to reflect the change in file structure - index.file <- file.path(res$out.dir, "index.html") - html <- readLines(index.file) - html <- gsub("vendor/", "", html) - cat(html, file = index.file, sep = "\n") - ## Figure out which files to post. - all.files <- Sys.glob(file.path(res$out.dir, "*")) - all.file.info <- file.info(all.files) - is.empty <- all.file.info$size == 0 - is.tilde <- grepl("~$", all.files) - is.png <- grepl("[.]png$", all.files) - is.ignored <- all.file.info$isdir | is.empty | is.tilde - ## TODO: delete the next line when gist_create can upload PNGs. - is.ignored <- is.ignored | is.png - to.post <- all.files[!is.ignored] - if(300 < length(to.post)){ - print(to.post) - stop("your animint has ", length(to.post), - " files but the Gist API will not serve more than 300 files,", - " so your animint will not be viewable on bl.ocks.org.", - " Try using https://pages.github.com/ to share your animint,", - " or the chunk_vars argument to reduce the number of tsv files", - " http://bit.ly/21scnod") - } - if(any(1024 * 1024 < all.file.info$size)){ - print(all.file.info[, "size", drop=FALSE]) - stop("your animint has files bigger than 1MB,", - " but the Gist API will truncate files bigger than 1MB,", - " so your animint will not be viewable on bl.ocks.org.", - " Try using https://pages.github.com/ to share your animint,", - " or the chunk_vars argument to combine some tsv files", - " http://bit.ly/21scnod") - } - gist <- gistr::gist_create(to.post, description = description, - browse = FALSE, ...) - if (browse) - browseURL(sprintf("http://bl.ocks.org/%s/raw/%s/", - gist$owner$login, gist$id)) - gist -} diff --git a/R/z_pages.R b/R/z_pages.R new file mode 100644 index 00000000..9945dace --- /dev/null +++ b/R/z_pages.R @@ -0,0 +1,237 @@ +#' Publish a list of ggplots as interactive visualizations on a GitHub repository +#' +#' This function takes a named list of ggplots, generates interactive animations, +#' and pushes the generated files to a specified GitHub repository. You can +#' choose to keep the repository private or public. +#' Before using this function set your appropriate git 'user.username' and 'user.email' +#' +#' @param plot.list A named list of ggplots and option lists. +#' @param github_repo The name of the GitHub repository to which the +#' files will be pushed. +#' @param commit_message A string specifying the commit message for +#' the pushed files. +#' @param private A logical flag indicating whether the GitHub +#' repository should be private or not (default FALSE). +#' @param required_opts Character vector of plot.list element names +#' which are checked (stop with an error if not present). Use +#' required_opts=NULL to skip check. +#' @param ... Additional options passed onto \code{animint2dir}. +#' +#' @return The function returns the initialized GitHub repository object. +#' +#' @examples +#' \dontrun{ +#' library(animint2) +#' p1 <- ggplot(mtcars, aes(x = mpg, y = wt)) + +#' geom_point() +#' p2 <- ggplot(mtcars, aes(x = hp, y = wt)) + +#' geom_point() +#' viz <- list(plot1 = p1, plot2 = p2) +#' animint2pages( +#' viz, +#' github_repo = "my_animint2_plots", +#' commit_message = "New animint", +#' private = TRUE) +#' } +#' +#' @export +animint2pages <- function(plot.list, github_repo, commit_message = "Commit from animint2pages", private = FALSE, required_opts = c("title","source"), ...) { + for(opt in required_opts){ + if(!opt %in% names(plot.list)){ + stop(sprintf("plot.list does not contain option named %s, which is required by animint2pages", opt)) + } + } + # Check for required packages + for(pkg in c("gert", "gh")){ + if (!requireNamespace(pkg)) { + stop(sprintf("Please run `install.packages('%s')` before using this function", pkg)) + } + } + # Generate plot files + res <- animint2dir(plot.list, open.browser = FALSE, ...) + # Select non-ignored files to post + all_files <- Sys.glob(file.path(res$out.dir, "*")) + file_info <- file.info(all_files) + to_post <- all_files[!(file_info$size == 0 | grepl("~$", all_files))] + tryCatch({ + gitcreds::gitcreds_get() + }, error = function(e) stop("A GitHub token is required to create and push to a new repository. \nTo create a GitHub token, follow these steps:\n1. Go to https://github.com/settings/tokens/new?scopes=repo&description=animint2pages\n2. Confirm your password if prompted.\n3. Ensure that the 'repo' scope is checked.\n4. Click 'Generate token' at the bottom of the page.\n5. Copy the generated token.\nAfter creating the token, you can set it up in your R environment by running: \nSys.setenv(GITHUB_PAT=\"yourGithubPAT\") \ngert::git_config_global_set(\"user.name\", \"yourUserName\") \ngert::git_config_global_set(\"user.email\", \"yourEmail\") \n")) + # Raise error if github_repo contains '/' + if (grepl("/", github_repo)) { + stop("The github_repo argument should not contain '/'.") + } + # Check for existing repository + whoami <- suppressMessages(gh::gh_whoami()) + owner <- whoami[["login"]] + viz_owner_repo <- paste0(owner, "/", github_repo) + local_clone <- tempfile() + if (!check_no_github_repo(owner, github_repo)) { + create <- gh::gh("POST /user/repos", name = github_repo, private = private) + origin_url <- create$clone_url + repo <- gert::git_init(path = local_clone) + gert::git_remote_add(name = "origin", url = origin_url, repo = repo) + } else { + origin_url <- paste0("https://github.com/", viz_owner_repo, ".git") + repo <- gert::git_clone(origin_url, local_clone) + } + viz_url <- paste0("https://", owner, ".github.io/", github_repo) + # check if repo has commit, if not, give it first commit, this can avoid error + has_commits <- FALSE + try( + { + if (nrow(gert::git_log(repo = repo)) > 0) { + has_commits <- TRUE + } + }, + silent = TRUE + ) + if (!has_commits) { + initial_commit(local_clone, repo, viz_url) + } + # Handle gh-pages branch + manage_gh_pages(repo, to_post, local_clone, commit_message) + message(sprintf( + "Visualization will be available at %s\nDeployment via GitHub Pages may take a few minutes...", viz_url)) + viz_owner_repo +} + +initial_commit <- function(local_clone, repo, viz_url) { + readme_file_path <- file.path(local_clone, "README.md") + header <- "## New animint visualization\n" + url_hyperlink <- sprintf("[%s](%s)\n", viz_url, viz_url) + full_content <- paste0(header, url_hyperlink) + writeLines(full_content, readme_file_path) + gert::git_add("README.md", repo = repo) + gert::git_commit("Initial commit", repo = repo) + df_or_vec <- gert::git_branch(repo) + # check if it is a data frame or an atomic vector + if (is.data.frame(df_or_vec)) { + all_branches <- df_or_vec[["name"]] + current_master <- all_branches[df_or_vec$active] + } else { + all_branches <- df_or_vec + current_master <- df_or_vec + } + # do not attempt to rename a branch to "main" when a branch with that name already exists + if (current_master != "main" && !"main" %in% all_branches) { + gert::git_branch_move(branch = current_master, new_branch = "main", repo = repo) + } + gert::git_push(repo = repo, remote = "origin", set_upstream = TRUE) +} + +manage_gh_pages <- function(repo, to_post, local_clone, commit_message) { + branches <- gert::git_branch_list(local = TRUE, repo = repo) + if (!"gh-pages" %in% branches$name) { + gert::git_branch_create(repo = repo, branch = "gh-pages") + } + gert::git_branch_checkout("gh-pages", repo = repo) + file.copy(to_post, local_clone, recursive = TRUE) + gert::git_add(files = ".", repo = repo) + gert::git_commit(message = commit_message, repo = repo) + gert::git_push(remote = "origin", set_upstream = TRUE, repo = repo, force = TRUE) +} + +check_no_github_repo <- function(owner, repo) { + tryCatch( + { + gh::gh("/repos/{owner}/{repo}", owner = owner, repo = repo) + TRUE + }, + "http_error_404" = function(err) FALSE + ) +} + +get_pages_info <- function(viz_owner_repo){ + viz_dir <- tempfile() + origin_url <- paste0("https://github.com/", viz_owner_repo, ".git") + gert::git_clone(origin_url, viz_dir) + gert::git_branch_checkout("gh-pages", repo=viz_dir) + Capture.PNG <- file.path(viz_dir, "Capture.PNG") + if(!file.exists(Capture.PNG)){ + stop(sprintf("gh-pages branch of %s should contain file named Capture.PNG (screenshot of data viz)", viz_owner_repo)) + } + plot.json <- file.path(viz_dir, "plot.json") + jlist <- RJSONIO::fromJSON(plot.json) + commit.row <- gert::git_log(max=1, repo=viz_dir) + repo.row <- data.table( + viz_owner_repo, Capture.PNG, commit.POSIXct=commit.row$time) + to.check <- c( + source="URL of data viz source code", + title="string describing the data viz") + for(attr.name in names(to.check)){ + attr.value <- jlist[[attr.name]] + if( + is.character(attr.value) + && length(attr.value)==1 + && !is.na(attr.value) + && nchar(attr.value)>0 + ){ + set(repo.row, j=attr.name, value=attr.value) + }else{ + stop(sprintf("plot.json file in gh-pages branch of %s should have element named %s which should be %s", viz_owner_repo, attr.name, to.check[[attr.name]])) + } + } + repo.row +} + +##' A gallery is a collection of meta-data about animints that have +##' been published to github pages. A gallery is defined as a github +##' repo that should have two source files in the gh-pages branch: +##' repos.txt (list of github repositories, one owner/repo per line) +##' and index.Rmd (source for web page with links to animints). To +##' perform the update, first repos.txt is read, then we clone each +##' repo which is not already present in meta.csv, and parse meta-data +##' (title, source, Capture.PNG) from the gh-pages branch, and write +##' the meta.csv/error.csv/Capture.PNG files, render index.Rmd to +##' index.html, commit, and push origin. For an example, see the main +##' gallery, \url{https://github.com/animint/gallery/tree/gh-pages} +##' which is updated using this function. +##' @title Update gallery +##' @param gallery_path path to local github repo with gh-pages +##' active. +##' @return named list of data tables (meta and error). +##' @author Toby Dylan Hocking +##' @export +update_gallery <- function(gallery_path="~/R/gallery"){ + commit.POSIXct <- title <- NULL + ## Above to avoid CRAN NOTE. + repos.txt <- file.path(gallery_path, "repos.txt") + repos.dt <- fread(repos.txt,header=FALSE,col.names="viz_owner_repo") + meta.csv <- file.path(gallery_path, "meta.csv") + old.meta <- fread(meta.csv) + todo.meta <- repos.dt[!old.meta, on="viz_owner_repo"] + meta.dt.list <- list(old.meta) + error.dt.list <- list() + add.POSIXct <- Sys.time() + for(viz_owner_repo in todo.meta[["viz_owner_repo"]]){ + tryCatch({ + meta.row <- data.table(add.POSIXct, get_pages_info(viz_owner_repo)) + meta.dt.list[[viz_owner_repo]] <- meta.row[, .( + add.POSIXct, viz_owner_repo, commit.POSIXct, source, title)] + Capture.PNG <- meta.row[["Capture.PNG"]] + repo.png <- file.path( + gallery_path, "repos", paste0(viz_owner_repo, ".png")) + user.dir <- dirname(repo.png) + dir.create(user.dir, showWarnings = FALSE, recursive = TRUE) + file.copy(Capture.PNG, repo.png, overwrite = TRUE) + }, error=function(e){ + error.dt.list[[viz_owner_repo]] <<- data.table( + add.POSIXct, viz_owner_repo, error=e$message) + }) + } + (meta.dt <- rbindlist(meta.dt.list)) + (error.dt <- rbindlist(error.dt.list)) + fwrite(meta.dt, meta.csv) + fwrite(error.dt, file.path(gallery_path, "error.csv")) + rmarkdown::render(file.path(gallery_path, "index.Rmd")) + to_add <- c( + "*.csv", + "repos.txt", + file.path("repos","*","*.png"), + "index.html", + "index.Rmd") + gert::git_add(to_add, repo=gallery_path) + gert::git_commit(paste("update", add.POSIXct), repo=gallery_path) + gert::git_push("origin", repo=gallery_path) + list(meta=meta.dt, error=error.dt) +} diff --git a/build.sh b/build.sh index b36b3035..afcbbefe 100644 --- a/build.sh +++ b/build.sh @@ -17,14 +17,16 @@ done cp animint2/data/economics_long.rda animint2-release/data cp animint2/man/animint2-gganimintproto.Rd animint2-release/man cp animint2/man/graphical-units.Rd animint2-release/man -grep -v RSelenium animint2/DESCRIPTION > animint2-release/DESCRIPTION +egrep -v 'VignetteBuilder|RSelenium' animint2/DESCRIPTION > animint2-release/DESCRIPTION rm animint2-release/tests/testthat/helper-HTML.R rm animint2-release/tests/testthat/test-compiler-chunk-vars.R -rm animint2-release/tests/testthat/test-compiler-gist.R +rm animint2-release/tests/testthat/test-compiler-ghpages.R +rm animint2-release/vignettes/animint2.Rmd #to save disk space cat < animint2-release/tests/testthat.R library(testthat) test_check("animint2", filter="compiler") EOF PKG_TGZ=$(R CMD build animint2-release|grep building|sed "s/.*\(animint2.*.tar.gz\).*/\1/") +echo built $PKG_TGZ so now we INSTALL R CMD INSTALL $PKG_TGZ R CMD check --as-cran $PKG_TGZ diff --git a/inst/htmljs/animint.js b/inst/htmljs/animint.js index 8ff60599..53f42f46 100644 --- a/inst/htmljs/animint.js +++ b/inst/htmljs/animint.js @@ -180,39 +180,6 @@ var animint = function (to_select, json_file) { ".axis text {font-family: sans-serif;font-size: 11px;}"]; var add_geom = function (g_name, g_info) { - // Determine what style to use to show the selection for this - // geom. This is a hack and should be removed when we implement - // the selected.color, selected.size, etc aesthetics. - // - // 2022.08.01 update: get rid of the hack of "rect stroke" to - // implement a general function for alpha_off, color_off. - // In order to have multiple styles functioning together - // so here use array to store the styles. - // Default using alpha/opacity style, execpt rect/tile geom - // rect/tile geom default using stroke style - const checkProperty = (prop) => - g_info.params.hasOwnProperty(prop) || g_info.aes.hasOwnProperty(prop); - - let select_styles = []; - const has_colour_off = checkProperty('colour_off'); - const has_alpha_off = checkProperty('alpha_off'); - const has_fill_off = checkProperty('fill_off'); - - if (has_colour_off || g_info.geom === 'rect') { - select_styles.push('stroke'); - } - if (has_alpha_off) { - select_styles.push('opacity'); - } - if (has_fill_off) { - select_styles.push('fill'); - } - if (!select_styles.length) { - select_styles = ['opacity']; - } - - g_info.select_style = select_styles; - // Determine if data will be an object or an array. if(g_info.geom in data_object_geoms){ g_info.data_is_object = true; @@ -1064,151 +1031,118 @@ var animint = function (to_select, json_file) { var layer_g_element = svg.select("g." + g_info.classed); var panel_g_element = layer_g_element.select("g.PANEL" + PANEL); var elements = panel_g_element.selectAll(".geom"); - // TODO: standardize this code across aes/styles. - let base_opacity; - let off_opacity; - // Explicitly check if it has the property, allows 0 as valid value - if (g_info.params.hasOwnProperty("alpha")) { - base_opacity = g_info.params.alpha; - } else { - base_opacity = 1; - } - if (g_info.params.hasOwnProperty("alpha_off")) { - off_opacity = g_info.params.alpha_off; - } else { - off_opacity = base_opacity - 0.5; - } - //alert(g_info.classed+" "+base_opacity); - var get_alpha = function (d) { - var a; - if (aes.hasOwnProperty("alpha") && d.hasOwnProperty("alpha")) { - a = d["alpha"]; - } else { - a = base_opacity; - } - return a; + + // helper functions so we can write code that works for both + // grouped and ungrouped geoms. get_one_row returns one row of + // data (not one group), in both cases. + var get_fun = function(fun){ + return function(input){ + var d = get_one_row(input); + return fun(d); + }; }; - const get_alpha_off = function (d) { - let a; - if (aes.hasOwnProperty("alpha_off") && d.hasOwnProperty("alpha_off")) { - a = d["alpha_off"]; - } else if (g_info.params.hasOwnProperty("alpha_off")) { - a = g_info.params.alpha_off; - } else if (aes.hasOwnProperty("alpha") && d.hasOwnProperty("alpha")) { - a = d["alpha"] - 0.5; - } else { - a = off_opacity; - } - return a; + var get_attr = function(attr_name){ + return get_fun(function(d){ + return d[attr_name]; + }); }; + var size = 2; - if(g_info.geom == "text"){ - size = 12; - } - if (g_info.params.hasOwnProperty("size")) { - size = g_info.params.size; + var get_size; + if(aes.hasOwnProperty("size")){ + get_size = get_attr("size"); + }else{ + get_size = function(d){ + return size; + }; } - var get_size = function (d) { - if (aes.hasOwnProperty("size") && d.hasOwnProperty("size")) { - return d["size"]; - } - return size; - }; + var get_style_on_stroke_width = get_size; // stroke_width for geom_point var stroke_width = 1; // by default ggplot2 has 0.5, animint has 1 - if (g_info.params.hasOwnProperty("stroke")) { - stroke_width = g_info.params.stroke; - } - var get_stroke_width = function (d) { - if (aes.hasOwnProperty("stroke") && d.hasOwnProperty("stroke")) { - return d["stroke"]; - } - return stroke_width; + var get_stroke_width; + if(aes.hasOwnProperty("stroke")){ + get_stroke_width = get_attr("stroke"); + }else{ + get_stroke_width = function(d){ + return stroke_width; + }; } var linetype = "solid"; - if (g_info.params.linetype) { - linetype = g_info.params.linetype; + var get_linetype; + if(aes.hasOwnProperty("linetype")){ + get_linetype = get_attr("linetype"); + }else{ + get_linetype = function(d){ + return linetype; + }; } - - var get_dasharray = function (d) { - var lt = linetype; - if (aes.hasOwnProperty("linetype") && d.hasOwnProperty("linetype")) { - lt = d["linetype"]; - } + var get_dasharray = function(d){ + var lt = get_linetype(d); return linetypesize2dasharray(lt, get_size(d)); }; - var colour = "black"; - var fill = "black"; - let angle = 0; - if (g_info.params.hasOwnProperty("angle")) { - angle = g_info.params["angle"]; + + var alpha = 1, alpha_off = 0.5; + var get_alpha; + var get_alpha_off = function (d) { + return alpha_off; + }; + if(aes.hasOwnProperty("alpha")){ + get_alpha = get_attr("alpha"); + get_alpha_off = get_attr("alpha"); + } else { + get_alpha = function(d){ + return alpha; + }; + } + + var colour = "black", colour_off; + var get_colour; + var get_colour_off = function (d) { + return colour_off; + }; + if(aes.hasOwnProperty("colour")){ + get_colour = get_attr("colour"); + get_colour_off = get_colour; + }else{ + get_colour = function (d) { + return colour; + }; } - const get_angle = function(d) { + var get_colour_off_default = get_colour; + + var fill = "black", fill_off = "black"; + var get_fill = function (d) { + return fill; + }; + var get_fill_off = function (d) { + return fill_off; + }; + + var angle = 0; + var get_angle; + if(aes.hasOwnProperty("angle")){ + get_angle = get_attr("angle"); + }else{ + get_angle = function(d){ + return angle; + }; + } + var get_rotate = function(d){ // x and y are the coordinates to rotate around, we choose the center // point of the text because otherwise it will rotate around (0,0) of its // coordinate system, which is the top left of the plot x = scales["x"](d["x"]); y = scales["y"](d["y"]); - if (d.hasOwnProperty("angle")) { - angle = d["angle"]; - } + var angle = get_angle(d); // ggplot expects angles to be in degrees CCW, SVG uses degrees CW, so // we negate the angle. return `rotate(${-angle}, ${x}, ${y})`; }; - var get_colour = function (d) { - if (d.hasOwnProperty("colour")) { - return d["colour"] - } - return colour; - }; - if (g_info.geom == "rect" && has_clickSelects && g_info.params.colour == "transparent"){ - colour = "black"; - } else if(g_info.params.colour){ - colour = g_info.params.colour; - } - // Only "colour_off" params appears would call this function, - // so no default off_colour value - const get_colour_off = function (d) { - let off_colour; - if (aes.hasOwnProperty("colour_off") && d.hasOwnProperty("colour_off")) { - off_colour = d["colour_off"]; - } else if(g_info.params.hasOwnProperty("colour_off")){ - off_colour = g_info.params.colour_off; - } - return off_colour; - }; - - var get_fill = function (d) { - if (d.hasOwnProperty("fill")) { - return d["fill"]; - } - return fill; - }; - if (g_info.params.fill) { - fill = g_info.params.fill; - }else if(g_info.params.colour){ - fill = g_info.params.colour; - } - - const get_fill_off = function (d) { - let off_fill; - if (aes.hasOwnProperty("fill_off") && d.hasOwnProperty("fill_off")) { - off_fill = d["fill_off"]; - } else if (g_info.params.hasOwnProperty("fill_off")) { - off_fill = g_info.params.fill_off; - } - return off_fill; - }; - // For aes(hjust) the compiler should make an "anchor" column. var text_anchor = "middle"; - if(g_info.params.hasOwnProperty("anchor")){ - text_anchor = g_info.params["anchor"]; - } var get_text_anchor; if(g_info.aes.hasOwnProperty("hjust")) { get_text_anchor = function(d){ @@ -1220,29 +1154,20 @@ var animint = function (to_select, json_file) { } } - var eActions, eAppend, linkActions; + var eActions, eAppend; var key_fun = null; - var id_fun = function(d){ - return d.id; - }; if(g_info.aes.hasOwnProperty("key")){ key_fun = function(d){ return d.key; }; } - - // Apply user-configurable selection style into each geom later. - var select_style_fun = function(g_info, e){ - if(!g_info.select_style.includes("stroke")){ - e.style("stroke", get_colour); - } - if(!g_info.select_style.includes("opacity")){ - e.style("opacity", get_alpha); - } - if(!g_info.select_style.includes("fill")){ - e.style("fill", get_fill); - } - }; + var get_one_row;//different for grouped and ungrouped geoms. + var data_to_bind; + g_info.style_list = [ + "opacity","stroke","stroke-width","stroke-dasharray","fill"]; + var line_style_list = [ + "opacity","stroke","stroke-width","stroke-dasharray"]; + var fill_comes_from="fill", fill_off_comes_from="fill_off"; if(g_info.data_is_object) { // Lines, paths, polygons, and ribbons are a bit special. For @@ -1336,27 +1261,19 @@ var animint = function (to_select, json_file) { .x(toXY("x", "x")) .y(toXY("y", "y")); } + if(["line","path"].includes(g_info.geom)){ + fill = "none"; + fill_off = "none"; + } // select the correct group before returning anything. key_fun = function(group_info){ return group_info.value; }; - id_fun = function(group_info){ + data_to_bind = kv; + get_one_row = function(group_info) { var one_group = keyed_data[group_info.value]; var one_row = one_group[0]; - // take key from first value in the group. - return one_row.id; - }; - elements = elements.data(kv, key_fun); - linkActions = function(a_elements){ - a_elements - .attr("xlink:href", function(group_info){ - var one_group = keyed_data[group_info.value]; - var one_row = one_group[0]; - return one_row.href; - }) - .attr("target", "_blank") - .attr("class", "geom") - ; + return one_row; }; eActions = function (e) { e.attr("d", function (d) { @@ -1371,298 +1288,254 @@ var animint = function (to_select, json_file) { }); return lineThing(no_na); }) - .style("fill", function (group_info) { - if (g_info.geom == "line" || g_info.geom == "path") { - return "none"; - } - var one_group = keyed_data[group_info.value]; - var one_row = one_group[0]; - // take color for first value in the group - return get_fill(one_row); - }) - .style("stroke-width", function (group_info) { - var one_group = keyed_data[group_info.value]; - var one_row = one_group[0]; - // take size for first value in the group - return get_size(one_row); - }) - .style("stroke", function (group_info) { - var one_group = keyed_data[group_info.value]; - var one_row = one_group[0]; - // take color for first value in the group - // Since line/path geom are using group to draw, - // so it is different from other geom - // and cannot call select_style_fun function here - if ((has_clickSelects || has_clickSelects_variable) && g_info.select_style.includes("stroke")){ - const v_name = g_info.aes['clickSelects.variable'] || g_info.aes['clickSelects']; - const s_info = Selectors[v_name]; - if(s_info.selected == one_row.clickSelects){ - return get_colour(one_row); - } else{ - return get_colour_off(one_row); - }; - }; - return get_colour(one_row); - }) - .style("stroke-dasharray", function (group_info) { - var one_group = keyed_data[group_info.value]; - var one_row = one_group[0]; - // take linetype for first value in the group - return get_dasharray(one_row); - }) - .style("stroke-width", function (group_info) { - var one_group = keyed_data[group_info.value]; - var one_row = one_group[0]; - // take line size for first value in the group - return get_size(one_row); - }); - if(!g_info.select_style.includes("opacity")){ - e.style("opacity", function (group_info) { - var one_group = keyed_data[group_info.value]; - var one_row = one_group[0]; - // take line size for first value in the group - return get_alpha(one_row); - }) - } }; eAppend = "path"; }else{ - linkActions = function(a_elements){ - a_elements.attr("xlink:href", function(d){ return d.href; }) - .attr("target", "_blank") - .attr("class", "geom"); - }; - } - if (g_info.geom == "segment") { - elements = elements.data(data, key_fun); - eActions = function (e) { - e.attr("x1", function (d) { - return scales.x(d["x"]); - }) - .attr("x2", function (d) { - return scales.x(d["xend"]); - }) - .attr("y1", function (d) { - return scales.y(d["y"]); - }) - .attr("y2", function (d) { - return scales.y(d["yend"]); - }) - .style("stroke-dasharray", get_dasharray) - .style("stroke-width", get_size); - select_style_fun(g_info, e); - }; - eAppend = "line"; - } - if (g_info.geom == "linerange") { - elements = elements.data(data, key_fun); - eActions = function (e) { - e.attr("x1", function (d) { - return scales.x(d["x"]); - }) - .attr("x2", function (d) { + get_one_row = function(d){ + return d; + } + data_to_bind = data; + if (g_info.geom == "segment") { + g_info.style_list = line_style_list; + eActions = function (e) { + e.attr("x1", function (d) { return scales.x(d["x"]); }) - .attr("y1", function (d) { - return scales.y(d["ymax"]); - }) - .attr("y2", function (d) { - return scales.y(d["ymin"]); + .attr("x2", function (d) { + return scales.x(d["xend"]); + }) + .attr("y1", function (d) { + return scales.y(d["y"]); + }) + .attr("y2", function (d) { + return scales.y(d["yend"]); + }) + }; + eAppend = "line"; + } + if (g_info.geom == "linerange") { + g_info.style_list = line_style_list; + eActions = function (e) { + e.attr("x1", function (d) { + return scales.x(d["x"]); }) - .style("stroke-dasharray", get_dasharray) - .style("stroke-width", get_size); - select_style_fun(g_info, e); - }; - eAppend = "line"; + .attr("x2", function (d) { + return scales.x(d["x"]); + }) + .attr("y1", function (d) { + return scales.y(d["ymax"]); + }) + .attr("y2", function (d) { + return scales.y(d["ymin"]); + }) + ; + }; + eAppend = "line"; + } + if (g_info.geom == "vline") { + g_info.style_list = line_style_list; + eActions = function (e) { + e.attr("x1", toXY("x", "xintercept")) + .attr("x2", toXY("x", "xintercept")) + .attr("y1", scales.y.range()[0]) + .attr("y2", scales.y.range()[1]) + ; + }; + eAppend = "line"; + } + if (g_info.geom == "hline") { + g_info.style_list = line_style_list; + eActions = function (e) { + e.attr("y1", toXY("y", "yintercept")) + .attr("y2", toXY("y", "yintercept")) + .attr("x1", scales.x.range()[0]) + .attr("x2", scales.x.range()[1]) + ; + }; + eAppend = "line"; + } + if (g_info.geom == "text") { + size = 12;//default + get_colour = function(d){ + return "none"; + }; + get_colour_off = function(d) { + return "none"; + }; + fill_comes_from = "colour"; + fill_off_comes_from = "colour_off"; + g_info.style_list = [ + "opacity","fill"]; + eActions = function (e) { + e.attr("x", toXY("x", "x")) + .attr("y", toXY("y", "y")) + .attr("font-size", get_size) + .style("text-anchor", get_text_anchor) + .attr("transform", get_rotate) + .text(function (d) { + return d.label; + }) + ; + }; + eAppend = "text"; + } + if (g_info.geom == "point") { + // point is special because it takes SVG fill from ggplot + // colour, if fill is not specified. + if(!( + g_info.params.hasOwnProperty("fill") || + aes.hasOwnProperty("fill") + )){ + fill_comes_from = "colour"; + } + if(!g_info.params.hasOwnProperty("fill_off")){ + fill_off_comes_from = "colour_off"; + } + get_style_on_stroke_width = get_stroke_width;//not size. + eActions = function (e) { + e.attr("cx", toXY("x", "x")) + .attr("cy", toXY("y", "y")) + .attr("r", get_size) + ; + }; + eAppend = "circle"; + } + var rect_geoms = ["tallrect","widerect","rect"]; + if(rect_geoms.includes(g_info.geom)){ + eAppend = "rect"; + if (g_info.geom == "tallrect") { + eActions = function (e) { + e.attr("x", toXY("x", "xmin")) + .attr("width", function (d) { + return scales.x(d["xmax"]) - scales.x(d["xmin"]); + }) + .attr("y", scales.y.range()[1]) + .attr("height", scales.y.range()[0] - scales.y.range()[1]) + ; + }; + } + if (g_info.geom == "widerect") { + eActions = function (e) { + e.attr("y", toXY("y", "ymax")) + .attr("height", function (d) { + return scales.y(d["ymin"]) - scales.y(d["ymax"]); + }) + .attr("x", scales.x.range()[0]) + .attr("width", scales.x.range()[1] - scales.x.range()[0]) + ; + }; + } + if (g_info.geom == "rect") { + alpha_off = alpha; + colour_off = "transparent"; + get_colour_off_default = get_colour_off; + eActions = function (e) { + e.attr("x", toXY("x", "xmin")) + .attr("width", function (d) { + return Math.abs(scales.x(d.xmax) - scales.x(d.xmin)); + }) + .attr("y", toXY("y", "ymax")) + .attr("height", function (d) { + return Math.abs(scales.y(d.ymin) - scales.y(d.ymax)); + }) + ; + }; + } + } } - if (g_info.geom == "vline") { - elements = elements.data(data, key_fun); - eActions = function (e) { - e.attr("x1", toXY("x", "xintercept")) - .attr("x2", toXY("x", "xintercept")) - .attr("y1", scales.y.range()[0]) - .attr("y2", scales.y.range()[1]) - .style("stroke-dasharray", get_dasharray) - .style("stroke-width", get_size); - select_style_fun(g_info, e); - }; - eAppend = "line"; + // set params after geom-specific code, because each geom may have + // a different default. + if (g_info.params.hasOwnProperty("stroke")) { + stroke_width = g_info.params.stroke; } - if (g_info.geom == "hline") { - // pretty much a copy of geom_vline with obvious modifications - elements = elements.data(data, key_fun); - eActions = function (e) { - e.attr("y1", toXY("y", "yintercept")) - .attr("y2", toXY("y", "yintercept")) - .attr("x1", scales.x.range()[0]) - .attr("x2", scales.x.range()[1]) - .style("stroke-dasharray", get_dasharray) - .style("stroke-width", get_size); - select_style_fun(g_info, e); - }; - eAppend = "line"; + if (g_info.params.hasOwnProperty("linetype")) { + linetype = g_info.params.linetype; } - if (g_info.geom == "text") { - elements = elements.data(data, key_fun); - // TODO: how to support vjust? firefox doensn't support - // baseline-shift... use paths? - // http://commons.oreilly.com/wiki/index.php/SVG_Essentials/Text - eActions = function (e) { - e.attr("x", toXY("x", "x")) - .attr("y", toXY("y", "y")) - .attr("font-size", get_size) - .style("text-anchor", get_text_anchor) - .attr("transform", get_angle) - .text(function (d) { - return d.label; - }); - }; - eAppend = "text"; + if(g_info.params.hasOwnProperty("alpha")){ + alpha = g_info.params.alpha; + alpha_off = alpha - 0.5 } - if (g_info.geom == "point") { - elements = elements.data(data, key_fun); - eActions = function (e) { - e.attr("cx", toXY("x", "x")) - .attr("cy", toXY("y", "y")) - .attr("r", get_size) - .style("stroke-width", get_stroke_width); - select_style_fun(g_info, e); - }; - eAppend = "circle"; + if(g_info.params.hasOwnProperty("alpha_off")){ + alpha_off = g_info.params.alpha_off; } - if (g_info.geom == "tallrect") { - elements = elements.data(data, key_fun); - eActions = function (e) { - e.attr("x", toXY("x", "xmin")) - .attr("width", function (d) { - return scales.x(d["xmax"]) - scales.x(d["xmin"]); - }) - .attr("y", scales.y.range()[1]) - .attr("height", scales.y.range()[0] - scales.y.range()[1]) - .style("stroke-dasharray", get_dasharray) - .style("stroke-width", get_size); - select_style_fun(g_info, e); - }; - eAppend = "rect"; + if(g_info.params.hasOwnProperty("anchor")){ + text_anchor = g_info.params["anchor"]; } - if (g_info.geom == "widerect") { - elements = elements.data(data, key_fun); - eActions = function (e) { - e.attr("y", toXY("y", "ymax")) - .attr("height", function (d) { - return scales.y(d["ymin"]) - scales.y(d["ymax"]); - }) - .attr("x", scales.x.range()[0]) - .attr("width", scales.x.range()[1] - scales.x.range()[0]) - .style("stroke-dasharray", get_dasharray) - .style("stroke-width", get_size); - select_style_fun(g_info, e); - }; - eAppend = "rect"; - } - // geom_rect/geom_tile selection style logic: - // 1. in geom-tile.R we specify if the colour parameter, not aes, is null - // - it shall be transparent when there is no clickSelects - // - it is black when clickSelects is specified, and no params colour - // 2. When colour param is not null, whether it has clickSelects or not - // the colour/stroke is the RGB value of colour params - if (g_info.geom == "rect") { - elements = elements.data(data, key_fun); - eActions = function (e) { - e.attr("x", toXY("x", "xmin")) - .attr("width", function (d) { - return Math.abs(scales.x(d.xmax) - scales.x(d.xmin)); - }) - .attr("y", toXY("y", "ymax")) - .attr("height", function (d) { - return Math.abs(scales.y(d.ymin) - scales.y(d.ymax)); - }) - .style("stroke-dasharray", get_dasharray) - .style("stroke-width", get_size) - select_style_fun(g_info, e); - }; - eAppend = "rect"; + if(g_info.params.hasOwnProperty("colour")){ + colour = g_info.params.colour; } - if (g_info.geom == "boxplot") { - - // TODO: currently boxplots are unsupported (we intentionally - // stop with an error in the R code). The reason why is that - // boxplots are drawn using multiple geoms and it is not - // straightforward to deal with that using our current JS - // code. After all, a boxplot could be produced by combing 3 - // other geoms (rects, lines, and points) if you really wanted - // it. - - fill = "white"; - - elements = elements.data(data); - eActions = function (e) { - e.append("line") - .attr("x1", function (d) { - return scales.x(d["x"]); - }) - .attr("x2", function (d) { - return scales.x(d["x"]); - }) - .attr("y1", function (d) { - return scales.y(d["ymin"]); - }) - .attr("y2", function (d) { - return scales.y(d["lower"]); - }) - .style("stroke-dasharray", get_dasharray) - .style("stroke-width", get_size); - select_style_fun(g_info, e); - e.append("line") - .attr("x1", function (d) { - return scales.x(d["x"]); - }) - .attr("x2", function (d) { - return scales.x(d["x"]); - }) - .attr("y1", function (d) { - return scales.y(d["upper"]); - }) - .attr("y2", function (d) { - return scales.y(d["ymax"]); - }) - .style("stroke-dasharray", get_dasharray) - .style("stroke-width", get_size); - select_style_fun(g_info, e); - e.append("rect") - .attr("x", function (d) { - return scales.x(d["xmin"]); - }) - .attr("width", function (d) { - return scales.x(d["xmax"]) - scales.x(d["xmin"]); - }) - .attr("y", function (d) { - return scales.y(d["upper"]); - }) - .attr("height", function (d) { - return Math.abs(scales.y(d["upper"]) - scales.y(d["lower"])); - }) - .style("stroke-dasharray", get_dasharray) - .style("stroke-width", get_size) - select_style_fun(g_info, e); - e.append("line") - .attr("x1", function (d) { - return scales.x(d["xmin"]); - }) - .attr("x2", function (d) { - return scales.x(d["xmax"]); - }) - .attr("y1", function (d) { - return scales.y(d["middle"]); - }) - .attr("y2", function (d) { - return scales.y(d["middle"]); - }) - .style("stroke-dasharray", get_dasharray) - .style("stroke-width", get_size); - select_style_fun(g_info, e); - }; + if(g_info.params.hasOwnProperty("colour_off")){ + colour_off = g_info.params.colour_off; + }else{ + get_colour_off = get_colour_off_default; + } + if (g_info.params.hasOwnProperty("angle")) { + angle = g_info.params["angle"]; } + if (g_info.params.hasOwnProperty(fill_comes_from)) { + fill = g_info.params[fill_comes_from]; + } + if (g_info.params.hasOwnProperty(fill_off_comes_from)) { + fill_off = g_info.params[fill_off_comes_from]; + } + if(aes.hasOwnProperty(fill_comes_from)){ + get_fill = get_attr(fill_comes_from); + get_fill_off = get_attr(fill_comes_from); + }; + if (g_info.params.hasOwnProperty("size")) { + size = g_info.params.size; + } + var styleActions = function(e){ + g_info.style_list.forEach(function(s){ + e.style(s, function(d) { + var style_on_fun = style_on_funs[s]; + return style_on_fun(d); + }); + }); + }; + var style_on_funs = { + "opacity": get_alpha, + "stroke": get_colour, + "fill": get_fill, + "stroke-width": get_style_on_stroke_width, + "stroke-dasharray": get_dasharray + }; + var style_off_funs = { + "opacity": get_alpha_off, + "stroke": get_colour_off, + "fill": get_fill_off + }; + // TODO cleanup. + var select_style_default = ["opacity","stroke","fill"]; + g_info.select_style = select_style_default.filter( + X => g_info.style_list.includes(X)); + var over_fun = function(e){ + g_info.select_style.forEach(function(s){ + e.style(s, function (d) { + return style_on_funs[s](d); + }); + }); + }; + var out_fun = function(e){ + g_info.select_style.forEach(function(s){ + e.style(s, function (d) { + var select_on = style_on_funs[s](d); + var select_off = style_off_funs[s](d); + if(has_clickSelects){ + return ifSelectedElse( + d.clickSelects, + g_info.aes.clickSelects, + select_on, select_off); + }else if(has_clickSelects_variable){ + return ifSelectedElse( + d["clickSelects.value"], + d["clickSelects.variable"], + select_on, select_off); + } + }); + }); + }; + elements = elements.data(data_to_bind, key_fun); elements.exit().remove(); var enter = elements.enter(); if(g_info.aes.hasOwnProperty("href")){ @@ -1670,83 +1543,11 @@ var animint = function (to_select, json_file) { .append("svg:"+eAppend); }else{ enter = enter.append(eAppend) - .attr("class", "geom"); + .attr("class", "geom"); } + var moreActions = function(e){}; if (has_clickSelects || has_clickSelects_variable) { - var selected_funs = function(style_name, select_fun){ - style_on_funs = { - "opacity": get_alpha, - "stroke": get_colour, - "fill": get_fill - }; - style_off_funs = { - "opacity": get_alpha_off, - "stroke": get_colour_off, - "fill": get_fill_off - }; - if(select_fun == "mouseout"){ - return function (d) { - var select_on = style_on_funs[style_name](d); - var select_off = style_off_funs[style_name](d); - if(has_clickSelects){ - return ifSelectedElse(d.clickSelects, g_info.aes.clickSelects, - select_on, select_off); - }else if(has_clickSelects_variable){ - return ifSelectedElse(d["clickSelects.value"], - d["clickSelects.variable"], - select_on, select_off); - } - } - } else if(select_fun == "mouseover"){ - return function (d) { - return style_on_funs[style_name](d); - } - }; - }; //selected_funs. - // My original design for clicking/interactivity/transparency: - // Basically I wanted a really simple way to show which element - // in a group of clickable geom elements is currently - // selected. So I decided that all the non-selected elements - // should have alpha transparency 0.5 less than normal, and the - // selected element should have normal alpha transparency. Also, - // the element currently under the mouse has normal alpha - // transparency, to visually indicate that it can be - // clicked. Looking at my examples, you will see that I - // basically use this in two ways: - - // 1. By specifying - // geom_vline(aes(clickSelects=variable),alpha=0.5), which - // implies a normal alpha transparency of 0.5. So all the vlines - // are hidden (normal alpha 0.5 - 0.5 = 0), except the current - // selection and the current element under the mouse pointer are - // drawn a bit faded with alpha=0.5. - - // 2. By specifying e.g. geom_point(aes(clickSelects=variable)), - // that implies a normal alpha=1. Thus the current selection and - // the current element under the mouse pointer are fully drawn - // with alpha=1 and the others are shown but a bit faded with - // alpha=0.5 (normal alpha 1 - 0.5 = 0.5). - - // Edit 19 March 2014: Now there are two styles to show the - // selection, depending on the geom. For most geoms it is as - // described above. But for geoms like rects with - // aes(fill=numericVariable), using opacity to indicate the - // selection results in a misleading decoding of the fill - // variable. So in this case we set stroke to "black" for the - // current selection. - - // TODO: user-configurable selection styles. - - var over_fun = function(e){ - g_info.select_style.forEach(function(s){ - e.style(s, selected_funs(s, "mouseover")); - }) - }; - var out_fun = function(e){ - g_info.select_style.forEach(function(s){ - e.style(s, selected_funs(s, "mouseout")); - }) - }; + moreActions = out_fun; elements.call(out_fun) .on("mouseover", function (d) { d3.select(this).call(over_fun); @@ -1757,9 +1558,6 @@ var animint = function (to_select, json_file) { ; if(has_clickSelects){ elements.on("click", function (d) { - // The main idea of how clickSelects works: when we click - // something, we call update_selector with the clicked - // value. var s_name = g_info.aes.clickSelects; update_selector(s_name, d.clickSelects); }); @@ -1770,30 +1568,19 @@ var animint = function (to_select, json_file) { update_selector(s_name, s_value); }); } - }else{//has neither clickSelects nor clickSelects.variable. - elements.style("opacity", get_alpha); - // geom_segment/linerange/hline/vline no `stroke` with no clickSelects - const excludedGeoms = ["segment", "linerange", "hline", "vline"]; - if (!excludedGeoms.includes(g_info.geom)) { - elements.style("fill", get_fill); - } - if(g_info.geom != "text"){ // geom_text no `stroke` with no clickSelects - elements.style("stroke", get_colour); - } } + // Set attributes of only the entering elements. This is needed to + // prevent things from flying around from the upper left when they + // enter the plot. + var doActions = function(e) { + eActions(e); + styleActions(e); + moreActions(e) + }; + doActions(enter); // DO NOT DELETE! var has_tooltip = g_info.aes.hasOwnProperty("tooltip"); if(has_clickSelects || has_tooltip || has_clickSelects_variable){ - var text_fun, get_one; - if(g_info.data_is_object){ - get_one = function(d_or_kv){ - var one_group = keyed_data[d_or_kv.value]; - return one_group[0]; - }; - }else{ - get_one = function(d_or_kv){ - return d_or_kv; - }; - } + var text_fun; if(has_tooltip){ text_fun = function(d){ return d.tooltip; @@ -1811,37 +1598,29 @@ var animint = function (to_select, json_file) { // if elements have an existing title, remove it. elements.selectAll("title").remove(); elements.append("svg:title") - .text(function(d_or_kv){ - var d = get_one(d_or_kv); - return text_fun(d); - }) + .text(get_fun(text_fun)) ; } - // Set attributes of only the entering elements. This is needed to - // prevent things from flying around from the upper left when they - // enter the plot. - eActions(enter); // DO NOT DELETE! if(Selectors.hasOwnProperty(selector_name)){ var milliseconds = Selectors[selector_name].duration; elements = elements.transition().duration(milliseconds); } if(g_info.aes.hasOwnProperty("id")){ - elements.attr("id", id_fun); + elements.attr("id", get_attr("id")); } if(g_info.aes.hasOwnProperty("href")){ // elements are , children are e.g. var linked_geoms = elements.select(eAppend); - // d3.select(linked_geoms).data(data, key_fun); // WHY did we need this? - eActions(linked_geoms); - linkActions(elements); + doActions(linked_geoms); + elements.attr("xlink:href", get_attr("href")) + .attr("target", "_blank") + .attr("class", "geom"); }else{ // elements are e.g. - eActions(elements); // Set the attributes of all elements (enter/exit/stay) + doActions(elements); // Set the attributes of all elements (enter/exit/stay) } }; - - var value_tostring = function(selected_values) { //function that is helpful to change the format of the string var selector_url="#" @@ -1876,19 +1655,6 @@ var animint = function (to_select, json_file) { return selected_values; }; - // var counter=-1; - // var update_selector_url = function() { - // var selected_values=get_values(); - // var url=value_tostring(selected_values); - // if(counter===-1){ - // $(".table_selector_widgets").after(""); - // $(".selectorurl").append("

Current URL

"); - // $(".selectorurl").append(""); - // counter++; - // } - // $(".selectorurl a").attr("href",url).text(url); - // }; - // update scales for the plots that have update_axes option in // theme_animint function update_scales(p_name, axes, v_name, value){ @@ -2282,7 +2048,12 @@ var animint = function (to_select, json_file) { // Widgets at bottom of page //////////////////////////////////////////// element.append("br"); - + if(response.hasOwnProperty("source")){ + element.append("a") + .attr("id","a_source_href") + .attr("href", response.source) + .text("source"); + } // loading table. var show_hide_table = element.append("button") .text("Show download status table"); diff --git a/man/animint2gist.Rd b/man/animint2gist.Rd deleted file mode 100644 index 58afa45e..00000000 --- a/man/animint2gist.Rd +++ /dev/null @@ -1,34 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/z_gist.R -\name{animint2gist} -\alias{animint2gist} -\title{Convert a list of ggplots to an interactive animation and post files as a gist} -\usage{ -animint2gist(plot.list, description = plot.list$title, browse = TRUE, ...) -} -\arguments{ -\item{plot.list}{a named list of ggplots and option lists.} - -\item{description}{Brief description of gist. -This becomes the plot title on the bl.ocks/username page.} - -\item{browse}{logical. Prompt browser to view viz on bl.ocks.org} - -\item{...}{options passed onto \code{animint2dir} and \code{gistr::gist_create}} -} -\description{ -Before using this function set your appropriate 'github.username' and 'github.password' \link{options} -} -\examples{ -\dontrun{ -library(animint) -iris$id <- 1:nrow(iris) -viz <- list(petal=ggplot()+ - geom_point(aes(Petal.Width, Petal.Length, fill=Species, - clickSelects=id), data=iris), - sepal=ggplot()+ - geom_point(aes(Sepal.Width, Sepal.Length, fill=Species, - clickSelects=id), data=iris)) -animint2gist(viz, description = "My animint plot") -} -} diff --git a/man/animint2pages.Rd b/man/animint2pages.Rd new file mode 100644 index 00000000..0c3b0093 --- /dev/null +++ b/man/animint2pages.Rd @@ -0,0 +1,58 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/z_pages.R +\name{animint2pages} +\alias{animint2pages} +\title{Publish a list of ggplots as interactive visualizations on a GitHub repository} +\usage{ +animint2pages( + plot.list, + github_repo, + commit_message = "Commit from animint2pages", + private = FALSE, + required_opts = c("title", "source"), + ... +) +} +\arguments{ +\item{plot.list}{A named list of ggplots and option lists.} + +\item{github_repo}{The name of the GitHub repository to which the +files will be pushed.} + +\item{commit_message}{A string specifying the commit message for +the pushed files.} + +\item{private}{A logical flag indicating whether the GitHub +repository should be private or not (default FALSE).} + +\item{required_opts}{Character vector of plot.list element names +which are checked (stop with an error if not present). Use +required_opts=NULL to skip check.} + +\item{...}{Additional options passed onto \code{animint2dir}.} +} +\value{ +The function returns the initialized GitHub repository object. +} +\description{ +This function takes a named list of ggplots, generates interactive animations, +and pushes the generated files to a specified GitHub repository. You can +choose to keep the repository private or public. +Before using this function set your appropriate git 'user.username' and 'user.email' +} +\examples{ +\dontrun{ +library(animint2) +p1 <- ggplot(mtcars, aes(x = mpg, y = wt)) + + geom_point() +p2 <- ggplot(mtcars, aes(x = hp, y = wt)) + + geom_point() +viz <- list(plot1 = p1, plot2 = p2) +animint2pages( + viz, + github_repo = "my_animint2_plots", + commit_message = "New animint", + private = TRUE) +} + +} diff --git a/man/geom_histogram.Rd b/man/geom_histogram.Rd index 831d32d5..ffcd23bc 100644 --- a/man/geom_histogram.Rd +++ b/man/geom_histogram.Rd @@ -194,10 +194,6 @@ m + geom_histogram(origin = 0) + coord_trans(x = "log10") # Use origin = 0, to make sure we don't take sqrt of negative values m + geom_histogram(origin = 0) + coord_trans(x = "sqrt") -# You can also transform the y axis. Remember that the base of the bars -# has value 0, so log transformations are not appropriate -m <- ggplot(movies, aes(x = rating)) -m + geom_histogram(binwidth = 0.5) + scale_y_sqrt() } rm(movies) } diff --git a/man/ggplot_gtable.Rd b/man/ggplot_gtable.Rd index 11a4db39..27317dca 100644 --- a/man/ggplot_gtable.Rd +++ b/man/ggplot_gtable.Rd @@ -8,8 +8,6 @@ ggplot_gtable(data) } \arguments{ \item{data}{plot data generated by \code{\link{ggplot_build}}} - -\item{plot}{plot object} } \value{ a \code{\link{gtable}} object diff --git a/man/luv_colours.Rd b/man/luv_colours.Rd index 72592db0..e1bc7f34 100644 --- a/man/luv_colours.Rd +++ b/man/luv_colours.Rd @@ -6,7 +6,7 @@ \title{\code{colors()} in Luv space.} \format{ A data frame with 657 observations and 4 variables: -\itemize{ +\describe{ \item{L,u,v}{Position in Luv colour space} \item{col}{Colour name} } diff --git a/man/txhousing.Rd b/man/txhousing.Rd index 3c3a42e0..ffbdb1e5 100644 --- a/man/txhousing.Rd +++ b/man/txhousing.Rd @@ -6,7 +6,7 @@ \title{Housing sales in TX.} \format{ A data frame with 8602 observations and 9 variables: -\itemize{ +\describe{ \item{city}{Name of MLS area} \item{year,month,date}{Date} \item{sales}{Number of sales} diff --git a/man/update_gallery.Rd b/man/update_gallery.Rd new file mode 100644 index 00000000..79b44d49 --- /dev/null +++ b/man/update_gallery.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/z_pages.R +\name{update_gallery} +\alias{update_gallery} +\title{Update gallery} +\usage{ +update_gallery(gallery_path = "~/R/gallery") +} +\arguments{ +\item{gallery_path}{path to local github repo with gh-pages +active.} +} +\value{ +named list of data tables (meta and error). +} +\description{ +A gallery is a collection of meta-data about animints that have +been published to github pages. A gallery is defined as a github +repo that should have two source files in the gh-pages branch: +repos.txt (list of github repositories, one owner/repo per line) +and index.Rmd (source for web page with links to animints). To +perform the update, first repos.txt is read, then we clone each +repo which is not already present in meta.csv, and parse meta-data +(title, source, Capture.PNG) from the gh-pages branch, and write +the meta.csv/error.csv/Capture.PNG files, render index.Rmd to +index.html, commit, and push origin. For an example, see the main +gallery, \url{https://github.com/animint/gallery/tree/gh-pages} +which is updated using this function. +} +\author{ +Toby Dylan Hocking +} diff --git a/tests/testthat/helper-functions.R b/tests/testthat/helper-functions.R index fa91ecb2..64bc0ce2 100644 --- a/tests/testthat/helper-functions.R +++ b/tests/testthat/helper-functions.R @@ -192,7 +192,7 @@ expect_color <- function(computed, expected){ } if(grepl("rgb", computed[1])){ ## On firefox, grey50 is "rgb(127, 127, 127)" - computed.vec <- gsub("[rgb() ]", "", computed) + computed.vec <- gsub("[ )]", "", sub("rgb[(]", "", computed)) expected.mat <- col2rgb(expected) expected.vec <- apply(expected.mat, 2, paste, collapse=",") }else{ diff --git a/tests/testthat/test-compiler-aes-ggplot.r b/tests/testthat/test-compiler-aes-ggplot.r index 10396a60..fff10274 100644 --- a/tests/testthat/test-compiler-aes-ggplot.r +++ b/tests/testthat/test-compiler-aes-ggplot.r @@ -1,4 +1,5 @@ -context("Creating aesthetic mappings") +library(testthat) +library(animint2) test_that("aes() captures input expressions", { out <- aes(mpg, wt + 1) @@ -23,11 +24,7 @@ test_that("aes_string() doesn't parse non-strings", { expect_equal(aes_string(0.4)$x, 0.4) }) -test_that("aes_q() & aes_string() preserves explicit NULLs", { - expect_equal(aes_q(NULL), aes(NULL)) - expect_equal(aes_q(x = NULL), aes(NULL)) - expect_equal(aes_q(colour = NULL), aes(colour = NULL)) - +test_that("aes_string() preserves explicit NULLs", { expect_equal(aes_string(NULL), aes(NULL)) expect_equal(aes_string(x = NULL), aes(NULL)) expect_equal(aes_string(colour = NULL), aes(colour = NULL)) diff --git a/tests/testthat/test-compiler-ghpages.R b/tests/testthat/test-compiler-ghpages.R new file mode 100644 index 00000000..abefaa43 --- /dev/null +++ b/tests/testthat/test-compiler-ghpages.R @@ -0,0 +1,47 @@ +acontext("GitHub Pages") + +viz <- animint( + title="one to ten", + source="https://github.com/animint/animint2/tree/master/tests/testthat/test-compiler-ghpages.R", + p=ggplot(data.frame(x = 1:10, y = 1:10), aes(x, y)) + + geom_point()) + +test_that("error for viz with no title", { + viz.no.title <- viz + viz.no.title$title <- NULL + expect_error({ + animint2pages(viz.no.title, "no-title") + }, "plot.list does not contain option named title, which is required by animint2pages") +}) + +test_that("error for viz with no source", { + viz.no.source <- viz + viz.no.source$source <- NULL + expect_error({ + animint2pages(viz.no.source, "no-source") + }, "plot.list does not contain option named source, which is required by animint2pages") +}) + +test_that("animint2pages() returns owner/repo string", { + viz_owner_repo <- animint2pages(viz, github_repo = "animint2pages_test_repo") + expect_is(viz_owner_repo, "character") +}) + +test_that("animint2pages raises an error if no GitHub token is present", { + env.names <- c("GITHUB_PAT", "GITHUB_PAT_GITHUB_COM") + env.old <- Sys.getenv(env.names) + Sys.unsetenv(env.names) + ## removing env vars is necessary but not sufficient for this test, + ## because if they do not exist, then gitcreds::gitcreds_get() will + ## be called to set the env vars/token. + repo.root <- system("git rev-parse --show-toplevel", intern=TRUE) + config.file <- file.path(repo.root, ".git", "config") + config.old <- file.path(repo.root, ".git", "config.old") + file.copy(config.file, config.old, overwrite = TRUE) + cat("[credential]\n\tusername = FOO", file=config.file, append=TRUE) + expect_error({ + animint2pages(viz, github_repo = "test_repo") + }, "A GitHub token is required to create and push to a new repository. \nTo create a GitHub token, follow these steps:\n1. Go to https://github.com/settings/tokens/new?scopes=repo&description=animint2pages\n2. Confirm your password if prompted.\n3. Ensure that the 'repo' scope is checked.\n4. Click 'Generate token' at the bottom of the page.\n5. Copy the generated token.\nAfter creating the token, you can set it up in your R environment by running: \nSys.setenv(GITHUB_PAT=\"yourGithubPAT\") \ngert::git_config_global_set(\"user.name\", \"yourUserName\") \ngert::git_config_global_set(\"user.email\", \"yourEmail\") \n", fixed=TRUE) + do.call(Sys.setenv, as.list(env.old)) + file.copy(config.old, config.file, overwrite = TRUE) +}) diff --git a/tests/testthat/test-compiler-gist.R b/tests/testthat/test-compiler-gist.R deleted file mode 100644 index 5546fff0..00000000 --- a/tests/testthat/test-compiler-gist.R +++ /dev/null @@ -1,119 +0,0 @@ -acontext("gists") - -test_that("animint2gist() returns an object of class 'gist'", { - g <- animint2gist(list(p = qplot(1:10)), browse = FALSE) - expect_is(g, "gist") - gistr::delete(g) -}) - -data(WorldBank, package = "animint2") -not.na <- subset(WorldBank, !(is.na(life.expectancy) | is.na(fertility.rate))) -subset(not.na, is.na(not.na$population)) -subset(not.na, country == "Kuwait" & 1991 <= year & year <= 1995) -not.na[not.na$country=="Kuwait", "population"] <- 1700000 -BOTH <- function(df, top, side){ - data.frame(df, - top=factor(top, c("Fertility rate", "Years")), - side=factor(side, c("Years", "Life expectancy"))) -} -TS <- function(df)BOTH(df, "Years", "Life expectancy") -SCATTER <- function(df)BOTH(df, "Fertility rate", "Life expectancy") -TS2 <- function(df)BOTH(df, "Fertility rate", "Years") -years <- unique(not.na[, "year", drop=FALSE]) -by.country <- split(not.na, not.na$country) -min.years <- do.call(rbind, lapply(by.country, subset, year == min(year))) -min.years$year <- 1958 - -viz.chunk.none <- - list(ts=ggplot()+ - theme_bw()+ - theme(panel.margin=grid::unit(0, "lines"))+ - xlab("")+ - ylab("")+ - geom_tallrect(aes(xmin=year-1/2, xmax=year+1/2), - clickSelects="year", - data=TS(years), alpha=1/2)+ - theme_animint(width=1000, height=800)+ - geom_line(aes(year, life.expectancy, group=country, colour=region), - clickSelects="country", - data=TS(not.na), size=4, alpha=3/5)+ - geom_point(aes(year, life.expectancy, color=region, size=population), - data=TS(not.na), - showSelected="country", - clickSelects="country")+ - geom_text(aes(year, life.expectancy, colour=region, label=country), - data=TS(min.years), - showSelected="country", - clickSelects="country", - hjust=1)+ - geom_widerect(aes(ymin=year-1/2, ymax=year+1/2), - data=TS2(years), alpha=1/2, - clickSelects="year")+ - geom_path(aes(fertility.rate, year, group=country, colour=region), - data=TS2(not.na), size=4, alpha=3/5, - clickSelects="country")+ - geom_point(aes(fertility.rate, year, color=region, size=population), - data=TS2(not.na), - showSelected="country", clickSelects="country")+ - geom_point(aes(fertility.rate, life.expectancy, - key=country, - colour=region, size=population), - chunk_vars=c(), - clickSelects="country", - showSelected="year", - data=SCATTER(not.na), - validate_params = FALSE)+ - geom_text(aes(fertility.rate, life.expectancy, - key=country, - label=country), - chunk_vars=c(), - showSelected=c("country", "year", "region"), - clickSelects="country", - data=SCATTER(not.na), - validate_params = FALSE)+ - scale_size_animint(breaks=10^(5:9))+ - facet_grid(side ~ top, scales="free")+ - geom_text(aes(5, 85, label=paste0("year = ", year), key=year), - showSelected="year", - data=SCATTER(years)), - time=list(variable="year",ms=3000), - duration=list(year=1000), - first=list(year=1975, country=c("United States", "Vietnam")), - selector.types=list(country="multiple"), - title="World Bank data (multiple selection, facets)") - -test_that("too big files error", { - expect_error({ - animint2gist(viz.chunk.none) - }, "files bigger than 1MB") -}) - -set.seed(1) -nrows <- 300 -too.many <- data.frame(row=1:nrows, x=rnorm(nrows), y=rnorm(nrows)) -too.tall.list <- list() -for(col.name in c("x", "y")){ - too.tall.list[[col.name]] <- - data.frame(col.name, - row=1:nrows, - value=too.many[[col.name]]) -} -too.tall <- do.call(rbind, too.tall.list) - -viz.too.many <- - list(points=ggplot()+ - geom_point(aes(x, y), - data=too.many, clickSelects="row"), - bars=ggplot()+ - geom_bar(aes(col.name, value), - chunk_vars=c("row"), showSelected="row", - stat="identity", - position="identity", - data=too.tall, - validate_params = FALSE)) - -test_that("too many files error", { - expect_error({ - animint2gist(viz.too.many) - }, "the Gist API will not serve more than 300 files") -}) diff --git a/tests/testthat/test-compiler-layer.r b/tests/testthat/test-compiler-layer.r index c201747e..d8c3b811 100644 --- a/tests/testthat/test-compiler-layer.r +++ b/tests/testthat/test-compiler-layer.r @@ -8,11 +8,6 @@ test_that("aesthetics go in aes_params", { expect_equal(l$aes_params, list(size = "red")) }) -test_that("unknown params create error", { - skip("passes when validate_params=FALSE") - expect_error(geom_point(blah = "red"), "Unknown parameters") -}) - test_that("Unknown params create error with validate_params = TRUE", { expect_error(geom_point(blah = "red", validate_params = TRUE), "Unknown parameters") @@ -33,21 +28,21 @@ test_that("Unknown params go in extra_params, not aes_params", { # Calculated aesthetics --------------------------------------------------- test_that("Bare name surround by .. is calculated", { - expect_true(is_calculated_aes(aes(..density..))) - expect_true(is_calculated_aes(aes(..DENSITY..))) - expect_false(is_calculated_aes(aes(a..x..b))) + expect_true(animint2:::is_calculated_aes(aes(..density..))) + expect_true(animint2:::is_calculated_aes(aes(..DENSITY..))) + expect_false(animint2:::is_calculated_aes(aes(a..x..b))) }) test_that("Calling using variable surround by .. is calculated", { - expect_true(is_calculated_aes(aes(mean(..density..)))) - expect_true(is_calculated_aes(aes(mean(..DENSITY..)))) - expect_false(is_calculated_aes(aes(mean(a..x..b)))) + expect_true(animint2:::is_calculated_aes(aes(mean(..density..)))) + expect_true(animint2:::is_calculated_aes(aes(mean(..DENSITY..)))) + expect_false(animint2:::is_calculated_aes(aes(mean(a..x..b)))) }) test_that("strip_dots remove dots around calculated aesthetics", { - expect_equal(strip_dots(aes(..density..))$x, quote(density)) - expect_equal(strip_dots(aes(mean(..density..)))$x, quote(mean(density))) - expect_equal(strip_dots(aes(sapply(..density.., function(x) mean(x)))$x), + expect_equal(animint2:::strip_dots(aes(..density..))$x, quote(density)) + expect_equal(animint2:::strip_dots(aes(mean(..density..)))$x, quote(mean(density))) + expect_equal(animint2:::strip_dots(aes(sapply(..density.., function(x) mean(x)))$x), quote(sapply(density, function(x) mean(x)))) }) diff --git a/tests/testthat/test-compiler-plot-named-timexxx.R b/tests/testthat/test-compiler-plot-named-timexxx.R index bd17a8de..d11a5e1c 100644 --- a/tests/testthat/test-compiler-plot-named-timexxx.R +++ b/tests/testthat/test-compiler-plot-named-timexxx.R @@ -26,14 +26,16 @@ viz <- duration=list(year=1000)) test_that("plot named timeSeries is OK without time option list", { - animint2dir(viz, open.browser=FALSE) + meta <- animint2dir(viz, open.browser=FALSE) + expect_is(meta, "environment") }) viz.time <- viz viz.time$time <- list(ms=2000, variable="year") test_that("plot named timeSeries is OK with time option list", { - animint2dir(viz.time, open.browser=FALSE) + meta <- animint2dir(viz.time, open.browser=FALSE) + expect_is(meta, "environment") }) bad <- diff --git a/tests/testthat/test-compiler-stat-bin.R b/tests/testthat/test-compiler-stat-bin.R index fee1c6b7..3c2fa891 100644 --- a/tests/testthat/test-compiler-stat-bin.R +++ b/tests/testthat/test-compiler-stat-bin.R @@ -2,13 +2,8 @@ context("stat_bin/stat_count") test_that("stat_bin throws error when y aesthetic present", { dat <- data.frame(x = c("a", "b", "c"), y = c(1, 5, 10)) - expect_error(ggplot_build(ggplot(dat, aes(x, y)) + stat_bin()), "must not be used with a y aesthetic.") - - skip("passes when validate_params=TRUE") - expect_error(p <- ggplot_build(ggplot(dat, aes(x)) + stat_bin(y = 5)), - "Unknown parameters: y") }) test_that("bins specifies the number of bins", { @@ -97,12 +92,8 @@ test_that("weights are added", { test_that("stat_count throws error when y aesthetic present", { dat <- data.frame(x = c("a", "b", "c"), y = c(1, 5, 10)) - expect_error(ggplot_build(ggplot(dat, aes(x, y)) + stat_count()), "must not be used with a y aesthetic.") - skip("passes when validate_params=TRUE") - expect_error(p <- ggplot_build(ggplot(dat, aes(x)) + stat_count(y = 5)), - "Unknown parameters: y") }) test_that("stat_count preserves x order for continuous and discrete", { diff --git a/tests/testthat/test-renderer1-PeakConsistency.R b/tests/testthat/test-renderer1-PeakConsistency.R index 4718d7c4..b8652620 100644 --- a/tests/testthat/test-renderer1-PeakConsistency.R +++ b/tests/testthat/test-renderer1-PeakConsistency.R @@ -1,16 +1,16 @@ acontext("PeakConsistency") - +library(animint2) data(PeakConsistency, package = "animint2") -color.code <- - c(truth="#1B9E77", #teal - PeakSeg="#D95F02", #orange - PeakSegJoint="#7570B3", #violet - "#E7298A", #pink - "#66A61E", #green - "#E6AB02", #tan - "#A6761D", #brown - "#666666") #grey +color.code <- c( + truth="#1B9E77", #teal + PeakSeg="#D95F02", #orange + PeakSegJoint="#7570B3", #violet + "#E7298A", #pink + "#66A61E", #green + "#E6AB02", #tan + "#A6761D", #brown + "#666666") #grey second.small <- list(signals=ggplot()+ @@ -51,53 +51,58 @@ test_that("15 segments of both colors", { expect_equal(color.counts, c(15, 15)) }) -viz <- - list(increase=ggplot()+ - make_tallrect(PeakConsistency$increase, "increase")+ - geom_line(aes(increase, mean.diff), data=PeakConsistency$increase), - errors=ggplot()+ - ylab("distance from true peaks to estimated peaks")+ - scale_color_manual(values=color.code)+ - make_tallrect(PeakConsistency$error, "sample.size")+ - geom_line(aes(sample.size, errors, - group=interaction(model, seed), - color=model), - showSelected="increase", - clickSelects="seed", - size=5, - alpha=0.7, - data=PeakConsistency$error), - signals=ggplot()+ - theme_bw()+ - theme_animint(width=1000, height=800)+ - theme(panel.margin=grid::unit(0, "cm"))+ - facet_grid(sample.id ~ ., labeller=function(val){ - mapply(paste, "sample", val, SIMPLIFY = FALSE) - })+ - geom_point(aes(chromEnd, count), - showSelected=c("seed", "increase"), - color="grey50", - data=PeakConsistency$signal)+ - geom_vline(aes(xintercept=chromStart+0.5, color=model), - showSelected=c("increase", "seed"), - show.legend=TRUE, - linetype="dashed", - data=PeakConsistency$truth)+ - guides(size="none")+ - geom_segment(aes(chromStart+0.5, mean, - xend=chromEnd+0.5, yend=mean, - color=model, size=model), - showSelected=c("seed", "sample.size", "increase"), - data=PeakConsistency$model)+ - geom_vline(aes(xintercept=chromStart+0.5, - color=model, size=model), - showSelected=c("seed", "sample.size", "increase"), - show.legend=TRUE, - linetype="dashed", - data=PeakConsistency$guess)+ - scale_size_manual(values=c(PeakSegJoint=1, PeakSeg=2))+ - scale_color_manual(values=color.code), - first=list(sample.size=5)) +viz <- list( + increase=ggplot()+ + make_tallrect(PeakConsistency$increase, "increase")+ + geom_line(aes(increase, mean.diff), data=PeakConsistency$increase), + errors=ggplot()+ + ylab("distance from true peaks to estimated peaks")+ + scale_color_manual(values=color.code)+ + make_tallrect(PeakConsistency$error, "sample.size")+ + geom_line(aes( + sample.size, errors, + group=interaction(model, seed), + color=model), + showSelected="increase", + clickSelects="seed", + size=5, + alpha=0.7, + data=PeakConsistency$error), + signals=ggplot()+ + theme_bw()+ + theme_animint(width=1000, height=800)+ + theme(panel.margin=grid::unit(0, "cm"))+ + facet_grid(sample.id ~ ., labeller=function(val){ + mapply(paste, "sample", val, SIMPLIFY = FALSE) + })+ + geom_point(aes( + chromEnd, count), + showSelected=c("seed", "increase"), + color="grey50", + data=PeakConsistency$signal)+ + geom_vline(aes( + xintercept=chromStart+0.5, color=model), + showSelected=c("increase", "seed"), + show.legend=TRUE, + linetype="dashed", + data=PeakConsistency$truth)+ + guides(size="none")+ + geom_segment(aes( + chromStart+0.5, mean, + xend=chromEnd+0.5, yend=mean, + color=model, size=model), + showSelected=c("seed", "sample.size", "increase"), + data=PeakConsistency$model)+ + geom_vline(aes( + xintercept=chromStart+0.5, + color=model, size=model), + showSelected=c("seed", "sample.size", "increase"), + show.legend=TRUE, + linetype="dashed", + data=PeakConsistency$guess)+ + scale_size_manual(values=c(PeakSegJoint=1, PeakSeg=2))+ + scale_color_manual(values=color.code), + first=list(sample.size=5)) ## viz$errors+facet_grid(. ~ increase) ## viz$signals+facet_grid(sample.id ~ increase + seed) @@ -105,10 +110,11 @@ viz <- info <- animint2HTML(viz) test_that("4 paths of both colors in second plot", { - path.list <- - getNodeSet(info$html, '//g[@class="geom4_line_errors"]//path') + path.list <- getNodeSet( + info$html, '//g[@class="geom4_line_errors"]//path') computed.vec <- getStroke(path.list) color.counts <- as.numeric(table(computed.vec)) + print(color.counts) expect_equal(color.counts, c(4, 4)) }) diff --git a/tests/testthat/test-renderer1-geom-text-color.R b/tests/testthat/test-renderer1-geom-text-color.R new file mode 100644 index 00000000..e5f40669 --- /dev/null +++ b/tests/testthat/test-renderer1-geom-text-color.R @@ -0,0 +1,32 @@ +acontext("geom text color") +library(animint2) +df <- data.frame(x=1,y="foo") +viz <- animint( + text=ggplot()+ + geom_text(aes(x, 4, label=y, id="ONETEXT"), color="black", clickSelects="y", data=df)+ + geom_text(aes(x, 3, label=y, color=y), data=df)+ + scale_color_manual(values=c(foo="blue"))+ + geom_text(aes(x, 2, label=y), color="red", data=df)+ + geom_text(aes(x, 1, label=y), color="black", color_off="pink", clickSelects="y", data=df)) + +info <- animint2HTML(viz) +test_that("geom_text color rendered as fill style", { + fill <- getStyleValue(info$html, '//text[@class="geom"]', "fill") + expect_color(fill, c("black", "blue","red","black")) + opacity <- getStyleValue(info$html, '//text[@class="geom"]', "opacity") + expect_identical(opacity, c("1","1","1","1")) +}) + +clickID("ONETEXT") +after.html <- getHTML() +test_that("geom_text color rendered as fill style", { + fill <- getStyleValue(after.html, '//text[@class="geom"]', "fill") + print(fill) + expect_color(fill, c("black", "red","pink")) +}) + +test_that("default text alpha_off correct", { + opacity <- getStyleValue(after.html, '//text[@class="geom"]', "opacity") + print(opacity) + expect_identical(opacity, c("0.5","1","0.5")) +}) diff --git a/tests/testthat/test-renderer1-global-variables.R b/tests/testthat/test-renderer1-global-variables.R index d32e9e20..5c84ab33 100644 --- a/tests/testthat/test-renderer1-global-variables.R +++ b/tests/testthat/test-renderer1-global-variables.R @@ -33,5 +33,6 @@ test_that("animint.js only defines 1 object, called animint", { remDr$refresh() without.vars <- getVariables() diff.vars <- animint.vars[!animint.vars %in% without.vars] + print(diff.vars) expect_identical(diff.vars, "animint") }) diff --git a/tests/testthat/test-renderer1-href.R b/tests/testthat/test-renderer1-href.R index 957b3bc8..ca6ea23d 100644 --- a/tests/testthat/test-renderer1-href.R +++ b/tests/testthat/test-renderer1-href.R @@ -1,44 +1,49 @@ acontext("aes(href)") -color.df <- - data.frame(x=c(1, 1, 2, 1, 2), - university=c("Stanford", - rep("UC Berkeley", 2), - rep("Oregon State", 2)), - color=c("red", "blue", "gold", "orange", "black")) +color.df <- data.frame( + x=c(1, 1, 2, 1, 2), + university=c( + "Stanford", + rep("UC Berkeley", 2), + rep("Oregon State", 2)), + color=c("red", "blue", "gold", "orange", "black")) university.df <- as.data.frame(table(color.df$university)) names(university.df) <- c("university", "colors") test_that("clickSelects and href is an error", { - viz <- - list(colors=ggplot()+ - geom_point(aes(x, university, color=color, href=color), - clickSelects="university", - data=color.df)+ - scale_color_identity()) + viz <- list( + colors=ggplot()+ + geom_point(aes( + x, university, color=color, href=color), + clickSelects="university", + data=color.df)+ + scale_color_identity()) expect_error({ animint2dir(viz, open.browser=FALSE) }, "clickSelects can not be used with aes(href)", fixed=TRUE) }) test_that("aes(href) becomes ", { - viz <- - list(universities=ggplot()+ - geom_bar(aes(university, colors, - id=university), - clickSelects="university", - data=university.df, stat="identity"), - colors=ggplot()+ - geom_point(aes(x, university, color=color, - href=paste0("http://en.wikipedia.org/wiki/", color)), - showSelected="university", - data=color.df, size=5)+ - scale_color_identity(), - first=list(university="UC Berkeley")) + viz <- list( + universities=ggplot()+ + geom_bar(aes( + university, colors, + id=university), + clickSelects="university", + data=university.df, stat="identity"), + colors=ggplot()+ + geom_point(aes( + x, university, color=color, + href=paste0("http://en.wikipedia.org/wiki/", color)), + showSelected="university", + data=color.df, size=5)+ + scale_color_identity(), + first=list(university="UC Berkeley")) info <- animint2HTML(viz) - expect_links(info$html, - c("http://en.wikipedia.org/wiki/blue", - "http://en.wikipedia.org/wiki/gold")) + expected.links <- c( + "http://en.wikipedia.org/wiki/blue", + "http://en.wikipedia.org/wiki/gold") + expect_links(info$html, expected.links) }) test_that("clicking updates href", { diff --git a/tests/testthat/test-renderer1-interactivity.R b/tests/testthat/test-renderer1-interactivity.R index 5d23df70..d8805c08 100644 --- a/tests/testthat/test-renderer1-interactivity.R +++ b/tests/testthat/test-renderer1-interactivity.R @@ -1,5 +1,5 @@ acontext("interactivity") - +library(animint2) ## Example: 2 plots, 2 selectors, but only interacting with 1 plot. data(breakpoints, package = "animint2") only.error <- subset(breakpoints$error,type=="E") @@ -182,32 +182,37 @@ library(plyr) UStornadoCounts <- ddply(UStornadoes, .(state, year), summarize, count=length(state)) seg.color <- "#55B1F7" -tornado.lines <- - list(map=ggplot()+ - make_text(UStornadoCounts, -100, 50, "year", "Tornadoes in %d")+ - geom_polygon(aes(x=long, y=lat, group=group, - id=state), - clickSelects="state", - data=USpolygons, fill="black", colour="grey") + - geom_segment(aes(x=startLong, y=startLat, xend=endLong, yend=endLat), - showSelected="year", - colour=seg.color, data=UStornadoes)+ - scale_fill_manual(values=c(end=seg.color))+ - theme_animint(width=750, height=500)+ - geom_point(aes(endLong, endLat, fill=place), - colour=seg.color, showSelected="year", - data=data.frame(UStornadoes,place="end")), - ts=ggplot()+ - geom_text(aes(year, count, label=state), - hjust=0, showSelected="state", - data=subset(UStornadoCounts, year==max(year)))+ - make_tallrect(UStornadoCounts, "year")+ - geom_line(aes(year, count, - group=state), - showSelected="state", - data=UStornadoCounts), - selector.types=list(state="multiple"), - first=list(state=c("CA", "NY"), year=1950)) +tornado.lines <- list( + map=ggplot()+ + make_text(UStornadoCounts, -100, 50, "year", "Tornadoes in %d")+ + geom_polygon(aes( + x=long, y=lat, group=group, + id=state), + clickSelects="state", + data=USpolygons, fill="black", colour="grey") + + geom_segment(aes( + x=startLong, y=startLat, xend=endLong, yend=endLat), + showSelected="year", + colour=seg.color, data=UStornadoes)+ + scale_fill_manual(values=c(end=seg.color))+ + theme_animint(width=750, height=500)+ + geom_point(aes( + endLong, endLat, fill=place), + colour=seg.color, showSelected="year", + data=data.frame(UStornadoes,place="end")), + ts=ggplot()+ + geom_text(aes( + year, count, label=state), + hjust=0, showSelected="state", + data=subset(UStornadoCounts, year==max(year)))+ + make_tallrect(UStornadoCounts, "year")+ + geom_line(aes( + year, count, + group=state), + showSelected="state", + data=UStornadoCounts), + selector.types=list(state="multiple"), + first=list(state=c("CA", "NY"), year=1950)) test_that("1950 and elements", { ## A warning should be issued when there is showSelected=place and diff --git a/tests/testthat/test-renderer1-text.R b/tests/testthat/test-renderer1-text.R index e9d7129c..5cf406a1 100644 --- a/tests/testthat/test-renderer1-text.R +++ b/tests/testthat/test-renderer1-text.R @@ -1,5 +1,5 @@ acontext("Text") - +library(animint2) data(WorldBank, package = "animint2") wb2010 <- subset(WorldBank, year==2010) subset(wb2010, population==min(population)) @@ -11,11 +11,13 @@ subset(wb2010, population==min(population)) ### fact there will be no text element with fontsize=10! wb <- subset(wb2010, !is.na(population) & !is.na(fertility.rate) & !is.na(life.expectancy)) -viz <- list(scatter=ggplot()+ - geom_text(aes(y=fertility.rate, x=life.expectancy, - label=country, size=population, colour=population, id=country), - data=wb)+ - scale_size_continuous(range=c(10,20))) +viz <- list( + scatter=ggplot()+ + geom_text(aes( + y=fertility.rate, x=life.expectancy, + label=country, size=population, colour=population, id=country), + data=wb)+ + scale_size_continuous(range=c(10,20))) test_that("text size range translates to ", { info <- animint2HTML(viz) @@ -47,13 +49,14 @@ plot.vec <- data.frame( angle ) -viz.aes.angle <- list(scatter = scatter.plot <- ggplot() + - geom_text( - data=plot.vec, - aes(x = x, y = y, label = labs, angle = angle), - clickSelects = "x", - size = 30 - )) +viz.aes.angle <- list( + scatter = ggplot() + + geom_text( + data=plot.vec, + aes(x = x, y = y, label = labs, angle = angle), + clickSelects = "x", + size = 30 + )) test_that("text rotation applies to when applied in aes", { info <- animint2HTML(viz.aes.angle) @@ -66,14 +69,15 @@ test_that("text rotation applies to when applied in aes", { expect_true(any(grepl("0", transform))) }) -viz.geom.angle <- list(scatter = scatter.plot <- ggplot() + - geom_text( - data = plot.vec, - aes(x = x, y = y, label = labs), - angle = 90, - clickSelects = "x", - size = 30 - )) +viz.geom.angle <- list( + scatter = ggplot() + + geom_text( + data = plot.vec, + aes(x = x, y = y, label = labs), + angle = 90, + clickSelects = "x", + size = 30 + )) test_that("text rotation applies to when used in geom", { @@ -83,4 +87,4 @@ test_that("text rotation applies to when used in geom", { geom <- getNodeSet(info$html, '//text[@class="geom"]') transform <- data.frame(t(sapply(geom, xmlAttrs)))$transform expect_true(any(grepl("-90", transform))) -}) \ No newline at end of file +}) diff --git a/tests/testthat/test-renderer1-theme-text-size.R b/tests/testthat/test-renderer1-theme-text-size.R index 6ea394f3..c547a717 100644 --- a/tests/testthat/test-renderer1-theme-text-size.R +++ b/tests/testthat/test-renderer1-theme-text-size.R @@ -107,20 +107,24 @@ test_that("specified legend title and label text size with rel()", { ## TDH default theme test, 1 Sep 2022. y <- 1:2 df <- data.frame(y, text=paste("category", y)) +sc <- scale_color_manual(values=c("category 1"="blue", "category 2"="red")) viz <- animint( default=ggplot()+ ggtitle("No theme specified")+ + sc+ geom_text(aes( 0,y,label=text,color=text), data=df), theme=ggplot()+ ggtitle("theme_grey()")+ + sc+ theme_grey()+ geom_text(aes( 0,y,label=text,color=text), data=df), sizeNum=ggplot()+ ggtitle("theme_grey()+theme(legend.text)")+ + sc+ theme_grey()+ theme(legend.text=element_text(size=16))+ geom_text(aes( @@ -128,6 +132,7 @@ viz <- animint( data=df), sizePx=ggplot()+ ggtitle("theme_grey()+theme(legend.text)")+ + sc+ theme_grey()+ theme(legend.text=element_text(size="16px"))+ geom_text(aes( @@ -149,6 +154,12 @@ test_that("theme_grey legend entry text size is 16px", { expect_match(size.list$sizePx, "16px") }) +test_that("text colors rendered", { + computed.colors <- getStyleValue( + info$html, '//svg[@id="plot_default"]//text[@class="geom"]', "fill") + expect_color(computed.colors, c("blue", "red")) +}) + test_that("Warning for invalid character/string input ", { viz <- list( s=scatterFacet + theme(axis.text.x = element_text(size = "12p"))) diff --git a/tests/testthat/test-renderer2-colour.R b/tests/testthat/test-renderer2-colour.R index 44248838..b6cd32ce 100644 --- a/tests/testthat/test-renderer2-colour.R +++ b/tests/testthat/test-renderer2-colour.R @@ -1,263 +1,215 @@ acontext("colour_off, color_off") - -# -# test geom without fill style -# -g1 <- ggplot()+ -geom_line(data=economics_long, - aes(x=date, y=value01, group = variable), - clickSelects="variable")+ - ggtitle("default to alpha_off(0.5) style") - -g2 <- ggplot() + - geom_line(data=economics_long, - aes(x=date, y=value01, group = variable), - colour = "red", - colour_off = "black", - clickSelects="variable")+ - ggtitle("With colour_off") - -g3 <- ggplot() + -geom_line(data=economics_long, -aes(x=date, y=value01, group = variable), - colour = "red", - colour_off = "black", - alpha_off=0.5, - clickSelects="variable")+ -ggtitle("colour_off + alpha_off") - -viz.line <- list(one = g1, - two = g2, - three = g3) +library(animint2) + +## test geom without fill style +viz.line <- list( + default = ggplot()+ + geom_line(aes( + x=date, y=value01, group = variable), + data=economics_long, + clickSelects="variable")+ + ggtitle("default to alpha_off(0.5) style"), + coff=ggplot() + + geom_line(aes( + x=date, y=value01, group = variable), + colour = "red", + colour_off = "black", + data=economics_long, + clickSelects="variable")+ + ggtitle("With colour_off"), + acoff=ggplot() + + geom_line(aes( + x=date, y=value01, group = variable), + colour = "red", + colour_off = "black", + alpha_off=1, + data=economics_long, + clickSelects="variable")+ + ggtitle("colour_off + alpha_off")) info <- animint2HTML(viz.line) - test_that("default clicking line only changes opacity", { - line.xpath <- '//svg[@id="plot_one"]//path[@class="geom"]' - node.list <- getNodeSet(info$html, line.xpath) - opacity.str <- getStyleValue(info$html, line.xpath, "opacity") - opacity.num <- as.numeric(opacity.str) - clicked.list <- node.list[opacity.num == 1] - nonclicked.list <- node.list[opacity.num == 0.5] - - # there shall be 1 line shows opacity=1, and the other 4 lines - # opacity = 0.5/whatever user defines - expect_equal(length(clicked.list), 1) - expect_equal(length(nonclicked.list), 4) - # color doesn't change - stroke.vec <- getStyleValue(info$html, line.xpath, "stroke") - color.vec <- rep("black", 5) - expect_color(stroke.vec, color.vec) + opacity.str <- getStyleValue( + info$html, + '//svg[@id="plot_default"]//path[@class="geom"]', + "opacity") + opacity.tab <- sort(table(opacity.str)) + expect_equal(as.numeric(opacity.tab), c(1, 4)) + expect_equal(names(opacity.tab), c("1","0.5")) + stroke.str <- getStyleValue( + info$html, + '//svg[@id="plot_default"]//path[@class="geom"]', + "stroke") + expect_color(stroke.str, rep("black", 5)) }) -test_that("using colour_off, clicking line only changes stroke", { - line.xpath <- '//svg[@id="plot_two"]//path[@class="geom"]' - node.list <- getNodeSet(info$html, line.xpath) - stroke.vec <- getStyleValue(info$html, line.xpath, "stroke") - colour.off.col <- "black" - colour <- "red" - - # On firefox, stroke is "rgb(127, 127, 127)" - # On phantomjs, stroke is "#7f7f7f" - if(grepl("rgb", stroke.vec[1])){ - nonclick.colour <- paste(col2rgb(colour.off.col), collapse=", ") - click.colour <- paste(col2rgb(colour), collapse=", ") - } else{ - nonclick.colour <- as.character(toRGB(colour.off.col)) - click.colour <- as.character(toRGB(colour)) - } - clicked.list <- node.list[grepl(click.colour, stroke.vec)] - nonclicked.list <- node.list[grepl(nonclick.colour, stroke.vec)] - expect_equal(length(clicked.list), 1) - expect_equal(length(nonclicked.list), 4) - # opacity remains the same - opacity.str <- getStyleValue(info$html, line.xpath, "opacity") - opacity.num <- as.numeric(opacity.str) - opacity.list <- node.list[opacity.num == 1] - expect_equal(length(opacity.list), 5) +test_that("setting colour_off makes stroke and opacity change", { + opacity.str <- getStyleValue( + info$html, + '//svg[@id="plot_coff"]//path[@class="geom"]', + "opacity") + opacity.tab <- sort(table(opacity.str)) + expect_equal(as.numeric(opacity.tab), c(1, 4)) + expect_equal(names(opacity.tab), c("1","0.5")) + stroke.str <- getStyleValue( + info$html, + '//svg[@id="plot_coff"]//path[@class="geom"]', + "stroke") + stroke.tab <- sort(table(stroke.str)) + expect_equal(as.numeric(stroke.tab), c(1, 4)) + expect_color(names(stroke.tab), c("red","black")) }) -test_that("using both alpha_off and colour_off, opacity and stroke change simultaneously", { - line.xpath <- '//svg[@id="plot_three"]//path[@class="geom"]' - node.list <- getNodeSet(info$html, line.xpath) - stroke.vec <- getStyleValue(info$html, line.xpath, "stroke") - colour.off.col <- "black" - colour <- "red" - if(grepl("rgb", stroke.vec[1])){ - nonclick.colour <- paste(col2rgb(colour.off.col), collapse=", ") - click.colour <- paste(col2rgb(colour), collapse=", ") - } else{ - nonclick.colour <- as.character(toRGB(colour.off.col)) - click.colour <- as.character(toRGB(colour)) - } - clicked.list <- node.list[grepl(click.colour, stroke.vec)] - nonclicked.list <- node.list[grepl(nonclick.colour, stroke.vec)] - expect_equal(length(clicked.list), 1) - expect_equal(length(nonclicked.list), 4) - # opacity changes as well - opacity.str <- getStyleValue(info$html, line.xpath, "opacity") - opacity.num <- as.numeric(opacity.str) - clicked.list <- node.list[opacity.num == 1] - nonclicked.list <- node.list[opacity.num == 0.5] - expect_equal(length(clicked.list), 1) - expect_equal(length(nonclicked.list), 4) +test_that("setting alpha_off and colour_off makes only stroke change", { + opacity.str <- getStyleValue( + info$html, + '//svg[@id="plot_acoff"]//path[@class="geom"]', + "opacity") + opacity.tab <- sort(table(opacity.str)) + expect_equal(as.numeric(opacity.tab), 5) + expect_equal(names(opacity.tab), "1") + stroke.str <- getStyleValue( + info$html, + '//svg[@id="plot_acoff"]//path[@class="geom"]', + "stroke") + stroke.tab <- sort(table(stroke.str)) + expect_equal(as.numeric(stroke.tab), c(1, 4)) + expect_color(names(stroke.tab), c("red","black")) }) -# -# test geom with both fill and colour styles -# -viz.point <- list(pointone = ggplot() + geom_point( - data = mtcars, - size = 10, - aes(x=wt, y=mpg, +## test geom with both fill and colour styles +viz.point <- list( + default = ggplot() + + geom_point(aes( + x=wt, y=mpg, colour = disp), - clickSelects = "gear")+ - ggtitle("default alpha_off(0.5) style"), - -pointtwo = ggplot() + geom_point( - data = mtcars, - colour="red", - colour_off="transparent", - size = 10, - aes(x=wt, y=mpg, + data = mtcars, + size = 10, + clickSelects = "gear")+ + ggtitle("default alpha_off(0.5) style"), + acoff = ggplot() + + geom_point(aes( + x=wt, y=mpg, fill = disp), - clickSelects = "gear")+ - ggtitle("colour=\"red\", colour_off=\"transparent\" "), - -pointthree = ggplot() + geom_point( - data = mtcars, - alpha_off=0.5, - colour="red", - colour_off="transparent", - size = 10, - aes(x=wt, y=mpg, - fill = disp, - id=paste0("pointthree_disp", disp, "gear", gear, "wt", wt)), - clickSelects = "gear")+ - ggtitle("colour_off + alpha_off")) - -info2 <- animint2HTML(viz.point) - -test_that("color_off only changes colour/stroke when clicked, fill does not change", { - point.xpath <- '//svg[@id="plot_pointthree"]//circle[@id="pointthree_disp275.8gear3wt3.73"]' - circle.list <- getNodeSet(info2$html, point.xpath) - before.click.color <- getStyleValue(info2$html, point.xpath, "stroke") - before.click.fill <- getStyleValue(info2$html, point.xpath, "fill") - - clickID('pointthree_disp275.8gear3wt3.73') - html <- getHTML() - after.click.color <- getStyleValue(html, point.xpath, "stroke") - after.click.fill <- getStyleValue(html, point.xpath, "fill") - - expect_false(isTRUE(all.equal(before.click.color, after.click.color))) - expect_equal(before.click.fill, after.click.fill) + data = mtcars, + colour="red", + colour_off="yellow", + alpha_off=1, + size = 10, + clickSelects = "gear")+ + ggtitle("colour=\"red\", colour_off=\"transparent\" ")) + +info.point <- animint2HTML(viz.point) + +test_that("default for point makes only alpha change", { + opacity.str <- getStyleValue( + info.point$html, + '//svg[@id="plot_default"]//circle[@class="geom"]', + "opacity") + opacity.tab <- table(opacity.str) + expect_equal(sort(names(opacity.tab)), c("0.5","1")) }) -test_that("fill and color are not same", { - point.xpath <- '//svg[@id="plot_pointthree"]//circle[@class="geom"]' - circle.list <- getNodeSet(info2$html, point.xpath) - circle.color <- getStyleValue(info2$html, point.xpath, "stroke") - circle.fill <- getStyleValue(info2$html, point.xpath, "fill") - expect_false(isTRUE(all.equal(circle.color, circle.fill))) +test_that("setting alpha_off and colour_off makes only stroke change", { + opacity.str <- getStyleValue( + info.point$html, + '//svg[@id="plot_acoff"]//circle[@class="geom"]', + "opacity") + opacity.tab <- table(opacity.str) + expect_equal(names(opacity.tab), "1") + stroke.str <- getStyleValue( + info.point$html, + '//svg[@id="plot_acoff"]//circle[@class="geom"]', + "stroke") + stroke.tab <- sort(table(stroke.str)) + expect_color(names(stroke.tab), c("red","yellow")) }) # # tests for g$geom="rect", originally only support 'stroke' as selection style # +library(data.table) row.vec <- paste("row", c(1:3)) col.vec <- paste("col", c(1:3)) heat.data <- data.table(row.name = row.vec, col.name = rep(col.vec, each=length(row.vec)), value = c(2,8,-5,-7,15,3,-1,6,-7.5)) -no.col <- ggplot() + - geom_tile(data=heat.data, - aes(x = row.name, y = col.name, fill = value, - id=paste0("no_col_", value)), - size = 5, - clickSelects = "value") -has.col.no.off <- ggplot() + - geom_tile(data=heat.data, - aes(x = row.name, y = col.name, fill = value, - id=paste0("col_", value)), - colour="red", - size = 5, - clickSelects = "value") -has.col.and.off <- ggplot() + - geom_tile(data=heat.data, - aes(x = row.name, y = col.name, fill = value, - id=paste0("col_off_", value)), - colour="red", - colour_off="grey50", - size = 5, - clickSelects = "value") viz.tile <- list( - nocol=no.col, - colnooff=has.col.no.off, - colandoff=has.col.and.off) - -info <- animint2HTML(viz.tile) - -test_that("if has clickSelects but no colour/colour_off, selection colour/stroke should be black, and transparent for not selected (no stroke)", { - clickID('no_col_2') - html <- getHTML() - stroke.col <- getStyleValue( - info$html, '//g[@class="geom1_tile_nocol"]//rect[@id="no_col_2"]', "stroke") - expect.stroke.col <- "black" - expect_color(stroke.col, expect.stroke.col) - # not selected, stroke=transparent(no stroke style) - node.set <- getNodeSet(info$html, '//g[@class="geom1_tile_nocol"]//rect[@id="no_col_8"]') - expect_no_style(node.set, "stroke") + default=ggplot() + + geom_tile(aes( + x = row.name, y = col.name, fill = value), + size = 5, + data=heat.data, + clickSelects = "value"), + colandoff=ggplot() + + geom_tile(aes( + x = row.name, y = col.name, fill = value), + data=heat.data, + colour="red", + colour_off="grey50", + size = 5, + clickSelects = "value"), + filloff=ggplot() + + geom_tile(aes( + x = row.name, y = col.name, color = value), + data=heat.data, + fill="blue", + fill_off="yellow", + size = 2, + clickSelects = "value")) + +info.tile <- animint2HTML(viz.tile) + +test_that("rect default is black/transparent stroke", { + opacity.str <- getStyleValue( + info.tile$html, + '//svg[@id="plot_default"]//rect[@class="geom"]', + "opacity") + opacity.tab <- table(opacity.str) + expect_equal(names(opacity.tab), "1") + stroke.str <- getStyleValue( + info.tile$html, + '//svg[@id="plot_default"]//rect[@class="geom"]', + "stroke") + stroke.tab <- sort(table(stroke.str)) + expect_color(names(stroke.tab), c("black","transparent")) + expect_equal(as.numeric(stroke.tab), c(1, 8)) }) -test_that("geom_tile has specified colour(selected=colour value), but no colour_off(not selected=transparent)",{ - clickID('col_2') - html <- getHTML() - - stroke.col <- getStyleValue( - info$html, '//g[@class="geom2_tile_colnooff"]//rect[@id="col_2"]', "stroke") - expect.stroke.col <- "red" - expect_color(stroke.col, expect.stroke.col) - - # not selected, stroke=transparent(no stroke style) - node.set <- getNodeSet(info$html, '//g[@class="geom2_tile_colnooff"]//rect[@id="col_8"]') - expect_no_style(node.set, "stroke") +test_that("rect custom color/off used as stroke", { + opacity.str <- getStyleValue( + info.tile$html, + '//svg[@id="plot_colandoff"]//rect[@class="geom"]', + "opacity") + opacity.tab <- table(opacity.str) + expect_equal(names(opacity.tab), "1") + stroke.str <- getStyleValue( + info.tile$html, + '//svg[@id="plot_colandoff"]//rect[@class="geom"]', + "stroke") + stroke.tab <- sort(table(stroke.str)) + expect_color(names(stroke.tab), c("red","grey50")) + expect_equal(as.numeric(stroke.tab), c(1, 8)) }) -test_that("geom_tile has specified colour(selected=colour value), and colour_off(not selected=colour_off value)",{ - clickID('col_off_2') - html <- getHTML() - - stroke.col <- getStyleValue( - info$html, '//g[@class="geom3_tile_colandoff"]//rect[@id="col_off_2"]', "stroke") - expect.stroke.col <- "red" - expect_color(stroke.col, expect.stroke.col) - - stroke.color.off <- getStyleValue( - info$html, '//g[@class="geom3_tile_colandoff"]//rect[@id="col_off_8"]', "stroke") - expect.stroke.col.off <- "grey50" - expect_color(stroke.color.off, expect.stroke.col.off) +test_that("rect custom fill/off used as fill", { + opacity.str <- getStyleValue( + info.tile$html, + '//svg[@id="plot_filloff"]//rect[@class="geom"]', + "opacity") + opacity.tab <- table(opacity.str) + expect_equal(names(opacity.tab), "1") + stroke.str <- getStyleValue( + info.tile$html, + '//svg[@id="plot_filloff"]//rect[@class="geom"]', + "stroke") + stroke.tab <- table(stroke.str) + expect_equal(length(stroke.tab), 9) + fill.str <- getStyleValue( + info.tile$html, + '//svg[@id="plot_filloff"]//rect[@class="geom"]', + "fill") + fill.tab <- sort(table(fill.str)) + expect_color(names(fill.tab), c("blue","yellow")) + expect_equal(as.numeric(fill.tab), c(1, 8)) }) - -# -# tests for color_off parameter -# -test_that("color_off = colour_off",{ - has.col.and.off <- ggplot() + - geom_tile(data=heat.data, - aes(x = row.name, y = col.name, fill = value, - id=paste0("col_off_", value)), - colour="red", - color_off="grey50", # use color_off here - clickSelects = "value") - viz.tile <- list( - colandoff=has.col.and.off) - info <- animint2HTML(viz.tile) - - clickID('col_off_2') - html <- getHTML() - - stroke.color.off <- getStyleValue( - info$html, '//g[@class="geom1_tile_colandoff"]//rect[@id="col_off_8"]', "stroke") - expect.stroke.col.off <- "grey50" - expect_color(stroke.color.off, expect.stroke.col.off) -}) \ No newline at end of file diff --git a/tests/testthat/test-renderer2-fill.R b/tests/testthat/test-renderer2-fill.R deleted file mode 100644 index 8990d90a..00000000 --- a/tests/testthat/test-renderer2-fill.R +++ /dev/null @@ -1,148 +0,0 @@ -acontext("fill_off") - -# -# Test geoms with both fill and colour styles -# -viz.point <- list( - defaultAlphaOff = ggplot() + - geom_point( - data = mtcars, - size = 10, - aes( - x = wt, y = mpg, - colour = disp - ), - clickSelects = "gear" - ) + - ggtitle("default alpha_off(0.5) style"), - fillOffSpecified = ggplot() + - geom_point( - data = mtcars, - fill_off = "transparent", - size = 10, - aes( - x = wt, y = mpg, - fill = disp - ), - clickSelects = "gear" - ) + - ggtitle("colour corresponding to `disp` group, fill_off=\"transparent\" "), - fillAndAlphaOff = ggplot() + - geom_point( - data = mtcars, - alpha_off = 0.5, - fill_off = "grey", - size = 10, - aes( - x = wt, y = mpg, - fill = disp, - id = paste0("fillAndAlphaOff_disp", disp, "gear", gear, "wt", wt) - ), - clickSelects = "gear" - ) + - ggtitle("fill_off + alpha_off") -) - -viz_info <- animint2HTML(viz.point) - -test_that("fill_off only changes fill when clicked, colour does not change", { - point.xpath <- '//svg[@id="plot_fillAndAlphaOff"]//circle[@id="fillAndAlphaOff_disp275.8gear3wt3.73"]' - circle.list <- getNodeSet(viz_info$html, point.xpath) - before.click.color <- getStyleValue(viz_info$html, point.xpath, "stroke") - before.click.fill <- getStyleValue(viz_info$html, point.xpath, "fill") - - clickID("fillAndAlphaOff_disp275.8gear3wt3.73") - html <- getHTML() - after.click.color <- getStyleValue(html, point.xpath, "stroke") - after.click.fill <- getStyleValue(html, point.xpath, "fill") - - expect_false(isTRUE(all.equal(before.click.fill, after.click.fill))) - expect_color(after.click.color, before.click.color) -}) - -test_that("fill and color are not same", { - point.xpath <- '//svg[@id="plot_fillAndAlphaOff"]//circle[@class="geom"]' - circle.list <- getNodeSet(viz_info$html, point.xpath) - circle.color <- getStyleValue(viz_info$html, point.xpath, "stroke") - circle.fill <- getStyleValue(viz_info$html, point.xpath, "fill") - expect_false(isTRUE(all.equal(circle.color, circle.fill))) -}) - -rect.data <- data.frame( - xmin = c(1, 3, 5), - xmax = c(2, 4, 6), - ymin = c(1, 2, 3), - ymax = c(2, 3, 4), - category = c("A", "B", "C") -) - -viz.rect <- list(rectFillOff = ggplot() + - geom_rect( - data = rect.data, aes( - xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax, - id = paste0("rectFillOff_", category) - ), - color = "black", fill = "blue", fill_off = "transparent", clickSelects = "category" - )) - -viz_info <- animint2HTML(viz.rect) - -test_that("with fill_off, fill changes when clicked", { - rect_xpath <- '//svg[@id="plot_rectFillOff"]//rect[@id="rectFillOff_A"]' - - rect_list <- getNodeSet(viz_info$html, rect_xpath) - - before_click_color <- getStyleValue(viz_info$html, rect_xpath, "stroke") - before_click_fill <- getStyleValue(viz_info$html, rect_xpath, "fill") - - clickID("rectFillOff_B") - - html <- getHTML() - - after_click_color <- getStyleValue(html, rect_xpath, "stroke") - after_click_fill <- getStyleValue(html, rect_xpath, "fill") - expect_false(isTRUE(all.equal(before_click_fill, after_click_fill))) -}) - -vline.data <- data.frame( - xintercept = c(1, 2, 3), - category = c("A", "B", "C") -) - -viz.vline <- list( - v = ggplot() + - geom_vline( - data = vline.data, aes(xintercept = xintercept, key = category, - id = paste0("v_", category)), - fill = "blue", fill_off = "grey", clickSelects = "category" - ) + - ggtitle("Click to Select a Vertical Line") -) - -test_that("Warning message shows up when using fill_off parameter with geom_vline", { - expect_warning( - animint2HTML(viz.vline), - "geom1_vline_v has fill_off which is not supported." - ) -}) - -test_that("When using fill_off and clickSelects parameter with geom_vline, use default(alpha) selection style", { - viz_info <- animint2HTML(viz.vline) - - vline_xpath <- '//g[@class="geom1_vline_v"]//line[@id="v_A"]' - - before_click_color <- getStyleValue(viz_info$html, vline_xpath, "stroke") - before_click_opacity <- getStyleValue(viz_info$html, vline_xpath, "opacity") - - clickID("v_B") - - html <- getHTML() - after_click_color <- getStyleValue(html, vline_xpath, "stroke") - after_click_opacity <- getStyleValue(html, vline_xpath, "opacity") - - expect_color(before_click_color, "black") - expect_color(after_click_color, before_click_color) - - expect_equal(before_click_opacity, "1") - expect_equal(after_click_opacity, "0.5") -}) \ No newline at end of file diff --git a/tests/testthat/test-renderer2-opacity.R b/tests/testthat/test-renderer2-opacity.R deleted file mode 100644 index 8d94af70..00000000 --- a/tests/testthat/test-renderer2-opacity.R +++ /dev/null @@ -1,265 +0,0 @@ -# Consider matrix of combinations of alpha and alpha_off in aes parameter -# vs geom parameter. -# Each can be one of geom, aes, or none. -# The test matrix of tuples, (alpha, alpha_off), is: -# (geom, geom), (geom, aes), (geom, none), -# (aes, geom), (aes, aes), (aes, none), -# (none, geom), (none, aes), (none, none) - -# The (alpha, none) column is the original behavior, where the alpha of -# unselected values is the original alpha - 0.5. -# (none, none) is the base case, where the selection uses alpha = 1, and the -# unselected use the original - 0.5 formula. -# (geom, geom) behaves similar to (none, none), but the alpha is set to any -# value the user selects. -# (geom, aes) gives the selection a defined alpha, and unselected points use -# the aes value. -# (aes, aes) gives both the selection and unselected items alpha from their aes. -# (none, geom) gives selected points the default opacity of 1, and unselected -# points the provided opacity. -# (none, aes) gives selected points the default opacity of 1, and unselected -# points use the aes value. - -acontext("User defined opacity") - - -alpha_seq <- seq(0.1, 1, by = 0.1) -alpha_rev_seq <- seq(1, 0.1, by = -0.1) - -plot.dt <- data.frame( - x = 1:10, - y = 1:10, - alpha_seq = alpha_seq, - alpha_rev_seq = alpha_rev_seq -) - -alpha_on <- 0.8 -alpha_off <- 0.2 - -scatter.plot <- ggplot() + - geom_point( - data = plot.dt, - size = 5, - aes(x, y, alpha = alpha_seq) - ) + - ggtitle("Scatter plot with non-interactive alpha") - -geom.geom.plot <- ggplot() + -geom_point( - data = plot.dt, - alpha = alpha_on, - alpha_off = alpha_off, - size = 5, - clickSelects = "y", - aes(x, y, id=paste0("y", y)) -) + -ggtitle("Scatter plot with (geom, geom)") - -geom.aes.plot <- ggplot() + - geom_point( - data = plot.dt, - alpha = alpha_on, - size = 5, - clickSelects = "y", - aes(x, y, alpha_off = alpha_seq) - ) + - ggtitle("Scatter plot with (geom, aes)") - -geom.none.plot <- ggplot() + - geom_point( - data = plot.dt, - alpha = alpha_on, - size = 5, - clickSelects = "y", - aes(x, y) - ) + - ggtitle("Scatter plot with (geom, none)") - -# TODO: fix this, right now behaving like (aes, none) -aes.geom.plot <- ggplot() + - geom_point( - data = plot.dt, - alpha_off = alpha_off, - size = 5, - clickSelects = "y", - aes(x, y, alpha = alpha_seq) - ) + - ggtitle("Scatter plot with (aes, geom)") - -aes.aes.plot <- ggplot() + - geom_point( - data = plot.dt, - size = 5, - clickSelects = "y", - aes(x, y, alpha = alpha_seq, alpha_off = alpha_rev_seq) - ) + - ggtitle("Scatter plot with (aes, aes)") - -aes.none.plot <- ggplot() + - geom_point( - data = plot.dt, - size = 5, - clickSelects = "y", - aes(x, y, alpha = alpha_seq) - ) + - ggtitle("Scatter plot with (aes, none)") - -none.geom.plot <- ggplot() + - geom_point( - data = plot.dt, - size = 5, - alpha_off = alpha_off, - clickSelects = "y", - aes(x, y) - ) + - ggtitle("Scatter plot with (none, geom)") - -none.aes.plot <- ggplot() + - geom_point( - data = plot.dt, - size = 5, - clickSelects = "y", - aes(x, y, alpha_off = alpha_seq) - ) + - ggtitle("Scatter plot with (none, aes)") - -none.none.plot <- ggplot() + - geom_point( - data = plot.dt, - size = 5, - clickSelects = "y", - aes(x, y) - ) + - ggtitle("Scatter plot with (none, none)") - -scatter.viz <- list() -scatter.viz$noninteractive <- scatter.plot -scatter.viz$geomGeom <- geom.geom.plot -scatter.viz$geomAes <- geom.aes.plot -scatter.viz$geomNone <- geom.none.plot -scatter.viz$aesGeom <- aes.geom.plot -scatter.viz$aesAes <- aes.aes.plot -scatter.viz$aesNone <- aes.none.plot -scatter.viz$noneGeom <- none.geom.plot -scatter.viz$noneAes <- none.aes.plot -scatter.viz$noneNone <- none.none.plot - -animint2HTML(scatter.viz) - - -get_points_geom <- function(geom, full.node.set) { - getNodeSet(full.node.set, paste0("//svg[@id='plot_", geom, "']//circle")) -} - -opacity_extract_pattern <- "(?<=opacity: )(\\-?\\d*\\.?\\d*)" - -get_opacity <- function (node) { - style <- xmlAttrs(node)[["style"]] - as.numeric( - regmatches(style, regexpr(opacity_extract_pattern, style, perl = TRUE))) - } - -# It can't hurt to make sure we explicitly set the initial state, -# just in case some browser or Selenium update changes things -before.update.nodes <- clickHTML(id=paste0("y", 1)) -after.update.nodes <- clickHTML(id=paste0("y", 2)) - - -test_that("(geom, geom) opacity updates", { - before.nodes <- get_points_geom("geomGeom", before.update.nodes) - after.nodes <- get_points_geom("geomGeom", after.update.nodes) - before.opacities <- sapply(before.nodes, get_opacity) - after.opacities <- sapply(after.nodes, get_opacity) - expect_equal(before.opacities[1], alpha_on) - expect_equal(before.opacities[2], alpha_off) - expect_equal(after.opacities[1], alpha_off) - expect_equal(after.opacities[2], alpha_on) -}) - -test_that("(geom, aes) opacity updates", { - before.nodes <- get_points_geom("geomAes", before.update.nodes) - after.nodes <- get_points_geom("geomAes", after.update.nodes) - before.opacities <- sapply(before.nodes, get_opacity) - after.opacities <- sapply(after.nodes, get_opacity) - expect_equal(before.opacities[1], alpha_on) - expect_equal(before.opacities[2], alpha_seq[2]) - expect_equal(after.opacities[1], alpha_seq[1]) - expect_equal(after.opacities[2], alpha_on) -}) - -test_that("(geom, none) opacity updates", { - before.nodes <- get_points_geom("geomNone", before.update.nodes) - after.nodes <- get_points_geom("geomNone", after.update.nodes) - before.opacities <- sapply(before.nodes, get_opacity) - after.opacities <- sapply(after.nodes, get_opacity) - expect_equal(before.opacities[1], alpha_on) - expect_equal(before.opacities[2], alpha_on - 0.5) - expect_equal(after.opacities[1], alpha_on - 0.5) - expect_equal(after.opacities[2], alpha_on) -}) - -test_that("(aes, geom) opacity update", { - before.nodes <- get_points_geom("aesGeom", before.update.nodes) - after.nodes <- get_points_geom("aesGeom", after.update.nodes) - before.opacities <- sapply(before.nodes, get_opacity) - after.opacities <- sapply(after.nodes, get_opacity) - expect_equal(before.opacities[1], alpha_seq[1]) - expect_equal(before.opacities[2], alpha_off) - expect_equal(after.opacities[1], alpha_off) - expect_equal(after.opacities[2], alpha_seq[2]) -}) - -test_that("(aes, aes) opacity updates", { - before.nodes <- get_points_geom("aesAes", before.update.nodes) - after.nodes <- get_points_geom("aesAes", after.update.nodes) - before.opacities <- sapply(before.nodes, get_opacity) - after.opacities <- sapply(after.nodes, get_opacity) - expect_equal(before.opacities[1], alpha_seq[1]) - expect_equal(before.opacities[2], alpha_rev_seq[2]) - expect_equal(after.opacities[1], alpha_rev_seq[1]) - expect_equal(after.opacities[2], alpha_seq[2]) -}) - -test_that("(aes, none) opacity updates", { - before.nodes <- get_points_geom("aesNone", before.update.nodes) - after.nodes <- get_points_geom("aesNone", after.update.nodes) - before.opacities <- sapply(before.nodes, get_opacity) - after.opacities <- sapply(after.nodes, get_opacity) - expect_equal(before.opacities[1], alpha_seq[1]) - expect_equal(before.opacities[2], alpha_seq[2] - 0.5) - expect_equal(after.opacities[1], alpha_seq[1] - 0.5) - expect_equal(after.opacities[2], alpha_seq[2]) -}) - -test_that("(none, geom) opacity updates", { - before.nodes <- get_points_geom("noneGeom", before.update.nodes) - after.nodes <- get_points_geom("noneGeom", after.update.nodes) - before.opacities <- sapply(before.nodes, get_opacity) - after.opacities <- sapply(after.nodes, get_opacity) - expect_equal(before.opacities[1], 1) - expect_equal(before.opacities[2], alpha_off) - expect_equal(after.opacities[1], alpha_off) - expect_equal(after.opacities[2], 1) -}) - -test_that("(none, aes) opacity updates", { - before.nodes <- get_points_geom("noneAes", before.update.nodes) - after.nodes <- get_points_geom("noneAes", after.update.nodes) - before.opacities <- sapply(before.nodes, get_opacity) - after.opacities <- sapply(after.nodes, get_opacity) - expect_equal(before.opacities[1], 1) - expect_equal(before.opacities[2], alpha_seq[2]) - expect_equal(after.opacities[1], alpha_seq[1]) - expect_equal(after.opacities[2], 1) -}) - -test_that("(none, none) opacity updates", { - before.nodes <- get_points_geom("noneNone", before.update.nodes) - after.nodes <- get_points_geom("noneNone", after.update.nodes) - before.opacities <- sapply(before.nodes, get_opacity) - after.opacities <- sapply(after.nodes, get_opacity) - expect_equal(before.opacities[1], 1) - expect_equal(before.opacities[2], 1 - 0.5) - expect_equal(after.opacities[1], 1 - 0.5) - expect_equal(after.opacities[2], 1) -}) diff --git a/tests/testthat/test-renderer2-widerect.R b/tests/testthat/test-renderer2-widerect.R index d1aff998..0860d89d 100644 --- a/tests/testthat/test-renderer2-widerect.R +++ b/tests/testthat/test-renderer2-widerect.R @@ -1,4 +1,15 @@ acontext("geom_widerect") +library(animint2) +expect_source <- function(expected){ + a.list <- getNodeSet(info$html, '//a[@id="a_source_href"]') + computed <- if(length(a.list)==0){ + NULL + }else{ + at.mat <- sapply(a.list, xmlAttrs) + at.mat["href",] + } + expect_identical(as.character(computed), as.character(expected)) +} recommendation <- data.frame( min.C=21, @@ -7,20 +18,22 @@ set.seed(1) temp.time <- data.frame( time=strptime(paste0("2015-10-", 1:31), "%Y-%m-%d"), temp.C=rnorm(31)) - -viz <- list( +viz <- animint( gg=ggplot()+ theme_bw()+ theme_animint(height=200, width=2000)+ - geom_widerect(aes(ymin=min.C, ymax=max.C), - color=NA, - fill="grey", - data=recommendation)+ - geom_line(aes(time, temp.C), - data=temp.time) - ) + geom_widerect(aes( + ymin=min.C, ymax=max.C), + color=NA, + fill="grey", + data=recommendation)+ + geom_line(aes( + time, temp.C), + data=temp.time) +) info <- animint2HTML(viz) +expect_source(NULL) getBounds <- function(geom.class){ script.txt <- sprintf('return document.getElementsByClassName("%s")[0].getBoundingClientRect()', geom.class) @@ -35,83 +48,90 @@ test_that("bottom of widerect is above line", { data(WorldBank, package = "animint2") not.na <- subset(WorldBank, !(is.na(life.expectancy) | is.na(fertility.rate))) -BOTH <- function(df, top, side){ - data.frame(df, - top=factor(top, c("Fertility rate", "Years")), - side=factor(side, c("Years", "Life expectancy"))) -} +BOTH <- function(df, top, side)data.frame( + df, + top=factor(top, c("Fertility rate", "Years")), + side=factor(side, c("Years", "Life expectancy"))) TS <- function(df)BOTH(df, "Years", "Life expectancy") SCATTER <- function(df)BOTH(df, "Fertility rate", "Life expectancy") TS2 <- function(df)BOTH(df, "Fertility rate", "Years") years <- unique(not.na[, "year", drop=FALSE]) years$status <- ifelse(years$year %% 2, "odd", "even") -wb.facets <- - list(ts=ggplot()+ - xlab("")+ - geom_tallrect(aes(xmin=year-1/2, xmax=year+1/2, - linetype=status), - clickSelects="year", - data=TS(years), alpha=1/2)+ - theme_bw()+ - theme_animint(width=1000, height=800)+ - theme(panel.margin=grid::unit(0, "lines"))+ - geom_line(aes(year, life.expectancy, group=country, colour=region, - id = country), - clickSelects="country", - data=TS(not.na), size=4, alpha=3/5)+ - geom_point(aes(year, life.expectancy, color=region, size=population), - clickSelects="country", - showSelected="country", - data=TS(not.na))+ - - geom_path(aes(fertility.rate, year, group=country, colour=region), - clickSelects="country", - data=TS2(not.na), size=4, alpha=3/5)+ - geom_point(aes(fertility.rate, year, color=region, size=population), - showSelected="country", clickSelects="country", - data=TS2(not.na))+ - geom_widerect(aes(ymin=year-1/2, ymax=year+1/2, - linetype=status, - id=paste0("year", year)), - clickSelects="year", - data=TS2(years), alpha=1/2)+ - - geom_point(aes(fertility.rate, life.expectancy, - colour=region, size=population, - key=country), # key aesthetic for animated transitions! - clickSelects="country", - showSelected="year", - data=SCATTER(not.na))+ - geom_text(aes(fertility.rate, life.expectancy, label=country, - key=country), #also use key here! - showSelected=c("country", "year"), - clickSelects="country", - data=SCATTER(not.na))+ - scale_size_animint(breaks=10^(5:9))+ - facet_grid(side ~ top, scales="free")+ - geom_text(aes(5, 85, label=paste0("year = ", year), - key=year), - showSelected="year", - data=SCATTER(years)), - - bar=ggplot()+ - theme_animint(height=2400)+ - geom_bar(aes(country, life.expectancy, fill=region, - key=country, id=gsub(" ", "_", country)), - showSelected="year", clickSelects="country", - data=not.na, stat="identity", position="identity")+ - coord_flip(), - - time=list(variable="year", ms=2000), - duration=list(year=2000), - first=list(year=1975, country=c("United States", "Vietnam")), - selector.types=list(country="multiple"), - title="World Bank data (multiple selection, facets)") +wb.facets <- animint( + ts=ggplot()+ + xlab("")+ + geom_tallrect(aes( + xmin=year-1/2, xmax=year+1/2, + linetype=status), + clickSelects="year", + data=TS(years), alpha=1/2)+ + theme_bw()+ + theme_animint(width=1000, height=800)+ + theme(panel.margin=grid::unit(0, "lines"))+ + geom_line(aes( + year, life.expectancy, group=country, colour=region, + id = country), + clickSelects="country", + data=TS(not.na), size=4, alpha=3/5)+ + geom_point(aes( + year, life.expectancy, color=region, size=population), + clickSelects="country", + showSelected="country", + data=TS(not.na))+ + geom_path(aes( + fertility.rate, year, group=country, colour=region), + clickSelects="country", + data=TS2(not.na), size=4, alpha=3/5)+ + geom_point(aes( + fertility.rate, year, color=region, size=population), + showSelected="country", clickSelects="country", + data=TS2(not.na))+ + geom_widerect(aes( + ymin=year-1/2, ymax=year+1/2, + linetype=status, + id=paste0("year", year)), + clickSelects="year", + data=TS2(years), alpha=1/2)+ + geom_point(aes( + fertility.rate, life.expectancy, + colour=region, size=population, + key=country), # key aesthetic for animated transitions! + clickSelects="country", + showSelected="year", + data=SCATTER(not.na))+ + geom_text(aes( + fertility.rate, life.expectancy, label=country, + key=country), #also use key here! + showSelected=c("country", "year"), + clickSelects="country", + data=SCATTER(not.na))+ + scale_size_animint(breaks=10^(5:9))+ + facet_grid(side ~ top, scales="free")+ + geom_text(aes( + 5, 85, label=paste0("year = ", year), + key=year), + showSelected="year", + data=SCATTER(years)), + bar=ggplot()+ + theme_animint(height=2400)+ + geom_bar(aes( + country, life.expectancy, fill=region, + key=country, id=gsub(" ", "_", country)), + showSelected="year", clickSelects="country", + data=not.na, stat="identity", position="identity")+ + coord_flip(), + time=list(variable="year", ms=2000), + duration=list(year=2000), + first=list(year=1975, country=c("United States", "Vietnam")), + selector.types=list(country="multiple"), + title="World Bank data (multiple selection, facets)", + source="https://github.com/animint/animint2/blob/master/tests/testthat/test-renderer2-widerect.R") info <- animint2HTML(wb.facets) +expect_source("https://github.com/animint/animint2/blob/master/tests/testthat/test-renderer2-widerect.R") -rect.list <- - getNodeSet(info$html, '//svg[@id="plot_ts"]//rect[@class="border_rect"]') +rect.list <- getNodeSet( + info$html, '//svg[@id="plot_ts"]//rect[@class="border_rect"]') expect_equal(length(rect.list), 4) at.mat <- sapply(rect.list, xmlAttrs) diff --git a/tests/testthat/test-renderer3-ChromHMMinit.R b/tests/testthat/test-renderer3-ChromHMMinit.R index 05002689..c614d13e 100644 --- a/tests/testthat/test-renderer3-ChromHMMinit.R +++ b/tests/testthat/test-renderer3-ChromHMMinit.R @@ -87,5 +87,5 @@ test_that("animation starts by default", { test_that("default tile colour/stroke is transparent", { stroke.vec <- getStyleValue( info$html, '//g[@class="geom1_tile_parameters"]//rect', "stroke") - expect_identical(stroke.vec, rep("transparent", 90)) + expect_color(stroke.vec, "black") }) diff --git a/tests/testthat/test-renderer3-point-fill-NA.R b/tests/testthat/test-renderer3-point-fill-NA.R index 8a5cd01c..b7af1e58 100644 --- a/tests/testthat/test-renderer3-point-fill-NA.R +++ b/tests/testthat/test-renderer3-point-fill-NA.R @@ -1,20 +1,21 @@ acontext("point fill NA") - +library(animint2) ##dput(RColorBrewer::brewer.pal(Inf, "Set1")) -species.colors <- - c(versicolor="#E41A1C", - setosa="#377EB8", - virginica="#4DAF4A", "#984EA3", - "#FF7F00", "#FFFF33", - "#A65628", "#F781BF", "#999999") +species.colors <- c( + versicolor="#E41A1C", + setosa="#377EB8", + virginica="#4DAF4A", "#984EA3", + "#FF7F00", "#FFFF33", + "#A65628", "#F781BF", "#999999") viz <- list( petals=ggplot()+ scale_color_manual(values=species.colors)+ - geom_point(aes(Petal.Length, Petal.Width, color=Species), - fill=NA, - shape=21, - data=iris) - ) + geom_point(aes( + Petal.Length, Petal.Width, color=Species), + fill=NA, + shape=21, + data=iris) +) test_that("geom_point(aes(color), fill=NA) renders fill transparent", { info <- animint2HTML(viz) diff --git a/tests/testthat/test-renderer4-geom-point-stroke.R b/tests/testthat/test-renderer4-geom-point-stroke.R index f95e6e00..b194cfd6 100644 --- a/tests/testthat/test-renderer4-geom-point-stroke.R +++ b/tests/testthat/test-renderer4-geom-point-stroke.R @@ -1,41 +1,39 @@ acontext("geom_point_stroke") stroke_in_R <- 5 -p1 <- ggplot(mtcars, aes(wt, mpg)) + - geom_point(shape = 21, colour = "black", fill = "white", - size = 5, stroke = stroke_in_R) +viz <- animint( + param=ggplot(mtcars, aes( + wt, mpg)) + + geom_point( + shape = 21, colour = "black", fill = "white", + size = 5, stroke = stroke_in_R), + aes=ggplot(mtcars, aes( + wt, mpg, stroke=cyl)) + + geom_point( + shape = 21, colour = "black", fill = "white", size = 5)) -p2 <- ggplot(mtcars, aes(wt, mpg, stroke=cyl)) + - geom_point(shape = 21, colour = "black", fill = "white", size = 5) - -viz <- list(p1=p1, p2=p2) info <- animint2HTML(viz) -test_that("points are rendered with stroke-width", { - stroke_vals <- - getStyleValue(info$html, '//g[@class="geom1_point_p1"]//circle', - "stroke-width") - # stroke-width is rendered for every point +test_that("geom_point stroke param rendered with stroke-width", { + stroke_vals <- getStyleValue( + info$html, + '//g[@class="geom1_point_param"]//circle', + "stroke-width") expect_equal(length(stroke_vals), length(mtcars$wt)) - stroke_vals_unique <- unique(stroke_vals) expect_equal(length(stroke_vals_unique), 1) - stroke_width_val <- as.numeric(gsub("[^0-9]", "", stroke_vals_unique)) expect_equal(stroke_width_val, stroke_in_R) }) test_that("aes(stroke) works", { - stroke_vals_2 <- - getStyleValue(info$html, '//g[@class="geom2_point_p2"]//circle', - "stroke-width") - - expect_equal(length(stroke_vals_2), length(mtcars$wt)) - - stroke_vals_unique_2 <- unique(stroke_vals_2) - expect_equal(length(stroke_vals_unique_2), length(unique(mtcars$cyl))) - - # Check that the values of the stroke are taken from mtcars$cyl - stroke_width_vals <- as.numeric(gsub("[^0-9]", "", stroke_vals_unique_2)) + stroke_vals_aes <- getStyleValue( + info$html, + '//g[@class="geom2_point_aes"]//circle', + "stroke-width") + expect_equal(length(stroke_vals_aes), length(mtcars$wt)) + stroke_vals_unique_aes <- unique(stroke_vals_aes) + expect_equal(length(stroke_vals_unique_aes), length(unique(mtcars$cyl))) + stroke_width_vals <- as.numeric(gsub("[^0-9]", "", stroke_vals_unique_aes)) expect_identical(sort(stroke_width_vals), sort(unique(mtcars$cyl))) }) diff --git a/tests/testthat/test-renderer5-ChromHMMiterations.R b/tests/testthat/test-renderer5-ChromHMMiterations.R index 89289613..8bff496a 100644 --- a/tests/testthat/test-renderer5-ChromHMMiterations.R +++ b/tests/testthat/test-renderer5-ChromHMMiterations.R @@ -1,44 +1,51 @@ acontext("ChromHMMiterations data set") - +library(animint2) data(ChromHMMiterations, package = "animint2") emission <- data.frame(ChromHMMiterations$emission, parameters="emission") transition <- data.frame(ChromHMMiterations$transition, parameters="transition") +unique(transition$state.from) +transition$state0.to <- sprintf("%02d", transition$state.to) +emission$exp.fac <- factor(emission$experiment, unique(emission$experiment)) viz <- list( parameters=ggplot()+ ggtitle("parameters at selected iteration")+ scale_fill_gradient(low="white", high="blue")+ - geom_tile(aes(state, experiment, fill=frequency, - key=paste(state, experiment)), - color="black", - showSelected="iteration", - data=emission)+ + scale_x_discrete("State coming from")+ + scale_y_discrete("", drop=TRUE)+ + geom_tile(aes( + state, exp.fac, fill=frequency, + key=paste(state, experiment)), + showSelected="iteration", + data=emission)+ scale_color_gradient(low="white", high="red")+ theme_bw()+ - theme_animint(height=600, width=350)+ + theme_animint(height=500, width=350)+ theme(panel.margin=grid::unit(0, "cm"))+ - facet_grid(parameters ~ ., - space="free", - scales="free_y")+ - scale_y_discrete(drop=FALSE)+ - geom_point(aes(state.to, state.from, color=probability, - key=paste(state.from, state.to)), - showSelected="iteration", - size=10, - data=transition), + facet_grid( + parameters ~ ., + space="free", + scales="free_y")+ + geom_point(aes( + state.from, state0.to, color=probability, + key=paste(state.from, state.to)), + showSelected="iteration", + size=10, + data=transition), metrics=ggplot()+ ggtitle("convergence metrics, select iteration")+ make_tallrect(ChromHMMiterations$metrics, "iteration")+ - geom_line(aes(iteration, metric.value), - data=ChromHMMiterations$metrics)+ + geom_line(aes( + iteration, metric.value), + data=ChromHMMiterations$metrics)+ theme_bw()+ theme_animint(height=500)+ - theme(panel.margin=grid::unit(0, "cm"))+ facet_grid(metric.name ~ ., scales="free_y"), duration=list(iteration=500), first=list(iteration=100), title="ChromHMM parameter fitting for one iPS sample") +viz$param expect_no_warning({ info <- animint2HTML(viz) diff --git a/vignettes/animint2.Rmd b/vignettes/animint2.Rmd index 063c299c..363a0c8d 100644 --- a/vignettes/animint2.Rmd +++ b/vignettes/animint2.Rmd @@ -1,7 +1,9 @@ ---- -title: "Animint2 Quick Start Guide" ---- + +# Animint2 Quick Start Guide ## Introduction