if (getRversion() >= "2.15.1") utils::globalVariables(c(".")) # allow dplyr, maggritr
.data = rlang::.data
#' Connect to formr
#'
#' Connects to formr using your normal login and the httr library
#' which supports persistent session cookies. Calling this function will persist
#' the specified host (by default https://formr.org) in further formr_ function
#' calls. You can change this by calling [formr_last_host()]
#'
#' @param email your registered email address
#' @param password your password
#' @param host defaults to [formr_last_host()], which defaults to https://formr.org
#' @param keyring a shorthand for the account you're using
#' @export
#' @examples
#' \dontrun{
#' formr_connect(keyring = "formr_diary_study_account" )
#' }
formr_connect <- function(email = NULL, password = NULL, host = formr_last_host(), keyring = NULL) {
formr_last_host(host) # Store the host
if (!missing(keyring) && !is.null(keyring)) {
if (is.null(email) &&
length(keyring::key_list(keyring)[["username"]]) %in% 1:2) {
usernames <- keyring::key_list(keyring)[["username"]]
email <- usernames[!grepl(" 2FA", usernames)][[1]]
}
password <- keyring::key_get(keyring, username = email)
} else {
warning("Please use the keyring package via the formr_store_keys() function instead of specifying email and password in plaintext.")
if (missing(email) || is.null(email))
email <- readline("Enter your email: ")
if (missing(password) || is.null(password))
password <- readline("Enter your password: ")
}
resp <- httr::POST(paste0(host, "/admin/account/login"), body = list(email = email,
password = password))
text <- httr::content(resp, encoding = "utf8", as = "text")
if (grepl("Two Factor Authentication Verification", text)) {
# Try to get 2FA secret from keyring if available
twofa_secret <- NULL
if (!is.null(keyring)) {
tryCatch({
twofa_secret <- keyring::key_get(keyring, username = paste0(email, " 2FA"))
}, error = function(e) {
# Key not found, will prompt for code instead
})
}
if (!is.null(twofa_secret) && twofa_secret != "") {
code <- otp::TOTP$new(twofa_secret)$now()
} else {
code <- readline("Enter 2FA code: ")
}
resp <- httr::POST(paste0(host, "/admin/account/two-factor"),
body = list(email = email,
password = password,
`2facode` = code))
text <- httr::content(resp, encoding = "utf8", as = "text")
}
if (resp$status_code == 200 && grepl("Success!", text, fixed = TRUE)) {
invisible(TRUE)
} else if (grepl("Logout", text, fixed = TRUE)) {
warning("Already logged in.")
} else if (grepl("alert-danger", text, fixed = TRUE)) {
stop("Incorrect credentials.")
} else {
stop("Could not login for unknown reason.")
}
}
#' Get the last specified host
#'
#' This function returns the default or the last specified host if called without an argument.
#' It changes the host when called with an argument.
#'
#' @param host defaults to https://formr.org
#'
#' @return the last specified host
#' @export
#' @examples
#' formr_last_host("https://formr.org")
#' formr_last_host()
formr_last_host <- local({
last_host <- "https://formr.org"
function(host = NULL) {
if (!is.null(host)) {
if (!grepl("^https?://", host)) {
stop("Host must start with 'https://' or 'http://'.")
}
if (grepl("/$", host)) {
host <- sub("/$", "", host)
}
last_host <<- host
}
return(last_host)
}
})
#' Store keys in keyring
#'
#' Store keys in the system keyring/keychain instead of plaintext.
#' @param account_name a shorthand for the account you're using
#' @param email email address for the account, will be prompted if omitted
#' @param secret_2fa a 2FA secret, optional, set to NULL if you want to
#' be prompted for it when logging in, set to "" if you don't have 2FA
#' @export
#' @examples
#' \dontrun{
#' formr_store_keys("formr_diary_study_account")
#' }
formr_store_keys = function(account_name, email = NULL, secret_2fa = NULL) {
if(is.null(email)) {
email = readline("Enter your email: ")
}
keyring::key_set(service = account_name,
username = email)
if(!is.null(secret_2fa)) {
keyring::key_set_with_value(service = account_name, username = paste(email, "2FA"),
password = secret_2fa)
} else {
keyring::key_set(service = account_name,
username = paste(email, "2FA"),
prompt = "2FA secret if applicable")
}
}
#' Disconnect from formr
#'
#' Disconnects from formr if connected.
#'
#' @param host defaults to [formr_last_host()], which defaults to https://formr.org
#' @export
#' @examples
#' \dontrun{
#' formr_disconnect()
#' }
formr_disconnect = function(host = formr_last_host()) {
resp = httr::GET(paste0(host, "/admin/account/logout"))
text = httr::content(resp, encoding = "utf8", as = "text")
if (resp$status_code == 200 && grepl("logged out", text,
fixed = T))
invisible(TRUE) else warning("You weren't logged in.")
}
#' Download run structure from formr
#'
#' After connecting to formr using [formr_connect()]
#' you can download the study/run structure using this command.
#'
#' @param run_name case-sensitive name of a run your account owns
#' @param host defaults to [formr_last_host()], which defaults to https://formr.org
#' @export
#' @examples
#' \dontrun{
#' formr_run_structure(run_name = 'training_diary' )
#' }
formr_run_structure = function(run_name, host = formr_last_host()) {
resp = httr::GET(paste0(host, "/admin/run/", run_name, "/export_run_structure?format=json"))
if (resp$status_code == 200)
results = jsonlite::fromJSON(httr::content(resp, encoding = "utf8",
as = "text"), simplifyVector = FALSE) else stop("This run does not exist or isn't yours.")
results
}
#' Backup a study
#'
#' Backup a study by downloading all surveys, results, item displays, run shuffle, user overview and user details. This function will save the data in a folder named after the study.
#'
#' @param study_name case-sensitive name of a study your account owns
#' @param save_path path to save the study data, defaults to the study name
#' @param host defaults to [formr_last_host()], which defaults to https://formr.org
#' @param overwrite should existing files be overwritten?
#' @export
#' @examples
#' \dontrun{
#' formr_backup_study(study_name = 'training_diary' )
#' }
formr_backup_study = function(study_name, save_path = study_name, host = formr_last_host(), overwrite = FALSE) {
run_structure = formr_run_structure(study_name, host)
if(file.exists(save_path) && !overwrite) {
stop("Save path already exists. Set overwrite = TRUE to overwrite.")
}
# create a folder for the study
dir.create(save_path, showWarnings = FALSE)
# save JSON copy of run structure
jsonlite::write_json(run_structure,
path = paste0(save_path, "/run_structure.json"),
pretty = TRUE)
# Loop through run structure to find all surveys
surveys = list()
for (unit in run_structure$units) {
if (unit$type == "Survey") {
surveys[[unit$survey_data$name]] = unit
}
}
survey_names = names(surveys)
formr_backup_surveys(survey_names, surveys, save_path, overwrite, host)
# Download run shuffle, if exists
if ("shuffle" %in% names(run_structure)) {
shuffle = formr_shuffled(study_name, host)
jsonlite::write_json(shuffle,
path = paste0(save_path, "/run_shuffle.json"),
pretty = TRUE)
}
# Download run user overview
user_overview = formr_user_overview(study_name, host)
jsonlite::write_json(user_overview,
path = paste0(save_path, "/run_user_overview.json"),
pretty = TRUE)
# Download run user details
user_detail = formr_user_detail(study_name, host)
jsonlite::write_json(user_detail,
path = paste0(save_path, "/run_user_detail.json"),
pretty = TRUE)
}
#' Backup surveys
#'
#' Backup surveys by downloading item lists, results, item displays and file lists.
#'
#' @param survey_names case-sensitive names of surveys your account owns
#' @param surveys a list of survey data (from a run structure), optional
#' @param overwrite should existing files be overwritten?
#' @param save_path path to save the study data, defaults to the study name
#' @param host defaults to [formr_last_host()], which defaults to https://formr.org
#' @export
#' @examples
#' \dontrun{
#' formr_backup_surveys(survey_names = 'training_diary', save_path = 'surveys')
#' }
formr_backup_surveys = function(survey_names, surveys = list(), save_path = "./", overwrite = FALSE, host = formr_last_host()) {
# Store all survey item lists/settings
for (survey_name in survey_names) {
dir.create(paste0(save_path, "/", survey_name), showWarnings = FALSE)
item_list = surveys[[survey_name]]
if(is.null(item_list)) {
item_list = formr_items(survey_name, host)
}
jsonlite::write_json(item_list,
path = paste0(save_path, "/", survey_name, "/item_list.json"),
pretty = TRUE)
google_sheet_link = surveys[[survey_name]]$survey_data$google_sheet
if(!is.null(google_sheet_link)) {
google_sheet_download_link = paste0(gsub("/edit", "", google_sheet_link), "/export?format=xlsx")
httr::GET(google_sheet_download_link,
httr::write_disk(paste0(save_path, "/", survey_name, "/google_sheet.xlsx"), overwrite = overwrite))
}
results = formr_raw_results(survey_name, host)
jsonlite::write_json(results,
path = paste0(save_path, "/", survey_name, "/results.json"),
pretty = TRUE)
item_displays = formr_item_displays(survey_name, host)
jsonlite::write_json(item_displays,
path = paste0(save_path, "/", survey_name, "/item_displays.json"),
pretty = TRUE)
file_list = formr_backup_files(survey_name, overwrite, paste0(save_path, "/", survey_name, "/user_uploaded_files"), host)
jsonlite::write_json(file_list,
path = paste0(save_path, "/", survey_name, "/file_list.json"),
pretty = TRUE)
}
}
#' Download processed, aggregated results from formr
#'
#' After connecting to formr using [formr_connect()]
#' you can download data and process it. This approach calls the following functions in the right sequence: [formr_raw_results()]
#' [formr_items()], [formr_item_displays()] and [formr_post_process_results()]. So, results are downloaded, metadata on items (labels etc.) is
#' added, normal and missing values are labelled. In the end, items like bfi_extra_3R are reversed in place (maintaining labels but changing underlying numbers),
#' and scales are aggregated (bfi_extra_1, bfi_extra_2, bfi_extra_3R become bfi_extra)
#'
#' @param survey_name case-sensitive name of a survey your account owns
#' @param host defaults to [formr_last_host()], which defaults to https://formr.org
#' @param ... passed to [formr_post_process_results()]
#' @export
#' @examples
#' \dontrun{
#' formr_results(survey_name = 'training_diary' )
#' }
formr_results = function(survey_name, host = formr_last_host(), ...) {
results = formr_raw_results(survey_name, host)
item_list = formr_items(survey_name, host)
item_displays = formr_item_displays(survey_name, host)
formr_post_process_results(results = results, item_list = item_list, item_displays = item_displays, ...)
}
#' Processed, aggregated results
#'
#' This function chains [formr_recognise()] and [formr_aggregate()]
#' in sequence. Useful if you want to post-process raw results before aggregating etc.
#'
#' @param item_list an item_list, defaults to NULL
#' @param results survey results
#' @param compute_alphas passed to formr_aggregate, defaults to TRUE
#' @param fallback_max passed to formr_reverse, defaults to 5
#' @param plot_likert passed to formr_aggregate, defaults to TRUE
#' @param quiet passed to formr_aggregate, defaults to FALSE
#' @param item_displays an item display table, necessary to tag missings
#' @param tag_missings should missings that result from an item not being shown be distinguished from missings due to skipped questions?
#' @param remove_test_sessions by default, formr removes results resulting from test session (animal names and null session codes)
#' @export
#' @examples
#' results = jsonlite::fromJSON(txt =
#' system.file('extdata/BFI_post.json', package = 'formr', mustWork = TRUE))
#' items = formr_items(path =
#' system.file('extdata/BFI_post_items.json', package = 'formr', mustWork = TRUE))
#' item_displays = jsonlite::fromJSON(
#' system.file('extdata/BFI_post_itemdisplay.json', package = 'formr', mustWork = TRUE))
#' processed_results = formr_post_process_results(items, results, item_displays = item_displays,
#' compute_alphas = FALSE, plot_likert = FALSE)
formr_post_process_results = function(item_list = NULL, results,
compute_alphas = FALSE, fallback_max = 5, plot_likert = FALSE, quiet = FALSE, item_displays = NULL, tag_missings = !is.null(item_displays), remove_test_sessions = TRUE) {
if (remove_test_sessions) {
if (exists("session", results)) {
sessions_before <- unique(results$session[!is.na(results$session)])
results = results[ !is.na(results$session) & !stringr::str_detect(results$session, "XXX"), ]
sessions_after <- unique(results$session)
if(length(sessions_after) < length(sessions_before)) {
message("These users were dropped as likely test users. This is a heuristic. ",
"If they don't have an animal name in their ID, they might not be test users.",
paste(setdiff(sessions_before, sessions_after), collapse = ", "))
} else {
message("No test users detected.")
}
} else {
warning("Cannot remove test sessions in results table, because session variable is missing (potentially this is an unlinked survey).")
}
if (!is.null(item_displays) && exists("session", item_displays)) {
item_displays = item_displays[ !is.na(item_displays$session) & !stringr::str_detect(item_displays$session, "XXX"), ]
} else if (!is.null(item_displays) ) {
warning("Cannot remove test sessions from item display table, because session variable is missing (potentially, this is an unlinked survey).")
}
}
results = formr_recognise(item_list = item_list, results = results)
results = formr_aggregate(item_list = item_list, results = results,
compute_alphas = compute_alphas, fallback_max = fallback_max,
plot_likert = plot_likert, quiet = quiet)
# todo: do this before formr_recognise?
results <- formr_label_missings(results, item_displays,
tag_missings = tag_missings)
results
}
formr_label_missings <- function(results, item_displays, tag_missings = TRUE) {
if (tag_missings & !is.null(item_displays)) {
missing_labels = c("Missing for unknown reason" = haven::tagged_na("o"),
"Item was not shown to this user." = haven::tagged_na("h"),
"User skipped this item." = haven::tagged_na("i"),
"Item was never rendered for this user." = haven::tagged_na("s"),
"Weird missing." = haven::tagged_na("w"))
missing_map <- item_displays %>%
dplyr::mutate(hidden = dplyr::if_else(.data$hidden == 1, 1,
dplyr::if_else(is.na(.data$shown), -1, 0), -1)) %>%
dplyr::select("item_name", "hidden", "unit_session_id", "session") %>%
dplyr::filter(!duplicated(cbind(.data$session, .data$unit_session_id, .data$item_name))) %>%
tidyr::spread("item_name", "hidden", fill = -2) %>%
dplyr::arrange("session", "unit_session_id")
results_with_attrs <- results
results <- results %>%
dplyr::arrange("session", "created") # sort in the same manner
if (nrow(missing_map) != nrow(results)) {
warning("Unequal number of rows between item display and results.",
" Missings not labelled.")
} else {
# make tagged NAs (works only for numeric variables)
for (i in seq_along(names(results))) {
var = names(results)[i]
if (var %in% names(missing_map)) {
attrs <- attributes(results[[var]])
if (is.numeric(results[[var]]) || is.factor(results[[i]])) {
results[[var]][is.na(results[[var]])] = haven::tagged_na("o")
results[[var]][is.na(results[[var]]) & missing_map[[var]] == 1] = haven::tagged_na("h")
results[[var]][is.na(results[[var]]) & missing_map[[var]] == 0] = haven::tagged_na("i")
results[[var]][is.na(results[[var]]) & missing_map[[var]] == -1] = haven::tagged_na("s")
results[[var]][is.na(results[[var]]) & missing_map[[var]] == -2] = haven::tagged_na("w")
value_labels = attributes(results[[var]])$labels
missing_kinds = stats::na.omit(unique(haven::na_tag(results[[var]])))
value_labels <- c(value_labels, missing_labels[ haven::na_tag(missing_labels) %in% missing_kinds])
if (length(value_labels) && !is.null(names(value_labels))) {
results[[var]] = haven::labelled(results[[var]],
label = attributes(results[[var]])[["label"]],
labels = value_labels)
attrs$labels <- value_labels
}
}
}
}
}
results <- rescue_attributes(results, results_with_attrs)
}
results
}
#' Download data from formr
#'
#' After connecting to formr using [formr_connect()]
#' you can download data using this command.
#'
#' @param survey_name case-sensitive name of a survey your account owns
#' @param host defaults to [formr_last_host()], which defaults to https://formr.org
#' @export
#' @examples
#' \dontrun{
#' formr_raw_results(survey_name = 'training_diary' )
#' }
formr_raw_results = function(survey_name, host = formr_last_host()) {
resp = httr::GET(paste0(host, "/admin/survey/", survey_name,
"/export_results?format=json"))
if (resp$status_code == 200)
results = jsonlite::fromJSON(httr::content(resp, encoding = "utf8",
as = "text")) else stop("This survey does not exist or isn't yours.")
results
}
#' Download items from formr
#'
#' After connecting to formr using [formr_connect()]
#' you can download items using this command. One of survey_name or path has to be specified, if both are specified, survey_name is preferred.
#'
#' @param survey_name case-sensitive name of a survey your account owns
#' @param host defaults to [formr_last_host()], which defaults to https://formr.org
#' @param path path to local JSON copy of the item table
#' @export
#' @examples
#' \dontrun{
#' formr_connect(email = 'you@@example.net', password = 'zebrafinch' )
#' formr_items(survey_name = 'training_diary' )
#' }
#' formr_items(path =
#' system.file('extdata/gods_example_items.json', package = 'formr', mustWork = TRUE))[1:2]
formr_items = function(survey_name = NULL, host = formr_last_host(),
path = NULL) {
item_list = NULL
if (!is.null(survey_name)) {
resp = httr::GET(paste0(host, "/admin/survey/", survey_name,
"/export_item_table?format=json"))
if (resp$status_code == 200) {
item_list = jsonlite::fromJSON(txt = httr::content(resp,
encoding = "utf8", as = "text"), simplifyDataFrame = FALSE)
} else {
stop("This survey does not exist.")
}
} else {
item_list = jsonlite::fromJSON(txt = path, simplifyDataFrame = FALSE)
}
if (!is.null(item_list)) {
if (!is.null(item_list[["items"]])) {
item_list = item_list[["items"]]
}
for (i in seq_along(item_list)) {
if (item_list[[i]]$type == "rating_button") {
from = 1
to = 5
by = 1
if (!is.null(item_list[[i]]$type_options)) {
# has the format 1,6 or 1,6,1 + possibly name of choice list
# allow for 1, 6, 1 and 1,6,1
item_list[[i]]$type_options <-
stringr::str_replace_all(item_list[[i]]$type_options,
",\\s+", ",")
# truncate choice list
sequence = stringr::str_split(item_list[[i]]$type_options,
"\\s", n = 2)[[1]][1]
sequence = stringr::str_split(sequence, ",")[[1]]
if (length(sequence) == 3) {
from = as.numeric(sequence[1])
to = as.numeric(sequence[2])
by = as.numeric(sequence[3])
} else if (length(sequence) == 2) {
from = as.numeric(sequence[1])
to = as.numeric(sequence[2])
} else if (length(sequence) == 1) {
to = as.numeric(sequence[1])
}
}
sequence = seq(from, to, ifelse(to >= from, by,
ifelse( by > 0, -1 * by, by)))
names(sequence) = sequence
if (length(item_list[[i]]$choices) <= 2) {
choices = item_list[[i]]$choices
from_pos <- which(sequence == from)
to_pos <- which(sequence == to)
sequence[ from_pos ] = paste0(sequence[ from_pos ], ": ", choices[[1]])
sequence[ to_pos ] = paste0(sequence[ to_pos ], ": ", choices[[length(choices)]])
} else {
for (c in seq_along(item_list[[i]]$choices)) {
sequence[ names(item_list[[i]]$choices)[c] == sequence ] = paste0(names(item_list[[i]]$choices)[c], ": ", item_list[[i]]$choices[[c]])
}
}
item_list[[i]]$choices = as.list(sequence)
}
# named array fails, if names go from 0 to len-1
if (!is.null(item_list[[i]]$choices) && is.null(names(item_list[[i]]$choices))) {
names(item_list[[i]]$choices) = 0:(length(item_list[[i]]$choices)-1)
}
}
names(item_list) = sapply(item_list, function(item) { item$name })
class(item_list) = c("formr_item_list", class(item_list))
item_list
} else {
stop("Have to specify either path to exported JSON file or get item table from formr.")
}
}
#' Transform formr_item_list into a data.frame for ease of use
#'
#' This function just turns a formr_item_list into a data.frame. The reason, these lists don't come as data.frames as default is because the 'choices' are a list themselves. When transforming, the choice column contains a collapsed choice list, which may be less useful for some purposes.
#'
#' @param x a formr_item_list
#' @param row.names not used
#' @param ... not used
#'
#' @export
#' @examples
#' \dontrun{
#' formr_connect(email = 'you@@example.net', password = 'zebrafinch' )
#' as.data.frame(formr_items(survey_name = 'training_diary' ))
#' }
#' items = formr_items(path =
#' system.file('extdata/gods_example_items.json', package = 'formr', mustWork = TRUE))
#' items_df = as.data.frame(items)
#' items_df[1,]
as.data.frame.formr_item_list = function(x, row.names, ...) {
item_list = x
names(item_list) = NULL
for (i in seq_along(item_list)) {
item_list[[i]][sapply(item_list[[i]], is.null)] <- NA # NULLs are annoying when wanting to transform into a df
if (!is.null(item_list[[i]]$choices)) {
item_list[[i]]$choices = paste(paste0(names(item_list[[i]]$choices),
"=", item_list[[i]]$choices), collapse = ",")
} else {
# in some cases the choices column is missing
# item_list[[i]]['choices'] = list(NULL)
}
item_list[[i]]$type_options = as.character(item_list[[i]]$type_options)
item_list[[i]]$choice_list = as.character(item_list[[i]]$choice_list)
item_list[[i]]$value = as.character(item_list[[i]]$value)
item_list[[i]]$block_order = as.character(item_list[[i]]$block_order)
item_list[[i]]$showif = as.character(item_list[[i]]$showif)
item_list[[i]]$class = as.character(item_list[[i]]$class)
}
class(item_list) = setdiff(class(item_list), "formr_item_list")
item_list <- data.frame(dplyr::bind_rows(item_list))
item_list$index = 1:nrow(item_list)
item_list
}
#' Download detailed result timings and display counts from formr
#'
#' After connecting to formr using [formr_connect()]
#' you can download detailed times and display counts for each item using this command.
#'
#' @param survey_name case-sensitive name of a survey your account owns
#' @param host defaults to [formr_last_host()], which defaults to https://formr.org
#' @export
#' @examples
#' \dontrun{
#' formr_connect(email = 'you@@example.net', password = 'zebrafinch' )
#' formr_item_displays(survey_name = 'training_diary' )
#' }
formr_item_displays = function(survey_name, host = formr_last_host()) {
resp = httr::GET(paste0(host, "/admin/survey/", survey_name,
"/export_itemdisplay?format=json"))
if (resp$status_code == 200) {
results = jsonlite::fromJSON(httr::content(resp, encoding = "utf8",
as = "text"))
} else {
warning("This item display table for this survey could not be accessed.")
}
results
}
#' Download uploaded files from formr
#'
#' After connecting to formr using [formr_connect()]
#' you can download uploaded files using this command.
#'
#' @param survey_name case-sensitive name of a survey your account owns
#' @param host defaults to [formr_last_host()], which defaults to https://formr.org
#' @export
#' @examples
#' \dontrun{
#' formr_uploaded_files(survey_name = 'training_diary' )
#' }
formr_uploaded_files = function(survey_name, host = formr_last_host()) {
resp = httr::GET(paste0(host, "/admin/survey/", survey_name, "/export_uploaded_files?format=json"))
if (resp$status_code == 200) {
jsonlite::fromJSON(httr::content(resp, encoding = "utf8", as = "text"),
simplifyVector = FALSE)
} else {
warning("This survey does not exist or isn't yours.")
}
}
#' Backup uploaded files from formr
#'
#' After connecting to formr using [formr_connect()]
#' you can backup uploaded files using this command.
#'
#' @param survey_name case-sensitive name of a survey your account owns
#' @param overwrite should existing files be overwritten? defaults to FALSE
#' @param save_path defaults to the survey name
#' @param host defaults to [formr_last_host()], which defaults to https://formr.org
#' @export
#' @examples
#' \dontrun{
#' formr_backup_files(survey_name = 'training_diary' )
#' }
formr_backup_files = function(survey_name,
overwrite = FALSE,
save_path = paste0(survey_name, "/user_uploaded_files"),
host = formr_last_host()) {
file_list = formr_uploaded_files(survey_name, host)
if(length(file_list) > 0) {
dir.create(save_path, showWarnings = FALSE)
message("Downloading ", length(file_list), " user-uploaded files...")
i = 0
for (file in file_list) {
i = i + 1
local_file_name = basename(file$stored_path)
local_file_name = paste0(save_path, "/", local_file_name)
resp = httr::GET(file$stored_path)
if (resp$status_code != 200) {
warning("Could not download file ", local_file_name)
file_list[[i]]$downloaded <- FALSE
} else {
if(overwrite | !file.exists(local_file_name)) {
raw_content <- httr::content(resp, as = "raw")
writeBin(raw_content, local_file_name)
}
file_list[[i]]$downloaded <- TRUE
}
}
}
invisible(file_list)
}
#' Download random groups
#'
#' formr has a specific module for randomisation.
#' After connecting using [formr_connect()]
#' you can download the assigned random groups and merge them with your data.
#'
#' @param run_name case-sensitive name of the run in which you randomised participants
#' @param host defaults to [formr_last_host()], which defaults to https://formr.org
#' @export
#' @examples
#' \dontrun{
#' formr_connect(email = 'you@@example.net', password = 'zebrafinch' )
#' formr_shuffled(run_name = 'different_drills' )
#' }
formr_shuffled = function(run_name, host = formr_last_host()) {
resp = httr::GET(paste0(host, "/admin/run/", run_name, "/random_groups_export?format=json"))
if (resp$status_code == 200)
jsonlite::fromJSON(httr::content(resp, encoding = "utf8",
as = "text")) else stop("This run does not exist.")
}
#' Download random groups
#'
#' formr collects information about users' progression through the run
#' After connecting using [formr_connect()]
#' you can download a table showing where they are in the run.
#'
#' @param run_name case-sensitive name of the run in which you randomised participants
#' @param host defaults to [formr_last_host()], which defaults to https://formr.org
#' @export
#' @examples
#' \dontrun{
#' formr_connect(email = 'you@@example.net', password = 'zebrafinch' )
#' formr_user_overview(run_name = 'different_drills' )
#' }
formr_user_overview = function(run_name, host = formr_last_host()) {
resp = httr::GET(paste0(host, "/admin/run/", run_name, "/export_user_overview?format=json"))
if (resp$status_code == 200)
jsonlite::fromJSON(httr::content(resp, encoding = "utf8",
as = "text")) else stop("This run does not exist.")
}
#' Download random groups
#'
#' formr collects information about users' progression through the run
#' After connecting using [formr_connect()]
#' you can download a table showing their progression through the run.
#'
#' @param run_name case-sensitive name of the run in which you randomised participants
#' @param host defaults to [formr_last_host()], which defaults to https://formr.org
#' @export
#' @examples
#' \dontrun{
#' formr_connect(email = 'you@@example.net', password = 'zebrafinch' )
#' formr_user_detail(run_name = 'different_drills' )
#' }
formr_user_detail = function(run_name, host = formr_last_host()) {
resp = httr::GET(paste0(host, "/admin/run/", run_name, "/export_user_detail?format=json"))
if (resp$status_code == 200)
jsonlite::fromJSON(httr::content(resp, encoding = "utf8",
as = "text")) else stop("This run does not exist.")
}
#' Random date in range
#'
#' taken from Dirk Eddelbuettel's answer
#' here http://stackoverflow.com/a/14721124/263054
#'
#' @param N desired number of random dates
#' @param lower lower limit
#' @param upper upper limit
random_date_in_range <- function(N, lower = "2012/01/01", upper = "2012/12/31") {
st <- as.POSIXct(as.Date(lower))
et <- as.POSIXct(as.Date(upper))
dt <- as.numeric(difftime(et, st, units = "sec"))
ev <- sort(stats::runif(N, 0, dt))
rt <- st + ev
rt
}
#' Recognise data types based on item table
#'
#' Once you've retrieved an item table using [formr_items()] you can use this
#' function to correctly type your variables based on the item table (e.g. formr free text types will be character, but select_add_one will be factor, dates are also typed as Date, datetimes as POSIXct).
#'
#'
#' @param survey_name case-sensitive name of a survey your account owns
#' @param item_list an item_list, will be auto-retrieved based on survey_name if omitted
#' @param results survey results, will be auto-retrieved based on survey_name if omitted
#' @param host defaults to [formr_last_host()], which defaults to https://formr.org
#' @export
#' @examples
#' results = jsonlite::fromJSON(txt =
#' system.file('extdata/gods_example_results.json', package = 'formr', mustWork = TRUE))
#' class(results$created)
#' items = formr_items(path =
#' system.file('extdata/gods_example_items.json', package = 'formr', mustWork = TRUE))
#' results = formr_recognise(item_list = items, results = results)
#' class(results$created)
formr_recognise = function(survey_name = NULL, item_list = formr_items(survey_name,
host = host), results = formr_raw_results(survey_name, host = host),
host = formr_last_host()) {
# from https://stackoverflow.com/questions/17397340/type-conversion-in-r-based-on-type-of-another-variable
# results fields that appear in all formr_results but aren't
# custom items
if (exists("created", where = results)) {
results$created = as.POSIXct(results$created)
attributes(results$created)$label = "user first opened survey"
}
if (exists("modified", where = results)) {
results$modified = as.POSIXct(results$modified)
attributes(results$modified)$label = "user last edited survey"
}
if (exists("ended", where = results)) {
results$ended = as.POSIXct(results$ended)
attributes(results$ended)$label = "user finished survey"
}
if (is.null(item_list)) {
warning("No item list provided, using type.convert as a fallback.")
char_vars = sapply(results, is.character)
if (length(char_vars) > 0) { # for special case: no data
type.convert = utils::type.convert
results[, char_vars] = dplyr::mutate_all(results[, char_vars, drop = F],
dplyr::funs(type.convert(., as.is = TRUE)))
}
} else {
items_with_result_columns = names(results)
for (i in seq_along(item_list)) {
item = item_list[[i]]
if (! item$name %in% items_with_result_columns) {
next
}
if (length(item$choices)) {
# choice-based items
results[, item$name] = utils::type.convert(as.character(results[,
item$name]), as.is = T)
if (all(is.na(results[[ item$name ]])) || is.integer(results[[ item$name ]])) {
# prevent logical types, for which labelled doesn't work,
# and prevent integers for which we can't have tagged NAs
results[, item$name] = as.numeric(results[, item$name])
}
choice_values = as_same_type_as(results[, item$name], names(item$choices))
choice_labels = item$choices
names(choice_values) = choice_labels
stopifnot(class(choice_values) == class(results[[ item$name ]]))
results[, item$name] = haven::labelled(results[, item$name], choice_values)
} else if (item$type %in% c("text", "textarea",
"email", "letters")) {
results[, item$name] = as.character(results[,
item$name])
} else if (item$type %in% c("datetime")) {
results[, item$name] = as.POSIXct(results[,
item$name])
} else if (item$type %in% c("date")) {
results[, item$name] = as.Date(results[, item$name],
format = "%Y-%m-%d")
} else if (item$type %in% c("time")) {
# results[, item$name ] = (results[, item$name ])
} else if (item$type %in% c("number", "range",
"range_list")) {
results[, item$name] = as.numeric(results[,
item$name])
}
attributes(results[[ item$name ]])$label = item$label
attributes(results[[ item$name ]])$item = item
}
}
results
results
}
#' Simulate data based on item table
#'
#' Once you've retrieved an item table using [formr_items()] you can use this
#' function to sample data from the possible choices.
#' At the moment random data is only generated for choice-type
#' items and numeric ones, as these are most likely to enter data analysis.
#' Does not yet handle dates, times, text, locations, colors
#'
#'
#' @param item_list the result of a call to [formr_connect()]
#' @param n defaults to 300
#' @export
#' @examples
#' \dontrun{
#' formr_connect(email = 'you@@example.net', password = 'zebrafinch' )
#' sim = formr_simulate_from_items(item_list = formr_items('training_diary'), n = 100)
#' summary(lm(pushups ~ pullups, data = sim))
#' }
#' items = formr_items(path =
#' system.file('extdata/gods_example_items.json', package = 'formr', mustWork = TRUE))
#' fakedata = formr_simulate_from_items(items, n = 20)
#' fakedata[1:2,]
formr_simulate_from_items = function(item_list, n = 300) {
sim = data.frame(id = 1:n)
sim$created = random_date_in_range(n, Sys.time() - 10000000,
Sys.time())
sim$modified = sim$ended = sim$created + lubridate::dseconds(stats::rpois(n,
lambda = length(item_list) * 20) # assume 20 seconds per item
)
for (i in seq_along(item_list)) {
item = item_list[[i]]
if (item$type %in% c("note", "mc_heading", "submit", "block")) {
next
} else if (length(item$choices)) {
# choice-based items
sample_from = utils::type.convert(names(item$choices), as.is = F)
sim[, item$name] = sample(sample_from, size = n,
replace = T)
} else if (length(item$type_options) && stringr::str_detect(item$type_options,
"^[0-9.,]+$")) {
limits = as.numeric(stringr::str_split(item$type_options,
pattern = stringr::fixed(","))[[1]])
if (length(limits) == 3) {
by = limits[3]
sample_from = seq(from = limits[1], to = limits[2],
by = ifelse( by < 0, -1 * by, by))
sim[, item$name] = sample(sample_from, size = n,
replace = T)
}
}
}
sim
}
#' Upload new item table
#'
#' To automatically create surveys using formr, you can upload survey item
#' tables from R. Only file uploads are available. The file name determines
#' the survey name. Updating existing surveys is not implemented and not
#' recommended (because of the sanity checks we require to prevent data
#' deletion).
#'
#'
#' @param survey_file_path the path to an item table in csv/json/xlsx etc.
#' @param host defaults to [formr_last_host()], which defaults to https://formr.org
#' @export
#' @examples
#' \dontrun{
#' formr_connect(email = 'you@@example.net', password = 'zebrafinch' )
#' items <- system.file('extdata/gods_example_items.json', package = 'formr',
#' mustWork = TRUE)
#' formr_upload_items(items)
#' }
formr_upload_items = function(survey_file_path, host = formr_last_host()) {
resp <- httr::POST(
url = paste0(host, "/admin/survey/add_survey"),
body = list(uploaded = httr::upload_file(survey_file_path))
)
text = httr::content(resp, encoding = "utf8", as = "text")
if (resp$status_code == 200 && grepl("Success!",text,fixed = T)) {
invisible(TRUE)
} else if (grepl("You have to select an item table file",text,fixed = T)) {
stop("You have to select an item table file here.")
} else if (grepl("You need to login",text,fixed = T)) {
stop("You need to login to access the admin section.")
} else if (grepl("is already taken",text,fixed = T)) {
stop("The survey name is already taken.", survey_file_path)
} else {
stop("Could not upload for unknown reasons. Try manually.")
}
}
#' Reverse items based on item table or a fallback_max
#'
#' Example: If your data contains Extraversion_1, Extraversion_2R and Extraversion_3, there will be two new variables in the result: Extraversion_2 (reversed to align with _1 and _2) and Extraversion, the mean score of the three. If you supply an item table, the maximum possible answer to the item will be used to reverse it. If you don't, the maximum actually given answer or the fallback_max argument will be used to reverse it. It's faster to do this without an item table, but this can lead to problems, if you mis-specify the fallback max or the highest possible value does not occur in the data.
#'
#'
#' @param results survey results
#' @param item_list an item_list, defaults to NULL
#' @param fallback_max defaults to 5 - if the item_list is set to null, we will use this to reverse
#' @export
#' @examples
#' \dontrun{
#' formr_connect(email = 'you@@example.net', password = 'zebrafinch' )
#' icar_items = formr_items(survey_name='ICAR',host = 'http://localhost:8888/formr/')
#' # get some simulated data and aggregate it
#' sim_results = formr_simulate_from_items(icar_items)
#' reversed_items = formr_reverse(item_list = icar_items, results = sim_results)
#' }
#' results = jsonlite::fromJSON(txt =
#' system.file('extdata/gods_example_results.json', package = 'formr', mustWork = TRUE))
#' items = formr_items(path =
#' system.file('extdata/gods_example_items.json', package = 'formr', mustWork = TRUE))
#' formr_reverse(results, items)
formr_reverse = function(results, item_list = NULL, fallback_max = 5) {
# reverse items first we're playing dumb and don't have the
# item table to base our aggregation on?
item_names = names(results) # we use the item names of all items, including text, hoping that there is no false positive
if (is.null(item_list)) {
char_vars = sapply(results, is.character)
type.convert = utils::type.convert
results[, char_vars] = dplyr::mutate_all(results[, char_vars, drop = F],
dplyr::funs(type.convert(., as.is = TRUE)))
# get reversed items
reversed_items = item_names[stringr::str_detect(item_names,
"^(?i)[a-zA-Z0-9_]+?[0-9]+R$")]
if (length(reversed_items)) {
for (i in seq_along(reversed_items)) {
# reverse these items based on fallback_max, or if higher the
# item's own maximum
item_max <- max(results[, reversed_items[i]],
fallback_max, na.rm = T)
warning(reversed_items[i], " was reversed in place without value labels. You will need to keep track of its reversion status manually.")
results[[ reversed_items[i] ]] <- item_max + 1 - results[[ reversed_items[i] ]]
}
}
} else {
# if we have an item list we can do more
for (i in seq_along(item_list)) {
item = item_list[[i]]
if (!item$name %in% item_names) {
next
} else if (length(item$choices) && stringr::str_detect(item$name, "(?i)^([a-z0-9_]+?)[0-9]+R$")) {
if ( !is.numeric(results[[item$name]])) {
warning(item$name, " is not numeric and cannot be reversed.")
} else if (!haven::is.labelled(results[[ item$name ]])) {
warning(item$name, " is not of type labelled and cannot be reversed")
} else {
results[[item$name]] = reverse_labelled_values(results[[item$name]])
}
}
}
}
results
}
#' Aggregate data based on item table
#'
#' If you've retrieved an item table using [formr_items()] you can use this
#' function to aggregate your multiple choice items into mean scores.
#' If you do not have a item table (e.g. your data was not collected using formr, you don't want another HTTP request in a time-sensitive process).
#' Example: If your data contains Extraversion_1, Extraversion_2R and Extraversion_3, there will be two new variables in the result: Extraversion_2 (reversed to align with _1 and _2) and Extraversion, the mean score of the three.
#'
#'
#' @param survey_name case-sensitive name of a survey your account owns
#' @param item_list an item_list, will be auto-retrieved based on survey_name if omitted
#' @param results survey results, will be auto-retrieved based on survey_name if omitted
#' @param host defaults to [formr_last_host()], which defaults to https://formr.org
#' @param compute_alphas deprecated, functionality migrated to codebook package
#' @param fallback_max defaults to 5 - if the item_list is set to null, we will use this to reverse
#' @param plot_likert deprecated, functionality migrated to codebook package
#' @param quiet defaults to FALSE - If set to true, likert plots and reliability computations are not echoed.
#' @param aggregation_function defaults to rowMeans with na.rm = FALSE
#' @param ... passed to [psych::alpha()]
#' @export
#' @examples
#' results = jsonlite::fromJSON(txt =
#' system.file('extdata/gods_example_results.json', package = 'formr', mustWork = TRUE))
#' items = formr_items(path =
#' system.file('extdata/gods_example_items.json', package = 'formr', mustWork = TRUE))
#' results = formr_recognise(item_list = items, results = results)
#' agg = formr_aggregate(item_list = items, results = results,
#' compute_alphas = FALSE, plot_likert = FALSE)
#' agg[, c('religiousness', 'prefer')]
formr_aggregate = function(survey_name, item_list = formr_items(survey_name,
host = host), results = formr_raw_results(survey_name, host = host),
host = formr_last_host(), compute_alphas = FALSE, fallback_max = 5,
plot_likert = FALSE, quiet = FALSE, aggregation_function = rowMeans, ...) {
results = formr_reverse(results, item_list, fallback_max = fallback_max)
item_names = names(results) # update after reversing
if (!is.null(item_list)) {
if (!inherits(item_list, "formr_item_list")) {
stop("The item_list has to be a formr item list.")
}
item_list_df = as.data.frame(item_list)
item_list_df$scale = suppressWarnings(stringr::str_match(item_list_df$name,
"(?i)^([a-z0-9_]+?)_?[0-9]+R?$")[, 2]) # fit the pattern
likert_scales = item_list_df[item_list_df$type %in% c("mc",
"mc_button", "rating_button"), ]
} else {
plot_likert = FALSE
}
scale_stubs = stringr::str_match(item_names, "(?i)^([a-z0-9_]+?)_?[0-9]+R?$")[,
2] # fit the pattern
# if the scale name ends in an underscore, remove it
scales = unique(stats::na.omit(scale_stubs[duplicated(scale_stubs)])) # only those which occur more than once
# todo: should check whether they all share the same reply
# options (choices, type_options)
for (i in seq_along(scales)) {
save_scale = scales[i]
if (exists(save_scale, where = results)) {
warning(save_scale, ": Would have generated scale, but a variable of that name existed already.")
next
}
scale_item_names = item_names[which(scale_stubs == save_scale)]
numbers = as.numeric(stringr::str_match(scale_item_names,
"(?i)^[a-z0-9_]+?([0-9])+R?$")[, 2])
if (!setequal(intersect(scale_item_names, names(results)),
scale_item_names)) {
warning(save_scale, ": Some items were missing. ",
paste(setdiff(scale_item_names, names(results)),
collapse = " "))
next
}
if (length(scale_item_names) == 1) {
warning(save_scale, ": seems to consist of only a single item.")
next
}
if (!setequal(min(numbers):max(numbers), numbers)) {
warning(save_scale, ": Some items from the scale might be missing, the lowest item number was ",
min(numbers), " the highest was ", max(numbers),
" but we didn't see ", paste(setdiff(min(numbers):max(numbers),
numbers), collapse = " "))
next
}
if (!all(sapply(results[, scale_item_names], is.numeric))) {
warning(save_scale, ": One of the items in the scale is not numeric. The scale was not aggregated.")
next
}
if (!is.null(item_list)) {
choice_lists = item_list[likert_scales[which(likert_scales$scale ==
save_scale), "index"]]
choice_values = unique(lapply(choice_lists, FUN = function(x) {
names(x$choices)
}))
if (length(choice_values) != 1) {
warning(save_scale, ": The responses were saved with different possible values. Hence, the scale could not be aggregated. We saw ",
paste(sapply(choice_values, FUN = paste, collapse = ";"),
collapse = " & "))
next
}
choice_labels = unique(lapply(choice_lists, FUN = function(x) {
x$choices
}))
if (length(choice_labels) != 1) {
warning(save_scale, ": Was aggregated, but the response labels/item choices weren't identical across items, we saw ",
paste(sapply(choice_labels, FUN = paste, collapse = ";"),
collapse = " & "))
}
}
# actually aggregate scale
results[, save_scale] = aggregate_and_document_scale(results[, scale_item_names], fun = aggregation_function)
if (plot_likert) {
warning("The plot_likert functionality was moved to the ",
"codebook package.")
}
if (compute_alphas) {
warning("The compute_alphas functionality was moved to the ",
"codebook package.")
}
}
results
}
#' get item list from survey attributes
#'
#'
#'
#' @param survey survey with item_list attribute
#' @export
#' @examples
#' example(formr_post_process_results)
#' items(processed_results)[[1]]
items = function(survey) {
vars = names(survey)
item_list = list()
for (i in 1:length(vars)) {
att = attributes(survey[[ vars[i] ]])
if (!is.null(att) && exists("item", att) && !exists("scale", att)) {
if (att$item$name != vars[i]) {
att$item$name = vars[i]
}
item_list[[ vars[i] ]] = att$item
}
}
class(item_list) = c("formr_item_list", class(item_list))
item_list
}
#' get item from survey attribute
#'
#' Shortcut for attributes(survey$item_name)$item. Fails with a warning.
#'
#' @param survey survey with item_list attribute
#' @param item_name item name
#' @export
#' @examples
#' example(formr_post_process_results)
#' item(processed_results, "BFIK_extra_4")
item = function(survey, item_name) {
att = attributes(survey[[ item_name ]])
if (!is.null(att) && exists("item", att)) {
if (att$item$name != item_name) {
att$item$name = item_name
}
att$item
} else {
warning("No item information found for this one.")
NULL
}
}
#' switch choice values with labels
#'
#' formr display labels for multiple choice items, but stores their values. We assume you prefer to analyse the values (e.g. numeric values for Likert-type items, or English values for international surveys), but sometimes you may wish to switch this around.
#'
#' @param survey survey with item_list attribute
#' @param item_name item name
#' @export
#' @examples
#' example(formr_post_process_results)
#' table(processed_results$BFIK_extra_4)
#' table(choice_labels_for_values(processed_results, "BFIK_extra_4"))
choice_labels_for_values = function(survey, item_name) {
choices = item(survey, item_name)$choices
unname( unlist(choices)[ survey[[ item_name ]] ])
}
#' generates valid email cids
#'
#' can be used as an argument to [knitr::opts_knit]. If you attach the images properly, you can then send knit emails including plots. See the formr OpenCPU module on Github for a sample implementation.
#'
#' @param x image ID
#' @param ext extension, defaults to .png
#' @export
#' @examples
#' \dontrun{
#' library(knitr); library(formr)
#' opts_knit$set(upload.fun=formr::email_image)
#' }
email_image = function(x, ext = ".png") {
cid = gsub("[^a-zA-Z0-9]", "", substring(x, 8))
structure(paste0("cid:", cid, ext), link = x)
}
#' pass in the url to the RDS representation of a openCPU session object, get the object
#'
#' useful to programmatically access openCPU session object stored in character variables etc.
#'
#' @param session_url the session url, e.g. https://public.opencpu.org/ocpu/tmp/x02a93ec/R/.val/rds
#' @param local defaults to FALSE, if true, will assume that the session is not on another server, and do some not-very-smart substitution to load it via the file system instead of HTTP/HTTPS
#' @export
#' @examples
#' \dontrun{
#' get_opencpu_rds('https://public.opencpu.org/ocpu/tmp/x02a93ec/R/.val/rds')
#' }
get_opencpu_rds = function(session_url, local = TRUE) {
if (local) {
sessionenv <- new.env()
filepath = stringr::str_match(session_url, "/ocpu/tmp/([xa-f0-9]+)/([a-z0-9A-Z/.]+)")
sessionfile <- file.path("/tmp/ocpu-www-data/tmp_library",
filepath[, 2], ".RData")
if (file.exists(sessionfile)) {
load(sessionfile, envir = sessionenv)
desired_obj = stringr::str_sub(filepath[, 3], 3,
-5)
sessionenv[[desired_obj]]
}
} else {
readRDS(gzcon(curl::curl(session_url)))
}
}
# #' Export the study/run specification from formr
# #'
# #' After connecting to formr using [formr_connect()]
# #' you can download the study structure (or run). It is a JSON file.
# #'
# #' @param run_name case-sensitive name of a run your account owns
# #' @param host defaults to [formr_last_host()], which defaults to https://formr.org
# #' @param ... passed to [formr_post_process_results()]
# #' @export
# #' @examples
# #' \dontrun{
# #' formr_results(survey_name = 'training_diary' )
# #' }
#
# formr_run = function(run_name, host = formr_last_host(), ...) {
# resp = httr::GET(paste0(host, "/admin/run/", run_name, "/export_run?format=json"))
# if (resp$status_code == 200)
# jsonlite::fromJSON(httr::content(resp, encoding = "utf8",
# as = "text")) else stop("This run does not exist.")
#
# }
# # # # # ## testing with credentials formr_connect('', '')
# vorab = formr_raw_results('Vorab_Fragebogen1') vorab_items
# = formr_items('Vorab_Fragebogen1') vorab_item_displays =
# formr_item_displays('Vorab_Fragebogen1') vorab_processed =
# formr_recognise(item_list=vorab_items, results=vorab)
# vorab_sim =
# formr_simulate_from_items(item_list=vorab_items)
# vorab_sim_agg = formr_aggregate(item_list=vorab_items,
# results=vorab_sim, compute_alphas = T) vorab_proc_agg =
# formr_aggregate(item_list=vorab_items,
# results=vorab_processed,compute_alphas=T) # vorab_raw_agg =
# formr_aggregate(item_list=vorab_items,
# results=vorab,compute_alphas=T) vorab_raw_agg =
# formr_aggregate(item_list=NULL,
# results=vorab,compute_alphas=T) vorab_comp =
# formr_results('Vorab_Fragebogen1') options(warn=2)
# todo: better rmarkdown with proper linebreaks
# http://rmarkdown.rstudio.com/developer_custom_formats.html
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.