From 10d6751b72ef2ca9f10233b495cefbfc96b09ebc Mon Sep 17 00:00:00 2001 From: Faye-yufan Date: Wed, 12 Jul 2023 23:17:09 -0700 Subject: [PATCH 01/88] created animint2pages() --- R/z_pages.R | 58 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 58 insertions(+) create mode 100644 R/z_pages.R diff --git a/R/z_pages.R b/R/z_pages.R new file mode 100644 index 000000000..e719f0c76 --- /dev/null +++ b/R/z_pages.R @@ -0,0 +1,58 @@ +animint2pages <- function(plot.list, github_repo, commit_message = "Commit from animint2pages", ...) { + + res <- animint2dir(plot.list, open.browser = FALSE, ...) + # Ensure required packages are installed. + if (!requireNamespace("git2r")) { + stop("Please run \n", + "install.packages('git2r')", + "before using this function") + } + if (!requireNamespace("webshot")) { + stop("Please run \n", + "install.packages('webshot')", + "before using this function") + } + # The below are copied from `animint2gist` + # 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] + + # Clone the repository to a temporary directory. + tmp_dir <- tempfile() + repo <- git2r::clone(github_repo, tmp_dir) + url <- paste0("file://", tmp_dir, "/index.html") + + # Take a screenshot and save as Capture.PNG. + webshot::webshot(url, file = file.path(tmp_dir, "Capture.PNG")) + + git2r::add(repo, "*") + git2r::commit(repo, commit_message) + + # Push the changes to the remote repository. + # NOTE: This assumes that the remote named 'origin' is correctly set. + # It also assumes the credentials are properly set in the environment + # (SSH keys or PAT), which might not be the case in a real scenario. + git2r::push(repo, "origin", refs = "refs/heads/main") + + # Return the repo for further use if needed. + return(repo) +} From b70ae5990cb0de633d4f54600c314c38148d35fa Mon Sep 17 00:00:00 2001 From: Faye-yufan Date: Fri, 21 Jul 2023 00:01:27 -0700 Subject: [PATCH 02/88] update to post files path --- R/z_pages.R | 45 +++++++++++++++++++-------------------------- 1 file changed, 19 insertions(+), 26 deletions(-) diff --git a/R/z_pages.R b/R/z_pages.R index e719f0c76..95d4d34e6 100644 --- a/R/z_pages.R +++ b/R/z_pages.R @@ -1,19 +1,21 @@ animint2pages <- function(plot.list, github_repo, commit_message = "Commit from animint2pages", ...) { - res <- animint2dir(plot.list, open.browser = FALSE, ...) # Ensure required packages are installed. if (!requireNamespace("git2r")) { - stop("Please run \n", - "install.packages('git2r')", - "before using this function") + stop( + "Please run \n", + "install.packages('git2r')", + "before using this function" + ) } if (!requireNamespace("webshot")) { - stop("Please run \n", - "install.packages('webshot')", - "before using this function") + stop( + "Please run \n", + "install.packages('webshot')", + "before using this function" + ) } # The below are copied from `animint2gist` - # 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) @@ -32,27 +34,18 @@ animint2pages <- function(plot.list, github_repo, commit_message = "Commit from 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] - # Clone the repository to a temporary directory. tmp_dir <- tempfile() - repo <- git2r::clone(github_repo, tmp_dir) - url <- paste0("file://", tmp_dir, "/index.html") - - # Take a screenshot and save as Capture.PNG. - webshot::webshot(url, file = file.path(tmp_dir, "Capture.PNG")) + repo <- git2r::repository(tmp_dir) - git2r::add(repo, "*") + # TODO: Take a screenshot and save as Capture.PNG. + # Commit the changes + lapply(to.post, function(file) git2r::add(repo, file)) git2r::commit(repo, commit_message) - - # Push the changes to the remote repository. - # NOTE: This assumes that the remote named 'origin' is correctly set. - # It also assumes the credentials are properly set in the environment - # (SSH keys or PAT), which might not be the case in a real scenario. - git2r::push(repo, "origin", refs = "refs/heads/main") - - # Return the repo for further use if needed. - return(repo) + + # Push the changes to the remote repository, replace 'credentials' with your GitHub credentials + git2r::push(repo, credentials = git2r::cred_user_pass("username", "password")) + + repo } From 5bffa3f09c2d52389ee8ba82c2565a45e0d62605 Mon Sep 17 00:00:00 2001 From: Yufan Fei <62975717+Faye-yufan@users.noreply.github.com> Date: Mon, 24 Jul 2023 15:19:53 -0700 Subject: [PATCH 03/88] GH pages is fine with nested file structure --- R/z_pages.R | 19 +++++++------------ 1 file changed, 7 insertions(+), 12 deletions(-) diff --git a/R/z_pages.R b/R/z_pages.R index 95d4d34e6..3a2b11938 100644 --- a/R/z_pages.R +++ b/R/z_pages.R @@ -16,27 +16,22 @@ animint2pages <- function(plot.list, github_repo, commit_message = "Commit from ) } # The below are copied from `animint2gist` - 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") + # but we don't need a flat file structure now ## 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 to.post <- all.files[!is.ignored] tmp_dir <- tempfile() + # check if the repo already exists on GH + gh_repos <- "/" + user_name + "/" + github_repo + repo_exists <- any(sapply(github_repo, function(x) x$name) == github_repo) + if(!repo_exists){ + gh("POST /user/repos", name = github_repo) + } repo <- git2r::repository(tmp_dir) # TODO: Take a screenshot and save as Capture.PNG. From 1a980fde563880a9db48b92f88ca1de15993b1e1 Mon Sep 17 00:00:00 2001 From: Yufan Fei <62975717+Faye-yufan@users.noreply.github.com> Date: Tue, 25 Jul 2023 11:27:20 -0700 Subject: [PATCH 04/88] Update NAMESPACE --- NAMESPACE | 1 + 1 file changed, 1 insertion(+) diff --git a/NAMESPACE b/NAMESPACE index 1e99920b5..154b960c1 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -215,6 +215,7 @@ export(alpha) export(animint) export(animint2dir) export(animint2gist) +export(animint2pages) export(animintOutput) export(annotate) export(annotation_custom) From 7ec13345e7d81aefdbc4bae8a60fab578a616931 Mon Sep 17 00:00:00 2001 From: Faye-yufan Date: Tue, 25 Jul 2023 22:18:55 -0700 Subject: [PATCH 05/88] Update DESCRIPTION --- DESCRIPTION | 1 + 1 file changed, 1 insertion(+) diff --git a/DESCRIPTION b/DESCRIPTION index 3611135cf..7c7d3f00b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -267,6 +267,7 @@ Collate: 'z_facets.R' 'z_geoms.R' 'z_gist.R' + 'z_pages.R' 'z_helperFunctions.R' 'z_knitr.R' 'z_print.R' From b660d219ddb35ea975c9063cd4caab7ac18e6470 Mon Sep 17 00:00:00 2001 From: Faye-yufan Date: Tue, 25 Jul 2023 23:22:54 -0700 Subject: [PATCH 06/88] use `git2r::cred_token()` for gh authentication --- R/z_pages.R | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/R/z_pages.R b/R/z_pages.R index 3a2b11938..4853fc4f2 100644 --- a/R/z_pages.R +++ b/R/z_pages.R @@ -1,6 +1,5 @@ animint2pages <- function(plot.list, github_repo, commit_message = "Commit from animint2pages", ...) { res <- animint2dir(plot.list, open.browser = FALSE, ...) - # Ensure required packages are installed. if (!requireNamespace("git2r")) { stop( "Please run \n", @@ -15,8 +14,8 @@ animint2pages <- function(plot.list, github_repo, commit_message = "Commit from "before using this function" ) } + # The below are copied from `animint2gist` - # but we don't need a flat file structure now ## Figure out which files to post. all.files <- Sys.glob(file.path(res$out.dir, "*")) all.file.info <- file.info(all.files) @@ -26,21 +25,23 @@ animint2pages <- function(plot.list, github_repo, commit_message = "Commit from to.post <- all.files[!is.ignored] tmp_dir <- tempfile() + # check if the repo already exists on GH - gh_repos <- "/" + user_name + "/" + github_repo - repo_exists <- any(sapply(github_repo, function(x) x$name) == github_repo) + gh_repos <- gh::gh("/user/repos") + repo_exists <- any(sapply(gh_repos, function(x) x$name) == github_repo) if(!repo_exists){ - gh("POST /user/repos", name = github_repo) + gh::gh("POST /user/repos", name = github_repo) } - repo <- git2r::repository(tmp_dir) + + repo <- git2r::clone(github_repo, tmp_dir, branch="gh-pages", credentials = git2r::cred_token()) + + file.copy(to.post, tmp_dir, recursive = TRUE) # TODO: Take a screenshot and save as Capture.PNG. # Commit the changes lapply(to.post, function(file) git2r::add(repo, file)) git2r::commit(repo, commit_message) - - # Push the changes to the remote repository, replace 'credentials' with your GitHub credentials - git2r::push(repo, credentials = git2r::cred_user_pass("username", "password")) - + git2r::push(repo, "origin", "gh-pages", credentials = git2r::cred_token()) + repo } From cbc942c5494704368b537057dde8ae7fa0876fba Mon Sep 17 00:00:00 2001 From: Faye-yufan Date: Wed, 26 Jul 2023 00:03:38 -0700 Subject: [PATCH 07/88] Error in 'git2r_branch_create': 'commit' must be an S3 class git_commit --- R/z_pages.R | 40 +++++++++++++++++++++++++--------------- 1 file changed, 25 insertions(+), 15 deletions(-) diff --git a/R/z_pages.R b/R/z_pages.R index 4853fc4f2..09d946df9 100644 --- a/R/z_pages.R +++ b/R/z_pages.R @@ -1,16 +1,9 @@ -animint2pages <- function(plot.list, github_repo, commit_message = "Commit from animint2pages", ...) { +animint2pages <- function(plot.list, user_name, github_repo, commit_message = "Commit from animint2pages", ...) { res <- animint2dir(plot.list, open.browser = FALSE, ...) if (!requireNamespace("git2r")) { stop( "Please run \n", - "install.packages('git2r')", - "before using this function" - ) - } - if (!requireNamespace("webshot")) { - stop( - "Please run \n", - "install.packages('webshot')", + "`install.packages('git2r')` ", "before using this function" ) } @@ -25,16 +18,33 @@ animint2pages <- function(plot.list, github_repo, commit_message = "Commit from to.post <- all.files[!is.ignored] tmp_dir <- tempfile() - + # check if the repo already exists on GH gh_repos <- gh::gh("/user/repos") repo_exists <- any(sapply(gh_repos, function(x) x$name) == github_repo) - if(!repo_exists){ + if (!repo_exists) { gh::gh("POST /user/repos", name = github_repo) + repo <- git2r::init(tmp_dir) + git2r::config(repo, user.name = user_name) + # have a initial commit to avoid error + # `Error in 'git2r_branch_create': 'commit' must be an S3 class git_commit` + readme_file_path <- file.path(tmp_dir, "README.md") + writeLines("## New Repo", readme_file_path) + git2r::add(repo, "README.md") + git2r::commit(repo, "Initial commit") + } else { + github_url <- paste0("https://github.com/", user_name, "/", github_repo, ".git") + repo <- git2r::clone(github_url, tmp_dir, credentials = git2r::cred_token()) + } + + # Check if the 'gh-pages' branch exists + branches <- git2r::branches(repo) + if (!"gh-pages" %in% names(branches)) { + # If 'gh-pages' branch doesn't exist, create it + git2r::branch_create(repo, "gh-pages") } - - repo <- git2r::clone(github_repo, tmp_dir, branch="gh-pages", credentials = git2r::cred_token()) - + + git2r::checkout(repo, "gh-pages") file.copy(to.post, tmp_dir, recursive = TRUE) # TODO: Take a screenshot and save as Capture.PNG. @@ -42,6 +52,6 @@ animint2pages <- function(plot.list, github_repo, commit_message = "Commit from lapply(to.post, function(file) git2r::add(repo, file)) git2r::commit(repo, commit_message) git2r::push(repo, "origin", "gh-pages", credentials = git2r::cred_token()) - + repo } From bbdeeb670c1be84bf5b216d4a9ea70a3ad2e6be0 Mon Sep 17 00:00:00 2001 From: Yufan Fei <62975717+Faye-yufan@users.noreply.github.com> Date: Thu, 27 Jul 2023 10:17:19 -0700 Subject: [PATCH 08/88] Create test-compiler-ghpages.R --- test-compiler-ghpages.R | 9 +++++++++ 1 file changed, 9 insertions(+) create mode 100644 test-compiler-ghpages.R diff --git a/test-compiler-ghpages.R b/test-compiler-ghpages.R new file mode 100644 index 000000000..0686ae9dc --- /dev/null +++ b/test-compiler-ghpages.R @@ -0,0 +1,9 @@ +acontext("GitHub Pages") + +Sys.setenv(GITHUB_PAT = Sys.getenv("GITHUB_PAT")) +gh_username <- Sys.getenv("GITHUB_USERNAME") + +test_that("animint2pages() returns an object of class 'git_repository'", { + repo <- animint2pages(list(p = ggplot2::qplot(1:10)), github_repo = repo_name) + expect_is(repo, "git_repository") +}) From 2b20045b2ba05b84ca8d35fdd62287f30f687c8a Mon Sep 17 00:00:00 2001 From: Yufan Fei <62975717+Faye-yufan@users.noreply.github.com> Date: Tue, 1 Aug 2023 10:59:53 -0700 Subject: [PATCH 09/88] Check if there are any commits in the repo --- R/z_pages.R | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/R/z_pages.R b/R/z_pages.R index 09d946df9..0538c1434 100644 --- a/R/z_pages.R +++ b/R/z_pages.R @@ -26,21 +26,24 @@ animint2pages <- function(plot.list, user_name, github_repo, commit_message = "C gh::gh("POST /user/repos", name = github_repo) repo <- git2r::init(tmp_dir) git2r::config(repo, user.name = user_name) - # have a initial commit to avoid error - # `Error in 'git2r_branch_create': 'commit' must be an S3 class git_commit` + } else { + github_url <- paste0("https://github.com/", user_name, "/", github_repo, ".git") + repo <- git2r::clone(github_url, tmp_dir, credentials = git2r::cred_token()) + } + + # Check if there are any commits in the repo + # have a initial commit to avoid error + if (length(git2r::commits(repo)) == 0) { + # Perform initial commit readme_file_path <- file.path(tmp_dir, "README.md") writeLines("## New Repo", readme_file_path) git2r::add(repo, "README.md") git2r::commit(repo, "Initial commit") - } else { - github_url <- paste0("https://github.com/", user_name, "/", github_repo, ".git") - repo <- git2r::clone(github_url, tmp_dir, credentials = git2r::cred_token()) } - # Check if the 'gh-pages' branch exists + # Check if the 'gh-pages' branch exists, if not, create it branches <- git2r::branches(repo) if (!"gh-pages" %in% names(branches)) { - # If 'gh-pages' branch doesn't exist, create it git2r::branch_create(repo, "gh-pages") } From 07967feb6231b588286ba3eac8c6d952f9e227df Mon Sep 17 00:00:00 2001 From: Faye-yufan Date: Thu, 31 Aug 2023 22:26:35 -0700 Subject: [PATCH 10/88] use `gert` package and HTTPS protocal --- R/z_pages.R | 115 +++++++++++++++++++++++++++++----------------------- 1 file changed, 65 insertions(+), 50 deletions(-) diff --git a/R/z_pages.R b/R/z_pages.R index 0538c1434..c00144da4 100644 --- a/R/z_pages.R +++ b/R/z_pages.R @@ -1,60 +1,75 @@ -animint2pages <- function(plot.list, user_name, github_repo, commit_message = "Commit from animint2pages", ...) { - res <- animint2dir(plot.list, open.browser = FALSE, ...) - if (!requireNamespace("git2r")) { - stop( - "Please run \n", - "`install.packages('git2r')` ", - "before using this function" - ) +animint2pages <- function(plot.list, github_repo, commit_message = "Commit from animint2pages", private = FALSE, ...) { + # Check for required packages + if (!requireNamespace("gert")) { + stop("Please run `install.packages('gert')` before using this function") } + + # Generate plot files + res <- animint2dir(plot.list, open.browser = FALSE, ...) - # The below are copied from `animint2gist` - ## 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.ignored <- all.file.info$isdir | is.empty | is.tilde - to.post <- all.files[!is.ignored] - + # 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))] + tmp_dir <- tempfile() - - # check if the repo already exists on GH - gh_repos <- gh::gh("/user/repos") - repo_exists <- any(sapply(gh_repos, function(x) x$name) == github_repo) - if (!repo_exists) { - gh::gh("POST /user/repos", name = github_repo) - repo <- git2r::init(tmp_dir) - git2r::config(repo, user.name = user_name) + + # Get GitHub user info + whoami <- suppressMessages(gh::gh_whoami()) + if (is.null(whoami)) { + stop("A GitHub token is required to create and push to a new repo.") + } + + # Check for existing repository + owner <- whoami$login + 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 = tmp_dir) + gert::git_remote_add(name = "origin", url = origin_url, repo = repo) } else { - github_url <- paste0("https://github.com/", user_name, "/", github_repo, ".git") - repo <- git2r::clone(github_url, tmp_dir, credentials = git2r::cred_token()) + origin_url <- paste0("https://github.com/", owner, "/", github_repo, ".git") + repo <- gert::git_clone(origin_url, tmp_dir) } - - # Check if there are any commits in the repo - # have a initial commit to avoid error + if (length(git2r::commits(repo)) == 0) { - # Perform initial commit - readme_file_path <- file.path(tmp_dir, "README.md") - writeLines("## New Repo", readme_file_path) - git2r::add(repo, "README.md") - git2r::commit(repo, "Initial commit") - } - - # Check if the 'gh-pages' branch exists, if not, create it - branches <- git2r::branches(repo) - if (!"gh-pages" %in% names(branches)) { - git2r::branch_create(repo, "gh-pages") + initial_commit(tmp_dir, repo) } + + # Handle gh-pages branch + manage_gh_pages(repo, to_post, tmp_dir, commit_message) + message("Visualization will be available at https://", whoami$login, ".github.io/", github_repo, + "\nDeployment via GitHub Pages may take a few minutes...") + + repo +} - git2r::checkout(repo, "gh-pages") - file.copy(to.post, tmp_dir, recursive = TRUE) - - # TODO: Take a screenshot and save as Capture.PNG. - # Commit the changes - lapply(to.post, function(file) git2r::add(repo, file)) - git2r::commit(repo, commit_message) - git2r::push(repo, "origin", "gh-pages", credentials = git2r::cred_token()) +initial_commit <- function(tmp_dir, repo) { + readme_file_path <- file.path(tmp_dir, "README.md") + writeLines("## New animint visualization", readme_file_path) + gert::git_add("README.md", repo = repo) + gert::git_commit("Initial commit", repo = repo) + gert::git_branch_move(branch = "master", new_branch = "main", repo = repo) + gert::git_push(repo = repo, remote = "origin", set_upstream = TRUE) +} - repo +manage_gh_pages <- function(repo, to_post, tmp_dir, 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, tmp_dir, 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) +} \ No newline at end of file From d2497dff939dd5e8aeabf7464354675eb3e308ee Mon Sep 17 00:00:00 2001 From: Faye-yufan Date: Thu, 31 Aug 2023 22:35:56 -0700 Subject: [PATCH 11/88] remove some weird spaces --- R/z_pages.R | 51 ++++++++++++++++++++++++++++----------------------- 1 file changed, 28 insertions(+), 23 deletions(-) diff --git a/R/z_pages.R b/R/z_pages.R index c00144da4..0b86cc906 100644 --- a/R/z_pages.R +++ b/R/z_pages.R @@ -3,7 +3,7 @@ animint2pages <- function(plot.list, github_repo, commit_message = "Commit from if (!requireNamespace("gert")) { stop("Please run `install.packages('gert')` before using this function") } - + # Generate plot files res <- animint2dir(plot.list, open.browser = FALSE, ...) @@ -11,15 +11,15 @@ animint2pages <- function(plot.list, github_repo, commit_message = "Commit from 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))] - + tmp_dir <- tempfile() - + # Get GitHub user info whoami <- suppressMessages(gh::gh_whoami()) if (is.null(whoami)) { stop("A GitHub token is required to create and push to a new repo.") } - + # Check for existing repository owner <- whoami$login if (!check_no_github_repo(owner, github_repo)) { @@ -31,45 +31,50 @@ animint2pages <- function(plot.list, github_repo, commit_message = "Commit from origin_url <- paste0("https://github.com/", owner, "/", github_repo, ".git") repo <- gert::git_clone(origin_url, tmp_dir) } - + if (length(git2r::commits(repo)) == 0) { initial_commit(tmp_dir, repo) } - + # Handle gh-pages branch manage_gh_pages(repo, to_post, tmp_dir, commit_message) - message("Visualization will be available at https://", whoami$login, ".github.io/", github_repo, - "\nDeployment via GitHub Pages may take a few minutes...") - + message( + "Visualization will be available at https://", whoami$login, ".github.io/", github_repo, + "\nDeployment via GitHub Pages may take a few minutes..." + ) + repo } initial_commit <- function(tmp_dir, repo) { readme_file_path <- file.path(tmp_dir, "README.md") writeLines("## New animint visualization", readme_file_path) - gert::git_add("README.md", repo = repo) - gert::git_commit("Initial commit", repo = repo) - gert::git_branch_move(branch = "master", new_branch = "main", repo = repo) - gert::git_push(repo = repo, remote = "origin", set_upstream = TRUE) + gert::git_add("README.md", repo = repo) + gert::git_commit("Initial commit", repo = repo) + gert::git_branch_move(branch = "master", new_branch = "main", repo = repo) + gert::git_push(repo = repo, remote = "origin", set_upstream = TRUE) } manage_gh_pages <- function(repo, to_post, tmp_dir, 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, tmp_dir, 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) + 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) -} \ No newline at end of file + tryCatch( + { + gh::gh("/repos/{owner}/{repo}", owner = owner, repo = repo) + TRUE + }, + "http_error_404" = function(err) FALSE + ) +} From 1e7106855a2ed7a89c36e67b3ca71046b4d0138f Mon Sep 17 00:00:00 2001 From: Faye-yufan Date: Thu, 31 Aug 2023 22:54:26 -0700 Subject: [PATCH 12/88] Test: Reorder 'Collate' in DESCRIPTION to debug remote installation issues --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 7c7d3f00b..eea8f7535 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -267,9 +267,9 @@ Collate: 'z_facets.R' 'z_geoms.R' 'z_gist.R' - 'z_pages.R' 'z_helperFunctions.R' 'z_knitr.R' + 'z_pages.R' 'z_print.R' 'z_scales.R' 'z_theme_animint.R' From b6675eb6069284aaa87643c3582d79254282d1e0 Mon Sep 17 00:00:00 2001 From: Faye-yufan Date: Fri, 1 Sep 2023 17:58:29 -0700 Subject: [PATCH 13/88] add function documentation --- R/z_pages.R | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/R/z_pages.R b/R/z_pages.R index 0b86cc906..b7c9a7925 100644 --- a/R/z_pages.R +++ b/R/z_pages.R @@ -1,3 +1,28 @@ +#' 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. +#' @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, ...) { # Check for required packages if (!requireNamespace("gert")) { From 1d888e3fe55e3cec7db35d40afc81c0928b9d278 Mon Sep 17 00:00:00 2001 From: Yufan Fei <62975717+Faye-yufan@users.noreply.github.com> Date: Tue, 12 Sep 2023 10:14:10 -0700 Subject: [PATCH 14/88] Add error message for missing GitHub token to include detailed setup instructions --- R/z_pages.R | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/R/z_pages.R b/R/z_pages.R index b7c9a7925..0486a2112 100644 --- a/R/z_pages.R +++ b/R/z_pages.R @@ -24,6 +24,21 @@ #' #' @export animint2pages <- function(plot.list, github_repo, commit_message = "Commit from animint2pages", private = FALSE, ...) { + # Check for GitHub token + github_token <- Sys.getenv("GITHUB_PAT") + if (identical(github_token, "")) { + stop("A GitHub token is required to create and push to a new repository. \n", + "To create a GitHub token, follow these steps:\n", + "1. Go to https://github.com/settings/tokens/new?scopes=repo&description=animint2pages\n", + "2. Confirm your password if prompted.\n", + "3. Ensure that the 'repo' scope is checked.\n", + "4. Click 'Generate token' at the bottom of the page.\n", + "5. Copy the generated token.\n", + "After creating the token, you can set it up in your R environment by running: \n", + "gitcreds::gitcreds_set()\n", + "And then paste the token when prompted.") + } + # Check for required packages if (!requireNamespace("gert")) { stop("Please run `install.packages('gert')` before using this function") From e738e8fe591d5ab88dd1a94321840566d5835c71 Mon Sep 17 00:00:00 2001 From: Yufan Fei <62975717+Faye-yufan@users.noreply.github.com> Date: Tue, 12 Sep 2023 10:20:36 -0700 Subject: [PATCH 15/88] Add test for error message --- test-compiler-ghpages.R | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/test-compiler-ghpages.R b/test-compiler-ghpages.R index 0686ae9dc..3574e0038 100644 --- a/test-compiler-ghpages.R +++ b/test-compiler-ghpages.R @@ -7,3 +7,21 @@ test_that("animint2pages() returns an object of class 'git_repository'", { repo <- animint2pages(list(p = ggplot2::qplot(1:10)), github_repo = repo_name) expect_is(repo, "git_repository") }) + +test_that("animint2pages raises an error if no GitHub token is present", { + withr::local_envvar(c(GITHUB_PAT = NULL), { + expect_error( + animint2pages(plot.list = list(), github_repo = "test_repo"), + paste0("A GitHub token is required to create and push to a new repository. \n", + "To create a GitHub token, follow these steps:\n", + "1. Go to https://github.com/settings/tokens/new?scopes=repo&description=animint2pages\n", + "2. Confirm your password if prompted.\n", + "3. Ensure that the 'repo' scope is checked.\n", + "4. Click 'Generate token' at the bottom of the page.\n", + "5. Copy the generated token.\n", + "After creating the token, you can set it up in your R environment by running: \n", + "gitcreds::gitcreds_set()\n", + "And then paste the token when prompted.") + ) + }) +}) From 99f18cc0132d0b5c20c712a2d175c66409500e74 Mon Sep 17 00:00:00 2001 From: Faye-yufan Date: Sat, 16 Sep 2023 19:40:34 -0700 Subject: [PATCH 16/88] combine whoami and gitcreds_get() --- R/z_pages.R | 57 ++++++++++++++++++++++++++++++----------------------- 1 file changed, 32 insertions(+), 25 deletions(-) diff --git a/R/z_pages.R b/R/z_pages.R index 0486a2112..23f05a051 100644 --- a/R/z_pages.R +++ b/R/z_pages.R @@ -1,10 +1,10 @@ #' 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 +#' 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. @@ -12,38 +12,30 @@ #' @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() +#' 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, ...) { - # Check for GitHub token - github_token <- Sys.getenv("GITHUB_PAT") - if (identical(github_token, "")) { - stop("A GitHub token is required to create and push to a new repository. \n", - "To create a GitHub token, follow these steps:\n", - "1. Go to https://github.com/settings/tokens/new?scopes=repo&description=animint2pages\n", - "2. Confirm your password if prompted.\n", - "3. Ensure that the 'repo' scope is checked.\n", - "4. Click 'Generate token' at the bottom of the page.\n", - "5. Copy the generated token.\n", - "After creating the token, you can set it up in your R environment by running: \n", - "gitcreds::gitcreds_set()\n", - "And then paste the token when prompted.") - } - + # Check for required packages if (!requireNamespace("gert")) { stop("Please run `install.packages('gert')` before using this function") } + if (!requireNamespace("gh")) { + stop("Please run `install.packages('gh')` before using this function") + } + # Generate plot files res <- animint2dir(plot.list, open.browser = FALSE, ...) @@ -54,11 +46,26 @@ animint2pages <- function(plot.list, github_repo, commit_message = "Commit from tmp_dir <- tempfile() - # Get GitHub user info - whoami <- suppressMessages(gh::gh_whoami()) - if (is.null(whoami)) { - stop("A GitHub token is required to create and push to a new repo.") - } + tryCatch( + { + whoami <- suppressMessages(gh::gh_whoami()) + }, + error = function(e) { + stop( + "A GitHub token is required to create and push to a new repository. \n", + "To create a GitHub token, follow these steps:\n", + "1. Go to https://github.com/settings/tokens/new?scopes=repo&description=animint2pages\n", + "2. Confirm your password if prompted.\n", + "3. Ensure that the 'repo' scope is checked.\n", + "4. Click 'Generate token' at the bottom of the page.\n", + "5. Copy the generated token.\n", + "After creating the token, you can set it up in your R environment by running: \n", + "Sys.setenv(GITHUB_PAT=\"yourGithubPAT\") \n", + "gert::git_config_global_set(\"user.name\", \"yourUserName\") \n", + "gert::git_config_global_set(\"user.email\", \"yourEmail\") \n" + ) + } + ) # Check for existing repository owner <- whoami$login From 96dc8cf20328c14fe826d4c72024b603a90070d8 Mon Sep 17 00:00:00 2001 From: Faye-yufan Date: Sat, 16 Sep 2023 19:49:25 -0700 Subject: [PATCH 17/88] use gitcreds_get(), cuz gh_whoami() doesn't raise error --- R/z_pages.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/z_pages.R b/R/z_pages.R index 23f05a051..2d1077495 100644 --- a/R/z_pages.R +++ b/R/z_pages.R @@ -48,7 +48,7 @@ animint2pages <- function(plot.list, github_repo, commit_message = "Commit from tryCatch( { - whoami <- suppressMessages(gh::gh_whoami()) + creds <- gitcreds::gitcreds_get() }, error = function(e) { stop( @@ -68,6 +68,7 @@ animint2pages <- function(plot.list, github_repo, commit_message = "Commit from ) # Check for existing repository + whoami <- suppressMessages(gh::gh_whoami()) owner <- whoami$login if (!check_no_github_repo(owner, github_repo)) { create <- gh::gh("POST /user/repos", name = github_repo, private = private) From 6ccc1df59585782ef60d9c849c1e1bcfa3eb2988 Mon Sep 17 00:00:00 2001 From: Faye-yufan Date: Thu, 12 Oct 2023 22:30:43 -0700 Subject: [PATCH 18/88] move unit test --- test-compiler-ghpages.R => tests/testthat/test-compiler-ghpages.R | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename test-compiler-ghpages.R => tests/testthat/test-compiler-ghpages.R (100%) diff --git a/test-compiler-ghpages.R b/tests/testthat/test-compiler-ghpages.R similarity index 100% rename from test-compiler-ghpages.R rename to tests/testthat/test-compiler-ghpages.R From 661b6a7e35fd02d2704e261ced1e1d8a3bd6db29 Mon Sep 17 00:00:00 2001 From: Faye-yufan Date: Thu, 12 Oct 2023 22:57:56 -0700 Subject: [PATCH 19/88] update plot.list --- tests/testthat/test-compiler-ghpages.R | 30 +++++++++++++++----------- 1 file changed, 17 insertions(+), 13 deletions(-) diff --git a/tests/testthat/test-compiler-ghpages.R b/tests/testthat/test-compiler-ghpages.R index 3574e0038..254ac0984 100644 --- a/tests/testthat/test-compiler-ghpages.R +++ b/tests/testthat/test-compiler-ghpages.R @@ -1,27 +1,31 @@ acontext("GitHub Pages") Sys.setenv(GITHUB_PAT = Sys.getenv("GITHUB_PAT")) -gh_username <- Sys.getenv("GITHUB_USERNAME") + +plot <- ggplot(data.frame(x = 1:10), aes(x)) + + geom_point() test_that("animint2pages() returns an object of class 'git_repository'", { - repo <- animint2pages(list(p = ggplot2::qplot(1:10)), github_repo = repo_name) + repo <- animint2pages(list(p = plot), github_repo = "test_repo") expect_is(repo, "git_repository") }) test_that("animint2pages raises an error if no GitHub token is present", { withr::local_envvar(c(GITHUB_PAT = NULL), { expect_error( - animint2pages(plot.list = list(), github_repo = "test_repo"), - paste0("A GitHub token is required to create and push to a new repository. \n", - "To create a GitHub token, follow these steps:\n", - "1. Go to https://github.com/settings/tokens/new?scopes=repo&description=animint2pages\n", - "2. Confirm your password if prompted.\n", - "3. Ensure that the 'repo' scope is checked.\n", - "4. Click 'Generate token' at the bottom of the page.\n", - "5. Copy the generated token.\n", - "After creating the token, you can set it up in your R environment by running: \n", - "gitcreds::gitcreds_set()\n", - "And then paste the token when prompted.") + animint2pages(list(p = plot), github_repo = "test_repo"), + paste0( + "A GitHub token is required to create and push to a new repository. \n", + "To create a GitHub token, follow these steps:\n", + "1. Go to https://github.com/settings/tokens/new?scopes=repo&description=animint2pages\n", + "2. Confirm your password if prompted.\n", + "3. Ensure that the 'repo' scope is checked.\n", + "4. Click 'Generate token' at the bottom of the page.\n", + "5. Copy the generated token.\n", + "After creating the token, you can set it up in your R environment by running: \n", + "gitcreds::gitcreds_set()\n", + "And then paste the token when prompted." + ) ) }) }) From e07e137671c848291c3f2abbadb357243d3b748c Mon Sep 17 00:00:00 2001 From: Faye-yufan Date: Thu, 12 Oct 2023 23:39:01 -0700 Subject: [PATCH 20/88] Dynamically identify the active Git branch --- R/z_pages.R | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/R/z_pages.R b/R/z_pages.R index 2d1077495..e1ba85953 100644 --- a/R/z_pages.R +++ b/R/z_pages.R @@ -99,7 +99,15 @@ initial_commit <- function(tmp_dir, repo) { writeLines("## New animint visualization", readme_file_path) gert::git_add("README.md", repo = repo) gert::git_commit("Initial commit", repo = repo) - gert::git_branch_move(branch = "master", new_branch = "main", repo = repo) + all_branches <- gert::git_branch(repo) + print(all_branches) + if (is.data.frame(all_branches)) { + current_master <- all_branches$name[all_branches$active] + } else { + current_master <- all_branches + } + print(current_master) + gert::git_branch_move(branch = current_master, new_branch = "main", repo = repo) gert::git_push(repo = repo, remote = "origin", set_upstream = TRUE) } From e2cc27d08b9a15e16da123ff7426fd5649a3d091 Mon Sep 17 00:00:00 2001 From: Faye-yufan Date: Thu, 12 Oct 2023 23:39:33 -0700 Subject: [PATCH 21/88] Add man/animint2pages.Rd and update test case --- man/animint2pages.Rd | 46 ++++++++++++++++++++++++++ tests/testthat/test-compiler-ghpages.R | 2 +- 2 files changed, 47 insertions(+), 1 deletion(-) create mode 100644 man/animint2pages.Rd diff --git a/man/animint2pages.Rd b/man/animint2pages.Rd new file mode 100644 index 000000000..6fa64da79 --- /dev/null +++ b/man/animint2pages.Rd @@ -0,0 +1,46 @@ +% 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, + ... +) +} +\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.} + +\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/tests/testthat/test-compiler-ghpages.R b/tests/testthat/test-compiler-ghpages.R index 254ac0984..c1c4147a6 100644 --- a/tests/testthat/test-compiler-ghpages.R +++ b/tests/testthat/test-compiler-ghpages.R @@ -2,7 +2,7 @@ acontext("GitHub Pages") Sys.setenv(GITHUB_PAT = Sys.getenv("GITHUB_PAT")) -plot <- ggplot(data.frame(x = 1:10), aes(x)) + +plot <- ggplot(data.frame(x = 1:10, y = 1:10), aes(x, y)) + geom_point() test_that("animint2pages() returns an object of class 'git_repository'", { From d01b45738d9b0952ab41f17f2d4dc217de510302 Mon Sep 17 00:00:00 2001 From: Faye-yufan Date: Fri, 13 Oct 2023 00:41:34 -0700 Subject: [PATCH 22/88] Update logic of identifying the active branch --- R/z_pages.R | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/R/z_pages.R b/R/z_pages.R index e1ba85953..b7a4e5d6b 100644 --- a/R/z_pages.R +++ b/R/z_pages.R @@ -100,14 +100,16 @@ initial_commit <- function(tmp_dir, repo) { gert::git_add("README.md", repo = repo) gert::git_commit("Initial commit", repo = repo) all_branches <- gert::git_branch(repo) - print(all_branches) + # check if it is a data frame or an atomic vector if (is.data.frame(all_branches)) { current_master <- all_branches$name[all_branches$active] } else { current_master <- all_branches } - print(current_master) - gert::git_branch_move(branch = current_master, new_branch = "main", repo = repo) + # 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$name) { + gert::git_branch_move(branch = current_master, new_branch = "main", repo = repo) + } gert::git_push(repo = repo, remote = "origin", set_upstream = TRUE) } From a6942188f580941fa3b21fe90ed53e787e9ae50a Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Fri, 27 Oct 2023 16:13:46 -0700 Subject: [PATCH 23/88] source option saved to plot.json and displayed below viz --- R/z_animint.R | 8 +- inst/htmljs/animint.js | 7 +- tests/testthat/test-renderer2-widerect.R | 176 +++++++++++++---------- 3 files changed, 110 insertions(+), 81 deletions(-) diff --git a/R/z_animint.R b/R/z_animint.R index 510bbb6a3..c6879580e 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/inst/htmljs/animint.js b/inst/htmljs/animint.js index 01dd1e740..5422f0268 100644 --- a/inst/htmljs/animint.js +++ b/inst/htmljs/animint.js @@ -2258,7 +2258,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/tests/testthat/test-renderer2-widerect.R b/tests/testthat/test-renderer2-widerect.R index d1aff9987..cf4436573 100644 --- a/tests/testthat/test-renderer2-widerect.R +++ b/tests/testthat/test-renderer2-widerect.R @@ -1,5 +1,16 @@ acontext("geom_widerect") +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(computed, expected) +} + recommendation <- data.frame( min.C=21, max.C=23) @@ -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) From 7d26efb37682e88d918f769865821bc1a6050396 Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Sat, 28 Oct 2023 00:51:23 +0100 Subject: [PATCH 24/88] bugfix when git_branch returns character --- R/z_pages.R | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/R/z_pages.R b/R/z_pages.R index b7a4e5d6b..f0c53caf5 100644 --- a/R/z_pages.R +++ b/R/z_pages.R @@ -99,15 +99,17 @@ initial_commit <- function(tmp_dir, repo) { writeLines("## New animint visualization", readme_file_path) gert::git_add("README.md", repo = repo) gert::git_commit("Initial commit", repo = repo) - all_branches <- gert::git_branch(repo) + df_or_vec <- gert::git_branch(repo) # check if it is a data frame or an atomic vector - if (is.data.frame(all_branches)) { - current_master <- all_branches$name[all_branches$active] + if (is.data.frame(df_or_vec)) { + all_branches <- df_or_vec[["name"]] + current_master <- all_branches[df_or_vec$active] } else { - current_master <- all_branches + 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$name) { + 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) From c1a4fa963f31277f827200becb6eb8667e9c9cdb Mon Sep 17 00:00:00 2001 From: Yufan Fei <62975717+Faye-yufan@users.noreply.github.com> Date: Fri, 27 Oct 2023 17:19:11 -0700 Subject: [PATCH 25/88] add viz url into README.md --- R/z_pages.R | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/R/z_pages.R b/R/z_pages.R index f0c53caf5..fa427392b 100644 --- a/R/z_pages.R +++ b/R/z_pages.R @@ -80,23 +80,28 @@ animint2pages <- function(plot.list, github_repo, commit_message = "Commit from repo <- gert::git_clone(origin_url, tmp_dir) } + viz_url <- paste0("https://", whoami$login, ".github.io/", github_repo) if (length(git2r::commits(repo)) == 0) { - initial_commit(tmp_dir, repo) + initial_commit(tmp_dir, repo, viz_url) } # Handle gh-pages branch manage_gh_pages(repo, to_post, tmp_dir, commit_message) message( - "Visualization will be available at https://", whoami$login, ".github.io/", github_repo, + "Visualization will be available at ", viz_url, "\nDeployment via GitHub Pages may take a few minutes..." ) repo } -initial_commit <- function(tmp_dir, repo) { +initial_commit <- function(tmp_dir, repo, viz_url) { readme_file_path <- file.path(tmp_dir, "README.md") - writeLines("## New animint visualization", readme_file_path) + 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) From 15a7067fed9f7c5402cb06387f97d45ffca529b4 Mon Sep 17 00:00:00 2001 From: Yufan Fei <62975717+Faye-yufan@users.noreply.github.com> Date: Fri, 27 Oct 2023 17:23:57 -0700 Subject: [PATCH 26/88] raise error if input `github_repo` contains "/" forward slash --- R/z_pages.R | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/R/z_pages.R b/R/z_pages.R index fa427392b..f5ea14312 100644 --- a/R/z_pages.R +++ b/R/z_pages.R @@ -67,9 +67,15 @@ animint2pages <- function(plot.list, github_repo, commit_message = "Commit from } ) + # 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 + if (!check_no_github_repo(owner, github_repo)) { create <- gh::gh("POST /user/repos", name = github_repo, private = private) origin_url <- create$clone_url From 0fb6fc98af6219e8ed9b22d4a6dcba26c1872f18 Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Fri, 27 Oct 2023 22:02:45 -0700 Subject: [PATCH 27/88] stop if required_opts not present --- DESCRIPTION | 2 ++ R/z_pages.R | 23 ++++++++++++++++------- man/animint2pages.Rd | 9 ++++++++- 3 files changed, 26 insertions(+), 8 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 382984415..6444a5504 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -76,6 +76,7 @@ Imports: methods Suggests: servr, + gert, gitcreds, gh, sp, gistr (>= 0.2), shiny, @@ -279,3 +280,4 @@ Collate: 'z_transformShape.R' RoxygenNote: 7.2.3 Config/Needs/website: tidyverse/tidytemplate +VignetteBuilder: knitr diff --git a/R/z_pages.R b/R/z_pages.R index f5ea14312..787ec95ed 100644 --- a/R/z_pages.R +++ b/R/z_pages.R @@ -9,6 +9,7 @@ #' @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. +#' @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. @@ -21,19 +22,27 @@ #' 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) +#' 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, ...) { +animint2pages <- function(plot.list, github_repo, commit_message = "Commit from animint2pages", private = FALSE, required_opts = c("title","source"), ...) { - # Check for required packages - if (!requireNamespace("gert")) { - stop("Please run `install.packages('gert')` before using this function") + 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)) + } } - if (!requireNamespace("gh")) { - stop("Please run `install.packages('gh')` before using this function") + # Check for required packages + for(pkg in c("gert", "gh")){ + if (!requireNamespace(pkg)) { + stop(sprinft("Please run `install.packages('%s')` before using this function", pkg)) + } } # Generate plot files diff --git a/man/animint2pages.Rd b/man/animint2pages.Rd index 6fa64da79..95f76ef03 100644 --- a/man/animint2pages.Rd +++ b/man/animint2pages.Rd @@ -9,6 +9,7 @@ animint2pages( github_repo, commit_message = "Commit from animint2pages", private = FALSE, + required_opts = c("title", "source"), ... ) } @@ -21,6 +22,8 @@ animint2pages( \item{private}{A logical flag indicating whether the GitHub repository should be private or not.} +\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{ @@ -40,7 +43,11 @@ p1 <- ggplot(mtcars, aes(x = mpg, y = wt)) + 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) +animint2pages( + viz, + github_repo = "my_animint2_plots", + commit_message = "New animint", + private = TRUE) } } From 54355b9a8bdab0217a393d4057b1a7103ac0dd4d Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Fri, 27 Oct 2023 22:10:06 -0700 Subject: [PATCH 28/88] version++ --- DESCRIPTION | 2 +- NEWS.md | 11 ++++++++++- 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 6444a5504..ae453f477 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: animint2 Title: Animated Interactive Grammar of Graphics -Version: 2023.6.11 +Version: 2023.10.27 URL: https://animint.github.io/animint2/ BugReports: https://github.com/animint/animint2/issues Authors@R: c( diff --git a/NEWS.md b/NEWS.md index d3aba0299..b7eecde81 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,12 @@ +# Changes in 2023.10.27 + +- 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 at the + below the rendered viz. + # Changes in 2023.6.11 - Remove maptools dependency. @@ -92,4 +101,4 @@ # Changes in 2017.08.24 -- DSL: clickSelects/showSelected are now specified as parameters rather than aesthetics. \ No newline at end of file +- DSL: clickSelects/showSelected are now specified as parameters rather than aesthetics. From 2c04fbfd8c49d29b85dfdb3e6564ba9487271e01 Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Fri, 27 Oct 2023 22:13:20 -0700 Subject: [PATCH 29/88] fix typo --- R/z_pages.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/z_pages.R b/R/z_pages.R index 787ec95ed..b34b952d2 100644 --- a/R/z_pages.R +++ b/R/z_pages.R @@ -41,7 +41,7 @@ animint2pages <- function(plot.list, github_repo, commit_message = "Commit from # Check for required packages for(pkg in c("gert", "gh")){ if (!requireNamespace(pkg)) { - stop(sprinft("Please run `install.packages('%s')` before using this function", pkg)) + stop(sprintf("Please run `install.packages('%s')` before using this function", pkg)) } } From 9395b1c9c273d19eec48d164767dccde496f20db Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Fri, 27 Oct 2023 22:13:34 -0700 Subject: [PATCH 30/88] provide header engine --- vignettes/animint2.Rmd | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/vignettes/animint2.Rmd b/vignettes/animint2.Rmd index 063c299ce..363a0c8d2 100644 --- a/vignettes/animint2.Rmd +++ b/vignettes/animint2.Rmd @@ -1,7 +1,9 @@ ---- -title: "Animint2 Quick Start Guide" ---- + +# Animint2 Quick Start Guide ## Introduction From 26e671307b7f3a35bca166806d4a49fadf6ee397 Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Fri, 27 Oct 2023 22:13:46 -0700 Subject: [PATCH 31/88] ignore readme_website --- .Rbuildignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.Rbuildignore b/.Rbuildignore index faca41cfa..1a0c31e56 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1,3 +1,4 @@ +readme_website.md .github ^.*\.Rproj$ ^\.Rproj\.user$ From a4f66e366f7a1ba76a771acb6818c8d9194973e1 Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Tue, 31 Oct 2023 22:38:20 -0700 Subject: [PATCH 32/88] reformat tryCatch, 1 line string for easier translation --- R/z_pages.R | 23 +++-------------------- 1 file changed, 3 insertions(+), 20 deletions(-) diff --git a/R/z_pages.R b/R/z_pages.R index b34b952d2..21f85494d 100644 --- a/R/z_pages.R +++ b/R/z_pages.R @@ -55,26 +55,9 @@ animint2pages <- function(plot.list, github_repo, commit_message = "Commit from tmp_dir <- tempfile() - tryCatch( - { - creds <- gitcreds::gitcreds_get() - }, - error = function(e) { - stop( - "A GitHub token is required to create and push to a new repository. \n", - "To create a GitHub token, follow these steps:\n", - "1. Go to https://github.com/settings/tokens/new?scopes=repo&description=animint2pages\n", - "2. Confirm your password if prompted.\n", - "3. Ensure that the 'repo' scope is checked.\n", - "4. Click 'Generate token' at the bottom of the page.\n", - "5. Copy the generated token.\n", - "After creating the token, you can set it up in your R environment by running: \n", - "Sys.setenv(GITHUB_PAT=\"yourGithubPAT\") \n", - "gert::git_config_global_set(\"user.name\", \"yourUserName\") \n", - "gert::git_config_global_set(\"user.email\", \"yourEmail\") \n" - ) - } - ) + tryCatch({ + creds <- 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)) { From a1231960f8719b992a73305aec9cb8e725e320d2 Mon Sep 17 00:00:00 2001 From: Faye-yufan Date: Tue, 31 Oct 2023 22:46:57 -0700 Subject: [PATCH 33/88] replace `git2r::commits` with `gert::git_log` --- R/z_pages.R | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/R/z_pages.R b/R/z_pages.R index b34b952d2..6ee342128 100644 --- a/R/z_pages.R +++ b/R/z_pages.R @@ -96,7 +96,17 @@ animint2pages <- function(plot.list, github_repo, commit_message = "Commit from } viz_url <- paste0("https://", whoami$login, ".github.io/", github_repo) - if (length(git2r::commits(repo)) == 0) { + # 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(tmp_dir, repo, viz_url) } From f41c1bf75a485e31d4eded84c39120eaff202b76 Mon Sep 17 00:00:00 2001 From: Faye-yufan Date: Tue, 31 Oct 2023 22:51:14 -0700 Subject: [PATCH 34/88] delete animint2gist, and run `roxygen2::roxygenise()` --- DESCRIPTION | 1 - NAMESPACE | 1 - R/z_gist.R | 80 --------------------------------------------- man/animint2gist.Rd | 34 ------------------- 4 files changed, 116 deletions(-) delete mode 100644 R/z_gist.R delete mode 100644 man/animint2gist.Rd diff --git a/DESCRIPTION b/DESCRIPTION index ae453f477..6687735ba 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -270,7 +270,6 @@ Collate: 'z_animintHelpers.R' 'z_facets.R' 'z_geoms.R' - 'z_gist.R' 'z_helperFunctions.R' 'z_knitr.R' 'z_pages.R' diff --git a/NAMESPACE b/NAMESPACE index 154b960c1..d31d60e57 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -214,7 +214,6 @@ export(aes_string) export(alpha) export(animint) export(animint2dir) -export(animint2gist) export(animint2pages) export(animintOutput) export(annotate) diff --git a/R/z_gist.R b/R/z_gist.R deleted file mode 100644 index 994961c93..000000000 --- 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/man/animint2gist.Rd b/man/animint2gist.Rd deleted file mode 100644 index 58afa45e1..000000000 --- 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") -} -} From 24f37f8e6b6f293078fd4c13c14aa7aacf2a7157 Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Tue, 31 Oct 2023 23:37:09 -0700 Subject: [PATCH 35/88] add update_gallery fun --- NAMESPACE | 1 + R/z_pages.R | 80 +++++++++++++++++++++++++++++++++++++++++++ man/update_gallery.Rd | 25 ++++++++++++++ 3 files changed, 106 insertions(+) create mode 100644 man/update_gallery.Rd diff --git a/NAMESPACE b/NAMESPACE index 154b960c1..1cf9c83bc 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -490,6 +490,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/R/z_pages.R b/R/z_pages.R index 21f85494d..39f89aa8b 100644 --- a/R/z_pages.R +++ b/R/z_pages.R @@ -141,3 +141,83 @@ check_no_github_repo <- function(owner, repo) { "http_error_404" = function(err) FALSE ) } + +get_pages_info <- function(viz_user_repo){ + viz_dir <- tempfile() + origin_url <- paste0("https://github.com/", viz_user_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_user_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_user_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_user_repo, attr.name, to.check[[attr.name]])) + } + } + repo.row +} + +##' A gallery is a collection of animints that have been published to +##' github pages. 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/commit the data, re-render index.Rmd in gallery, and push +##' gallery to origin. +##' @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"){ + repos.txt <- file.path(gallery_path, "repos.txt") + repos.dt <- fread(repos.txt,header=FALSE,col.names="viz_user_repo") + meta.csv <- file.path(gallery_path, "meta.csv") + old.meta <- fread(meta.csv) + todo.meta <- repos.dt[!old.meta, on="viz_user_repo"] + meta.dt.list <- list(old.meta) + error.dt.list <- list() + add.POSIXct <- Sys.time() + for(viz_user_repo in todo.meta[["viz_user_repo"]]){ + tryCatch({ + meta.row <- data.table(add.POSIXct, get_repo_row(viz_user_repo)) + meta.dt.list[[viz_user_repo]] <- meta.row + Capture.PNG <- meta.row[["Capture.PNG"]] + repo.png <- file.path( + gallery_path, "repos", paste0(viz_user_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_user_repo]] <<- data.table( + add.POSIXct, viz_user_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", file.path("repos","*","*.png"), "index.html") + 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/man/update_gallery.Rd b/man/update_gallery.Rd new file mode 100644 index 000000000..0a7518650 --- /dev/null +++ b/man/update_gallery.Rd @@ -0,0 +1,25 @@ +% 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 animints that have been published to +github pages. 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/commit the data, re-render index.Rmd in gallery, and push +gallery to origin. +} +\author{ +Toby Dylan Hocking +} From 4bd9344a3f2915971de84bf22f587716daea8dbc Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Tue, 31 Oct 2023 23:52:35 -0700 Subject: [PATCH 36/88] get_repo_row->get_pages_info --- R/z_pages.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/z_pages.R b/R/z_pages.R index b709d4f52..e3c4600ba 100644 --- a/R/z_pages.R +++ b/R/z_pages.R @@ -207,7 +207,7 @@ update_gallery <- function(gallery_path="~/R/gallery"){ add.POSIXct <- Sys.time() for(viz_user_repo in todo.meta[["viz_user_repo"]]){ tryCatch({ - meta.row <- data.table(add.POSIXct, get_repo_row(viz_user_repo)) + meta.row <- data.table(add.POSIXct, get_pages_info(viz_user_repo)) meta.dt.list[[viz_user_repo]] <- meta.row Capture.PNG <- meta.row[["Capture.PNG"]] repo.png <- file.path( From 2d305eef28fd28a76688c4d3000ddc29f384584f Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Wed, 1 Nov 2023 00:04:15 -0700 Subject: [PATCH 37/88] link gallery --- R/z_pages.R | 10 +++++++--- man/update_gallery.Rd | 7 +++++-- 2 files changed, 12 insertions(+), 5 deletions(-) diff --git a/R/z_pages.R b/R/z_pages.R index e3c4600ba..c5fa069cb 100644 --- a/R/z_pages.R +++ b/R/z_pages.R @@ -190,9 +190,12 @@ get_pages_info <- function(viz_user_repo){ ##' which is not already present in meta.csv, and parse meta-data ##' (title, source, Capture.PNG) from the gh-pages branch, and ##' write/commit the data, re-render index.Rmd in gallery, and push -##' gallery to origin. +##' gallery to origin. See +##' \url{https://github.com/animint/gallery/tree/gh-pages} which is +##' the main gallery which is updated using this function. ##' @title Update gallery -##' @param gallery_path path to local github repo with gh-pages active. +##' @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 @@ -225,7 +228,8 @@ update_gallery <- function(gallery_path="~/R/gallery"){ 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", file.path("repos","*","*.png"), "index.html") + to_add <- c( + "*.csv", 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) diff --git a/man/update_gallery.Rd b/man/update_gallery.Rd index 0a7518650..3b5fe3c75 100644 --- a/man/update_gallery.Rd +++ b/man/update_gallery.Rd @@ -7,7 +7,8 @@ update_gallery(gallery_path = "~/R/gallery") } \arguments{ -\item{gallery_path}{path to local github repo with gh-pages active.} +\item{gallery_path}{path to local github repo with gh-pages +active.} } \value{ named list of data tables (meta and error). @@ -18,7 +19,9 @@ github pages. 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/commit the data, re-render index.Rmd in gallery, and push -gallery to origin. +gallery to origin. See +\url{https://github.com/animint/gallery/tree/gh-pages} which is +the main gallery which is updated using this function. } \author{ Toby Dylan Hocking From 717cab6afeab64e3f6d5257001134b2fd6bc711f Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Wed, 1 Nov 2023 22:44:26 -0700 Subject: [PATCH 38/88] fix pages tests --- R/z_pages.R | 89 +++++++++++--------------- tests/testthat/test-compiler-ghpages.R | 62 +++++++++++------- 2 files changed, 78 insertions(+), 73 deletions(-) diff --git a/R/z_pages.R b/R/z_pages.R index c5fa069cb..196971d64 100644 --- a/R/z_pages.R +++ b/R/z_pages.R @@ -6,10 +6,15 @@ #' 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. -#' @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 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. @@ -31,54 +36,45 @@ #' #' @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))] - - tmp_dir <- tempfile() - tryCatch({ - creds <- gitcreds::gitcreds_get() + 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 - + 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 = tmp_dir) + 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/", owner, "/", github_repo, ".git") - repo <- gert::git_clone(origin_url, tmp_dir) + origin_url <- paste0("https://github.com/", viz_owner_repo, ".git") + repo <- gert::git_clone(origin_url, local_clone) } - - viz_url <- paste0("https://", whoami$login, ".github.io/", github_repo) + 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( @@ -90,26 +86,21 @@ animint2pages <- function(plot.list, github_repo, commit_message = "Commit from silent = TRUE ) if (!has_commits) { - initial_commit(tmp_dir, repo, viz_url) + initial_commit(local_clone, repo, viz_url) } - # Handle gh-pages branch - manage_gh_pages(repo, to_post, tmp_dir, commit_message) - message( - "Visualization will be available at ", viz_url, - "\nDeployment via GitHub Pages may take a few minutes..." - ) - - repo + 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(tmp_dir, repo, viz_url) { - readme_file_path <- file.path(tmp_dir, "README.md") +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) @@ -128,15 +119,13 @@ initial_commit <- function(tmp_dir, repo, viz_url) { gert::git_push(repo = repo, remote = "origin", set_upstream = TRUE) } -manage_gh_pages <- function(repo, to_post, tmp_dir, commit_message) { +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, tmp_dir, recursive = TRUE) + 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) @@ -152,20 +141,20 @@ check_no_github_repo <- function(owner, repo) { ) } -get_pages_info <- function(viz_user_repo){ +get_pages_info <- function(viz_owner_repo){ viz_dir <- tempfile() - origin_url <- paste0("https://github.com/", viz_user_repo, ".git") + 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_user_repo)) + 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_user_repo, Capture.PNG, commit.POSIXct=commit.row$time) + 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") @@ -179,7 +168,7 @@ get_pages_info <- function(viz_user_repo){ ){ 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_user_repo, attr.name, to.check[[attr.name]])) + 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 @@ -201,26 +190,26 @@ get_pages_info <- function(viz_user_repo){ ##' @export update_gallery <- function(gallery_path="~/R/gallery"){ repos.txt <- file.path(gallery_path, "repos.txt") - repos.dt <- fread(repos.txt,header=FALSE,col.names="viz_user_repo") + 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_user_repo"] + 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_user_repo in todo.meta[["viz_user_repo"]]){ + for(viz_owner_repo in todo.meta[["viz_owner_repo"]]){ tryCatch({ - meta.row <- data.table(add.POSIXct, get_pages_info(viz_user_repo)) - meta.dt.list[[viz_user_repo]] <- meta.row + meta.row <- data.table(add.POSIXct, get_pages_info(viz_owner_repo)) + meta.dt.list[[viz_owner_repo]] <- meta.row Capture.PNG <- meta.row[["Capture.PNG"]] repo.png <- file.path( - gallery_path, "repos", paste0(viz_user_repo, ".png")) + 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_user_repo]] <<- data.table( - add.POSIXct, viz_user_repo, error=e$message) + error.dt.list[[viz_owner_repo]] <<- data.table( + add.POSIXct, viz_owner_repo, error=e$message) }) } (meta.dt <- rbindlist(meta.dt.list)) diff --git a/tests/testthat/test-compiler-ghpages.R b/tests/testthat/test-compiler-ghpages.R index c1c4147a6..ce617b5bc 100644 --- a/tests/testthat/test-compiler-ghpages.R +++ b/tests/testthat/test-compiler-ghpages.R @@ -1,31 +1,47 @@ acontext("GitHub Pages") -Sys.setenv(GITHUB_PAT = Sys.getenv("GITHUB_PAT")) +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()) -plot <- 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 an object of class 'git_repository'", { - repo <- animint2pages(list(p = plot), github_repo = "test_repo") - expect_is(repo, "git_repository") +viz_owner_repo <- animint2pages(viz, github_repo = "animint2pages_test_repo") +test_that("animint2pages() returns owner/repo string", { + expect_is(viz_owner_repo, "character") }) test_that("animint2pages raises an error if no GitHub token is present", { - withr::local_envvar(c(GITHUB_PAT = NULL), { - expect_error( - animint2pages(list(p = plot), github_repo = "test_repo"), - paste0( - "A GitHub token is required to create and push to a new repository. \n", - "To create a GitHub token, follow these steps:\n", - "1. Go to https://github.com/settings/tokens/new?scopes=repo&description=animint2pages\n", - "2. Confirm your password if prompted.\n", - "3. Ensure that the 'repo' scope is checked.\n", - "4. Click 'Generate token' at the bottom of the page.\n", - "5. Copy the generated token.\n", - "After creating the token, you can set it up in your R environment by running: \n", - "gitcreds::gitcreds_set()\n", - "And then paste the token when prompted." - ) - ) - }) + 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) }) From 47010984bca333e63c4ba33b0e2506675c007000 Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Wed, 1 Nov 2023 22:46:06 -0700 Subject: [PATCH 39/88] line breaks in docs --- man/animint2pages.Rd | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/man/animint2pages.Rd b/man/animint2pages.Rd index 95f76ef03..0c3b00930 100644 --- a/man/animint2pages.Rd +++ b/man/animint2pages.Rd @@ -16,13 +16,18 @@ animint2pages( \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{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{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.} +\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{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}.} } From 500392eee97b87996b838568437db59f6370d149 Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Thu, 2 Nov 2023 17:15:26 +0100 Subject: [PATCH 40/88] rm commented code with empty href to fix CRAN check warning about inst/doc/vignette.html --- inst/htmljs/animint.js | 13 ------------- 1 file changed, 13 deletions(-) diff --git a/inst/htmljs/animint.js b/inst/htmljs/animint.js index d58e50a0d..1c8d9c19f 100644 --- a/inst/htmljs/animint.js +++ b/inst/htmljs/animint.js @@ -1876,19 +1876,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){ From 274e19994f7a5b14ef42cdaf742c794944f12377 Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Thu, 2 Nov 2023 17:23:11 +0100 Subject: [PATCH 41/88] rm plot arg from docs --- R/plot-build.r | 1 - build.sh | 1 + man/ggplot_gtable.Rd | 2 -- 3 files changed, 1 insertion(+), 3 deletions(-) diff --git a/R/plot-build.r b/R/plot-build.r index 59828432a..a3b617dd8 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/build.sh b/build.sh index b36b30351..1f3a11b2e 100644 --- a/build.sh +++ b/build.sh @@ -26,5 +26,6 @@ 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/man/ggplot_gtable.Rd b/man/ggplot_gtable.Rd index 11a4db393..27317dca6 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 From 439be011fa35d6d4d32c7845f89211c4153d73d3 Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Thu, 2 Nov 2023 18:38:19 +0100 Subject: [PATCH 42/88] rm ghpages test on CRAN --- build.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build.sh b/build.sh index 1f3a11b2e..85011370f 100644 --- a/build.sh +++ b/build.sh @@ -20,7 +20,7 @@ cp animint2/man/graphical-units.Rd animint2-release/man grep -v 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 cat < animint2-release/tests/testthat.R library(testthat) test_check("animint2", filter="compiler") From 631ccb29a4889e185f28f65fb4bbb1e900b60514 Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Thu, 2 Nov 2023 18:50:11 +0100 Subject: [PATCH 43/88] do not include vignette on CRAN to save disk space --- build.sh | 1 + 1 file changed, 1 insertion(+) diff --git a/build.sh b/build.sh index 85011370f..2d23b01bf 100644 --- a/build.sh +++ b/build.sh @@ -21,6 +21,7 @@ grep -v 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-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") From 8ef857708a1d72ed3c74040482c3f4867cb0425e Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Thu, 2 Nov 2023 18:50:43 +0100 Subject: [PATCH 44/88] remove aes_q NULL test which was failing on CRAN --- tests/testthat/test-compiler-aes-ggplot.r | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/tests/testthat/test-compiler-aes-ggplot.r b/tests/testthat/test-compiler-aes-ggplot.r index 10396a60b..fff10274b 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)) From ac41dfed443e69b72259eb0cfb5989aa312c279a Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Thu, 2 Nov 2023 18:51:02 +0100 Subject: [PATCH 45/88] \itemize->\describe --- R/data.R | 4 ++-- man/luv_colours.Rd | 2 +- man/txhousing.Rd | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/R/data.R b/R/data.R index e45a1b646..2f442f0d9 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/man/luv_colours.Rd b/man/luv_colours.Rd index 72592db01..e1bc7f34f 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 3c3a42e0f..ffbdb1e55 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} From 8ff04cacacdc84b47e93ea6af18ce70bd0f923dd Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Thu, 2 Nov 2023 18:52:28 +0100 Subject: [PATCH 46/88] rm gist test --- tests/testthat/test-compiler-gist.R | 119 ---------------------------- 1 file changed, 119 deletions(-) delete mode 100644 tests/testthat/test-compiler-gist.R diff --git a/tests/testthat/test-compiler-gist.R b/tests/testthat/test-compiler-gist.R deleted file mode 100644 index 5546fff0d..000000000 --- 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") -}) From 610cab381406f8b26faa5a589abdb1fae349a8f8 Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Thu, 2 Nov 2023 19:04:02 +0100 Subject: [PATCH 47/88] do not include VignetteBuilder on CRAN --- build.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build.sh b/build.sh index 2d23b01bf..afcbbefec 100644 --- a/build.sh +++ b/build.sh @@ -17,7 +17,7 @@ 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-ghpages.R From 25e659653d4c7cece40caedbe80de4ac143a60e2 Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Thu, 2 Nov 2023 19:04:08 +0100 Subject: [PATCH 48/88] fix skip tests --- tests/testthat/test-compiler-layer.r | 23 ++++++++----------- .../test-compiler-plot-named-timexxx.R | 6 +++-- tests/testthat/test-compiler-stat-bin.R | 9 -------- 3 files changed, 13 insertions(+), 25 deletions(-) diff --git a/tests/testthat/test-compiler-layer.r b/tests/testthat/test-compiler-layer.r index c201747ea..d8c3b8112 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 bd17a8de3..d11a5e1cf 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 fee1c6b7d..3c2fa891e 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", { From 02027e2fbfaeae6e0ad32f1f9d9c2819af6e4009 Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Thu, 2 Nov 2023 11:16:57 -0700 Subject: [PATCH 49/88] set user name and email before running tests --- .github/workflows/tests.yaml | 13 ++++++------- tests/testthat/test-compiler-ghpages.R | 2 +- 2 files changed, 7 insertions(+), 8 deletions(-) diff --git a/.github/workflows/tests.yaml b/.github/workflows/tests.yaml index 639d670cb..660dfbd9a 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/tests/testthat/test-compiler-ghpages.R b/tests/testthat/test-compiler-ghpages.R index ce617b5bc..abefaa433 100644 --- a/tests/testthat/test-compiler-ghpages.R +++ b/tests/testthat/test-compiler-ghpages.R @@ -22,8 +22,8 @@ test_that("error for viz with no source", { }, "plot.list does not contain option named source, which is required by animint2pages") }) -viz_owner_repo <- animint2pages(viz, github_repo = "animint2pages_test_repo") test_that("animint2pages() returns owner/repo string", { + viz_owner_repo <- animint2pages(viz, github_repo = "animint2pages_test_repo") expect_is(viz_owner_repo, "character") }) From 496255957ba2a051e87179ab79be7ffd9b156fd3 Mon Sep 17 00:00:00 2001 From: Yufan Fei <62975717+Faye-yufan@users.noreply.github.com> Date: Fri, 3 Nov 2023 17:04:02 -0700 Subject: [PATCH 50/88] test owner=animint, repo=animint/animint2pages_test_repo --- .github/workflows/tests.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/tests.yaml b/.github/workflows/tests.yaml index 660dfbd9a..99fdc5126 100644 --- a/.github/workflows/tests.yaml +++ b/.github/workflows/tests.yaml @@ -17,7 +17,7 @@ jobs: name: Test Suite ${{ matrix.test-suite }} env: TEST_SUITE: ${{ matrix.test-suite }} - GITHUB_PAT: ${{ secrets.PAT_GITHUB }} + GITHUB_PAT: ${{ secrets.PAT_GITHUB_TEST }} GH_ACTION: "ENABLED" steps: - uses: actions/checkout@v3 From 7c1186ca99da21885b01afe4a4cef39e8363a0d9 Mon Sep 17 00:00:00 2001 From: Yufan Fei <62975717+Faye-yufan@users.noreply.github.com> Date: Fri, 3 Nov 2023 17:19:41 -0700 Subject: [PATCH 51/88] new setting not working, change token to the previous one --- .github/workflows/tests.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/tests.yaml b/.github/workflows/tests.yaml index 99fdc5126..660dfbd9a 100644 --- a/.github/workflows/tests.yaml +++ b/.github/workflows/tests.yaml @@ -17,7 +17,7 @@ jobs: name: Test Suite ${{ matrix.test-suite }} env: TEST_SUITE: ${{ matrix.test-suite }} - GITHUB_PAT: ${{ secrets.PAT_GITHUB_TEST }} + GITHUB_PAT: ${{ secrets.PAT_GITHUB }} GH_ACTION: "ENABLED" steps: - uses: actions/checkout@v3 From 38776ada9790bcb6a15bb85fd05a024fbccd8475 Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Sat, 4 Nov 2023 21:27:12 -0700 Subject: [PATCH 52/88] expect geom_text color --- tests/testthat/test-renderer1-theme-text-size.R | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/tests/testthat/test-renderer1-theme-text-size.R b/tests/testthat/test-renderer1-theme-text-size.R index 6ea394f35..c547a717f 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"))) From 56a3583825a02e4549afef6977001f347210b93b Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Sat, 4 Nov 2023 23:01:46 -0700 Subject: [PATCH 53/88] fix geom text --- inst/htmljs/animint.js | 89 +++++++++++++++++++++++------------------- 1 file changed, 49 insertions(+), 40 deletions(-) diff --git a/inst/htmljs/animint.js b/inst/htmljs/animint.js index 1c8d9c19f..f184037e6 100644 --- a/inst/htmljs/animint.js +++ b/inst/htmljs/animint.js @@ -204,7 +204,7 @@ var animint = function (to_select, json_file) { if (has_alpha_off) { select_styles.push('opacity'); } - if (has_fill_off) { + if (has_fill_off || has_colour_off) { select_styles.push('fill'); } if (!select_styles.length) { @@ -1090,9 +1090,7 @@ var animint = function (to_select, json_file) { }; 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")) { + 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; @@ -1158,12 +1156,19 @@ var animint = function (to_select, json_file) { // we negate the angle. return `rotate(${-angle}, ${x}, ${y})`; }; - var get_colour = function (d) { - if (d.hasOwnProperty("colour")) { - return d["colour"] - } - return colour; - }; + var get_colour; + if (g_info.geom == "text") { + get_colour = function(d){ + return null; + }; + } else { + 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){ @@ -1172,34 +1177,40 @@ var animint = function (to_select, json_file) { // 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_colour_off; + if (g_info.geom == "text") { + get_colour_off = function(d) { + return null; + }; + } else { + get_colour_off = function (d) { + let off_colour; + 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"]; + } else if(d.hasOwnProperty("colour")) { + return d["colour"]; } return fill; }; - if (g_info.params.fill) { + if (g_info.params.hasOwnProperty("fill")) { fill = g_info.params.fill; - }else if(g_info.params.colour){ + }else if (g_info.params.hasOwnProperty("colour")){ fill = g_info.params.colour; } - - const get_fill_off = function (d) { + var 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")) { + if (g_info.params.hasOwnProperty("fill_off")) { off_fill = g_info.params.fill_off; + } else if (g_info.params.hasOwnProperty("colour_off")) { + off_fill = g_info.params.colour_off; } return off_fill; }; @@ -1450,7 +1461,7 @@ var animint = function (to_select, json_file) { }) .style("stroke-dasharray", get_dasharray) .style("stroke-width", get_size); - select_style_fun(g_info, e); + select_style_fun(g_info, e); }; eAppend = "line"; } @@ -1471,7 +1482,7 @@ var animint = function (to_select, json_file) { }) .style("stroke-dasharray", get_dasharray) .style("stroke-width", get_size); - select_style_fun(g_info, e); + select_style_fun(g_info, e); }; eAppend = "line"; } @@ -1484,7 +1495,7 @@ var animint = function (to_select, json_file) { .attr("y2", scales.y.range()[1]) .style("stroke-dasharray", get_dasharray) .style("stroke-width", get_size); - select_style_fun(g_info, e); + select_style_fun(g_info, e); }; eAppend = "line"; } @@ -1498,7 +1509,7 @@ var animint = function (to_select, json_file) { .attr("x2", scales.x.range()[1]) .style("stroke-dasharray", get_dasharray) .style("stroke-width", get_size); - select_style_fun(g_info, e); + select_style_fun(g_info, e); }; eAppend = "line"; } @@ -1516,6 +1527,7 @@ var animint = function (to_select, json_file) { .text(function (d) { return d.label; }); + select_style_fun(g_info, e); }; eAppend = "text"; } @@ -1523,10 +1535,10 @@ var animint = function (to_select, json_file) { 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); + .attr("cy", toXY("y", "y")) + .attr("r", get_size) + .style("stroke-width", get_stroke_width); + select_style_fun(g_info, e);x }; eAppend = "circle"; } @@ -1541,7 +1553,7 @@ var animint = function (to_select, json_file) { .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); + select_style_fun(g_info, e); }; eAppend = "rect"; } @@ -1556,7 +1568,7 @@ var animint = function (to_select, json_file) { .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); + select_style_fun(g_info, e); }; eAppend = "rect"; } @@ -1579,7 +1591,7 @@ var animint = function (to_select, json_file) { }) .style("stroke-dasharray", get_dasharray) .style("stroke-width", get_size) - select_style_fun(g_info, e); + select_style_fun(g_info, e); }; eAppend = "rect"; } @@ -1777,9 +1789,6 @@ var animint = function (to_select, json_file) { 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); - } } var has_tooltip = g_info.aes.hasOwnProperty("tooltip"); if(has_clickSelects || has_tooltip || has_clickSelects_variable){ From 48a42968ec1eb25d6d1eab2349afdfb095c1f2fe Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Sat, 4 Nov 2023 23:03:16 -0700 Subject: [PATCH 54/88] bugfix geom_text --- NEWS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/NEWS.md b/NEWS.md index 5e3dbf9e6..2ffea3547 100644 --- a/NEWS.md +++ b/NEWS.md @@ -8,6 +8,7 @@ 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. # Changes in 2023.10.6 From cbdabd1401644bb9b60616d6dee33ebfd32dee8e Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Sat, 4 Nov 2023 23:03:25 -0700 Subject: [PATCH 55/88] text color tests --- .../testthat/test-renderer1-geom-text-color.R | 24 +++++++++++++++++++ 1 file changed, 24 insertions(+) create mode 100644 tests/testthat/test-renderer1-geom-text-color.R 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 000000000..4b34230af --- /dev/null +++ b/tests/testthat/test-renderer1-geom-text-color.R @@ -0,0 +1,24 @@ +acontext("geom text color") + +df <- data.frame(x=1,y="foo") +viz <- animint( + text=ggplot()+ + geom_text(aes(x, 4, label=y), 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("plot_text_y_variable_foo_svg") +test_that("geom_text color rendered as fill style", { + fill <- getStyleValue(info$html, '//text[@class="geom"]', "fill") + expect_color(fill, c("black", "red","pink")) + opacity <- getStyleValue(info$html, '//text[@class="geom"]', "opacity") + expect_identical(opacity, c("0.5","1","1")) +}) From f922021cee249678ba1a064200d9e42c5cf98df6 Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Sat, 4 Nov 2023 23:28:55 -0700 Subject: [PATCH 56/88] specify columns in meta --- R/z_pages.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/z_pages.R b/R/z_pages.R index 196971d64..71f68ec7d 100644 --- a/R/z_pages.R +++ b/R/z_pages.R @@ -200,7 +200,8 @@ update_gallery <- function(gallery_path="~/R/gallery"){ 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 + 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")) From fb65ff8376ac6f2ce80baf098fe604e611daf354 Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Sun, 5 Nov 2023 22:32:17 -0700 Subject: [PATCH 57/88] use get_fill in get_fill_off --- inst/htmljs/animint.js | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/inst/htmljs/animint.js b/inst/htmljs/animint.js index f184037e6..15b29ae19 100644 --- a/inst/htmljs/animint.js +++ b/inst/htmljs/animint.js @@ -190,14 +190,14 @@ var animint = function (to_select, json_file) { // 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); - + var checkOff = function(prop){ + return (!g_info.aes.hasOwnProperty(prop)) && + g_info.params.hasOwnProperty(prop+"_off") + }; let select_styles = []; - const has_colour_off = checkProperty('colour_off'); - const has_alpha_off = checkProperty('alpha_off'); - const has_fill_off = checkProperty('fill_off'); - + const has_colour_off = checkOff('colour'); + const has_alpha_off = checkOff('alpha'); + const has_fill_off = checkOff('fill'); if (has_colour_off || g_info.geom === 'rect') { select_styles.push('stroke'); } @@ -1207,7 +1207,9 @@ var animint = function (to_select, json_file) { } var get_fill_off = function (d) { let off_fill; - if (g_info.params.hasOwnProperty("fill_off")) { + if (g_info.aes.hasOwnProperty("fill")) { + off_fill = get_fill(d); + } else if (g_info.params.hasOwnProperty("fill_off")) { off_fill = g_info.params.fill_off; } else if (g_info.params.hasOwnProperty("colour_off")) { off_fill = g_info.params.colour_off; From a11d1d2ff71a210512336de65f1e04b38acbf625 Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Sun, 12 Nov 2023 07:50:12 -0500 Subject: [PATCH 58/88] remove typo --- inst/htmljs/animint.js | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/inst/htmljs/animint.js b/inst/htmljs/animint.js index 15b29ae19..324e00dbd 100644 --- a/inst/htmljs/animint.js +++ b/inst/htmljs/animint.js @@ -1540,7 +1540,7 @@ var animint = function (to_select, json_file) { .attr("cy", toXY("y", "y")) .attr("r", get_size) .style("stroke-width", get_stroke_width); - select_style_fun(g_info, e);x + select_style_fun(g_info, e); }; eAppend = "circle"; } From 26989027cd3c29dbc0d3b3a34241b4dd60646049 Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Sun, 12 Nov 2023 07:50:45 -0500 Subject: [PATCH 59/88] reformat line breaks --- tests/testthat/test-renderer1-href.R | 61 +++++++++++++++------------- 1 file changed, 33 insertions(+), 28 deletions(-) diff --git a/tests/testthat/test-renderer1-href.R b/tests/testthat/test-renderer1-href.R index 957b3bc82..ca6ea23d0 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", { From c71b8ff62e15479cd13c733134358e6e4db82b65 Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Sun, 12 Nov 2023 07:50:59 -0500 Subject: [PATCH 60/88] comment --- tests/testthat/test-renderer1-geom-text-color.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/tests/testthat/test-renderer1-geom-text-color.R b/tests/testthat/test-renderer1-geom-text-color.R index 4b34230af..1bb4dbbe1 100644 --- a/tests/testthat/test-renderer1-geom-text-color.R +++ b/tests/testthat/test-renderer1-geom-text-color.R @@ -1,4 +1,5 @@ acontext("geom text color") +library(animint2) df <- data.frame(x=1,y="foo") viz <- animint( @@ -15,7 +16,7 @@ test_that("geom_text color rendered as fill style", { opacity <- getStyleValue(info$html, '//text[@class="geom"]', "opacity") expect_identical(opacity, c("1","1","1","1")) }) -clickID("plot_text_y_variable_foo_svg") +clickID("plot_text_y_variable_foo_svg")#or foo_label? test_that("geom_text color rendered as fill style", { fill <- getStyleValue(info$html, '//text[@class="geom"]', "fill") expect_color(fill, c("black", "red","pink")) From 1fde9d21093d3f02350928b90c7a3fde2813a619 Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Sun, 12 Nov 2023 08:51:02 -0500 Subject: [PATCH 61/88] range_is_zero helper --- R/scale-.r | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/R/scale-.r b/R/scale-.r index f72542036..197f32118 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() } From 9cfe4d41b9282166464f7bfe38f07c768f4c0a4d Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Sun, 12 Nov 2023 08:51:28 -0500 Subject: [PATCH 62/88] rm sqrt y example --- R/geom-histogram.r | 4 ---- man/geom_histogram.Rd | 4 ---- 2 files changed, 8 deletions(-) diff --git a/R/geom-histogram.r b/R/geom-histogram.r index a6eeaf206..ff207768b 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/man/geom_histogram.Rd b/man/geom_histogram.Rd index 831d32d55..ffcd23bce 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) } From 7b6066a470b6342cdd84371cd2254b1288217ce9 Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Sun, 12 Nov 2023 09:18:21 -0500 Subject: [PATCH 63/88] typo --- NEWS.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/NEWS.md b/NEWS.md index 2ffea3547..93413a826 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,8 +4,8 @@ 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 at the - below the rendered viz. + 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. From e8bfa4641d08cf7531fa6c9484d0ee659f797199 Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Sun, 12 Nov 2023 10:32:48 -0500 Subject: [PATCH 64/88] clarify geom_text fix --- NEWS.md | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/NEWS.md b/NEWS.md index 93413a826..892dadf0e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -8,7 +8,9 @@ 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. +- Bugfix: geom_text renders color as svg fill style (was rendering as + stroke style, a regression introduced by the initial implementation + of `fill_off`). # Changes in 2023.10.6 From 893788b73d58d6e9356af57c517d2ff4a336c910 Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Sun, 12 Nov 2023 10:33:08 -0500 Subject: [PATCH 65/88] clarify gallery input/output --- R/z_pages.R | 22 ++++++++++++++-------- man/update_gallery.Rd | 20 ++++++++++++-------- 2 files changed, 26 insertions(+), 16 deletions(-) diff --git a/R/z_pages.R b/R/z_pages.R index 71f68ec7d..b729b2f9f 100644 --- a/R/z_pages.R +++ b/R/z_pages.R @@ -174,14 +174,18 @@ get_pages_info <- function(viz_owner_repo){ repo.row } -##' A gallery is a collection of animints that have been published to -##' github pages. 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/commit the data, re-render index.Rmd in gallery, and push -##' gallery to origin. See -##' \url{https://github.com/animint/gallery/tree/gh-pages} which is -##' the main gallery which is updated using this function. +##' 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. @@ -189,6 +193,8 @@ get_pages_info <- function(viz_owner_repo){ ##' @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") diff --git a/man/update_gallery.Rd b/man/update_gallery.Rd index 3b5fe3c75..79b44d495 100644 --- a/man/update_gallery.Rd +++ b/man/update_gallery.Rd @@ -14,14 +14,18 @@ active.} named list of data tables (meta and error). } \description{ -A gallery is a collection of animints that have been published to -github pages. 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/commit the data, re-render index.Rmd in gallery, and push -gallery to origin. See -\url{https://github.com/animint/gallery/tree/gh-pages} which is -the main gallery which is updated using this function. +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 From 9cc8788c0ab89af39eca037f060cc4be41aa6215 Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Sun, 12 Nov 2023 15:47:25 -0700 Subject: [PATCH 66/88] big re-organization --- inst/htmljs/animint.js | 935 +++++++----------- .../test-renderer5-ChromHMMiterations.R | 2 +- 2 files changed, 358 insertions(+), 579 deletions(-) diff --git a/inst/htmljs/animint.js b/inst/htmljs/animint.js index 324e00dbd..b8e25ce98 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 - var checkOff = function(prop){ - return (!g_info.aes.hasOwnProperty(prop)) && - g_info.params.hasOwnProperty(prop+"_off") - }; - let select_styles = []; - const has_colour_off = checkOff('colour'); - const has_alpha_off = checkOff('alpha'); - const has_fill_off = checkOff('fill'); - if (has_colour_off || g_info.geom === 'rect') { - select_styles.push('stroke'); - } - if (has_alpha_off) { - select_styles.push('opacity'); - } - if (has_fill_off || has_colour_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,159 +1031,167 @@ 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){ + d = get_one_row(input); + return fun(d); + }; }; - const get_alpha_off = function (d) { - let a; - 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 = function (d) { - if (aes.hasOwnProperty("size") && d.hasOwnProperty("size")) { - return d["size"]; - } - return size; - }; + var get_size; + if(aes.hasOwnProperty("size")){ + get_size = get_attr("size"); + }else{ + get_size = function(d){ + return 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) { + if (g_info.params.hasOwnProperty("linetype")) { linetype = g_info.params.linetype; } - - var get_dasharray = function (d) { - var lt = linetype; - if (aes.hasOwnProperty("linetype") && d.hasOwnProperty("linetype")) { - lt = d["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){ + 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 base_opacity; + if(g_info.params.hasOwnProperty("alpha")){ + alpha = g_info.params.alpha; + }else{ + alpha = 1; } - const get_angle = 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"]; - } - // 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; - if (g_info.geom == "text") { - get_colour = function(d){ - return null; - }; + var off_opacity; + if(g_info.params.hasOwnProperty("alpha_off")){ + alpha_off = g_info.params.alpha_off; + }else{ + alpha_off = alpha - 0.5; + } + var get_alpha; + if(aes.hasOwnProperty("alpha")){ + get_alpha = get_attr("alpha"); } else { - get_colour = function (d) { - if (d.hasOwnProperty("colour")) { - return d["colour"] - } - return colour; + get_alpha = function(d){ + return alpha; }; } - if (g_info.geom == "rect" && has_clickSelects && g_info.params.colour == "transparent"){ - colour = "black"; - } else if(g_info.params.colour){ + var get_alpha_off = function (d) { + return alpha_off; + }; + + var colour; + if(g_info.params.hasOwnProperty("colour")){ colour = g_info.params.colour; + }else{ + colour = "black"; } - - // Only "colour_off" params appears would call this function, - // so no default off_colour value - var get_colour_off; - if (g_info.geom == "text") { - get_colour_off = function(d) { - return null; - }; - } else { - get_colour_off = function (d) { - let off_colour; - if (g_info.params.hasOwnProperty("colour_off")){ - off_colour = g_info.params.colour_off; - } - return off_colour; + if(g_info.params.hasOwnProperty("colour_off")){ + colour_off = g_info.params.colour_off; + }else{ + colour_off = colour; + } + var get_colour; + if(aes.hasOwnProperty("colour")){ + get_colour = get_attr("colour"); + }else{ + get_colour = function (d) { + return colour; }; } - - var get_fill = function (d) { - if (d.hasOwnProperty("fill")) { - return d["fill"]; - } else if(d.hasOwnProperty("colour")) { - return d["colour"]; - } - return fill; + var get_colour_off = function (d) { + return colour_off; }; + + var fill; if (g_info.params.hasOwnProperty("fill")) { fill = g_info.params.fill; }else if (g_info.params.hasOwnProperty("colour")){ fill = g_info.params.colour; + }else{ + fill = "black"; } + var fill_off; + if (g_info.params.hasOwnProperty("fill_off")) { + fill_off = g_info.params.fill_off; + }else if (g_info.params.hasOwnProperty("colour_off")){ + fill_off = g_info.params.colour_off; + }else{ + fill_off = fill; + } + var get_fill; + if(aes.hasOwnProperty("fill")){ + get_fill = get_attr("fill"); + } else if(aes.hasOwnProperty("colour")) { + get_fill = get_attr("colour"); + } else { + get_fill = function (d) { + return fill; + }; + }; var get_fill_off = function (d) { - let off_fill; - if (g_info.aes.hasOwnProperty("fill")) { - off_fill = get_fill(d); - } else if (g_info.params.hasOwnProperty("fill_off")) { - off_fill = g_info.params.fill_off; - } else if (g_info.params.hasOwnProperty("colour_off")) { - off_fill = g_info.params.colour_off; - } - return off_fill; + return fill_off; }; - + + var angle = 0; + if (g_info.params.hasOwnProperty("angle")) { + angle = g_info.params["angle"]; + } + var get_angle; + if(aes.hasOwnProperty("angle")){ + get_angle = get_attr("angle"); + }else{ + get_angle = function(d){ + return 0; + }; + } + 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"]); + 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})`; + }; + // For aes(hjust) the compiler should make an "anchor" column. var text_anchor = "middle"; if(g_info.params.hasOwnProperty("anchor")){ @@ -1233,29 +1208,27 @@ 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 style_on_funs = { + "opacity": get_alpha, + "stroke": get_colour, + "fill": get_fill, + "stroke-width": get_size, + "stroke-dasharray": get_dasharray + }; + var style_off_funs = { + "opacity": get_alpha_off, + "stroke": get_colour_off, + "fill": get_fill_off }; + var get_one_row;//different for grouped and ungrouped geoms. + var data_to_bind; if(g_info.data_is_object) { // Lines, paths, polygons, and ribbons are a bit special. For @@ -1339,12 +1312,15 @@ var animint = function (to_select, json_file) { // line, path, and polygon use d3.svg.line(), // ribbon uses d3.svg.area() // we have to define lineThing accordingly. + g_info.style_list = [ + "opacity","fill","stroke","stroke-width","stroke-dasharray"]; if (g_info.geom == "ribbon") { var lineThing = d3.svg.area() .x(toXY("x", "x")) .y(toXY("y", "ymax")) .y0(toXY("y", "ymin")); } else { + fill = "none"; var lineThing = d3.svg.line() .x(toXY("x", "x")) .y(toXY("y", "y")); @@ -1353,23 +1329,11 @@ var animint = function (to_select, json_file) { 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) { @@ -1384,299 +1348,205 @@ 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 = [ + "opacity","stroke","stroke-width","stroke-dasharray"]; + 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"]); - }) - .style("stroke-dasharray", get_dasharray) - .style("stroke-width", get_size); - select_style_fun(g_info, e); - }; - eAppend = "line"; - } - 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"; - } - 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.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; - }); - select_style_fun(g_info, e); - }; - eAppend = "text"; - } - 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.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.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.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) { + .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 = [ + "opacity","stroke","stroke-width","stroke-dasharray"]; + eActions = function (e) { + e.attr("x1", 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); - }; + .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 = [ + "opacity","stroke","stroke-width","stroke-dasharray"]; + 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 = [ + "opacity","stroke","stroke-width","stroke-dasharray"]; + 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; + get_colour = function(d){ + return null; + }; + get_colour_off = function(d) { + return null; + }; + 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") { + g_info.style_list = [ + "opacity","stroke","stroke-width","stroke-dasharray","fill"]; + style_on_funs["stroke-width"] = get_attr("stroke"); + 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"; + g_info.style_list = [ + "opacity","stroke","stroke-width","stroke-dasharray","fill"]; + 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") { + if(g_info.params.hasOwnProperty("alpha_off")){ + alpha_off = g_info.params.alpha_off; + }else{ + alpha_off = alpha; + } + if(g_info.params.hasOwnProperty("colour")){ + colour = g_info.params.colour; + }else{ + colour = "black"; + } + if(g_info.params.hasOwnProperty("colour_off")){ + colour_off = g_info.params.colour_off; + }else{ + colour_off = "transparent"; + } + 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)); + }) + ; + }; + } + } } + 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); + }); + }); + }; + // TODO cleanup. + g_info.select_style = ["opacity","stroke","fill"]; + 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")){ @@ -1684,83 +1554,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); @@ -1771,9 +1569,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); }); @@ -1784,27 +1579,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); - } } + // 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; @@ -1822,37 +1609,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="#" diff --git a/tests/testthat/test-renderer5-ChromHMMiterations.R b/tests/testthat/test-renderer5-ChromHMMiterations.R index 892896134..8e961f227 100644 --- a/tests/testthat/test-renderer5-ChromHMMiterations.R +++ b/tests/testthat/test-renderer5-ChromHMMiterations.R @@ -1,5 +1,5 @@ acontext("ChromHMMiterations data set") - +library(animint2) data(ChromHMMiterations, package = "animint2") emission <- data.frame(ChromHMMiterations$emission, parameters="emission") From b4eed26622cf44b9ba7fd685dd75c0c0472ed500 Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Sun, 12 Nov 2023 16:10:45 -0700 Subject: [PATCH 67/88] fix scales --- .../test-renderer5-ChromHMMiterations.R | 43 +++++++++++-------- 1 file changed, 25 insertions(+), 18 deletions(-) diff --git a/tests/testthat/test-renderer5-ChromHMMiterations.R b/tests/testthat/test-renderer5-ChromHMMiterations.R index 8e961f227..8bff496a3 100644 --- a/tests/testthat/test-renderer5-ChromHMMiterations.R +++ b/tests/testthat/test-renderer5-ChromHMMiterations.R @@ -5,40 +5,47 @@ 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) From 6f91b765820fc5944eacdec2a484576b7ebb421c Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Mon, 13 Nov 2023 05:45:10 -0700 Subject: [PATCH 68/88] bugfix geom_point stroke param --- inst/htmljs/animint.js | 2 +- .../test-renderer4-geom-point-stroke.R | 48 +++++++++---------- 2 files changed, 24 insertions(+), 26 deletions(-) diff --git a/inst/htmljs/animint.js b/inst/htmljs/animint.js index b8e25ce98..ecb32a484 100644 --- a/inst/htmljs/animint.js +++ b/inst/htmljs/animint.js @@ -1444,7 +1444,7 @@ var animint = function (to_select, json_file) { if (g_info.geom == "point") { g_info.style_list = [ "opacity","stroke","stroke-width","stroke-dasharray","fill"]; - style_on_funs["stroke-width"] = get_attr("stroke"); + style_on_funs["stroke-width"] = get_stroke_width; eActions = function (e) { e.attr("cx", toXY("x", "x")) .attr("cy", toXY("y", "y")) diff --git a/tests/testthat/test-renderer4-geom-point-stroke.R b/tests/testthat/test-renderer4-geom-point-stroke.R index f95e6e004..1209bfa93 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_stroke=ggplot(mtcars, aes( + wt, mpg)) + + geom_point( + shape = 21, colour = "black", fill = "white", + size = 5, stroke = stroke_in_R), + aes_stroke=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_stroke"]//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_stroke"]//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))) }) From ff7cdaa0468f52880f3bfca0a7a23e8c5a32c05c Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Mon, 13 Nov 2023 05:54:17 -0700 Subject: [PATCH 69/88] bugfix for geom_point with aes(color) and param fill --- inst/htmljs/animint.js | 9 ++++--- tests/testthat/test-renderer3-point-fill-NA.R | 25 ++++++++++--------- 2 files changed, 19 insertions(+), 15 deletions(-) diff --git a/inst/htmljs/animint.js b/inst/htmljs/animint.js index ecb32a484..3ea6937d6 100644 --- a/inst/htmljs/animint.js +++ b/inst/htmljs/animint.js @@ -1155,14 +1155,17 @@ var animint = function (to_select, json_file) { fill_off = fill; } var get_fill; + var get_fill_constant = function (d) { + return fill; + }; if(aes.hasOwnProperty("fill")){ get_fill = get_attr("fill"); + } else if(g_info.params.hasOwnProperty("fill")){ + get_fill = get_fill_constant; } else if(aes.hasOwnProperty("colour")) { get_fill = get_attr("colour"); } else { - get_fill = function (d) { - return fill; - }; + get_fill = get_fill_constant; }; var get_fill_off = function (d) { return fill_off; diff --git a/tests/testthat/test-renderer3-point-fill-NA.R b/tests/testthat/test-renderer3-point-fill-NA.R index 8a5cd01c5..b7af1e585 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) From a260b8cf8c125d5a5440ce2104e640711cd25756 Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Mon, 13 Nov 2023 06:12:57 -0700 Subject: [PATCH 70/88] fix text size, angle, stroke --- inst/htmljs/animint.js | 22 +++++++------ tests/testthat/test-renderer1-text.R | 48 +++++++++++++++------------- 2 files changed, 39 insertions(+), 31 deletions(-) diff --git a/inst/htmljs/animint.js b/inst/htmljs/animint.js index 3ea6937d6..2449804ef 100644 --- a/inst/htmljs/animint.js +++ b/inst/htmljs/animint.js @@ -1048,9 +1048,6 @@ var animint = function (to_select, json_file) { }; var size = 2; - if (g_info.params.hasOwnProperty("size")) { - size = g_info.params.size; - } var get_size; if(aes.hasOwnProperty("size")){ get_size = get_attr("size"); @@ -1180,7 +1177,7 @@ var animint = function (to_select, json_file) { get_angle = get_attr("angle"); }else{ get_angle = function(d){ - return 0; + return angle; }; } var get_rotate = function(d){ @@ -1189,7 +1186,7 @@ var animint = function (to_select, json_file) { // coordinate system, which is the top left of the plot x = scales["x"](d["x"]); y = scales["y"](d["y"]); - angle = get_angle(d); + 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})`; @@ -1422,12 +1419,12 @@ var animint = function (to_select, json_file) { eAppend = "line"; } if (g_info.geom == "text") { - size = 12; + size = 12;//default get_colour = function(d){ - return null; + return "none"; }; get_colour_off = function(d) { - return null; + return "none"; }; g_info.style_list = [ "opacity","fill"]; @@ -1513,6 +1510,11 @@ var animint = function (to_select, json_file) { } } } + // set param size after geom-specific code, because text has a + // different size default. + 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) { @@ -1522,7 +1524,9 @@ var animint = function (to_select, json_file) { }); }; // TODO cleanup. - g_info.select_style = ["opacity","stroke","fill"]; + 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) { diff --git a/tests/testthat/test-renderer1-text.R b/tests/testthat/test-renderer1-text.R index e9d7129c3..5cf406a1e 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 +}) From 84a1d3b1f2df2d435dcc40d84675ae25beb78d0a Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Mon, 13 Nov 2023 09:00:01 -0700 Subject: [PATCH 71/88] fix global variables and polygon drawing --- inst/htmljs/animint.js | 11 ++-- tests/testthat/test-renderer1-interactivity.R | 59 ++++++++++--------- 2 files changed, 38 insertions(+), 32 deletions(-) diff --git a/inst/htmljs/animint.js b/inst/htmljs/animint.js index 2449804ef..776fa4a00 100644 --- a/inst/htmljs/animint.js +++ b/inst/htmljs/animint.js @@ -1084,17 +1084,16 @@ var animint = function (to_select, json_file) { }; } var get_dasharray = function(d){ - lt = get_linetype(d); + var lt = get_linetype(d); return linetypesize2dasharray(lt, get_size(d)); }; - var base_opacity; + var alpha, alpha_off; if(g_info.params.hasOwnProperty("alpha")){ alpha = g_info.params.alpha; }else{ alpha = 1; } - var off_opacity; if(g_info.params.hasOwnProperty("alpha_off")){ alpha_off = g_info.params.alpha_off; }else{ @@ -1112,7 +1111,7 @@ var animint = function (to_select, json_file) { return alpha_off; }; - var colour; + var colour, colour_off; if(g_info.params.hasOwnProperty("colour")){ colour = g_info.params.colour; }else{ @@ -1320,11 +1319,13 @@ var animint = function (to_select, json_file) { .y(toXY("y", "ymax")) .y0(toXY("y", "ymin")); } else { - fill = "none"; var lineThing = d3.svg.line() .x(toXY("x", "x")) .y(toXY("y", "y")); } + if(["line","path"].includes(g_info.geom)){ + fill = "none"; + } // select the correct group before returning anything. key_fun = function(group_info){ return group_info.value; diff --git a/tests/testthat/test-renderer1-interactivity.R b/tests/testthat/test-renderer1-interactivity.R index 5d23df70c..d8805c08f 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 From ed3c1406be00205f1edc13674d992f511c7c998f Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Mon, 13 Nov 2023 10:13:51 -0700 Subject: [PATCH 72/88] rm _stroke --- tests/testthat/test-renderer4-geom-point-stroke.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/testthat/test-renderer4-geom-point-stroke.R b/tests/testthat/test-renderer4-geom-point-stroke.R index 1209bfa93..b194cfd66 100644 --- a/tests/testthat/test-renderer4-geom-point-stroke.R +++ b/tests/testthat/test-renderer4-geom-point-stroke.R @@ -2,12 +2,12 @@ acontext("geom_point_stroke") stroke_in_R <- 5 viz <- animint( - param_stroke=ggplot(mtcars, aes( + param=ggplot(mtcars, aes( wt, mpg)) + geom_point( shape = 21, colour = "black", fill = "white", size = 5, stroke = stroke_in_R), - aes_stroke=ggplot(mtcars, aes( + aes=ggplot(mtcars, aes( wt, mpg, stroke=cyl)) + geom_point( shape = 21, colour = "black", fill = "white", size = 5)) @@ -17,7 +17,7 @@ info <- animint2HTML(viz) test_that("geom_point stroke param rendered with stroke-width", { stroke_vals <- getStyleValue( info$html, - '//g[@class="geom1_point_param_stroke"]//circle', + '//g[@class="geom1_point_param"]//circle', "stroke-width") expect_equal(length(stroke_vals), length(mtcars$wt)) stroke_vals_unique <- unique(stroke_vals) @@ -29,7 +29,7 @@ test_that("geom_point stroke param rendered with stroke-width", { test_that("aes(stroke) works", { stroke_vals_aes <- getStyleValue( info$html, - '//g[@class="geom2_point_aes_stroke"]//circle', + '//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) From 493fc83f854625a2f96c26f230ad1cd8bfe4b7fe Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Mon, 13 Nov 2023 10:16:09 -0700 Subject: [PATCH 73/88] print diff.vars --- tests/testthat/test-renderer1-global-variables.R | 1 + 1 file changed, 1 insertion(+) diff --git a/tests/testthat/test-renderer1-global-variables.R b/tests/testthat/test-renderer1-global-variables.R index d32e9e20f..5c84ab333 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") }) From f0b90c98924fd83abee6ee4c6cf7cb45fadef1ea Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Mon, 13 Nov 2023 10:18:52 -0700 Subject: [PATCH 74/88] more prints --- tests/testthat/test-renderer1-PeakConsistency.R | 1 + tests/testthat/test-renderer1-geom-text-color.R | 2 ++ 2 files changed, 3 insertions(+) diff --git a/tests/testthat/test-renderer1-PeakConsistency.R b/tests/testthat/test-renderer1-PeakConsistency.R index 4718d7c45..b73dfb70e 100644 --- a/tests/testthat/test-renderer1-PeakConsistency.R +++ b/tests/testthat/test-renderer1-PeakConsistency.R @@ -109,6 +109,7 @@ test_that("4 paths of both colors in second plot", { 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 index 1bb4dbbe1..d5b9f4b4f 100644 --- a/tests/testthat/test-renderer1-geom-text-color.R +++ b/tests/testthat/test-renderer1-geom-text-color.R @@ -19,7 +19,9 @@ test_that("geom_text color rendered as fill style", { clickID("plot_text_y_variable_foo_svg")#or foo_label? test_that("geom_text color rendered as fill style", { fill <- getStyleValue(info$html, '//text[@class="geom"]', "fill") + print(fill) expect_color(fill, c("black", "red","pink")) opacity <- getStyleValue(info$html, '//text[@class="geom"]', "opacity") + print(opacity) expect_identical(opacity, c("0.5","1","1")) }) From 51f95ef3523490a0d56b40fd23d181261266d466 Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Mon, 13 Nov 2023 11:25:49 -0700 Subject: [PATCH 75/88] d is local --- inst/htmljs/animint.js | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/inst/htmljs/animint.js b/inst/htmljs/animint.js index 776fa4a00..137b4d524 100644 --- a/inst/htmljs/animint.js +++ b/inst/htmljs/animint.js @@ -1037,7 +1037,7 @@ var animint = function (to_select, json_file) { // data (not one group), in both cases. var get_fun = function(fun){ return function(input){ - d = get_one_row(input); + var d = get_one_row(input); return fun(d); }; }; From ec0641e65dd639c33f4635bce6c21990e9a71f7e Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Tue, 14 Nov 2023 12:35:16 -0700 Subject: [PATCH 76/88] set defaults after geom specific code --- inst/htmljs/animint.js | 188 ++++++++---------- .../testthat/test-renderer1-PeakConsistency.R | 123 ++++++------ 2 files changed, 149 insertions(+), 162 deletions(-) diff --git a/inst/htmljs/animint.js b/inst/htmljs/animint.js index 137b4d524..e602ee081 100644 --- a/inst/htmljs/animint.js +++ b/inst/htmljs/animint.js @@ -1056,12 +1056,10 @@ var animint = function (to_select, json_file) { 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; if(aes.hasOwnProperty("stroke")){ get_stroke_width = get_attr("stroke"); @@ -1072,9 +1070,6 @@ var animint = function (to_select, json_file) { } var linetype = "solid"; - if (g_info.params.hasOwnProperty("linetype")) { - linetype = g_info.params.linetype; - } var get_linetype; if(aes.hasOwnProperty("linetype")){ get_linetype = get_attr("linetype"); @@ -1089,16 +1084,6 @@ var animint = function (to_select, json_file) { }; var alpha, alpha_off; - if(g_info.params.hasOwnProperty("alpha")){ - alpha = g_info.params.alpha; - }else{ - alpha = 1; - } - if(g_info.params.hasOwnProperty("alpha_off")){ - alpha_off = g_info.params.alpha_off; - }else{ - alpha_off = alpha - 0.5; - } var get_alpha; if(aes.hasOwnProperty("alpha")){ get_alpha = get_attr("alpha"); @@ -1112,16 +1097,6 @@ var animint = function (to_select, json_file) { }; var colour, colour_off; - if(g_info.params.hasOwnProperty("colour")){ - colour = g_info.params.colour; - }else{ - colour = "black"; - } - if(g_info.params.hasOwnProperty("colour_off")){ - colour_off = g_info.params.colour_off; - }else{ - colour_off = colour; - } var get_colour; if(aes.hasOwnProperty("colour")){ get_colour = get_attr("colour"); @@ -1130,47 +1105,20 @@ var animint = function (to_select, json_file) { return colour; }; } + var get_colour_off_default = get_colour; var get_colour_off = function (d) { return colour_off; }; - var fill; - if (g_info.params.hasOwnProperty("fill")) { - fill = g_info.params.fill; - }else if (g_info.params.hasOwnProperty("colour")){ - fill = g_info.params.colour; - }else{ - fill = "black"; - } - var fill_off; - if (g_info.params.hasOwnProperty("fill_off")) { - fill_off = g_info.params.fill_off; - }else if (g_info.params.hasOwnProperty("colour_off")){ - fill_off = g_info.params.colour_off; - }else{ - fill_off = fill; - } - var get_fill; - var get_fill_constant = function (d) { + var fill = "black", fill_off = "black"; + var get_fill = function (d) { return fill; }; - if(aes.hasOwnProperty("fill")){ - get_fill = get_attr("fill"); - } else if(g_info.params.hasOwnProperty("fill")){ - get_fill = get_fill_constant; - } else if(aes.hasOwnProperty("colour")) { - get_fill = get_attr("colour"); - } else { - get_fill = get_fill_constant; - }; var get_fill_off = function (d) { return fill_off; }; var angle = 0; - if (g_info.params.hasOwnProperty("angle")) { - angle = g_info.params["angle"]; - } var get_angle; if(aes.hasOwnProperty("angle")){ get_angle = get_attr("angle"); @@ -1193,9 +1141,6 @@ var animint = function (to_select, json_file) { // 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){ @@ -1214,20 +1159,13 @@ var animint = function (to_select, json_file) { return d.key; }; } - var style_on_funs = { - "opacity": get_alpha, - "stroke": get_colour, - "fill": get_fill, - "stroke-width": get_size, - "stroke-dasharray": get_dasharray - }; - var style_off_funs = { - "opacity": get_alpha_off, - "stroke": get_colour_off, - "fill": get_fill_off - }; 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"; if(g_info.data_is_object) { // Lines, paths, polygons, and ribbons are a bit special. For @@ -1311,8 +1249,6 @@ var animint = function (to_select, json_file) { // line, path, and polygon use d3.svg.line(), // ribbon uses d3.svg.area() // we have to define lineThing accordingly. - g_info.style_list = [ - "opacity","fill","stroke","stroke-width","stroke-dasharray"]; if (g_info.geom == "ribbon") { var lineThing = d3.svg.area() .x(toXY("x", "x")) @@ -1325,6 +1261,7 @@ var animint = function (to_select, json_file) { } if(["line","path"].includes(g_info.geom)){ fill = "none"; + fill_off = "none"; } // select the correct group before returning anything. key_fun = function(group_info){ @@ -1357,8 +1294,7 @@ var animint = function (to_select, json_file) { } data_to_bind = data; if (g_info.geom == "segment") { - g_info.style_list = [ - "opacity","stroke","stroke-width","stroke-dasharray"]; + g_info.style_list = line_style_list; eActions = function (e) { e.attr("x1", function (d) { return scales.x(d["x"]); @@ -1376,8 +1312,7 @@ var animint = function (to_select, json_file) { eAppend = "line"; } if (g_info.geom == "linerange") { - g_info.style_list = [ - "opacity","stroke","stroke-width","stroke-dasharray"]; + g_info.style_list = line_style_list; eActions = function (e) { e.attr("x1", function (d) { return scales.x(d["x"]); @@ -1396,8 +1331,7 @@ var animint = function (to_select, json_file) { eAppend = "line"; } if (g_info.geom == "vline") { - g_info.style_list = [ - "opacity","stroke","stroke-width","stroke-dasharray"]; + g_info.style_list = line_style_list; eActions = function (e) { e.attr("x1", toXY("x", "xintercept")) .attr("x2", toXY("x", "xintercept")) @@ -1408,8 +1342,7 @@ var animint = function (to_select, json_file) { eAppend = "line"; } if (g_info.geom == "hline") { - g_info.style_list = [ - "opacity","stroke","stroke-width","stroke-dasharray"]; + g_info.style_list = line_style_list; eActions = function (e) { e.attr("y1", toXY("y", "yintercept")) .attr("y2", toXY("y", "yintercept")) @@ -1443,9 +1376,18 @@ var animint = function (to_select, json_file) { eAppend = "text"; } if (g_info.geom == "point") { - g_info.style_list = [ - "opacity","stroke","stroke-width","stroke-dasharray","fill"]; - style_on_funs["stroke-width"] = get_stroke_width; + // 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")) @@ -1457,8 +1399,6 @@ var animint = function (to_select, json_file) { var rect_geoms = ["tallrect","widerect","rect"]; if(rect_geoms.includes(g_info.geom)){ eAppend = "rect"; - g_info.style_list = [ - "opacity","stroke","stroke-width","stroke-dasharray","fill"]; if (g_info.geom == "tallrect") { eActions = function (e) { e.attr("x", toXY("x", "xmin")) @@ -1482,21 +1422,10 @@ var animint = function (to_select, json_file) { }; } if (g_info.geom == "rect") { - if(g_info.params.hasOwnProperty("alpha_off")){ - alpha_off = g_info.params.alpha_off; - }else{ - alpha_off = alpha; - } - if(g_info.params.hasOwnProperty("colour")){ - colour = g_info.params.colour; - }else{ - colour = "black"; - } - if(g_info.params.hasOwnProperty("colour_off")){ - colour_off = g_info.params.colour_off; - }else{ - colour_off = "transparent"; - } + alpha_off = alpha; + colour = "black"; + colour_off = "transparent"; + get_colour_off_default = get_colour_off; eActions = function (e) { e.attr("x", toXY("x", "xmin")) .attr("width", function (d) { @@ -1511,8 +1440,49 @@ var animint = function (to_select, json_file) { } } } - // set param size after geom-specific code, because text has a - // different size default. + // 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.params.hasOwnProperty("linetype")) { + linetype = g_info.params.linetype; + } + if(g_info.params.hasOwnProperty("alpha")){ + alpha = g_info.params.alpha; + }else{ + alpha = 1; + } + if(g_info.params.hasOwnProperty("alpha_off")){ + alpha_off = g_info.params.alpha_off; + }else{ + alpha_off = alpha - 0.5; + } + if(g_info.params.hasOwnProperty("anchor")){ + text_anchor = g_info.params["anchor"]; + } + if(g_info.params.hasOwnProperty("colour")){ + colour = g_info.params.colour; + }else{ + colour = "black"; + } + 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); + }; if (g_info.params.hasOwnProperty("size")) { size = g_info.params.size; } @@ -1524,6 +1494,18 @@ var animint = function (to_select, json_file) { }); }); }; + 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( diff --git a/tests/testthat/test-renderer1-PeakConsistency.R b/tests/testthat/test-renderer1-PeakConsistency.R index b73dfb70e..b86526208 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,8 +110,8 @@ 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) From 325ec99cbefe0b3aee5a9022df63a2303d8330e5 Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Tue, 14 Nov 2023 16:11:02 -0700 Subject: [PATCH 77/88] change && to || to fix point fill --- inst/htmljs/animint.js | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/inst/htmljs/animint.js b/inst/htmljs/animint.js index e602ee081..023faaf33 100644 --- a/inst/htmljs/animint.js +++ b/inst/htmljs/animint.js @@ -1379,7 +1379,7 @@ var animint = function (to_select, json_file) { // point is special because it takes SVG fill from ggplot // colour, if fill is not specified. if(!( - g_info.params.hasOwnProperty("fill") && + g_info.params.hasOwnProperty("fill") || aes.hasOwnProperty("fill") )){ fill_comes_from = "colour"; From e0e6bbd394ac84f4d6907fe99530f41c6bcb795a Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Tue, 14 Nov 2023 16:11:19 -0700 Subject: [PATCH 78/88] tile color/stroke transparent by default --- tests/testthat/test-renderer5-ChromHMMiterations.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-renderer5-ChromHMMiterations.R b/tests/testthat/test-renderer5-ChromHMMiterations.R index 8bff496a3..862c15dcb 100644 --- a/tests/testthat/test-renderer5-ChromHMMiterations.R +++ b/tests/testthat/test-renderer5-ChromHMMiterations.R @@ -71,8 +71,8 @@ test_that("fill not constant in probability legend and circles", { expect_true(1 < length(table(fill.vec))) }) -test_that("tile stroke is black", { +test_that("tile stroke is transparent", { stroke.vec <- getStyleValue( info$html, '//g[@class="geom1_tile_parameters"]//rect', "stroke") - expect_color(stroke.vec, "black") + expect_color(stroke.vec, "transparent") }) From 5fb272fe08e297dc2d671d984621038d7b68d34f Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Tue, 14 Nov 2023 16:15:26 -0700 Subject: [PATCH 79/88] text fill comes from colour --- inst/htmljs/animint.js | 2 ++ 1 file changed, 2 insertions(+) diff --git a/inst/htmljs/animint.js b/inst/htmljs/animint.js index 023faaf33..48428c384 100644 --- a/inst/htmljs/animint.js +++ b/inst/htmljs/animint.js @@ -1360,6 +1360,8 @@ var animint = function (to_select, json_file) { 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) { From 06492f2fe21df8d9913f118b4cc3fc8a84541c45 Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Tue, 14 Nov 2023 16:19:20 -0700 Subject: [PATCH 80/88] use getHTML --- tests/testthat/test-renderer1-geom-text-color.R | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-renderer1-geom-text-color.R b/tests/testthat/test-renderer1-geom-text-color.R index d5b9f4b4f..fed69e87e 100644 --- a/tests/testthat/test-renderer1-geom-text-color.R +++ b/tests/testthat/test-renderer1-geom-text-color.R @@ -17,11 +17,12 @@ test_that("geom_text color rendered as fill style", { expect_identical(opacity, c("1","1","1","1")) }) clickID("plot_text_y_variable_foo_svg")#or foo_label? +after.html <- getHTML() test_that("geom_text color rendered as fill style", { - fill <- getStyleValue(info$html, '//text[@class="geom"]', "fill") + fill <- getStyleValue(after.html, '//text[@class="geom"]', "fill") print(fill) expect_color(fill, c("black", "red","pink")) - opacity <- getStyleValue(info$html, '//text[@class="geom"]', "opacity") + opacity <- getStyleValue(after.html, '//text[@class="geom"]', "opacity") print(opacity) expect_identical(opacity, c("0.5","1","1")) }) From f47979548ac7219e4d22428dc546e885804861be Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Tue, 14 Nov 2023 16:19:28 -0700 Subject: [PATCH 81/88] move expect_warning to next test --- tests/testthat/test-renderer2-fill.R | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/tests/testthat/test-renderer2-fill.R b/tests/testthat/test-renderer2-fill.R index 8990d90ad..4b5d2cf85 100644 --- a/tests/testthat/test-renderer2-fill.R +++ b/tests/testthat/test-renderer2-fill.R @@ -119,15 +119,11 @@ viz.vline <- list( ggtitle("Click to Select a Vertical Line") ) -test_that("Warning message shows up when using fill_off parameter with geom_vline", { +test_that("When using fill_off and clickSelects parameter with geom_vline, use default(alpha) selection style", { expect_warning( - animint2HTML(viz.vline), + viz_info <- 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"]' @@ -145,4 +141,4 @@ test_that("When using fill_off and clickSelects parameter with geom_vline, use d expect_equal(before_click_opacity, "1") expect_equal(after_click_opacity, "0.5") -}) \ No newline at end of file +}) From 151e25ecd4587b72b100222b7ce44debe548dbf0 Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Tue, 14 Nov 2023 23:19:09 -0700 Subject: [PATCH 82/88] fix off tests --- R/geom-.r | 1 - R/geom-tile.r | 5 +- inst/htmljs/animint.js | 15 +- tests/testthat/test-renderer2-colour.R | 418 +++++++++++-------------- 4 files changed, 191 insertions(+), 248 deletions(-) diff --git a/R/geom-.r b/R/geom-.r index 68aa8a04d..f7d75dd4b 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-tile.r b/R/geom-tile.r index 3d39ddbbf..c50b7f913 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/inst/htmljs/animint.js b/inst/htmljs/animint.js index 48428c384..4a8d1ae35 100644 --- a/inst/htmljs/animint.js +++ b/inst/htmljs/animint.js @@ -1083,7 +1083,7 @@ var animint = function (to_select, json_file) { return linetypesize2dasharray(lt, get_size(d)); }; - var alpha, alpha_off; + var alpha = 1, alpha_off; var get_alpha; if(aes.hasOwnProperty("alpha")){ get_alpha = get_attr("alpha"); @@ -1096,7 +1096,7 @@ var animint = function (to_select, json_file) { return alpha_off; }; - var colour, colour_off; + var colour = "black", colour_off; var get_colour; if(aes.hasOwnProperty("colour")){ get_colour = get_attr("colour"); @@ -1165,7 +1165,7 @@ var animint = function (to_select, json_file) { "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"; + 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 @@ -1425,7 +1425,6 @@ var animint = function (to_select, json_file) { } if (g_info.geom == "rect") { alpha_off = alpha; - colour = "black"; colour_off = "transparent"; get_colour_off_default = get_colour_off; eActions = function (e) { @@ -1452,21 +1451,16 @@ var animint = function (to_select, json_file) { } if(g_info.params.hasOwnProperty("alpha")){ alpha = g_info.params.alpha; - }else{ - alpha = 1; + alpha_off = alpha - 0.5 } if(g_info.params.hasOwnProperty("alpha_off")){ alpha_off = g_info.params.alpha_off; - }else{ - alpha_off = alpha - 0.5; } if(g_info.params.hasOwnProperty("anchor")){ text_anchor = g_info.params["anchor"]; } if(g_info.params.hasOwnProperty("colour")){ colour = g_info.params.colour; - }else{ - colour = "black"; } if(g_info.params.hasOwnProperty("colour_off")){ colour_off = g_info.params.colour_off; @@ -1484,6 +1478,7 @@ var animint = function (to_select, json_file) { } 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; diff --git a/tests/testthat/test-renderer2-colour.R b/tests/testthat/test-renderer2-colour.R index 442488380..dc2780aea 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("0.5","1")) + 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("0.5","1")) + 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="transparent", + 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","transparent")) }) # # 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 From 1d9f795c3e0fa460e6a41333ac43e7b7564d93b8 Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Tue, 14 Nov 2023 23:31:23 -0700 Subject: [PATCH 83/88] fix default alpha_off --- inst/htmljs/animint.js | 2 +- tests/testthat/test-renderer1-geom-text-color.R | 8 ++++++-- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/inst/htmljs/animint.js b/inst/htmljs/animint.js index 4a8d1ae35..3096c53d2 100644 --- a/inst/htmljs/animint.js +++ b/inst/htmljs/animint.js @@ -1083,7 +1083,7 @@ var animint = function (to_select, json_file) { return linetypesize2dasharray(lt, get_size(d)); }; - var alpha = 1, alpha_off; + var alpha = 1, alpha_off = 0.5; var get_alpha; if(aes.hasOwnProperty("alpha")){ get_alpha = get_attr("alpha"); diff --git a/tests/testthat/test-renderer1-geom-text-color.R b/tests/testthat/test-renderer1-geom-text-color.R index fed69e87e..25c0aa2de 100644 --- a/tests/testthat/test-renderer1-geom-text-color.R +++ b/tests/testthat/test-renderer1-geom-text-color.R @@ -1,6 +1,5 @@ acontext("geom text color") library(animint2) - df <- data.frame(x=1,y="foo") viz <- animint( text=ggplot()+ @@ -9,6 +8,7 @@ viz <- animint( 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") @@ -16,13 +16,17 @@ test_that("geom_text color rendered as fill style", { opacity <- getStyleValue(info$html, '//text[@class="geom"]', "opacity") expect_identical(opacity, c("1","1","1","1")) }) + clickID("plot_text_y_variable_foo_svg")#or foo_label? 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","1")) + expect_identical(opacity, c("0.5","1","0.5")) }) From 4180b88a538b38cf22e8cc4078e0ed4082c57547 Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Tue, 14 Nov 2023 23:54:19 -0700 Subject: [PATCH 84/88] fix tests --- tests/testthat/helper-functions.R | 2 +- .../testthat/test-renderer1-geom-text-color.R | 2 +- tests/testthat/test-renderer2-colour.R | 4 +- tests/testthat/test-renderer2-fill.R | 144 ---------- tests/testthat/test-renderer2-opacity.R | 265 ------------------ tests/testthat/test-renderer3-ChromHMMinit.R | 2 +- .../test-renderer5-ChromHMMiterations.R | 4 +- 7 files changed, 7 insertions(+), 416 deletions(-) delete mode 100644 tests/testthat/test-renderer2-fill.R delete mode 100644 tests/testthat/test-renderer2-opacity.R diff --git a/tests/testthat/helper-functions.R b/tests/testthat/helper-functions.R index fa91ecb26..64bc0ce24 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-renderer1-geom-text-color.R b/tests/testthat/test-renderer1-geom-text-color.R index 25c0aa2de..1120bbafe 100644 --- a/tests/testthat/test-renderer1-geom-text-color.R +++ b/tests/testthat/test-renderer1-geom-text-color.R @@ -17,7 +17,7 @@ test_that("geom_text color rendered as fill style", { expect_identical(opacity, c("1","1","1","1")) }) -clickID("plot_text_y_variable_foo_svg")#or foo_label? +clickID("plot_text_y_variable_foo_label")#not _svg. after.html <- getHTML() test_that("geom_text color rendered as fill style", { fill <- getStyleValue(after.html, '//text[@class="geom"]', "fill") diff --git a/tests/testthat/test-renderer2-colour.R b/tests/testthat/test-renderer2-colour.R index dc2780aea..247c1d8f4 100644 --- a/tests/testthat/test-renderer2-colour.R +++ b/tests/testthat/test-renderer2-colour.R @@ -35,7 +35,7 @@ test_that("default clicking line only changes opacity", { "opacity") opacity.tab <- sort(table(opacity.str)) expect_equal(as.numeric(opacity.tab), c(1, 4)) - expect_equal(names(opacity.tab), c("0.5","1")) + expect_equal(names(opacity.tab), c("1","0.5")) stroke.str <- getStyleValue( info$html, '//svg[@id="plot_default"]//path[@class="geom"]', @@ -50,7 +50,7 @@ test_that("setting colour_off makes stroke and opacity change", { "opacity") opacity.tab <- sort(table(opacity.str)) expect_equal(as.numeric(opacity.tab), c(1, 4)) - expect_equal(names(opacity.tab), c("0.5","1")) + expect_equal(names(opacity.tab), c("1","0.5")) stroke.str <- getStyleValue( info$html, '//svg[@id="plot_coff"]//path[@class="geom"]', diff --git a/tests/testthat/test-renderer2-fill.R b/tests/testthat/test-renderer2-fill.R deleted file mode 100644 index 4b5d2cf85..000000000 --- a/tests/testthat/test-renderer2-fill.R +++ /dev/null @@ -1,144 +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("When using fill_off and clickSelects parameter with geom_vline, use default(alpha) selection style", { - expect_warning( - viz_info <- animint2HTML(viz.vline), - "geom1_vline_v has fill_off which is not supported." - ) - - 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") -}) diff --git a/tests/testthat/test-renderer2-opacity.R b/tests/testthat/test-renderer2-opacity.R deleted file mode 100644 index 8d94af70e..000000000 --- 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-renderer3-ChromHMMinit.R b/tests/testthat/test-renderer3-ChromHMMinit.R index 050026896..4ba6c2166 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_identical(stroke.vec, rep("black", 90)) }) diff --git a/tests/testthat/test-renderer5-ChromHMMiterations.R b/tests/testthat/test-renderer5-ChromHMMiterations.R index 862c15dcb..8bff496a3 100644 --- a/tests/testthat/test-renderer5-ChromHMMiterations.R +++ b/tests/testthat/test-renderer5-ChromHMMiterations.R @@ -71,8 +71,8 @@ test_that("fill not constant in probability legend and circles", { expect_true(1 < length(table(fill.vec))) }) -test_that("tile stroke is transparent", { +test_that("tile stroke is black", { stroke.vec <- getStyleValue( info$html, '//g[@class="geom1_tile_parameters"]//rect', "stroke") - expect_color(stroke.vec, "transparent") + expect_color(stroke.vec, "black") }) From c5efbaa05cd7d8deeb9bc5e424449c36925fe79d Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Wed, 15 Nov 2023 06:24:26 -0700 Subject: [PATCH 85/88] fix tests --- inst/htmljs/animint.js | 7 ++++--- tests/testthat/test-renderer1-geom-text-color.R | 4 ++-- tests/testthat/test-renderer2-colour.R | 4 ++-- tests/testthat/test-renderer2-widerect.R | 4 ++-- tests/testthat/test-renderer3-ChromHMMinit.R | 2 +- 5 files changed, 11 insertions(+), 10 deletions(-) diff --git a/inst/htmljs/animint.js b/inst/htmljs/animint.js index 3096c53d2..651993c26 100644 --- a/inst/htmljs/animint.js +++ b/inst/htmljs/animint.js @@ -1098,17 +1098,18 @@ var animint = function (to_select, json_file) { 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; }; } var get_colour_off_default = get_colour; - var get_colour_off = function (d) { - return colour_off; - }; var fill = "black", fill_off = "black"; var get_fill = function (d) { diff --git a/tests/testthat/test-renderer1-geom-text-color.R b/tests/testthat/test-renderer1-geom-text-color.R index 1120bbafe..e5f406692 100644 --- a/tests/testthat/test-renderer1-geom-text-color.R +++ b/tests/testthat/test-renderer1-geom-text-color.R @@ -3,7 +3,7 @@ library(animint2) df <- data.frame(x=1,y="foo") viz <- animint( text=ggplot()+ - geom_text(aes(x, 4, label=y), color="black", clickSelects="y", data=df)+ + 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)+ @@ -17,7 +17,7 @@ test_that("geom_text color rendered as fill style", { expect_identical(opacity, c("1","1","1","1")) }) -clickID("plot_text_y_variable_foo_label")#not _svg. +clickID("ONETEXT") after.html <- getHTML() test_that("geom_text color rendered as fill style", { fill <- getStyleValue(after.html, '//text[@class="geom"]', "fill") diff --git a/tests/testthat/test-renderer2-colour.R b/tests/testthat/test-renderer2-colour.R index 247c1d8f4..b6cd32cec 100644 --- a/tests/testthat/test-renderer2-colour.R +++ b/tests/testthat/test-renderer2-colour.R @@ -93,7 +93,7 @@ viz.point <- list( fill = disp), data = mtcars, colour="red", - colour_off="transparent", + colour_off="yellow", alpha_off=1, size = 10, clickSelects = "gear")+ @@ -122,7 +122,7 @@ test_that("setting alpha_off and colour_off makes only stroke change", { '//svg[@id="plot_acoff"]//circle[@class="geom"]', "stroke") stroke.tab <- sort(table(stroke.str)) - expect_color(names(stroke.tab), c("red","transparent")) + expect_color(names(stroke.tab), c("red","yellow")) }) # diff --git a/tests/testthat/test-renderer2-widerect.R b/tests/testthat/test-renderer2-widerect.R index cf4436573..0860d89da 100644 --- a/tests/testthat/test-renderer2-widerect.R +++ b/tests/testthat/test-renderer2-widerect.R @@ -1,5 +1,5 @@ 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){ @@ -8,7 +8,7 @@ expect_source <- function(expected){ at.mat <- sapply(a.list, xmlAttrs) at.mat["href",] } - expect_identical(computed, expected) + expect_identical(as.character(computed), as.character(expected)) } recommendation <- data.frame( diff --git a/tests/testthat/test-renderer3-ChromHMMinit.R b/tests/testthat/test-renderer3-ChromHMMinit.R index 4ba6c2166..c614d13e5 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("black", 90)) + expect_color(stroke.vec, "black") }) From 42b0271df8d90946f4c95a7ea6492c2d5d54ee2c Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Wed, 15 Nov 2023 07:11:44 -0700 Subject: [PATCH 86/88] version++ --- DESCRIPTION | 2 +- NEWS.md | 9 ++++++++- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 6687735ba..1e2d65120 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: animint2 Title: Animated Interactive Grammar of Graphics -Version: 2023.10.27 +Version: 2023.11.15 URL: https://animint.github.io/animint2/ BugReports: https://github.com/animint/animint2/issues Authors@R: c( diff --git a/NEWS.md b/NEWS.md index 892dadf0e..67b929dfd 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# Changes in 2023.10.27 +# Changes in 2023.11.15 - New function `animint2pages(viz,"new_github_repo")` for publishing/sharing animints, replacement for animint2gist, which @@ -11,6 +11,13 @@ - 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 From 47c9f1bd60bde02b4b1b52d37a27e9b219baef53 Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Wed, 15 Nov 2023 09:03:37 -0700 Subject: [PATCH 87/88] get_alpha_off same as alpha when aes is set --- inst/htmljs/animint.js | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/inst/htmljs/animint.js b/inst/htmljs/animint.js index 651993c26..53f42f468 100644 --- a/inst/htmljs/animint.js +++ b/inst/htmljs/animint.js @@ -1085,16 +1085,17 @@ var animint = function (to_select, json_file) { 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 get_alpha_off = function (d) { - return alpha_off; - }; var colour = "black", colour_off; var get_colour; From fb8f29760c605b8ffaa26e4884572e13cf1b1d5b Mon Sep 17 00:00:00 2001 From: Toby Dylan Hocking Date: Wed, 15 Nov 2023 19:36:39 -0700 Subject: [PATCH 88/88] commit repos.txt --- R/z_pages.R | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/R/z_pages.R b/R/z_pages.R index b729b2f9f..9945dace6 100644 --- a/R/z_pages.R +++ b/R/z_pages.R @@ -225,7 +225,11 @@ update_gallery <- function(gallery_path="~/R/gallery"){ fwrite(error.dt, file.path(gallery_path, "error.csv")) rmarkdown::render(file.path(gallery_path, "index.Rmd")) to_add <- c( - "*.csv", file.path("repos","*","*.png"), "index.html", "index.Rmd") + "*.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)