From ed3b3772c952187ef5bb226f9b6e1a4b7171459d Mon Sep 17 00:00:00 2001 From: Peter Harrison Date: Sat, 18 Jul 2020 10:59:30 +0100 Subject: [PATCH 01/17] Testing results deleting/archiving --- DESCRIPTION | 3 ++- inst/js/confirm-clear-sessions.js | 4 ++- inst/js/confirm-delete-errors.js | 4 ++- inst/js/confirm-delete-results.js | 4 ++- inst/js/confirm-resume-session.js | 4 ++- tests/testthat/test-results.R | 41 ++++++++++++++++++++++--------- 6 files changed, 44 insertions(+), 16 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 352fdda3..d578f970 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -34,7 +34,8 @@ Imports: htm2txt, shinytest, testthat (>= 2.0.0), - stringr (>= 1.4.0) + stringr (>= 1.4.0), + withr Depends: R (>= 3.4.0) RoxygenNote: 7.1.0 Suggests: diff --git a/inst/js/confirm-clear-sessions.js b/inst/js/confirm-clear-sessions.js index 78d830d6..93dae5ba 100644 --- a/inst/js/confirm-clear-sessions.js +++ b/inst/js/confirm-clear-sessions.js @@ -1,5 +1,7 @@ +var skip_confirm = false; + confirm_clear_sessions = function() { - if (confirm("Are you sure you want to clear all session files?")) { + if (skip_confirm || confirm("Are you sure you want to clear all session files?")) { Shiny.onInputChange("admin_panel.confirm_clear_sessions", performance.now()); } }; diff --git a/inst/js/confirm-delete-errors.js b/inst/js/confirm-delete-errors.js index b17e8ab4..07f1906e 100644 --- a/inst/js/confirm-delete-errors.js +++ b/inst/js/confirm-delete-errors.js @@ -1,5 +1,7 @@ +var skip_confirm = false; + confirm_delete_errors = function() { - if (confirm("Are you sure you want to delete all error logs?")) { + if (skip_confirm || confirm("Are you sure you want to delete all error logs?")) { Shiny.onInputChange("admin_panel.confirm_delete_errors", performance.now()); } }; diff --git a/inst/js/confirm-delete-results.js b/inst/js/confirm-delete-results.js index b504c5f4..196977ba 100644 --- a/inst/js/confirm-delete-results.js +++ b/inst/js/confirm-delete-results.js @@ -1,5 +1,7 @@ +var skip_confirm = false; + confirm_delete_results = function() { - if (confirm("Are you sure you want to delete all results?")) { + if (skip_confirm || confirm("Are you sure you want to delete all results?")) { Shiny.onInputChange("admin_panel.confirm_delete_results", performance.now()); } }; diff --git a/inst/js/confirm-resume-session.js b/inst/js/confirm-resume-session.js index 3fbe3013..42938ba5 100644 --- a/inst/js/confirm-resume-session.js +++ b/inst/js/confirm-resume-session.js @@ -1,7 +1,9 @@ +var skip_confirm = false; + confirm_resume_session = function() { if (confirm("Resuming ongoing testing session.\n" + "Please click 'OK' to confirm, " + - "or click 'Cancel' to restart as a new user.")) { + "or click 'Cancel' to restart as a new user.") || skip_confirm) { return(true); } else { hide_content(); diff --git a/tests/testthat/test-results.R b/tests/testthat/test-results.R index 025ebfcb..91020c88 100644 --- a/tests/testthat/test-results.R +++ b/tests/testthat/test-results.R @@ -10,20 +10,19 @@ test_that("main", { app$click(answer) } - invisible(app) + app } run_participants <- function(...) { - for (answers in list(...)) { - app <- run_participant(answers) - } - app + answers <- list(...) + lapply(answers, run_participant) } - app <- run_participants(c(1, 2, 3, 4), - c(2, 4), - c(4, 4, 3), - c(3, 3, 1, 2)) + apps <- + run_participants(c(1, 2, 3, 4), + c(2, 4), + c(4, 4, 3), + c(3, 3, 1, 2)) df <- df_all_results("apps/results/output/results") @@ -33,6 +32,26 @@ test_that("main", { expect_equal(df$results.q3, c(3, NA, 3, 1) %>% as.character()) expect_equal(df$results.q4, c(4, NA, NA, 2) %>% as.character()) - app$stop() - + # Try deleting results + app <- apps[[1]] + app$click("admin_login_trigger") + Sys.sleep(0.2) + app$set_inputs(admin_password = "demo") + app$click("submit_admin_password") + app$executeScript("skip_confirm = true") + app$click("admin_panel.delete_results") + expect_equal(nrow(df_all_results("apps/results/output/results")), 0) + + deleted_zip <- normalizePath(list.files("apps/results/output/deleted-results", + pattern = "\\.zip$", + full.names = TRUE)) + tmp_dir <- tempfile("dir") + R.utils::mkdirs(tmp_dir) + withr::with_dir(tmp_dir, unzip(zipfile = deleted_zip)) + + recovered_df <- df_all_results(file.path(tmp_dir, "results")) + expect_equal(df, recovered_df) + + # Clean up + lapply(apps, function(x) x$stop()) }) From 9287e68ff398f1312a842ac822bad139f261373b Mon Sep 17 00:00:00 2001 From: Peter Harrison Date: Sat, 18 Jul 2020 14:02:46 +0100 Subject: [PATCH 02/17] Working on repository implementation --- DESCRIPTION | 4 +- R/options.R | 7 +- R/results.R | 171 ++++++++++++++++++++++++++++++++++ tests/testthat/test-results.R | 8 ++ 4 files changed, 187 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index d578f970..33778074 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -35,7 +35,9 @@ Imports: shinytest, testthat (>= 2.0.0), stringr (>= 1.4.0), - withr + withr, + uuid, + rdrop2 (>= 0.8.1) Depends: R (>= 3.4.0) RoxygenNote: 7.1.0 Suggests: diff --git a/R/options.R b/R/options.R index b47d089c..9181d008 100644 --- a/R/options.R +++ b/R/options.R @@ -109,7 +109,8 @@ test_options <- function(title, admin_password, logo_height = NULL, display = display_options(), allow_url_rewrite = TRUE, - advance_delay = 0) { + advance_delay = 0, + repository = LocalRespository$new()) { stopifnot(is.character(title), is.scalar.character(admin_password), is.null.or(researcher_email, is.scalar.character), @@ -139,7 +140,8 @@ test_options <- function(title, admin_password, (is.scalar.character(logo_width) && is.scalar.character(logo_height)), is.list(display), is.scalar.logical(allow_url_rewrite), - is.scalar.numeric(advance_delay)) + is.scalar.numeric(advance_delay), + is(repository, "Repository")) # if (is.null(session_dir)) session_dir <- get_default_session_dir() if (!allow_url_rewrite && enable_resume_session) { @@ -218,6 +220,7 @@ test_options <- function(title, admin_password, allow_any_p_id_url = allow_any_p_id_url, force_p_id_from_url = force_p_id_from_url, enable_admin_panel = enable_admin_panel, + repository = repository, output_dir = output_dir, results_dir = results_dir, supplementary_results_dir = supplementary_results_dir, diff --git a/R/results.R b/R/results.R index 168e5a68..e5a5fa75 100644 --- a/R/results.R +++ b/R/results.R @@ -155,3 +155,174 @@ save_result.state <- function(place, label, value) { place$passive$results <- save_result.results(place$passive$results, label, value) place } + +Repository <- R6::R6Class("Repository", public = list( + is_slow = NA, + + initialize = function(is_slow) { + self$is_slow <- is_slow + }, + + deposit_file = function(local_file, key, opt, ...) stop("not implemented"), + load_file = function(key, target_path, opt, ...) stop("not implemented"), + file_exists = function(key, opt, ...) stop("not implemented"), + delete_file = function(key, opt, ...) stop("not implemented"), + prepare = function(opt, ...) stop("not implemented"), + + check = function(opt) { + self$prepare(opt) + + tmp_file_in <- tempfile() + tmp_file_out <- tempfile() + key <- uuid::UUIDgenerate() + file_content <- as.character(Sys.time()) + writeLines(file_content, tmp_file_in) + + testthat::expect( + !self$file_exists(key, opt), + failure_message = "repository$file_exists should return FALSE for non-existent files" + ) + self$deposit_file(tmp_file_in, key, opt) + testthat::expect( + self$file_exists(key, opt), + failure_message = "repository$file_exists should return TRUE once a file has been deposited" + ) + self$load_file(key, tmp_file_out, opt) + testthat::expect( + testthat::compare(readLines(tmp_file_out), file_content)$equal, + failure_message = "repository$load_file returned unexpected contents" + ) + self$delete_file(key, opt) + testthat::expect( + !self$file_exists(key, opt), + failure_message = "repository$file_exists should return FALSE once a file has been deleted" + ) + } +)) + +LocalRespository <- R6::R6Class( + "LocalRespository", + inherit = Repository, + + public = list( + initialize = function() super$initialize(is_slow = FALSE), + + prepare = function(opt, ...) { + R.utils::mkdirs(opt$results_dir) + }, + + path_in_repository = function(key, opt) { + file.path(opt$results_dir, key) + }, + + deposit_file = function(local_file, key, opt, ...) { + file.copy(local_file, self$path_in_repository(key, opt)) + }, + + load_file = function(key, target_path, opt, ...) { + file.copy(self$path_in_repository(key, opt), target_path) + }, + + file_exists = function(key, opt, ...) { + file.exists(self$path_in_repository(key, opt)) + }, + + delete_file = function(key, opt) { + file.remove(self$path_in_repository(key, opt)) + } + ) +) + +DropboxRepository <- R6::R6Class( + "DropboxRepository", + inherit = Repository, + + public = list( + dropbox_dir = NA_character_, + dropbox_results_dir = NA_character_, + token_path = NA_character_, + + initialize = function(dropbox_dir, token_path = "dropbox-token.rds") { + super$initialize(is_slow = TRUE) + self$dropbox_dir = dropbox_dir + self$dropbox_results_dir = file.path(self$dropbox_dir, "results") + self$token_path = token_path + }, + + check = function(opt, ...) { + message("Checking that Dropbox repository is accessible...") + super$check(opt, ...) + message("Dropbox check complete.") + }, + + prepare = function(opt, ...) { + if (!self$dropbox_exists(self$dropbox_dir)) { + stop("directory '", self$dropbox_dir, "' not found in Dropbox, ", + "you must create this manually") + } + if (!self$dropbox_exists(self$dropbox_results_dir)) { + rdrop2::drop_create(self$dropbox_results_dir, + dtoken = self$get_dropbox_token()) + } + }, + + dropbox_exists = function(path) { + tryCatch( + rdrop2::drop_exists(path, dtoken = self$get_dropbox_token()), + error = function(e) { + browser() + } + ) + }, + + path_in_repository = function(key) { + file.path(self$dropbox_dir, "results", key) + }, + + get_dropbox_token = function() { + if (!file.exists(self$token_path)) + stop("Couldn't find ", self$token_path, ". Do you need to call repo$new_dropbox_token()?") + readRDS(self$token_path) + }, + + # @inheritParams rdrop2::drop_auth + new_dropbox_token = function(key = "mmhfsybffdom42w", + secret = "l8zeqqqgm1ne5z0") { + token <- rdrop2::drop_auth( + new_user = TRUE, + key = key, + secret = secret + ) + saveRDS(token, self$token_path) + }, + + deposit_file = function(local_file, key, opt, ...) { + tmp_dir <- tempfile("dir") + R.utils::mkdirs(tmp_dir) + new_local_path <- file.path(tmp_dir, key) + file.copy(local_file, new_local_path) + rdrop2::drop_upload(new_local_path, + self$dropbox_results_dir, + autorename = FALSE, + dtoken = self$get_dropbox_token()) + }, + + load_file = function(key, target_path, opt, ...) { + rdrop2::drop_download( + self$path_in_repository(key), + target_path, + overwrite = TRUE, + dtoken = self$get_dropbox_token() + ) + }, + + file_exists = function(key, opt, ...) { + self$dropbox_exists(self$path_in_repository(key)) + }, + + delete_file = function(key, opt) { + rdrop2::drop_delete(self$path_in_repository(key), + dtoken = self$get_dropbox_token()) + } + ) +) diff --git a/tests/testthat/test-results.R b/tests/testthat/test-results.R index 91020c88..dece9da5 100644 --- a/tests/testthat/test-results.R +++ b/tests/testthat/test-results.R @@ -1,5 +1,13 @@ context("test_results") +test_that("repository_local", { + repo <- LocalRespository$new() + opt <- demo_options(repository = repo) + tmp_dir <- tempfile("dir") + R.utils::mkdirs(tmp_dir) + withr::with_dir(tmp_dir, repo$check(opt)) +}) + test_that("main", { skip_on_cran() From 010296257d25f75b8f0ed39141ec5daa25b95446 Mon Sep 17 00:00:00 2001 From: Peter Harrison Date: Sat, 18 Jul 2020 15:09:16 +0100 Subject: [PATCH 03/17] Refactoring repository --- R/results.R | 45 +++++++++++++++++++++++---------------------- 1 file changed, 23 insertions(+), 22 deletions(-) diff --git a/R/results.R b/R/results.R index e5a5fa75..0183aa8a 100644 --- a/R/results.R +++ b/R/results.R @@ -163,12 +163,13 @@ Repository <- R6::R6Class("Repository", public = list( self$is_slow <- is_slow }, - deposit_file = function(local_file, key, opt, ...) stop("not implemented"), - load_file = function(key, target_path, opt, ...) stop("not implemented"), - file_exists = function(key, opt, ...) stop("not implemented"), - delete_file = function(key, opt, ...) stop("not implemented"), prepare = function(opt, ...) stop("not implemented"), + deposit_results = function(local_file, key, opt, ...) stop("not implemented"), + load_results = function(key, target_path, opt, ...) stop("not implemented"), + results_exist = function(key, opt, ...) stop("not implemented"), + delete_results = function(key, opt, ...) stop("not implemented"), + check = function(opt) { self$prepare(opt) @@ -179,23 +180,23 @@ Repository <- R6::R6Class("Repository", public = list( writeLines(file_content, tmp_file_in) testthat::expect( - !self$file_exists(key, opt), - failure_message = "repository$file_exists should return FALSE for non-existent files" + !self$results_exist(key, opt), + failure_message = "repository$results_exist should return FALSE for non-existent files" ) - self$deposit_file(tmp_file_in, key, opt) + self$deposit_results(tmp_file_in, key, opt) testthat::expect( - self$file_exists(key, opt), - failure_message = "repository$file_exists should return TRUE once a file has been deposited" + self$results_exist(key, opt), + failure_message = "repository$results_exist should return TRUE once a file has been deposited" ) - self$load_file(key, tmp_file_out, opt) + self$load_results(key, tmp_file_out, opt) testthat::expect( testthat::compare(readLines(tmp_file_out), file_content)$equal, - failure_message = "repository$load_file returned unexpected contents" + failure_message = "repository$load_results returned unexpected contents" ) - self$delete_file(key, opt) + self$delete_results(key, opt) testthat::expect( - !self$file_exists(key, opt), - failure_message = "repository$file_exists should return FALSE once a file has been deleted" + !self$results_exist(key, opt), + failure_message = "repository$results_exist should return FALSE once a file has been deleted" ) } )) @@ -215,19 +216,19 @@ LocalRespository <- R6::R6Class( file.path(opt$results_dir, key) }, - deposit_file = function(local_file, key, opt, ...) { + deposit_results = function(local_file, key, opt, ...) { file.copy(local_file, self$path_in_repository(key, opt)) }, - load_file = function(key, target_path, opt, ...) { + load_results = function(key, target_path, opt, ...) { file.copy(self$path_in_repository(key, opt), target_path) }, - file_exists = function(key, opt, ...) { + results_exist = function(key, opt, ...) { file.exists(self$path_in_repository(key, opt)) }, - delete_file = function(key, opt) { + delete_results = function(key, opt) { file.remove(self$path_in_repository(key, opt)) } ) @@ -296,7 +297,7 @@ DropboxRepository <- R6::R6Class( saveRDS(token, self$token_path) }, - deposit_file = function(local_file, key, opt, ...) { + deposit_results = function(local_file, key, opt, ...) { tmp_dir <- tempfile("dir") R.utils::mkdirs(tmp_dir) new_local_path <- file.path(tmp_dir, key) @@ -307,7 +308,7 @@ DropboxRepository <- R6::R6Class( dtoken = self$get_dropbox_token()) }, - load_file = function(key, target_path, opt, ...) { + load_results = function(key, target_path, opt, ...) { rdrop2::drop_download( self$path_in_repository(key), target_path, @@ -316,11 +317,11 @@ DropboxRepository <- R6::R6Class( ) }, - file_exists = function(key, opt, ...) { + results_exist = function(key, opt, ...) { self$dropbox_exists(self$path_in_repository(key)) }, - delete_file = function(key, opt) { + delete_results = function(key, opt) { rdrop2::drop_delete(self$path_in_repository(key), dtoken = self$get_dropbox_token()) } From 8b96c1aa1b23c9484c28adcdf898177c21a2afe1 Mon Sep 17 00:00:00 2001 From: Peter Harrison Date: Sat, 18 Jul 2020 15:26:15 +0100 Subject: [PATCH 04/17] Working on repositories --- R/results.R | 31 +++++++++++++++++++++---------- R/state.R | 10 +++++----- R/test-elements.R | 25 +++++++++++-------------- 3 files changed, 37 insertions(+), 29 deletions(-) diff --git a/R/results.R b/R/results.R index 0183aa8a..95e4b83e 100644 --- a/R/results.R +++ b/R/results.R @@ -163,10 +163,21 @@ Repository <- R6::R6Class("Repository", public = list( self$is_slow <- is_slow }, - prepare = function(opt, ...) stop("not implemented"), + deposit_results <- function(results, key, opt, ...) { + path <- tempfile() + saveRDS(results, path) + self$deposit_results_file(path, key, opt, ...) + }, - deposit_results = function(local_file, key, opt, ...) stop("not implemented"), - load_results = function(key, target_path, opt, ...) stop("not implemented"), + load_results <- function(key, opt, ...) { + path <- tempfile() + self$load_results_file(key, path, opt, ...) + readRDS(path) + }, + + prepare = function(opt, ...) stop("not implemented"), + deposit_results_file = function(local_file, key, opt, ...) stop("not implemented"), + load_results_file = function(key, target_path, opt, ...) stop("not implemented"), results_exist = function(key, opt, ...) stop("not implemented"), delete_results = function(key, opt, ...) stop("not implemented"), @@ -183,15 +194,15 @@ Repository <- R6::R6Class("Repository", public = list( !self$results_exist(key, opt), failure_message = "repository$results_exist should return FALSE for non-existent files" ) - self$deposit_results(tmp_file_in, key, opt) + self$deposit_results_file(tmp_file_in, key, opt) testthat::expect( self$results_exist(key, opt), failure_message = "repository$results_exist should return TRUE once a file has been deposited" ) - self$load_results(key, tmp_file_out, opt) + self$load_results_file(key, tmp_file_out, opt) testthat::expect( testthat::compare(readLines(tmp_file_out), file_content)$equal, - failure_message = "repository$load_results returned unexpected contents" + failure_message = "repository$load_results_file returned unexpected contents" ) self$delete_results(key, opt) testthat::expect( @@ -216,11 +227,11 @@ LocalRespository <- R6::R6Class( file.path(opt$results_dir, key) }, - deposit_results = function(local_file, key, opt, ...) { + deposit_results_file = function(local_file, key, opt, ...) { file.copy(local_file, self$path_in_repository(key, opt)) }, - load_results = function(key, target_path, opt, ...) { + load_results_file = function(key, target_path, opt, ...) { file.copy(self$path_in_repository(key, opt), target_path) }, @@ -297,7 +308,7 @@ DropboxRepository <- R6::R6Class( saveRDS(token, self$token_path) }, - deposit_results = function(local_file, key, opt, ...) { + deposit_results_file = function(local_file, key, opt, ...) { tmp_dir <- tempfile("dir") R.utils::mkdirs(tmp_dir) new_local_path <- file.path(tmp_dir, key) @@ -308,7 +319,7 @@ DropboxRepository <- R6::R6Class( dtoken = self$get_dropbox_token()) }, - load_results = function(key, target_path, opt, ...) { + load_results_file = function(key, target_path, opt, ...) { rdrop2::drop_download( self$path_in_repository(key), target_path, diff --git a/R/state.R b/R/state.R index 6d33e5f0..e552fae7 100644 --- a/R/state.R +++ b/R/state.R @@ -55,7 +55,7 @@ STATE <- R6::R6Class( time_started = as.POSIXct(NA), num_restarts = 0L, save_id = 1L, - previous_save_path = NULL, + previous_results_key = NULL, language = as.character(NA), demo = FALSE, error = NULL, @@ -118,15 +118,15 @@ allow_url_rewrite <- function(state) { state$passive$allow_url_rewrite } -previous_save_path <- function(state) { +previous_results_key <- function(state) { stopifnot(is(state, "state")) - state$passive$previous_save_path + state$passive$previous_results_key } -`previous_save_path<-` <- function(state, value) { +`previous_results_key<-` <- function(state, value) { stopifnot(is(state, "state"), is.scalar.character(value)) - state$passive$previous_save_path <- value + state$passive$previous_results_key <- value state } diff --git a/R/test-elements.R b/R/test-elements.R index 0e520c63..3eaf4872 100644 --- a/R/test-elements.R +++ b/R/test-elements.R @@ -1125,25 +1125,22 @@ elt_save_results_to_disk <- function(complete) { #' @param ... Further arguments are allowed but ignored (for back-compatibility). #' @export save_results_to_disk <- function(complete, state, opt, ...) { - dir <- opt$results_dir - R.utils::mkdirs(dir) - if (!test_permissions(dir)) stop( - "Insufficient permissions to write to directory ", dir, ".") - if (!is.null(previous_save_path(state))) unlink(previous_save_path(state)) - filename <- save_results_to_disk.get_filename(state, dir, complete) - path <- file.path(dir, filename) + key <- save_results_to_disk.get_key(state, complete) results <- get_results(state, complete = complete, add_session_info = TRUE) - saveRDS(results, path) - if (complete) notify_new_participant(opt) - previous_save_path(state) <- path + + opt$repository$deposit_results(results, key) + if (!is.null(previous_results_key(state))) + opt$repository$delete_results(previous_results_key(state)) + + previous_results_key(state) <- path save_id(state) <- save_id(state) + 1L + + if (complete) notify_new_participant(opt) } -save_results_to_disk.get_filename <- function(state, dir, complete) { +save_results_to_disk.get_key <- function(state, complete) { sprintf( - "id=%s&p_id=%s&save_id=%s&pilot=%s&complete=%s.rds", - id = format(length(list_results_files(dir)) + 1L, - scientific = FALSE), + "p_id=%s&save_id=%s&pilot=%s&complete=%s.rds", p_id = format(p_id(state), scientific = FALSE), save_id = format(save_id(state), scientific = FALSE), pilot = tolower(pilot(state)), From bc6e53f9f968293e4688548be51ea2e3760bf9e3 Mon Sep 17 00:00:00 2001 From: Peter Harrison Date: Sat, 18 Jul 2020 19:25:49 +0100 Subject: [PATCH 05/17] Refactoring repositories --- NAMESPACE | 1 - NEWS.md | 2 + R/admin-panel.R | 1 - R/options.R | 6 +- R/results.R | 149 ++++++++++++++++----------- R/supplementary-results.R | 22 ---- man/get_supplementary_results_dir.Rd | 28 ----- man/test_options.Rd | 3 +- tests/testthat/test-results.R | 5 +- 9 files changed, 94 insertions(+), 123 deletions(-) delete mode 100644 R/supplementary-results.R delete mode 100644 man/get_supplementary_results_dir.Rd diff --git a/NAMESPACE b/NAMESPACE index 84fa8654..28497093 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -50,7 +50,6 @@ export(get_local) export(get_p_id) export(get_results) export(get_session_info) -export(get_supplementary_results_dir) export(get_url_params) export(i18n) export(i18n_dict) diff --git a/NEWS.md b/NEWS.md index f949253d..e95ff041 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,5 @@ +- Removed `supplementary_results_dir`. + # psychTestR 2.19.1 - Adding an input check for conditional(). diff --git a/R/admin-panel.R b/R/admin-panel.R index d6c8d54a..a74e8168 100644 --- a/R/admin-panel.R +++ b/R/admin-panel.R @@ -330,7 +330,6 @@ admin_panel.delete_results.actual <- function(opt) { unlink(opt$results_dir, recursive = TRUE) Sys.sleep(0.01) dir.create(opt$results_dir) - dir.create(opt$supplementary_results_dir) shiny::showNotification("Deleted results.") } else { shiny::showNotification( diff --git a/R/options.R b/R/options.R index 9181d008..37c4b610 100644 --- a/R/options.R +++ b/R/options.R @@ -110,7 +110,7 @@ test_options <- function(title, admin_password, display = display_options(), allow_url_rewrite = TRUE, advance_delay = 0, - repository = LocalRespository$new()) { + repository = LocalRespository$new(output_dir)) { stopifnot(is.character(title), is.scalar.character(admin_password), is.null.or(researcher_email, is.scalar.character), @@ -193,8 +193,6 @@ test_options <- function(title, admin_password, } server_closed_msg <- enc2utf8(server_closed_msg) - results_dir <- file.path(output_dir, "results") - supplementary_results_dir <- file.path(results_dir, "supplementary") session_dir <- file.path(output_dir, "sessions") results_archive_dir <- file.path(output_dir, "deleted-results") error_dir <- file.path(output_dir, "errors") @@ -222,8 +220,6 @@ test_options <- function(title, admin_password, enable_admin_panel = enable_admin_panel, repository = repository, output_dir = output_dir, - results_dir = results_dir, - supplementary_results_dir = supplementary_results_dir, session_dir = session_dir, results_archive_dir = results_archive_dir, error_dir = error_dir, diff --git a/R/results.R b/R/results.R index 95e4b83e..0705cad7 100644 --- a/R/results.R +++ b/R/results.R @@ -158,32 +158,34 @@ save_result.state <- function(place, label, value) { Repository <- R6::R6Class("Repository", public = list( is_slow = NA, + dirs = c("results", "deleted-results"), initialize = function(is_slow) { self$is_slow <- is_slow }, - deposit_results <- function(results, key, opt, ...) { + deposit_results = function(results, key, opt, ...) { path <- tempfile() saveRDS(results, path) - self$deposit_results_file(path, key, opt, ...) + self$deposit_file(path, "results", key, opt, ...) }, - load_results <- function(key, opt, ...) { + get_results = function(key, opt, ...) { path <- tempfile() - self$load_results_file(key, path, opt, ...) + self$get_file(key, "results", path, opt, ...) readRDS(path) }, prepare = function(opt, ...) stop("not implemented"), - deposit_results_file = function(local_file, key, opt, ...) stop("not implemented"), - load_results_file = function(key, target_path, opt, ...) stop("not implemented"), - results_exist = function(key, opt, ...) stop("not implemented"), - delete_results = function(key, opt, ...) stop("not implemented"), + deposit_file = function(local_file, dir, key, opt, ...) stop("not implemented"), + get_file = function(dir, key, target_path, opt, ...) stop("not implemented"), + file_exists = function(dir, key, opt, ...) stop("not implemented"), + delete_file = function(dir, key, opt, ...) stop("not implemented"), check = function(opt) { self$prepare(opt) + dir <- "results" tmp_file_in <- tempfile() tmp_file_out <- tempfile() key <- uuid::UUIDgenerate() @@ -191,23 +193,23 @@ Repository <- R6::R6Class("Repository", public = list( writeLines(file_content, tmp_file_in) testthat::expect( - !self$results_exist(key, opt), - failure_message = "repository$results_exist should return FALSE for non-existent files" + !self$file_exists(dir, key, opt), + failure_message = "repository$file_exists should return FALSE for non-existent files" ) - self$deposit_results_file(tmp_file_in, key, opt) + self$deposit_file(tmp_file_in, dir, key, opt) testthat::expect( - self$results_exist(key, opt), - failure_message = "repository$results_exist should return TRUE once a file has been deposited" + self$file_exists(dir, key, opt), + failure_message = "repository$file_exists should return TRUE once a file has been deposited" ) - self$load_results_file(key, tmp_file_out, opt) + self$get_file(dir, key, tmp_file_out, opt) testthat::expect( testthat::compare(readLines(tmp_file_out), file_content)$equal, - failure_message = "repository$load_results_file returned unexpected contents" + failure_message = "repository$get_file returned unexpected contents" ) - self$delete_results(key, opt) + self$delete_file(dir, key, opt) testthat::expect( - !self$results_exist(key, opt), - failure_message = "repository$results_exist should return FALSE once a file has been deleted" + !self$file_exists(dir, key, opt), + failure_message = "repository$file_exists should return FALSE once a file has been deleted" ) } )) @@ -217,30 +219,37 @@ LocalRespository <- R6::R6Class( inherit = Repository, public = list( - initialize = function() super$initialize(is_slow = FALSE), + root_dir = NA_character_, + + initialize = function(root_dir) { + super$initialize(is_slow = FALSE) + self$root_dir <- root_dir + }, prepare = function(opt, ...) { - R.utils::mkdirs(opt$results_dir) + for (dir in self$dirs) { + R.utils::mkdirs(file.path(self$root_dir, dir)) + } }, - path_in_repository = function(key, opt) { - file.path(opt$results_dir, key) + path_in_repository = function(dir, key, opt) { + file.path(self$root_dir, dir, key) }, - deposit_results_file = function(local_file, key, opt, ...) { - file.copy(local_file, self$path_in_repository(key, opt)) + deposit_file = function(local_file, dir, key, opt, ...) { + file.copy(local_file, self$path_in_repository(dir, key, opt)) }, - load_results_file = function(key, target_path, opt, ...) { - file.copy(self$path_in_repository(key, opt), target_path) + get_file = function(dir, key, target_path, opt, ...) { + file.copy(self$path_in_repository(dir, key, opt), target_path) }, - results_exist = function(key, opt, ...) { - file.exists(self$path_in_repository(key, opt)) + file_exists = function(dir, key, opt, ...) { + file.exists(self$path_in_repository(dir, key, opt)) }, - delete_results = function(key, opt) { - file.remove(self$path_in_repository(key, opt)) + delete_file = function(dir, key, opt) { + file.remove(self$path_in_repository(dir, key, opt)) } ) ) @@ -250,15 +259,21 @@ DropboxRepository <- R6::R6Class( inherit = Repository, public = list( - dropbox_dir = NA_character_, - dropbox_results_dir = NA_character_, + root_dir = NA_character_, token_path = NA_character_, + dropbox_key = NA_character_, + dropbox_secret = NA_character_, - initialize = function(dropbox_dir, token_path = "dropbox-token.rds") { + initialize = function(root_dir, + token_path = "dropbox-token.rds", + dropbox_key = "mmhfsybffdom42w", + dropbox_secret = "l8zeqqqgm1ne5z0") { super$initialize(is_slow = TRUE) - self$dropbox_dir = dropbox_dir - self$dropbox_results_dir = file.path(self$dropbox_dir, "results") - self$token_path = token_path + self$root_dir <- root_dir + self$token_path <- token_path + self$dropbox_key <- dropbox_key + self$dropbox_secret <- dropbox_secret + self$mute_dropbox_notifications <- mute_dropbox_notifications }, check = function(opt, ...) { @@ -268,27 +283,38 @@ DropboxRepository <- R6::R6Class( }, prepare = function(opt, ...) { - if (!self$dropbox_exists(self$dropbox_dir)) { - stop("directory '", self$dropbox_dir, "' not found in Dropbox, ", + self$authenticate() + if (!self$dropbox_exists(self$root_dir)) { + stop("directory '", self$root_dir, "' not found in Dropbox, ", "you must create this manually") } - if (!self$dropbox_exists(self$dropbox_results_dir)) { - rdrop2::drop_create(self$dropbox_results_dir, - dtoken = self$get_dropbox_token()) + for (dir in self$dirs) { + full_path <- file.path(self$root_dir, dir) + if (!self$dropbox_exists(full_path)) { + rdrop2::drop_create(full_path) + } } }, + authenticate = function() { + rdrop2::drop_auth(rdstoken = self$token_path, + cache = FALSE, + key = self$dropbox_key, + secret = self$dropbox_secret) + }, + dropbox_exists = function(path) { + self$authenticate() tryCatch( - rdrop2::drop_exists(path, dtoken = self$get_dropbox_token()), + rdrop2::drop_exists(path), error = function(e) { - browser() + if (e$message == "Conflict (HTTP 409).") FALSE else stop(e) } ) }, - path_in_repository = function(key) { - file.path(self$dropbox_dir, "results", key) + path_in_repository = function(dir, key) { + file.path(self$root_dir, dir, key) }, get_dropbox_token = function() { @@ -298,43 +324,42 @@ DropboxRepository <- R6::R6Class( }, # @inheritParams rdrop2::drop_auth - new_dropbox_token = function(key = "mmhfsybffdom42w", - secret = "l8zeqqqgm1ne5z0") { + new_dropbox_token = function() { token <- rdrop2::drop_auth( new_user = TRUE, - key = key, - secret = secret + key = self$dropbox_key, + secret = self$dropbox_secret ) saveRDS(token, self$token_path) }, - deposit_results_file = function(local_file, key, opt, ...) { + deposit_file = function(local_file, dir, key, opt, ...) { + self$authenticate() tmp_dir <- tempfile("dir") R.utils::mkdirs(tmp_dir) new_local_path <- file.path(tmp_dir, key) file.copy(local_file, new_local_path) rdrop2::drop_upload(new_local_path, - self$dropbox_results_dir, - autorename = FALSE, - dtoken = self$get_dropbox_token()) + file.path(self$root_dir, dir), + autorename = FALSE) }, - load_results_file = function(key, target_path, opt, ...) { + get_file = function(dir, key, target_path, opt, ...) { + self$authenticate() rdrop2::drop_download( - self$path_in_repository(key), + self$path_in_repository(dir, key), target_path, - overwrite = TRUE, - dtoken = self$get_dropbox_token() + overwrite = TRUE ) }, - results_exist = function(key, opt, ...) { - self$dropbox_exists(self$path_in_repository(key)) + file_exists = function(dir, key, opt, ...) { + self$dropbox_exists(self$path_in_repository(dir, key)) }, - delete_results = function(key, opt) { - rdrop2::drop_delete(self$path_in_repository(key), - dtoken = self$get_dropbox_token()) + delete_file = function(dir, key, opt) { + self$authenticate() + rdrop2::drop_delete(self$path_in_repository(dir, key)) } ) ) diff --git a/R/supplementary-results.R b/R/supplementary-results.R deleted file mode 100644 index bca154fe..00000000 --- a/R/supplementary-results.R +++ /dev/null @@ -1,22 +0,0 @@ -#' Supplementary results directory -#' -#' Returns the location of the supplementary results directory. -#' The supplementary results directory provides a place to store -#' results in addition to the results saved by the psychTestR -#' function \code{save_results_to_disk}. -#' The researcher has full control over what to put in the supplementary -#' results directory. -#' @note The supplementary results directory is typically stored -#' within the main results directory. It will be deleted if the -#' researcher presses the 'Delete all results' button in the admin panel. -#' @param opt Options list as created by \code{test_options()}. -#' @return Character scalar identifying the (relative) -#' path to the supplementary results directory. -#' @export -get_supplementary_results_dir <- function(opt) { - x <- opt$supplementary_results_dir - if (is.null(x)) stop("supplementary_results_dir missing from options list") - if (!is.scalar.character(x)) stop("wrong format for supplementary_results_dir") - R.utils::mkdirs(x) - x -} diff --git a/man/get_supplementary_results_dir.Rd b/man/get_supplementary_results_dir.Rd deleted file mode 100644 index eb59b53d..00000000 --- a/man/get_supplementary_results_dir.Rd +++ /dev/null @@ -1,28 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/supplementary-results.R -\name{get_supplementary_results_dir} -\alias{get_supplementary_results_dir} -\title{Supplementary results directory} -\usage{ -get_supplementary_results_dir(opt) -} -\arguments{ -\item{opt}{Options list as created by \code{test_options()}.} -} -\value{ -Character scalar identifying the (relative) -path to the supplementary results directory. -} -\description{ -Returns the location of the supplementary results directory. -The supplementary results directory provides a place to store -results in addition to the results saved by the psychTestR -function \code{save_results_to_disk}. -The researcher has full control over what to put in the supplementary -results directory. -} -\note{ -The supplementary results directory is typically stored -within the main results directory. It will be deleted if the -researcher presses the 'Delete all results' button in the admin panel. -} diff --git a/man/test_options.Rd b/man/test_options.Rd index aeaae116..5af8a4be 100644 --- a/man/test_options.Rd +++ b/man/test_options.Rd @@ -34,7 +34,8 @@ test_options( logo_height = NULL, display = display_options(), allow_url_rewrite = TRUE, - advance_delay = 0 + advance_delay = 0, + repository = LocalRespository$new(output_dir) ) } \arguments{ diff --git a/tests/testthat/test-results.R b/tests/testthat/test-results.R index dece9da5..048a2b39 100644 --- a/tests/testthat/test-results.R +++ b/tests/testthat/test-results.R @@ -1,11 +1,10 @@ context("test_results") test_that("repository_local", { - repo <- LocalRespository$new() - opt <- demo_options(repository = repo) + opt <- demo_options() tmp_dir <- tempfile("dir") R.utils::mkdirs(tmp_dir) - withr::with_dir(tmp_dir, repo$check(opt)) + withr::with_dir(tmp_dir, opt$repository$check(opt)) }) test_that("main", { From a25b0d93bb43ab09ac81ff043cd91726823ac34b Mon Sep 17 00:00:00 2001 From: Peter Harrison Date: Sun, 19 Jul 2020 13:51:12 +0100 Subject: [PATCH 06/17] Implementing list_files and get_folder in repository --- R/results.R | 72 +++++++++++++++++++++++++------ R/utils.R | 80 +++++++++++++++++++++++++++++++++++ tests/testthat/test-results.R | 13 ++++++ 3 files changed, 153 insertions(+), 12 deletions(-) diff --git a/R/results.R b/R/results.R index 0705cad7..57e446f5 100644 --- a/R/results.R +++ b/R/results.R @@ -180,6 +180,7 @@ Repository <- R6::R6Class("Repository", public = list( deposit_file = function(local_file, dir, key, opt, ...) stop("not implemented"), get_file = function(dir, key, target_path, opt, ...) stop("not implemented"), file_exists = function(dir, key, opt, ...) stop("not implemented"), + list_files = function(dir, opt, ...) stop("not implemented"), delete_file = function(dir, key, opt, ...) stop("not implemented"), check = function(opt) { @@ -196,16 +197,29 @@ Repository <- R6::R6Class("Repository", public = list( !self$file_exists(dir, key, opt), failure_message = "repository$file_exists should return FALSE for non-existent files" ) + testthat::expect( + !key %in% self$list_files(dir, opt), + failure_message = paste0("repository$list_files() should not contain ", key, " yet") + ) self$deposit_file(tmp_file_in, dir, key, opt) testthat::expect( self$file_exists(dir, key, opt), failure_message = "repository$file_exists should return TRUE once a file has been deposited" ) + testthat::expect( + key %in% self$list_files(dir, opt), + failure_message = paste0("repository$list_files() should now contain ", key, ".") + ) self$get_file(dir, key, tmp_file_out, opt) testthat::expect( testthat::compare(readLines(tmp_file_out), file_content)$equal, failure_message = "repository$get_file returned unexpected contents" ) + + tmp_dir_2 <- tempfile("dir") + self$get_folder(dir, tmp_dir_2) + stopifnot(key %in% list.files(tmp_dir_2)) + self$delete_file(dir, key, opt) testthat::expect( !self$file_exists(dir, key, opt), @@ -226,30 +240,43 @@ LocalRespository <- R6::R6Class( self$root_dir <- root_dir }, - prepare = function(opt, ...) { + prepare = function(...) { for (dir in self$dirs) { R.utils::mkdirs(file.path(self$root_dir, dir)) } }, - path_in_repository = function(dir, key, opt) { - file.path(self$root_dir, dir, key) + path_in_repository = function(dir, key = NULL, ...) { + dir_path <- file.path(self$root_dir, dir) + if (is.null(key)) { + dir_path + } else { + file.path(dir_path, key) + } }, - deposit_file = function(local_file, dir, key, opt, ...) { - file.copy(local_file, self$path_in_repository(dir, key, opt)) + deposit_file = function(local_file, dir, key, ...) { + file.copy(local_file, self$path_in_repository(dir, key)) }, - get_file = function(dir, key, target_path, opt, ...) { - file.copy(self$path_in_repository(dir, key, opt), target_path) + get_file = function(dir, key, target_path, ...) { + file.copy(self$path_in_repository(dir, key), target_path) + }, + + get_folder = function(dir, target_path, ...) { + dir_copy(self$path_in_repository(dir), target_path) }, file_exists = function(dir, key, opt, ...) { - file.exists(self$path_in_repository(dir, key, opt)) + file.exists(self$path_in_repository(dir, key)) + }, + + list_files = function(dir, opt, ...) { + list.files(self$path_in_repository(dir)) }, delete_file = function(dir, key, opt) { - file.remove(self$path_in_repository(dir, key, opt)) + file.remove(self$path_in_repository(dir, key)) } ) ) @@ -273,7 +300,6 @@ DropboxRepository <- R6::R6Class( self$token_path <- token_path self$dropbox_key <- dropbox_key self$dropbox_secret <- dropbox_secret - self$mute_dropbox_notifications <- mute_dropbox_notifications }, check = function(opt, ...) { @@ -313,8 +339,13 @@ DropboxRepository <- R6::R6Class( ) }, - path_in_repository = function(dir, key) { - file.path(self$root_dir, dir, key) + path_in_repository = function(dir, key = NULL) { + dir_path <- file.path(self$root_dir, dir) + if (is.null(key)) { + dir_path + } else { + file.path(dir_path, key) + } }, get_dropbox_token = function() { @@ -353,10 +384,27 @@ DropboxRepository <- R6::R6Class( ) }, + get_folder = function(dir, target_path, opt, ...) { + dropbox_download_folder( + self$path_in_repository(dir), + target_path, + dtoken = self$get_dropbox_token() + ) + }, + file_exists = function(dir, key, opt, ...) { self$dropbox_exists(self$path_in_repository(dir, key)) }, + list_files = function(dir, opt, ...) { + x <- rdrop2::drop_dir(self$path_in_repository(dir)) + if (nrow(x) == 0) { + character() + } else { + x$name + } + }, + delete_file = function(dir, key, opt) { self$authenticate() rdrop2::drop_delete(self$path_in_repository(dir, key)) diff --git a/R/utils.R b/R/utils.R index f12487ba..6d808fdf 100644 --- a/R/utils.R +++ b/R/utils.R @@ -65,3 +65,83 @@ assert_global_is_null <- function(key, state) { stop("global variable <", key, "> in was not NULL") } } + +remove_trailing_slashes <- function(x) gsub("/*$", "", x) + +dir_copy <- function(dir, target_path) { + dir <- remove_trailing_slashes(dir) + target_path <- remove_trailing_slashes(target_path) + target_parent <- dirname(target_path) + + tmp_dir <- tempfile("dir") + dir.create(tmp_dir) + + old_dir_name <- basename(dir) + new_dir_name <- basename(target_path) + + file.copy( + from = dir, + to = tmp_dir, + recursive = TRUE + ) + + file.rename(file.path(tmp_dir, old_dir_name), + file.path(tmp_dir, new_dir_name)) + + file.copy( + from = file.path(tmp_dir, new_dir_name), + to = target_parent, + recursive = TRUE + ) +} + +dropbox_download_folder <- function( + path, + local_path, + unzip = TRUE, + overwrite = FALSE, + dtoken = rdrop2::drop_auth(), + progress = interactive(), + verbose = interactive()) { + + if (unzip && dir.exists(local_path)) + stop("a directory already exists at ", local_path) + if (!unzip && file.exists(local_path)) + stop("a file already exists at ", local_path) + + path <- remove_trailing_slashes(path) + local_path <- remove_trailing_slashes(local_path) + local_parent <- dirname(local_path) + original_dir_name <- basename(path) + download_path <- if (unzip) tempfile("dir") else local_path + + if (!dir.exists(local_parent)) stop("target parent directory ", local_parent, " not found") + + url <- "https://content.dropboxapi.com/2/files/download_zip" + req <- httr::POST( + url = url, + httr::config(token = dtoken), + httr::add_headers( + `Dropbox-API-Arg` = jsonlite::toJSON(list(path = paste0("/", path)), + auto_unbox = TRUE)), + if (progress) httr::progress(), + httr::write_disk(download_path, overwrite) + ) + httr::stop_for_status(req) + if (verbose) { + size <- file.size(download_path) + class(size) <- "object_size" + message(sprintf("Downloaded %s to %s: %s on disk", path, + download_path, format(size, units = "auto"))) + } + if (unzip) { + if (verbose) message("Unzipping file...") + new_dir_name <- basename(local_path) + unzip_path <- tempfile("dir") + unzip(download_path, exdir = unzip_path) + dir_copy(file.path(unzip_path, original_dir_name), + local_path) + } + + TRUE +} diff --git a/tests/testthat/test-results.R b/tests/testthat/test-results.R index 048a2b39..26632b3c 100644 --- a/tests/testthat/test-results.R +++ b/tests/testthat/test-results.R @@ -7,6 +7,19 @@ test_that("repository_local", { withr::with_dir(tmp_dir, opt$repository$check(opt)) }) +test_that("repository_dropbox", { + skip_on_cran() + skip_on_appveyor() + skip_on_travis() + + token_path <- "~/dropbox-token.rds" + opt <- demo_options(repository = DropboxRepository$new(token_path = token_path, + root_dir = "Archive/psychTestR-tests")) + tmp_dir <- tempfile("dir") + R.utils::mkdirs(tmp_dir) + withr::with_dir(tmp_dir, opt$repository$check(opt)) +}) + test_that("main", { skip_on_cran() From eae1b695d7c0454713e660e427e0b585207f35c7 Mon Sep 17 00:00:00 2001 From: Peter Harrison Date: Sun, 19 Jul 2020 13:51:59 +0100 Subject: [PATCH 07/17] Updated Dropbox test --- tests/testthat/test-results.R | 1 + 1 file changed, 1 insertion(+) diff --git a/tests/testthat/test-results.R b/tests/testthat/test-results.R index 26632b3c..47bcaf99 100644 --- a/tests/testthat/test-results.R +++ b/tests/testthat/test-results.R @@ -11,6 +11,7 @@ test_that("repository_dropbox", { skip_on_cran() skip_on_appveyor() skip_on_travis() + skip_if_offline() token_path <- "~/dropbox-token.rds" opt <- demo_options(repository = DropboxRepository$new(token_path = token_path, From 56c8d10c66de22e348efcbb3318245a607ed307a Mon Sep 17 00:00:00 2001 From: Peter Harrison Date: Sun, 19 Jul 2020 13:52:11 +0100 Subject: [PATCH 08/17] gitignore --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 3a6516d2..131b1718 100644 --- a/.gitignore +++ b/.gitignore @@ -7,3 +7,4 @@ closed.txt output docs vignettes/output +.DS_Store From 02085362a044e4ff3f579f7b5b555f3f937fa3b0 Mon Sep 17 00:00:00 2001 From: Peter Harrison Date: Sun, 19 Jul 2020 13:59:58 +0100 Subject: [PATCH 09/17] Removing opt dependency --- R/results.R | 64 +++++++++++++++++------------------ tests/testthat/test-results.R | 4 +-- 2 files changed, 34 insertions(+), 34 deletions(-) diff --git a/R/results.R b/R/results.R index 57e446f5..fbe128b1 100644 --- a/R/results.R +++ b/R/results.R @@ -164,27 +164,27 @@ Repository <- R6::R6Class("Repository", public = list( self$is_slow <- is_slow }, - deposit_results = function(results, key, opt, ...) { + deposit_results = function(results, key, ...) { path <- tempfile() saveRDS(results, path) - self$deposit_file(path, "results", key, opt, ...) + self$deposit_file(path, "results", key, ...) }, - get_results = function(key, opt, ...) { + get_results = function(key, ...) { path <- tempfile() - self$get_file(key, "results", path, opt, ...) + self$get_file(key, "results", path, ...) readRDS(path) }, - prepare = function(opt, ...) stop("not implemented"), - deposit_file = function(local_file, dir, key, opt, ...) stop("not implemented"), - get_file = function(dir, key, target_path, opt, ...) stop("not implemented"), - file_exists = function(dir, key, opt, ...) stop("not implemented"), - list_files = function(dir, opt, ...) stop("not implemented"), - delete_file = function(dir, key, opt, ...) stop("not implemented"), + prepare = function(...) stop("not implemented"), + deposit_file = function(local_file, dir, key, ...) stop("not implemented"), + get_file = function(dir, key, target_path, ...) stop("not implemented"), + file_exists = function(dir, key, ...) stop("not implemented"), + list_files = function(dir, ...) stop("not implemented"), + delete_file = function(dir, key, ...) stop("not implemented"), - check = function(opt) { - self$prepare(opt) + check = function() { + self$prepare() dir <- "results" tmp_file_in <- tempfile() @@ -194,23 +194,23 @@ Repository <- R6::R6Class("Repository", public = list( writeLines(file_content, tmp_file_in) testthat::expect( - !self$file_exists(dir, key, opt), + !self$file_exists(dir, key), failure_message = "repository$file_exists should return FALSE for non-existent files" ) testthat::expect( - !key %in% self$list_files(dir, opt), + !key %in% self$list_files(dir), failure_message = paste0("repository$list_files() should not contain ", key, " yet") ) - self$deposit_file(tmp_file_in, dir, key, opt) + self$deposit_file(tmp_file_in, dir, key) testthat::expect( - self$file_exists(dir, key, opt), + self$file_exists(dir, key), failure_message = "repository$file_exists should return TRUE once a file has been deposited" ) testthat::expect( - key %in% self$list_files(dir, opt), + key %in% self$list_files(dir), failure_message = paste0("repository$list_files() should now contain ", key, ".") ) - self$get_file(dir, key, tmp_file_out, opt) + self$get_file(dir, key, tmp_file_out) testthat::expect( testthat::compare(readLines(tmp_file_out), file_content)$equal, failure_message = "repository$get_file returned unexpected contents" @@ -220,9 +220,9 @@ Repository <- R6::R6Class("Repository", public = list( self$get_folder(dir, tmp_dir_2) stopifnot(key %in% list.files(tmp_dir_2)) - self$delete_file(dir, key, opt) + self$delete_file(dir, key) testthat::expect( - !self$file_exists(dir, key, opt), + !self$file_exists(dir, key), failure_message = "repository$file_exists should return FALSE once a file has been deleted" ) } @@ -267,15 +267,15 @@ LocalRespository <- R6::R6Class( dir_copy(self$path_in_repository(dir), target_path) }, - file_exists = function(dir, key, opt, ...) { + file_exists = function(dir, key, ...) { file.exists(self$path_in_repository(dir, key)) }, - list_files = function(dir, opt, ...) { + list_files = function(dir, ...) { list.files(self$path_in_repository(dir)) }, - delete_file = function(dir, key, opt) { + delete_file = function(dir, key) { file.remove(self$path_in_repository(dir, key)) } ) @@ -302,13 +302,13 @@ DropboxRepository <- R6::R6Class( self$dropbox_secret <- dropbox_secret }, - check = function(opt, ...) { + check = function(...) { message("Checking that Dropbox repository is accessible...") - super$check(opt, ...) + super$check(...) message("Dropbox check complete.") }, - prepare = function(opt, ...) { + prepare = function(...) { self$authenticate() if (!self$dropbox_exists(self$root_dir)) { stop("directory '", self$root_dir, "' not found in Dropbox, ", @@ -364,7 +364,7 @@ DropboxRepository <- R6::R6Class( saveRDS(token, self$token_path) }, - deposit_file = function(local_file, dir, key, opt, ...) { + deposit_file = function(local_file, dir, key, ...) { self$authenticate() tmp_dir <- tempfile("dir") R.utils::mkdirs(tmp_dir) @@ -375,7 +375,7 @@ DropboxRepository <- R6::R6Class( autorename = FALSE) }, - get_file = function(dir, key, target_path, opt, ...) { + get_file = function(dir, key, target_path, ...) { self$authenticate() rdrop2::drop_download( self$path_in_repository(dir, key), @@ -384,7 +384,7 @@ DropboxRepository <- R6::R6Class( ) }, - get_folder = function(dir, target_path, opt, ...) { + get_folder = function(dir, target_path, ...) { dropbox_download_folder( self$path_in_repository(dir), target_path, @@ -392,11 +392,11 @@ DropboxRepository <- R6::R6Class( ) }, - file_exists = function(dir, key, opt, ...) { + file_exists = function(dir, key, ...) { self$dropbox_exists(self$path_in_repository(dir, key)) }, - list_files = function(dir, opt, ...) { + list_files = function(dir, ...) { x <- rdrop2::drop_dir(self$path_in_repository(dir)) if (nrow(x) == 0) { character() @@ -405,7 +405,7 @@ DropboxRepository <- R6::R6Class( } }, - delete_file = function(dir, key, opt) { + delete_file = function(dir, key) { self$authenticate() rdrop2::drop_delete(self$path_in_repository(dir, key)) } diff --git a/tests/testthat/test-results.R b/tests/testthat/test-results.R index 47bcaf99..0dbfa47f 100644 --- a/tests/testthat/test-results.R +++ b/tests/testthat/test-results.R @@ -4,7 +4,7 @@ test_that("repository_local", { opt <- demo_options() tmp_dir <- tempfile("dir") R.utils::mkdirs(tmp_dir) - withr::with_dir(tmp_dir, opt$repository$check(opt)) + withr::with_dir(tmp_dir, opt$repository$check()) }) test_that("repository_dropbox", { @@ -18,7 +18,7 @@ test_that("repository_dropbox", { root_dir = "Archive/psychTestR-tests")) tmp_dir <- tempfile("dir") R.utils::mkdirs(tmp_dir) - withr::with_dir(tmp_dir, opt$repository$check(opt)) + withr::with_dir(tmp_dir, opt$repository$check()) }) test_that("main", { From 929273952cac3d1cd4fa2bcc7f05d2d0f35083ec Mon Sep 17 00:00:00 2001 From: Peter Harrison Date: Sun, 19 Jul 2020 16:50:18 +0100 Subject: [PATCH 10/17] Refactoring tabulate_results --- R/admin-panel.R | 8 ++++---- R/app_tester.R | 1 - R/make-test.R | 4 +++- R/options.R | 3 +-- R/results.R | 42 +++++++++++++++++++++++++++++++++++++----- R/server.R | 2 +- R/statistics.R | 28 +++------------------------- R/test-elements.R | 11 +++++++---- 8 files changed, 56 insertions(+), 43 deletions(-) diff --git a/R/admin-panel.R b/R/admin-panel.R index a74e8168..f417efa3 100644 --- a/R/admin-panel.R +++ b/R/admin-panel.R @@ -238,7 +238,7 @@ admin_panel.statistics.num_participants <- function(input, output, opt) { input$admin_panel.statistics.refresh input$admin_panel.statistics.open shiny::showNotification("Refreshing statistics...") - df <- tabulate_results(opt, include_pilot = FALSE) + df <- opt$repository$tabulate_results(include_pilot = FALSE) n_complete <- sum(df$complete) n_part_complete <- sum(!df$complete) shiny::p( @@ -258,7 +258,7 @@ admin_panel.statistics.latest_results <- function(input, output, opt) { output$admin_panel.statistics.latest_results <- shiny::renderUI({ input$admin_panel.statistics.refresh input$admin_panel.statistics.open - files <- tabulate_results(opt, include_pilot = FALSE) + files <- opt$repository$tabulate_results(include_pilot = FALSE) if (nrow(files) > 0L) { latest_file <- files$file[[which.max(files$id)]] latest_path <- file.path(opt$results_dir, latest_file) @@ -281,7 +281,7 @@ admin_panel.statistics.average_time <- function(input, output, opt) { output$admin_panel.statistics.average_time <- shiny::renderUI({ input$admin_panel.statistics.refresh input$admin_panel.statistics.open - files <- tabulate_results(opt, include_pilot = FALSE) + files <- opt$repository$tabulate_results(include_pilot = FALSE) files <- files[files$complete, ] if (nrow(files) > 0L) { data <- lapply(files$full_file, readRDS) @@ -484,7 +484,7 @@ zip_dir <- function(dir, output_file) { } df_all_results <- function(results_dir) { - files <- list_results_files(results_dir, full.names = TRUE) + files <- get_results_files(opt, full.names = TRUE) if (length(files) == 0L) return(data.frame()) data <- lapply(files, readRDS) data_df <- lapply(data, as.data.frame) diff --git a/R/app_tester.R b/R/app_tester.R index ad50077e..816e3dd7 100644 --- a/R/app_tester.R +++ b/R/app_tester.R @@ -75,7 +75,6 @@ AppTester <- R6::R6Class( "AppTester", inherit = shinytest::ShinyDriver, public = list( - get_ui = function() { self$getAllValues(input = FALSE, output = FALSE, export = TRUE)$export$ui }, diff --git a/R/make-test.R b/R/make-test.R index 86e73799..3de3b641 100644 --- a/R/make-test.R +++ b/R/make-test.R @@ -24,10 +24,12 @@ make_test <- function(elts, opt = demo_options(), if (is.list(elts)) elts <- new_timeline(elts) check_elts(elts) check_opt(opt, elts) - shiny::shinyApp( + app <- shiny::shinyApp( ui = ui(opt = opt), server = server(elts = elts, opt = opt, custom_admin_panel = custom_admin_panel)) + app$opt <- opt + app } check_opt <- function(opt, elts) { diff --git a/R/options.R b/R/options.R index 37c4b610..d5e4f2cb 100644 --- a/R/options.R +++ b/R/options.R @@ -378,8 +378,7 @@ test_permissions <- function(dir) { success } -OUTPUT_DIRS <- c("output_dir", "results_dir", "session_dir", - "results_archive_dir", "error_dir") +OUTPUT_DIRS <- c("output_dir", "session_dir", "error_dir") #' Check directories #' diff --git a/R/results.R b/R/results.R index fbe128b1..084ff1cf 100644 --- a/R/results.R +++ b/R/results.R @@ -170,11 +170,11 @@ Repository <- R6::R6Class("Repository", public = list( self$deposit_file(path, "results", key, ...) }, - get_results = function(key, ...) { - path <- tempfile() - self$get_file(key, "results", path, ...) - readRDS(path) - }, + # get_results = function(key, ...) { + # path <- tempfile() + # self$get_file(key, "results", path, ...) + # readRDS(path) + # }, prepare = function(...) stop("not implemented"), deposit_file = function(local_file, dir, key, ...) stop("not implemented"), @@ -182,6 +182,38 @@ Repository <- R6::R6Class("Repository", public = list( file_exists = function(dir, key, ...) stop("not implemented"), list_files = function(dir, ...) stop("not implemented"), delete_file = function(dir, key, ...) stop("not implemented"), + get_folder = function(dir, target_path, ...) stop("not implemented"), + + tabulate_results = function(include_pilot) { + df <- data.frame(file = self$list_files_with_pattern("results", "^id=.*\\.rds$"), stringsAsFactors = FALSE) + cols <- c("id", "p_id", "save_id", "pilot", "complete") + if (nrow(df) > 0L) { + df <- tidyr::extract( + df, "file", cols, + "(?:id=)([[0-9]]*)(?:&p_id=)([[A-Za-z0-9_]]*)(?:&save_id=)([[0-9]]*)(?:&pilot=)([[a-z]]*)(?:&complete=)([[a-z]]*)", + remove = FALSE) + } else { + for (col in cols) df[[col]] <- character() + } + for (col in c("pilot", "complete")) + df[[col]] <- as.logical(toupper(df[[col]])) + for (col in c("id", "save_id")) + df[[col]] <- as.integer(df[[col]]) + for (col in c("p_id")) + df[[col]] <- as.character(df[[col]]) + if (!include_pilot) df <- df[!df$pilot, , drop = FALSE] + df + }, + + list_files_with_pattern = function(dir, pattern) { + all_files <- self$list_files(dir) + grep(pattern, all_files, value = TRUE) + }, + + export_results_as_df = function() { + # this would be replacing df_all_results + stop("not implemented") + }, check = function() { self$prepare() diff --git a/R/server.R b/R/server.R index f2410fc4..6f92e3d4 100644 --- a/R/server.R +++ b/R/server.R @@ -75,7 +75,7 @@ setup_session <- function(state, input, output, elts, session, opt) { } max <- opt$max_num_participants if (!is.null(max)) { - results <- tabulate_results(opt, include_pilot = FALSE) + results <- opt$repository$tabulate_results(include_pilot = FALSE) num_complete <- sum(results$complete) if (num_complete + 1L > max) { error(state) <- opt$max_participants_msg diff --git a/R/statistics.R b/R/statistics.R index b82e1822..5b6c9bc8 100644 --- a/R/statistics.R +++ b/R/statistics.R @@ -12,31 +12,9 @@ # # # "id=1&p_id=PeterHarrison&save_id=1&final=true.rds" -list_results_files <- function(results_dir, full.names = FALSE) { +get_results_files <- function(opt, full.names = FALSE, target_path = tempfile("dir")) { + opt$repository$get_folder("results", target_path) pattern <- "^id=.*\\.rds$" - list.files(results_dir, pattern = pattern, full.names = full.names) + list.files(target_path, pattern = pattern, full.names = full.names) } -tabulate_results <- function(opt, include_pilot) { - stopifnot(is.scalar.logical(include_pilot)) - df <- data.frame(file = list_results_files(opt$results_dir), - stringsAsFactors = FALSE) - cols <- c("id", "p_id", "save_id", "pilot", "complete") - if (nrow(df) > 0L) { - df <- tidyr::extract( - df, "file", cols, - "(?:id=)([[0-9]]*)(?:&p_id=)([[A-Za-z0-9_]]*)(?:&save_id=)([[0-9]]*)(?:&pilot=)([[a-z]]*)(?:&complete=)([[a-z]]*)", - remove = FALSE) - } else { - for (col in cols) df[[col]] <- character() - } - for (col in c("pilot", "complete")) - df[[col]] <- as.logical(toupper(df[[col]])) - for (col in c("id", "save_id")) - df[[col]] <- as.integer(df[[col]]) - for (col in c("p_id")) - df[[col]] <- as.character(df[[col]]) - if (!include_pilot) df <- df[!df$pilot, , drop = FALSE] - df$full_file <- file.path(opt$results_dir, df$file) - df -} diff --git a/R/test-elements.R b/R/test-elements.R index 3eaf4872..bb805aca 100644 --- a/R/test-elements.R +++ b/R/test-elements.R @@ -1125,7 +1125,9 @@ elt_save_results_to_disk <- function(complete) { #' @param ... Further arguments are allowed but ignored (for back-compatibility). #' @export save_results_to_disk <- function(complete, state, opt, ...) { - key <- save_results_to_disk.get_key(state, complete) + num_previous_results <- count_results_excluding_current_participant(state) + + key <- save_results_to_disk.get_key(state, complete, num_previous_results) results <- get_results(state, complete = complete, add_session_info = TRUE) opt$repository$deposit_results(results, key) @@ -1138,9 +1140,10 @@ save_results_to_disk <- function(complete, state, opt, ...) { if (complete) notify_new_participant(opt) } -save_results_to_disk.get_key <- function(state, complete) { +save_results_to_disk.get_key <- function(state, complete, num_previous_results) { sprintf( - "p_id=%s&save_id=%s&pilot=%s&complete=%s.rds", + "id=%s&p_id=%s&save_id=%s&pilot=%s&complete=%s.rds", + id = format(num_previous_results + 1, scientific = FALSE), p_id = format(p_id(state), scientific = FALSE), save_id = format(save_id(state), scientific = FALSE), pilot = tolower(pilot(state)), @@ -1151,7 +1154,7 @@ notify_new_participant <- function(opt) { enabled <- opt$notify_new_participant stopifnot(is.scalar.logical(enabled)) if (enabled) { - results <- tabulate_results(opt, include_pilot = FALSE) + results <- opt$repository$tabulate_results(include_pilot = FALSE) num_complete <- sum(results$complete) title <- sprintf("N = %i", num_complete) msg <- sprintf("Participant number %i%s just completed the experiment '%s'.", From 5c33a8335d6bcb0b10890b617967c4f64f4905f8 Mon Sep 17 00:00:00 2001 From: Peter Harrison Date: Sun, 19 Jul 2020 22:43:44 +0100 Subject: [PATCH 11/17] Refactored admin panel statistics --- R/admin-panel.R | 18 ++++++++---------- R/results.R | 28 ++++++++++++++++++++++++++-- R/test-elements.R | 4 ++-- 3 files changed, 36 insertions(+), 14 deletions(-) diff --git a/R/admin-panel.R b/R/admin-panel.R index f417efa3..5ff7eafe 100644 --- a/R/admin-panel.R +++ b/R/admin-panel.R @@ -258,11 +258,10 @@ admin_panel.statistics.latest_results <- function(input, output, opt) { output$admin_panel.statistics.latest_results <- shiny::renderUI({ input$admin_panel.statistics.refresh input$admin_panel.statistics.open - files <- opt$repository$tabulate_results(include_pilot = FALSE) - if (nrow(files) > 0L) { - latest_file <- files$file[[which.max(files$id)]] - latest_path <- file.path(opt$results_dir, latest_file) - latest_data <- readRDS(latest_path) + results_table <- opt$repository$tabulate_results(include_pilot = FALSE) + if (nrow(results_table) > 0L) { + latest_key <- results_table$key[[which.max(results_table$id)]] + latest_data <- opt$repository$load_results(latest_key) latest_time <- as.list(latest_data)$session$current_time if (!is.null(latest_time)) { time_diff <- Sys.time() - latest_time @@ -281,11 +280,10 @@ admin_panel.statistics.average_time <- function(input, output, opt) { output$admin_panel.statistics.average_time <- shiny::renderUI({ input$admin_panel.statistics.refresh input$admin_panel.statistics.open - files <- opt$repository$tabulate_results(include_pilot = FALSE) - files <- files[files$complete, ] - if (nrow(files) > 0L) { - data <- lapply(files$full_file, readRDS) - time_taken <- vapply(data, function(x) { + results <- opt$repository$load_all_results(include_pilot = FALSE) + results <- results[results$complete, ] + if (nrow(results) > 0L) { + time_taken <- vapply(results$data, function(x) { difftime(x$session$current_time, x$session$time_started, units = "mins") }, numeric(1)) M <- mean(time_taken) diff --git a/R/results.R b/R/results.R index 084ff1cf..a01d0d1c 100644 --- a/R/results.R +++ b/R/results.R @@ -185,11 +185,11 @@ Repository <- R6::R6Class("Repository", public = list( get_folder = function(dir, target_path, ...) stop("not implemented"), tabulate_results = function(include_pilot) { - df <- data.frame(file = self$list_files_with_pattern("results", "^id=.*\\.rds$"), stringsAsFactors = FALSE) + df <- data.frame(key = self$list_files_with_pattern("results", "^id=.*\\.rds$"), stringsAsFactors = FALSE) cols <- c("id", "p_id", "save_id", "pilot", "complete") if (nrow(df) > 0L) { df <- tidyr::extract( - df, "file", cols, + df, "key", cols, "(?:id=)([[0-9]]*)(?:&p_id=)([[A-Za-z0-9_]]*)(?:&save_id=)([[0-9]]*)(?:&pilot=)([[a-z]]*)(?:&complete=)([[a-z]]*)", remove = FALSE) } else { @@ -205,6 +205,30 @@ Repository <- R6::R6Class("Repository", public = list( df }, + load_results = function(key) { + checkmate::qassert(key, "S1") + file <- tempfile() + self$get_file("results", key, file) + readRDS(file) + }, + + load_all_results = function(include_pilot) { + df <- self$tabulate_results(include_pilot) + temp_dir <- tempfile("dir") + self$get_folder("results", temp_dir) + df$data <- lapply(df$key, function(key) readRDS(file.path(temp_dir, key))) + df + }, + + delete_results = function(key) { + self$delete_file("results", key) + }, + + count_results_excluding_participant = function(p_id) { + df <- self$tabulate_results(include_pilot = TRUE) + nrow(df) - sum(df$p_id == p_id) + }, + list_files_with_pattern = function(dir, pattern) { all_files <- self$list_files(dir) grep(pattern, all_files, value = TRUE) diff --git a/R/test-elements.R b/R/test-elements.R index bb805aca..c97cc94b 100644 --- a/R/test-elements.R +++ b/R/test-elements.R @@ -1125,7 +1125,7 @@ elt_save_results_to_disk <- function(complete) { #' @param ... Further arguments are allowed but ignored (for back-compatibility). #' @export save_results_to_disk <- function(complete, state, opt, ...) { - num_previous_results <- count_results_excluding_current_participant(state) + num_previous_results <- opt$repository$count_results_excluding_participant(state$passive$p_id) key <- save_results_to_disk.get_key(state, complete, num_previous_results) results <- get_results(state, complete = complete, add_session_info = TRUE) @@ -1134,7 +1134,7 @@ save_results_to_disk <- function(complete, state, opt, ...) { if (!is.null(previous_results_key(state))) opt$repository$delete_results(previous_results_key(state)) - previous_results_key(state) <- path + previous_results_key(state) <- key save_id(state) <- save_id(state) + 1L if (complete) notify_new_participant(opt) From a743ab41ce5e0e9714e2a5b878093408c88657b2 Mon Sep 17 00:00:00 2001 From: Peter Harrison Date: Mon, 20 Jul 2020 08:24:18 +0100 Subject: [PATCH 12/17] Added todo.txt --- todo.txt | 4 ++++ 1 file changed, 4 insertions(+) create mode 100644 todo.txt diff --git a/todo.txt b/todo.txt new file mode 100644 index 00000000..f00dbe90 --- /dev/null +++ b/todo.txt @@ -0,0 +1,4 @@ +finish removing results_dir from statistics / admin panel +implement asynchronous code block +make Dropbox upload asynchronous +integrate deleted-results with Dropbox From 65342a805433cb1c486aaa55a9e27d5759ea2f1f Mon Sep 17 00:00:00 2001 From: Peter Harrison Date: Tue, 13 Jul 2021 14:12:06 +0200 Subject: [PATCH 13/17] Update exports --- .Rbuildignore | 1 + .gitignore | 1 + DESCRIPTION | 2 +- NAMESPACE | 2 ++ R/results.R | 2 ++ dropbox-token.rds | Bin 0 -> 4668 bytes man/AppTester.Rd | 4 ++++ man/slider_page.Rd | 6 +++--- man/trigger_button.Rd | 2 +- 9 files changed, 15 insertions(+), 5 deletions(-) create mode 100644 dropbox-token.rds diff --git a/.Rbuildignore b/.Rbuildignore index c37d6891..94ecb120 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -13,3 +13,4 @@ psychTestR.pdf ^vignettes/output$ ^docs$ ^tests/testthat/output$ +^\.httr-oauth$ diff --git a/.gitignore b/.gitignore index 131b1718..94731bd0 100644 --- a/.gitignore +++ b/.gitignore @@ -8,3 +8,4 @@ output docs vignettes/output .DS_Store +.httr-oauth diff --git a/DESCRIPTION b/DESCRIPTION index 33778074..3d21c129 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -39,7 +39,7 @@ Imports: uuid, rdrop2 (>= 0.8.1) Depends: R (>= 3.4.0) -RoxygenNote: 7.1.0 +RoxygenNote: 7.1.1 Suggests: knitr, rmarkdown diff --git a/NAMESPACE b/NAMESPACE index 28497093..6bcded30 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -17,7 +17,9 @@ export("answer<-") export("error<-") export("results<-") export(AppTester) +export(DropboxRepository) export(I18N_STATE) +export(LocalRespository) export(NAFC_page) export(answer) export(as.timeline) diff --git a/R/results.R b/R/results.R index a01d0d1c..d0298d43 100644 --- a/R/results.R +++ b/R/results.R @@ -284,6 +284,7 @@ Repository <- R6::R6Class("Repository", public = list( } )) +#' @export LocalRespository <- R6::R6Class( "LocalRespository", inherit = Repository, @@ -337,6 +338,7 @@ LocalRespository <- R6::R6Class( ) ) +#' @export DropboxRepository <- R6::R6Class( "DropboxRepository", inherit = Repository, diff --git a/dropbox-token.rds b/dropbox-token.rds new file mode 100644 index 0000000000000000000000000000000000000000..961be7342c5255759902aa7a65cec18e405798e3 GIT binary patch literal 4668 zcmV-C62t8uiwFP!000001MM7XcO1oWwOXA)FL@~zm$@)h6s0t|)> zv%9m>pxvF-%&ZOrxquKtNJ8#Uyu8PUJou9Hhvns49`9)~J<~l?(^K8kqXQc(y(g>P zM^$xIb#--5SKS&c6bjviQkVa4k6$eGym0gE*kQj=@_+r>!hii@F({V`1ODI5Wlb|$ z)rRHxf95rfb|pXmqkoIEYiY)HZCdUbFYhl;aIiM{u=J{H&Km)ot>N%Qmma6nHf(@| zr>Dm!rDgb)-EpUq7k29L1W-$k(Wv|XCGE@cZ?aF#Fxvj#LCS~%?bi$XbiEl&H(6Oc zI!0?Fp4moIZ)^2Vt4f&WAcOizqib5Nuq{c6Re6Jq`GTw8Vl`@7%UB2m(bi3yb_&R( z2p;edWW5c&-EJ&}EhC`EW)DH%wWtWTXx5S1O{P;$PHw9w1~$aX3C55aVxawM)3#bo zqvdj-myzz>b<5_UcbQ1P0mqorbYHEe!^SNVdLP0VF<{nwip;9s2pb>4I(0pTvGDe7 zfYbl`7{nb-#20*eo+umr@}nNk_HThc+dLJtzOG5w+f%U(eYTKTQK?^^4x~Nxe@ra~ z8m8k;`0}5?wKqV*FPNS{Ukd59-rLsgP=^w0(rC8brBL-!)?r3>W_XG2!o++WsqAeS zt!Z}#;m0uPb>ig$`#~*}W8N`%-EQiO6vR*=G+5hW#JhME;6V-rQ`KBcYjqk#Ynj#S z66+YM`hEUtry%^MClyxulPDNp)ye_q37I>+@RyXo?S;RjyxR+ZQ7sZtSUh%2!k9<~ zh4?39{?DK$);8RZ-QqNw_SyrdE}%WuLZ<0}Qhsd4s(AvVutea-_2V9=5(D8bZw6K{ zK~UN0R2;*lD{qhi9|3(3FM(INzKYqZ1<(h1)O~H+oY!3=r)0Z!AeFEncZL2w|w??lY9Q8MR zqw1FBQeEjJ4oLQaRWSv^mf7x2zU|av5z}r50qSShYKkgbNq^h2UA@u}(DL{yY1yx^ z?dH}yWIm5&z)0@Z3o~XkVQA|!?7T=YvPnT-0_sXHqAL*Zs9>=T$rzZh2hS*Q1^{Lz zFp$_9PO!x4B`{aTK)+nfVAf**{!tZ;kr>@g09K|$P<;C7u=WUOeRu_2P%>u>>mWJ2 zY4m8AWw9BLj;|9{#}#%Bj0W^HR%+=@GN+VpJFho7v_ZvVI|j;!X!!(ZsAWjJ`}iQzbxg+l@MgaGzg75XLCHA@obLEZQBXz_Z=goAxf1;={J zFvHZGQ{-cog;{f&SEzqN8WiDX;TX(=FRyjUL5Jx4iR#x1=MCjo%)mFn&HD`OuVk-- zJvL)^4YZMNrh}k-0F=+ta+c;#fI4NX#lhH*z<|5JO06rS4Qd;&dC(8V_H@j`WNF<5 zKQ^ZYW&D8J!mm*1zf5?s|B_lc5}ez;Bs^9=1ee;zM!s6zNCm7+RzcBor6w4S|hv zYi7MJ>C(foXvMTCxnfK%zCM|#U`owt!;Q%$A_zXEt>oYkeLld7bBkMw2$`J@8e8-Zi?@MmHuqk>_!#Cic?6Nq23!7Wl?PTLCk{uiZ z80PA(Nw#6pCA5^V-X?hX0a49KNOkf=@#C76RM`0kSs9iEyn?-jE5e3nY?9 z>RC5LYWIIa6S-A)%H(l?{JS|%1X(ICcm<`sD{JvqK-~{$8C$Luz}O01t{SAFkS$1v zYnZFUGnfS({N|38uxPWK}cdT*71Z*$6suv@9IrQ3z5W~@TY)e zv!U)(%`4>lBG8?<9cQo7>Jp;>eeQ44a!q0s;2L6|?WYktP=oL#YbW|%CHoGw%=IaN zI>~tgGkE;wFPfWy%t>m;IGe}wFjlpORh<=@Q6)2pXu9a~P{xYN8nfbnA}eMPnv_E;^&pVg=^=nWoJ|$sO?Ddlse}>=ZFA8RY zJs^Oq+oa`_8HV)@TE3)!2fh{A=K=ai-3XXUf8A{9jqqt~9*1ZP8)s_^wtqf|PDjFB zFyom8q_m+*se-M5+vcpug!ff+$B5o6qg{qVwB*HFAu5>-EjbL zFkp@jnBoXx{SsO=Vzx|ItJ+2oD4~U1iUOfFD}T(A|;vqAFpv2E0CgS_rvCz2dbfr^r2PPgs~2|K+)QHD0{*f$;Uy(KPAJ*0#bgAIl2;yM3db>>BG?%d(pR4VvShceCyxQ=my;h~9Jx z>80Egz(dv!vX}JpO2yCIE@s)YX_1Dn5Qxi=JY%$qc@OU3?1)+ zM0F>gjp`6fk-QtLT8)O@b_`A(3xfW>-=Wtu^5k8s>eU%Tu5wvVkW+FS41j8FJqWVl z#F0AI71DiDO5Phl1PA1(<-xk)R%gO#)HK(cHCjmt^HlCcOg7)=T?NmGapFDB66cy9 zf_u@!X?u@vSA@5e0dFZMy!g19*g#|`-p`5R%?y&?;*=WuC^T*S(L8sa+z$FUu2-~uIlV=a0FEMAH7KkIzGrlb%K~$ z*tJkdaQZ_P#Z>H%Db`2Wra62RXwvafWS+f&<=z{&yd=R3wT(>wryhr|`0Oa43bu4n zj{S-s!m$aRMrmwpY%qyBwur>zqT6v1N_>g>#wEsJS`Jhk+)9+d#FC#=*@g0~u@pDI z>v0?$m^R$!+i?_dg7Og(Dy~_2$EAi;LGuSle3e;mS=fu*;#+SawOdT593lZO24eBB z3;2Wy!8Z2?BH*Dvf>^$IXE(zu_5yBAau`$|g{ooar>trXdCMpp_pWIA10BbRTS3-4i`2sA%5c{mgzyD)VX)tk(8WKX6P;ZdEE|D^_4_$bE3h2o zA>4qMt|w!$#0g9e(c&Kg0^d|73w$hC9$Is*SCM#5my zVW;%?3TSK8xu?d{U5c9fh<;jDB?^eJDq0v{!`^B*+Ki#s43^$vm<*`sj#<@$DYCuU zYSqnYjhJ5MELIz)zt1F&zG2J5a~;E83Wi%YIj|UuuC2#BeV;L`#PRlorX4!q95}uI z(g9~G`q3{muegia!d~~3U8$eFdH#jPv!||{sh>V#9Il?Zy6?`dspho{M=Gt^D;&Ju zilN)Vy%4PJ+jsEDk;8k(x$0fDidmbSnmS#*xYsmIr+w($(y8i;H!AxUZtTB0JAdKA z^Yhd5zNzD+Qes9^uT~Amq5ccqs)GM$Kpx#4v&I_z0anN7pjnG~LyTZI#+$yHZM7@b zB3He+arllgH#axk9B&y1?(F58o6VWJvs9_qYgTjr!~)m+h_B1-$vt}-R#k7zSdKe6 zzJGl09>EOz{M{gk*`nNa3}5z49lFV$Njc$bglQX9SL@hj2y2dCMgwqvS&sMYVD8;? z!6d{(NOgQ#7Zw)Elo#cy)!Y*Rn%EO*8#nGLHcoGw*f{ELCMMh+-=FxZ?6}cdiEvO3 zgd!JAaX7U!jdwuL=~iO>OnnsAA`LmR!s@Ao5K4pgOMZm$1`yKD5m*fK2+Yk9%J6xCGsdM z@v9L3WXubu?}%RFNvm8U7Z>wE~5 zWgmxElQsjr%)Vb!W#kEZUD13byqXl?{yOEs_#W%?HA{Vw=bb*ZFB=&za9DXVUSRJb z)+^7&N;68_3p7CADR^Z?eWw$&tm20p1LgZIdBxOP*zSS&YwiQHg_`O5(RYO))=BH$(bc6A$>BOk>0D(f>+fUn!{rNjlVadme)Ux6&- z8Ou^~+%}Hp`!UA=42iEQz}!d~u(l}!YM^cn@&mxw zYUm9FA^SPA0KhQ(jnMzJTHdYDf0cOmjW~aWUxCb-{%^$j+FwnC_m>@$-$eMiqR?zbJ9{5T*tap2yxU@v;GTo!qtOu3ILT)eI3ivuUHn7(fV@w<@Hd&OAOz-wBVXm4ho!7W1Jnv-h!?B?CF63jwn$pI{6aXzR9PXrVY*C&{Y9h>ie9_eepUO$_8y zfl_77{8NOOzj(2%k~67v%tlQx6Ha4YPrh`9_!*T*FcHGO5t_(i4OW&Ygd0_fl`M=z zK-TI&@v&H$z6!hk_$xOFbWv`#jixnkAmRRlh(ct2Fu?f7lY#X|1NR~tIFr1os<*U6 zQWKGC<+9bY!TtVMr#6e=2wNrRP=v!VsO?(TC{VeC$&%oGtfd`>* zx#0W_gA;`{<^uJ13={~7%mwTp0NCd_dGk3&NFv5E7r1|7;IR12Tu}doK^4Y!<^cTf z)RHgdO4kE(!z_TZEG19gZQ+ih&A?Vmmh1jDfJc6RNdNyM`uE2iEw3T-7UjhG2`dj5 z(%+4Py6jXqsU#0k-%w8PWXMT1#|;)MpC{wXdjR&&IG*yjHZs*D;pNR#BXW!GPFk8! z4~gpl^M8Ec;kabkXMVx;O{ba(aec_)`Xy--oU1-!<&gq7O(yfmWMxIUx01*F8bH72 z)5U}W`;E6Y$zf8-ApE|+#c0Tp_~mz?{CiOTgTNT%N#gQHfdTlFXkq0rBwwWrEq|75 yGBP+D30dT@R-2FonujQ50!z5iAJ|B8+@UudH$gIu;`M`M=>Gv%T13C;hX4R5(<}Y} literal 0 HcmV?d00001 diff --git a/man/AppTester.Rd b/man/AppTester.Rd index d32d07b8..891281f0 100644 --- a/man/AppTester.Rd +++ b/man/AppTester.Rd @@ -99,8 +99,10 @@ which you can install with \code{\link[shinytest]{installDependencies}}. \item \out{}\href{../../shinytest/html/ShinyDriver.html#method-getAppFilename}{\code{shinytest::ShinyDriver$getAppFilename()}}\out{} \item \out{}\href{../../shinytest/html/ShinyDriver.html#method-getDebugLog}{\code{shinytest::ShinyDriver$getDebugLog()}}\out{} \item \out{}\href{../../shinytest/html/ShinyDriver.html#method-getEventLog}{\code{shinytest::ShinyDriver$getEventLog()}}\out{} +\item \out{}\href{../../shinytest/html/ShinyDriver.html#method-getRelativePathToApp}{\code{shinytest::ShinyDriver$getRelativePathToApp()}}\out{} \item \out{}\href{../../shinytest/html/ShinyDriver.html#method-getSnapshotDir}{\code{shinytest::ShinyDriver$getSnapshotDir()}}\out{} \item \out{}\href{../../shinytest/html/ShinyDriver.html#method-getSource}{\code{shinytest::ShinyDriver$getSource()}}\out{} +\item \out{}\href{../../shinytest/html/ShinyDriver.html#method-getTestsDir}{\code{shinytest::ShinyDriver$getTestsDir()}}\out{} \item \out{}\href{../../shinytest/html/ShinyDriver.html#method-getTitle}{\code{shinytest::ShinyDriver$getTitle()}}\out{} \item \out{}\href{../../shinytest/html/ShinyDriver.html#method-getUrl}{\code{shinytest::ShinyDriver$getUrl()}}\out{} \item \out{}\href{../../shinytest/html/ShinyDriver.html#method-getValue}{\code{shinytest::ShinyDriver$getValue()}}\out{} @@ -122,6 +124,8 @@ which you can install with \code{\link[shinytest]{installDependencies}}. \item \out{}\href{../../shinytest/html/ShinyDriver.html#method-takeScreenshot}{\code{shinytest::ShinyDriver$takeScreenshot()}}\out{} \item \out{}\href{../../shinytest/html/ShinyDriver.html#method-uploadFile}{\code{shinytest::ShinyDriver$uploadFile()}}\out{} \item \out{}\href{../../shinytest/html/ShinyDriver.html#method-waitFor}{\code{shinytest::ShinyDriver$waitFor()}}\out{} +\item \out{}\href{../../shinytest/html/ShinyDriver.html#method-waitForShiny}{\code{shinytest::ShinyDriver$waitForShiny()}}\out{} +\item \out{}\href{../../shinytest/html/ShinyDriver.html#method-waitForValue}{\code{shinytest::ShinyDriver$waitForValue()}}\out{} } \out{} } diff --git a/man/slider_page.Rd b/man/slider_page.Rd index c36f2d80..d0f5347e 100644 --- a/man/slider_page.Rd +++ b/man/slider_page.Rd @@ -73,10 +73,10 @@ according to some simple heuristics.} \item{animate}{\code{TRUE} to show simple animation controls with default settings; \code{FALSE} not to; or a custom settings list, such as those -created using \code{\link[shiny:animationOptions]{animationOptions()}}.} +created using \code{\link[shiny:sliderInput]{animationOptions()}}.} \item{width}{The width of the input, e.g. \code{'400px'}, or \code{'100\%'}; -see \code{\link[shiny:validateCssUnit]{validateCssUnit()}}.} +see \code{\link[shiny:reexports]{validateCssUnit()}}.} \item{sep}{Separator between thousands places in numbers.} @@ -88,7 +88,7 @@ see \code{\link[shiny:validateCssUnit]{validateCssUnit()}}.} format string, to be passed to the Javascript strftime library. See \url{https://github.com/samsonjs/strftime} for more details. The allowed format specifications are very similar, but not identical, to those for R's -\code{\link[base:strftime]{base::strftime()}} function. For Dates, the default is \code{"\%F"} +\code{\link[base:strptime]{base::strftime()}} function. For Dates, the default is \code{"\%F"} (like \code{"2015-07-01"}), and for POSIXt, the default is \code{"\%F \%T"} (like \code{"2015-07-01 15:32:10"}).} diff --git a/man/trigger_button.Rd b/man/trigger_button.Rd index 1b1c6fa8..77175eca 100644 --- a/man/trigger_button.Rd +++ b/man/trigger_button.Rd @@ -23,7 +23,7 @@ you could also use any other HTML, like an image.} \item{icon}{An optional \code{\link[shiny:icon]{icon()}} to appear on the button.} \item{width}{The width of the input, e.g. \code{'400px'}, or \code{'100\%'}; -see \code{\link[shiny:validateCssUnit]{validateCssUnit()}}.} +see \code{\link[shiny:reexports]{validateCssUnit()}}.} \item{enable_after}{Number of seconds after which responses should be permitted.} From 663f1e607d2afc3bc0fbfe70993387ef44b717c2 Mon Sep 17 00:00:00 2001 From: Peter Harrison Date: Tue, 13 Jul 2021 17:51:31 +0200 Subject: [PATCH 14/17] Bugfix in data export --- R/admin-panel.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/admin-panel.R b/R/admin-panel.R index 5ff7eafe..d669e901 100644 --- a/R/admin-panel.R +++ b/R/admin-panel.R @@ -441,7 +441,7 @@ admin_panel.handle_downloads.all_results.csv <- function(state, output, opt) { filename = "results.csv", content = function(file) { df <- tryCatch({ - df_all_results(opt$results_dir) %>% + df_all_results(opt) %>% list_cols_to_json() }, error = function(e) { print(e) @@ -481,7 +481,7 @@ zip_dir <- function(dir, output_file) { ) } -df_all_results <- function(results_dir) { +df_all_results <- function(opt) { files <- get_results_files(opt, full.names = TRUE) if (length(files) == 0L) return(data.frame()) data <- lapply(files, readRDS) From ba907c7d668ed2cbe5661bc0e62e65e44056c97f Mon Sep 17 00:00:00 2001 From: Peter Harrison Date: Tue, 13 Jul 2021 18:31:42 +0200 Subject: [PATCH 15/17] Bugfix in delete results --- R/admin-panel.R | 27 +++++++++++++++++---------- R/options.R | 2 -- R/results.R | 26 ++++++++++++++++++++++++++ 3 files changed, 43 insertions(+), 12 deletions(-) diff --git a/R/admin-panel.R b/R/admin-panel.R index d669e901..653d3047 100644 --- a/R/admin-panel.R +++ b/R/admin-panel.R @@ -315,19 +315,26 @@ admin_panel.clear_sessions.observers <- function(state, input, opt) { } admin_panel.delete_results.actual <- function(opt) { - dir <- opt$results_archive_dir - R.utils::mkdirs(dir) - file <- paste0(format(Sys.time(), - format = "date=%Y-%m-%d&time=%H-%M-%S&tz=%Z"), - ".zip") - path <- file.path(dir, file) + # "deleted-results" + zip_key <- paste0( + format(Sys.time(), format = "date=%Y-%m-%d&time=%H-%M-%S&tz=%Z"), + ".zip" + ) shiny::showNotification("Creating results backup...") - zip_dir(dir = opt$results_dir, output_file = path) - if (file.exists(path)) { + + tmp_results_dir <- tempfile("dir") + opt$repository$download_results_dir(tmp_results_dir) + + tmp_zip_file <- tempfile(fileext = ".zip") + + zip_dir(dir = tmp_results_dir, output_file = tmp_zip_file) + opt$repository$deposit_file(tmp_zip_file, "deleted-results", zip_key) + + if (opt$repository$file_exists("deleted-results", zip_key)) { shiny::showNotification("Backup created.") - unlink(opt$results_dir, recursive = TRUE) + opt$repository$delete_folder("results") Sys.sleep(0.01) - dir.create(opt$results_dir) + opt$repository$create_folder("results") shiny::showNotification("Deleted results.") } else { shiny::showNotification( diff --git a/R/options.R b/R/options.R index d5e4f2cb..52dff79b 100644 --- a/R/options.R +++ b/R/options.R @@ -194,7 +194,6 @@ test_options <- function(title, admin_password, server_closed_msg <- enc2utf8(server_closed_msg) session_dir <- file.path(output_dir, "sessions") - results_archive_dir <- file.path(output_dir, "deleted-results") error_dir <- file.path(output_dir, "errors") list(title = title, @@ -221,7 +220,6 @@ test_options <- function(title, admin_password, repository = repository, output_dir = output_dir, session_dir = session_dir, - results_archive_dir = results_archive_dir, error_dir = error_dir, closed_file = file.path(output_dir, "closed.txt"), session_timeout_min = session_timeout_min, diff --git a/R/results.R b/R/results.R index d0298d43..09ebc198 100644 --- a/R/results.R +++ b/R/results.R @@ -182,6 +182,11 @@ Repository <- R6::R6Class("Repository", public = list( file_exists = function(dir, key, ...) stop("not implemented"), list_files = function(dir, ...) stop("not implemented"), delete_file = function(dir, key, ...) stop("not implemented"), + delete_folder = function(dir, ...) stop("not implemented"), + + # May throw an error if the folder already exists + create_folder = function(dir, ...) stop("not implemented"), + get_folder = function(dir, target_path, ...) stop("not implemented"), tabulate_results = function(include_pilot) { @@ -212,6 +217,10 @@ Repository <- R6::R6Class("Repository", public = list( readRDS(file) }, + download_results_dir = function(target_path) { + self$get_folder("results", target_path) + }, + load_all_results = function(include_pilot) { df <- self$tabulate_results(include_pilot) temp_dir <- tempfile("dir") @@ -334,6 +343,14 @@ LocalRespository <- R6::R6Class( delete_file = function(dir, key) { file.remove(self$path_in_repository(dir, key)) + }, + + delete_folder = function(dir) { + unlink(self$path_in_repository(dir), recursive = TRUE) + }, + + create_folder = function(dir, ...) { + dir.create(self$path_in_repository(dir)) } ) ) @@ -466,6 +483,15 @@ DropboxRepository <- R6::R6Class( delete_file = function(dir, key) { self$authenticate() rdrop2::drop_delete(self$path_in_repository(dir, key)) + }, + + delete_folder = function(dir) { + self$authenticate() + rdrop2::drop_delete(self$path_in_repository(dir)) + }, + + create_folder = function(dir, ...) { + rdrop2::drop_create(self$path_in_repository(dir)) } ) ) From b4e33d17b995f00d2fd440ad287ced5b48d5c8c9 Mon Sep 17 00:00:00 2001 From: Peter Harrison Date: Tue, 13 Jul 2021 21:33:13 +0200 Subject: [PATCH 16/17] Bugfix in tabulate_results --- R/results.R | 55 ++++++++++++++++++++++++++++++++++++----------------- 1 file changed, 38 insertions(+), 17 deletions(-) diff --git a/R/results.R b/R/results.R index 09ebc198..61665d2a 100644 --- a/R/results.R +++ b/R/results.R @@ -195,7 +195,7 @@ Repository <- R6::R6Class("Repository", public = list( if (nrow(df) > 0L) { df <- tidyr::extract( df, "key", cols, - "(?:id=)([[0-9]]*)(?:&p_id=)([[A-Za-z0-9_]]*)(?:&save_id=)([[0-9]]*)(?:&pilot=)([[a-z]]*)(?:&complete=)([[a-z]]*)", + "(?:id=)([0-9]*)(?:&p_id=)([A-Za-z0-9]*)(?:&save_id=)([0-9]*)(?:&pilot=)([a-z]*)(?:&complete=)([a-z]*)", remove = FALSE) } else { for (col in cols) df[[col]] <- character() @@ -363,6 +363,7 @@ DropboxRepository <- R6::R6Class( public = list( root_dir = NA_character_, token_path = NA_character_, + token = NULL, dropbox_key = NA_character_, dropbox_secret = NA_character_, @@ -373,6 +374,7 @@ DropboxRepository <- R6::R6Class( super$initialize(is_slow = TRUE) self$root_dir <- root_dir self$token_path <- token_path + self$token <- readRDS(self$token_path) self$dropbox_key <- dropbox_key self$dropbox_secret <- dropbox_secret }, @@ -384,7 +386,7 @@ DropboxRepository <- R6::R6Class( }, prepare = function(...) { - self$authenticate() + # self$authenticate() if (!self$dropbox_exists(self$root_dir)) { stop("directory '", self$root_dir, "' not found in Dropbox, ", "you must create this manually") @@ -392,7 +394,10 @@ DropboxRepository <- R6::R6Class( for (dir in self$dirs) { full_path <- file.path(self$root_dir, dir) if (!self$dropbox_exists(full_path)) { - rdrop2::drop_create(full_path) + rdrop2::drop_create( + full_path, dtoken = self$token, + dtoken = self$token + ) } } }, @@ -405,9 +410,9 @@ DropboxRepository <- R6::R6Class( }, dropbox_exists = function(path) { - self$authenticate() + # self$authenticate() tryCatch( - rdrop2::drop_exists(path), + rdrop2::drop_exists(path, dtoken = self$token), error = function(e) { if (e$message == "Conflict (HTTP 409).") FALSE else stop(e) } @@ -440,22 +445,26 @@ DropboxRepository <- R6::R6Class( }, deposit_file = function(local_file, dir, key, ...) { - self$authenticate() + # self$authenticate() tmp_dir <- tempfile("dir") R.utils::mkdirs(tmp_dir) new_local_path <- file.path(tmp_dir, key) file.copy(local_file, new_local_path) - rdrop2::drop_upload(new_local_path, - file.path(self$root_dir, dir), - autorename = FALSE) + rdrop2::drop_upload( + new_local_path, + file.path(self$root_dir, dir), + autorename = FALSE, + dtoken = self$token + ) }, get_file = function(dir, key, target_path, ...) { - self$authenticate() + # self$authenticate() rdrop2::drop_download( self$path_in_repository(dir, key), target_path, - overwrite = TRUE + overwrite = TRUE, + dtoken = self$token ) }, @@ -472,7 +481,10 @@ DropboxRepository <- R6::R6Class( }, list_files = function(dir, ...) { - x <- rdrop2::drop_dir(self$path_in_repository(dir)) + x <- rdrop2::drop_dir( + self$path_in_repository(dir), + dtoken = self$token + ) if (nrow(x) == 0) { character() } else { @@ -481,17 +493,26 @@ DropboxRepository <- R6::R6Class( }, delete_file = function(dir, key) { - self$authenticate() - rdrop2::drop_delete(self$path_in_repository(dir, key)) + # self$authenticate() + rdrop2::drop_delete( + self$path_in_repository(dir, key), + dtoken = self$token + ) }, delete_folder = function(dir) { - self$authenticate() - rdrop2::drop_delete(self$path_in_repository(dir)) + # self$authenticate() + rdrop2::drop_delete( + self$path_in_repository(dir), + dtoken = self$token + ) }, create_folder = function(dir, ...) { - rdrop2::drop_create(self$path_in_repository(dir)) + rdrop2::drop_create( + self$path_in_repository(dir), + dtoken = self$token + ) } ) ) From 2a76dac3d13d38b2d8180bc3964d575c10ea9594 Mon Sep 17 00:00:00 2001 From: Peter Harrison Date: Tue, 13 Jul 2021 22:07:12 +0200 Subject: [PATCH 17/17] Bugfix in Dropbox repository initialisation --- R/make-test.R | 1 + R/results.R | 13 ++++++++++++- 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/R/make-test.R b/R/make-test.R index 3de3b641..39e90c80 100644 --- a/R/make-test.R +++ b/R/make-test.R @@ -29,6 +29,7 @@ make_test <- function(elts, opt = demo_options(), server = server(elts = elts, opt = opt, custom_admin_panel = custom_admin_panel)) app$opt <- opt + app$opt$repository$check() app } diff --git a/R/results.R b/R/results.R index 61665d2a..cef66658 100644 --- a/R/results.R +++ b/R/results.R @@ -374,7 +374,18 @@ DropboxRepository <- R6::R6Class( super$initialize(is_slow = TRUE) self$root_dir <- root_dir self$token_path <- token_path + + if (!file.exists(self$token_path)) + stop("Couldn't find any tokens at ", self$token_path, ".") + self$token <- readRDS(self$token_path) + + # It should work just passing the token as the dtoken argument + # to the rdrop2 calls. However there is a bug in drop_create + # where dtoken is allowed. We therefore use drop_auth to + # overcome this. + rdrop2::drop_auth(rdstoken = self$token_path) + self$dropbox_key <- dropbox_key self$dropbox_secret <- dropbox_secret }, @@ -395,7 +406,7 @@ DropboxRepository <- R6::R6Class( full_path <- file.path(self$root_dir, dir) if (!self$dropbox_exists(full_path)) { rdrop2::drop_create( - full_path, dtoken = self$token, + full_path, dtoken = self$token ) }