R/utils.R
In JasperHG90/qualtRics: Download Qualtrics Survey Data
Defines functions
qualtRicsResponseCodes
constructHeader
checkForWarnings
checkParams
appendRootUrl
createRawPayload
qualtricsApiRequest
downloadQualtricsExport
inferDataTypes
wrapper_mc
# Download qualtrics data into R
# Copyright (C) 2018 Jasper Ginn
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <http://www.gnu.org/licenses/>.
# Download qualtrics data into R
# Copyright (C) 2016 Jasper Ginn
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <http://www.gnu.org/licenses/>.
# utils.R contains helper functions for the qualtRics package. These functions should not be called directly by the user and should not be exported.
#' @importFrom magrittr '%>%'
#' @importFrom dplyr mutate
#' @importFrom rlang ':='
#' @importFrom dplyr select
#' @importFrom dplyr pull
#' @importFrom readr parse_factor
#' @importFrom sjlabelled get_label
#' @importFrom sjlabelled set_label
#' @noRd
# Checks responses against qualtrics response codes and returns error message.
#
# @param res response from httr::GET
# @param raw if TRUE, add 'raw' flag to httr::content() function.
#
# @author Jasper Ginn
qualtRicsResponseCodes <- function(res, raw=FALSE) {
# Check status code and raise error/warning
if(res$status_code == 200) {
if(raw) {
result <- httr::content(res, "raw")
} else {
result <- httr::content(res)
}
return(list(
"content" = result,
"OK" = TRUE
)
)
} else if(res$status_code == 401) {
stop("Qualtrics API raised an authentication (401) error - you may not have the\nrequired authorization. Please check your API key and root url.") # nolint
} else if(res$status_code == 400) {
stop("Qualtrics API raised a bad request (400) error - Please report this on\nhttps://github.com/ropensci/qualtRics/issues") # nolint
} else if(res$status_code == 404) {
stop("Qualtrics API complains that the requested resource cannot be found (404 error).\nPlease check if you are using the correct survey ID.") # nolint
} else if(res$status_code == 500) {
stop(paste0("Qualtrics API reports an internal server (500) error. Please contact\nQualtrics Support (https://www.qualtrics.com/contact/) and provide the instanceId and errorCode below.", "\n", # nolint
"\n",
"instanceId:", " ",
httr::content(res)$meta$error$instanceId,
"\n",
"errorCode: ",
httr::content(res)$meta$error$errorCode))
return(list(
"content" = httr::content(res),
"OK"= FALSE
))
} else if(res$status_code == 503) {
stop(paste0("Qualtrics API reports a temporary internal server (500) error. Please\ncontact Qualtrics Support (https://www.qualtrics.com/contact/) with the instanceId and\nerrorCode below or retry your query.", "\n", # nolint
"\n",
"instanceId:", " ", httr::content(res)$meta$error$instanceId,
"\n",
"errorCode: ", httr::content(res)$meta$error$errorCode))
return(list(
"content" = httr::content(res),
"OK"= FALSE
)
)
} else if(res$status_code == 413) {
stop("The request body was too large. This can also happen in cases where a\nmultipart/form-data request is malformed.") # nolint
} else if(res$status_code == 429) {
stop("You have reached the concurrent request limit.")
}
}
# Construct a header to send to qualtrics API
#
# @param API.TOKEN API token. Available in your qualtrics account (see: \url{https://api.qualtrics.com/docs/authentication})
#
# @seealso See \url{https://api.qualtrics.com/docs/root-url} for documentation on the Qualtrics API.
# @author Jasper Ginn
constructHeader <- function(API.TOKEN) {
# Construct and return
headers <- c(
'X-API-TOKEN' = API.TOKEN,
'Content-Type' = "application/json",
'Accept' = '*/*',
'accept-encoding' = 'gzip, deflate'
)
return(headers)
}
# Check if httr GET result contains a warning
#
# @param resp object returned by 'qualtRicsResponseCodes()'
#
# @author Jasper Ginn
checkForWarnings <- function(resp) {
# Raise warning if resp contains notice
if(!is.null(resp$content$meta)) {
if(!is.null(resp$content$meta$notice)) {
warning(resp$content$meta$notice)
}
}
NULL
}
# Check if parameters passed to functions are correct
#
# @param ... options passed to checkParams
#
# @author: Jasper Ginn
checkParams <- function(...) {
args <- list(...)
### root_url
assert_rootUrl_stored()
### API Token
assert_apikey_stored()
### Options
if(all(c("verbose", "convertVariables",
"useLocalTime", "useLabels") %in% names(args))) {
assert_options_logical(
args$verbose,
args$convertVariables,
args$useLocalTime,
args$useLabels
)
}
# Check if params are of the right type
if("startDate" %in% names(args)) {
if(!is.null(args$startDate)) {
assert_startDate_string(args$startDate)
}
}
if("endDate" %in% names(args)) {
if(!is.null(args$endDate)) assert_endDate_string(args$endDate)
}
if("lastResponseId" %in% names(args)) {
if(!is.null(args$lastResponseId)) {
assert_lastResponseId_string(args$lastResponseId)
}
}
# Check if saveDir exists
if("saveDir" %in% names(args)) {
if(!is.null(args$saveDir)) {
assert_saveDir_exists(args$saveDir)
}
}
# Check if seenUnansweredRecode is NULL or else a string
if("seenUnansweredRecode" %in% names(args)) {
if(!is.null(args$seenUnansweredRecode)) {
assert_seenUnansweredRecode_string(args$seenUnansweredRecode)
}
}
# Check if limit > 0
if("limit" %in% names(args)) {
if(!is.null(args$limit)) {
assert_limit_abovezero(args$limit)
}
}
# Check if includedQuestionIds is a string
if("includedQuestionIds" %in% names(args)) {
if(!is.null(args$includedQuestionIds)) {
assert_includedQuestionIds_string(args$includedQuestionIds)
}
}
}
# Append proper end points to create root url
#
# @param root_url Base url for your institution (see \url{https://api.qualtrics.com/docs/csv}. You need to supply this url. Your query will NOT work without it.).
#
# @return root url + appended end point
#
# @author: Jasper Ginn
appendRootUrl <- function(root_url, type = c("responseexports", 'surveys')) {
# match
type <- match.arg(type)
# Create root url
root_url <- paste0(root_url,
ifelse(substr(root_url, nchar(root_url),
nchar(root_url)) == "/",
paste0("API/v3/", type,"/"),
paste0("/API/v3/", type,"/")))
# Return
return(root_url)
}
# Create raw JSON payload to post response exports request
#
# @param: see getSurveys() and registerOptions() functions
#
# @return: returns json file with options to send to API
#
# @author: Jasper Ginn
createRawPayload <- function(surveyID,
useLabels=TRUE,
lastResponseId=NULL,
startDate=NULL,
endDate=NULL,
limit=NULL,
useLocalTime=FALSE,
seenUnansweredRecode=NULL,
includedQuestionIds = NULL) {
paste0(
'{"format": ', '"', 'csv', '"' ,
', "surveyId": ', '"', surveyID, '"',
ifelse(
is.null(lastResponseId),
"",
paste0(
', "lastResponseId": ',
'"',
lastResponseId,
'"')
) ,
ifelse(
is.null(startDate),
"",
paste0(
', "startDate": ',
'"',
paste0(startDate,"T00:00:00Z"),
'"')
) ,
ifelse(
is.null(endDate),
"",
paste0(
', "endDate": ',
'"',
paste0(endDate,"T00:00:00Z"),
'"')
) ,
ifelse(
is.null(seenUnansweredRecode),
"",
paste0(
', "seenUnansweredRecode": ',
'"',
seenUnansweredRecode,
'"')
),
ifelse(
!useLocalTime,
"",
paste0(
', "useLocalTime": ',
tolower(useLocalTime)
)
),
ifelse(
is.null(includedQuestionIds),
"",
paste0(
', "includedQuestionIds": ',
'[', paste0('"',includedQuestionIds, '"', collapse=", "), ']'
)
),
ifelse(
is.null(limit),
"",
paste0(
', "limit": ',
limit
)
),
', ',
'"useLabels": ', tolower(useLabels),
'}'
)
}
# Send httr requests to qualtrics API
#
# @param verb type of request to be sent (@seealso ?httr::VERB)
# @param url qualtrics endpoint url created by appendRootUrl() function
# @param body options created by createRawPayload() function
#
# @author: Jasper Ginn
qualtricsApiRequest <- function(verb = c("GET", "POST"), url = url,
body = NULL) {
# Match arg
verb <- match.arg(verb)
# Construct header
headers <- constructHeader(Sys.getenv("QUALTRICS_API_KEY"))
# Send request to qualtrics API
res <- httr::VERB(verb,
url = url,
httr::add_headers(
headers
),
body = body)
# Check if response type is OK
cnt <- qualtRicsResponseCodes(res)
# Check if OK
if(cnt$OK) {
# If notice occurs, raise warning
w <- checkForWarnings(cnt)
# return content
return(cnt$content)
}
}
# Download response export
#
# @param check_url url provided by qualtrics API that shows the download percentage completneness
# @param verbose see getSurvey()
#
# @author Jasper Ginn
downloadQualtricsExport <- function(check_url, verbose = FALSE) {
# Construct header
headers <- constructHeader(Sys.getenv("QUALTRICS_API_KEY"))
# Create a progress bar and monitor when export is ready
if(verbose) {
pbar <- utils::txtProgressBar(min=0,
max=100,
style = 3)
}
# While download is in progress
progress <- 0
while(progress < 100) {
# Get percentage complete
CU <- qualtricsApiRequest("GET", url = check_url)
progress <- CU$result$percentComplete
# Set progress
if(verbose) {
utils::setTxtProgressBar(pbar, progress)
}
}
# Kill progress bar
if(verbose) {
close(pbar)
}
# Download file
f <- tryCatch({
httr::GET(paste0(check_url, "/file"), httr::add_headers(headers))
}, error = function(e) {
# Retry if first attempt fails
httr::GET(paste0(check_url, "/file"), httr::add_headers(headers))
})
# If content is test request, then load temp file (this is purely for testing)
# httptest library didn't work the way it needed and somehow still called the API
# leading to errors
if(f$request$url == "t.qualtrics.com/API/v3/responseexports/T_123/file"){
if(f$request$headers["X-API-TOKEN"] == "1234") {
ct <- readRDS("files/file_getSurvey.rds")
f$content <- ct
}
}
#browser()
# Load raw zip file
ty <- qualtRicsResponseCodes(f, raw=TRUE)
# To zip file
tf <- paste0(tempdir(),
ifelse(substr(tempdir(),
nchar(tempdir()),
nchar(tempdir())) == "/",
"temp.zip",
"/temp.zip"))
# Write to temporary file
writeBin(ty$content, tf)
# Try to unzip
u <- tryCatch({
utils::unzip(tf, exdir = tempdir())
}, error = function(e) {
stop(paste0("Error extracting ",
"csv",
" from zip file. Please re-run your query."))
})
## There is an issue with survey names that contain special characters such as colons.
## Temporarily change all names to 'temp.csv'
# Rename file
temp_name <- paste0(tempdir(), "/temp.csv")
io <- file.rename(u, temp_name)
# Remove zipfile
p <- file.remove(tf)
# Return file location
return(temp_name)
}
# Set proper data types on survey data.
#
# @param data imported qualtrics survey
# @author Jasper Ginn
inferDataTypes <- function(data,
surveyID,
verbose = FALSE) {
# Download survey metadata
md <- metadata(surveyID, get=list("questions"=TRUE,
"metadata"=FALSE,
"responsecounts"=FALSE))[[1]]
# Check which questions are of type allowed
interest <- lapply(md, function(x) {
# Check if question type supported
type_supp <- ifelse(!is.null(x$questionType$type),
x$questionType$type %in%
getOption("QUALTRICS_INTERNAL_SETTINGS")$question_types_supported$type,
FALSE
) # This one is the most important so ifelse
selector_supp <- ifelse(!is.null(x$questionType$selector),
x$questionType$selector %in%
getOption("QUALTRICS_INTERNAL_SETTINGS")$question_types_supported$selector,
FALSE)
if(!is.null(x$questionType$subSelector)) {
subselector_supp <- x$questionType$subSelector %in%
getOption("QUALTRICS_INTERNAL_SETTINGS")$question_types_supported$subSelector
} else {
subselector_supp <- NA
}
# Evaluate
supported <- ifelse(all(selector_supp, type_supp), TRUE, FALSE)
# Check if question in survey
question_is_in_survey <- x$questionName %in% names(data)
# If both true, return element
if(supported & question_is_in_survey) {
return(x)
}
})
# Remove NULL values
interest <- interest[!vapply(interest, is.null, FALSE)]
# Get value names
mc <- vapply(interest, function(x) x$questionName, "character", USE.NAMES = FALSE)
# Unfortunately, something goes wrong with the labels so we need to do this
lab <- sjlabelled::get_label(data)
# For each, convert
#browser()
for(m in mc) {
data <- data %>%
wrapper_mc(m, interest)
}
# Return labels
data <- sjlabelled::set_label(data, lab)
# Check if warning given
if(Sys.getenv("QUALTRICS_WARNING_DATE_GIVEN") == "") {
warning("The 'StartDate', 'EndDate' and 'RecordedDate' variables were converted without passing\na specific timezone. If you like to set these timestamps to your own timezone, please\nvisit https://www.qualtrics.com/support/survey-platform/getting-started/managing-your-account/\n(under 'User Settings'). See https://api.qualtrics.com/docs/dates-and-times for more\ninformation about how the Qualtrics API handles dates and times.")
Sys.setenv("QUALTRICS_WARNING_DATE_GIVEN"=TRUE)
}
# Return data
return(data)
}
# Convert multiple choice questions to ordered factors
# Idea: add ORDER = TRUE/FALSE (if user wants factors to be ordered). Add # REVERSE = TRUE/FALSE if user wants the factor levels to be reversed
wrapper_mc <- function(data, col_name, survey_meta) {
# Get question data from metadata
meta <- survey_meta[vapply(survey_meta,
function(x) x$questionName == col_name, TRUE)]
# Level names
ln <- vapply(meta[[1]]$choices,
function(x) x$choiceText, "character", USE.NAMES = FALSE)
# Convert
data %>%
mutate(!!col_name := readr::parse_factor(data %>% select(!!col_name) %>% pull(),
levels=ln,
ordered = TRUE))
}
JasperHG90/qualtRics documentation built on May 7, 2019, 10:33 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions qualtRicsResponseCodes constructHeader checkForWarnings checkParams appendRootUrl createRawPayload qualtricsApiRequest downloadQualtricsExport inferDataTypes wrapper_mc
# Download qualtrics data into R
# Copyright (C) 2018 Jasper Ginn
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <http://www.gnu.org/licenses/>.
# Download qualtrics data into R
# Copyright (C) 2016 Jasper Ginn
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <http://www.gnu.org/licenses/>.
# utils.R contains helper functions for the qualtRics package. These functions should not be called directly by the user and should not be exported.
#' @importFrom magrittr '%>%'
#' @importFrom dplyr mutate
#' @importFrom rlang ':='
#' @importFrom dplyr select
#' @importFrom dplyr pull
#' @importFrom readr parse_factor
#' @importFrom sjlabelled get_label
#' @importFrom sjlabelled set_label
#' @noRd
# Checks responses against qualtrics response codes and returns error message.
#
# @param res response from httr::GET
# @param raw if TRUE, add 'raw' flag to httr::content() function.
#
# @author Jasper Ginn
qualtRicsResponseCodes <- function(res, raw=FALSE) {
# Check status code and raise error/warning
if(res$status_code == 200) {
if(raw) {
result <- httr::content(res, "raw")
} else {
result <- httr::content(res)
}
return(list(
"content" = result,
"OK" = TRUE
)
)
} else if(res$status_code == 401) {
stop("Qualtrics API raised an authentication (401) error - you may not have the\nrequired authorization. Please check your API key and root url.") # nolint
} else if(res$status_code == 400) {
stop("Qualtrics API raised a bad request (400) error - Please report this on\nhttps://github.com/ropensci/qualtRics/issues") # nolint
} else if(res$status_code == 404) {
stop("Qualtrics API complains that the requested resource cannot be found (404 error).\nPlease check if you are using the correct survey ID.") # nolint
} else if(res$status_code == 500) {
stop(paste0("Qualtrics API reports an internal server (500) error. Please contact\nQualtrics Support (https://www.qualtrics.com/contact/) and provide the instanceId and errorCode below.", "\n", # nolint
"\n",
"instanceId:", " ",
httr::content(res)$meta$error$instanceId,
"\n",
"errorCode: ",
httr::content(res)$meta$error$errorCode))
return(list(
"content" = httr::content(res),
"OK"= FALSE
))
} else if(res$status_code == 503) {
stop(paste0("Qualtrics API reports a temporary internal server (500) error. Please\ncontact Qualtrics Support (https://www.qualtrics.com/contact/) with the instanceId and\nerrorCode below or retry your query.", "\n", # nolint
"\n",
"instanceId:", " ", httr::content(res)$meta$error$instanceId,
"\n",
"errorCode: ", httr::content(res)$meta$error$errorCode))
return(list(
"content" = httr::content(res),
"OK"= FALSE
)
)
} else if(res$status_code == 413) {
stop("The request body was too large. This can also happen in cases where a\nmultipart/form-data request is malformed.") # nolint
} else if(res$status_code == 429) {
stop("You have reached the concurrent request limit.")
}
}
# Construct a header to send to qualtrics API
#
# @param API.TOKEN API token. Available in your qualtrics account (see: \url{https://api.qualtrics.com/docs/authentication})
#
# @seealso See \url{https://api.qualtrics.com/docs/root-url} for documentation on the Qualtrics API.
# @author Jasper Ginn
constructHeader <- function(API.TOKEN) {
# Construct and return
headers <- c(
'X-API-TOKEN' = API.TOKEN,
'Content-Type' = "application/json",
'Accept' = '*/*',
'accept-encoding' = 'gzip, deflate'
)
return(headers)
}
# Check if httr GET result contains a warning
#
# @param resp object returned by 'qualtRicsResponseCodes()'
#
# @author Jasper Ginn
checkForWarnings <- function(resp) {
# Raise warning if resp contains notice
if(!is.null(resp$content$meta)) {
if(!is.null(resp$content$meta$notice)) {
warning(resp$content$meta$notice)
}
}
NULL
}
# Check if parameters passed to functions are correct
#
# @param ... options passed to checkParams
#
# @author: Jasper Ginn
checkParams <- function(...) {
args <- list(...)
### root_url
assert_rootUrl_stored()
### API Token
assert_apikey_stored()
### Options
if(all(c("verbose", "convertVariables",
"useLocalTime", "useLabels") %in% names(args))) {
assert_options_logical(
args$verbose,
args$convertVariables,
args$useLocalTime,
args$useLabels
)
}
# Check if params are of the right type
if("startDate" %in% names(args)) {
if(!is.null(args$startDate)) {
assert_startDate_string(args$startDate)
}
}
if("endDate" %in% names(args)) {
if(!is.null(args$endDate)) assert_endDate_string(args$endDate)
}
if("lastResponseId" %in% names(args)) {
if(!is.null(args$lastResponseId)) {
assert_lastResponseId_string(args$lastResponseId)
}
}
# Check if saveDir exists
if("saveDir" %in% names(args)) {
if(!is.null(args$saveDir)) {
assert_saveDir_exists(args$saveDir)
}
}
# Check if seenUnansweredRecode is NULL or else a string
if("seenUnansweredRecode" %in% names(args)) {
if(!is.null(args$seenUnansweredRecode)) {
assert_seenUnansweredRecode_string(args$seenUnansweredRecode)
}
}
# Check if limit > 0
if("limit" %in% names(args)) {
if(!is.null(args$limit)) {
assert_limit_abovezero(args$limit)
}
}
# Check if includedQuestionIds is a string
if("includedQuestionIds" %in% names(args)) {
if(!is.null(args$includedQuestionIds)) {
assert_includedQuestionIds_string(args$includedQuestionIds)
}
}
}
# Append proper end points to create root url
#
# @param root_url Base url for your institution (see \url{https://api.qualtrics.com/docs/csv}. You need to supply this url. Your query will NOT work without it.).
#
# @return root url + appended end point
#
# @author: Jasper Ginn
appendRootUrl <- function(root_url, type = c("responseexports", 'surveys')) {
# match
type <- match.arg(type)
# Create root url
root_url <- paste0(root_url,
ifelse(substr(root_url, nchar(root_url),
nchar(root_url)) == "/",
paste0("API/v3/", type,"/"),
paste0("/API/v3/", type,"/")))
# Return
return(root_url)
}
# Create raw JSON payload to post response exports request
#
# @param: see getSurveys() and registerOptions() functions
#
# @return: returns json file with options to send to API
#
# @author: Jasper Ginn
createRawPayload <- function(surveyID,
useLabels=TRUE,
lastResponseId=NULL,
startDate=NULL,
endDate=NULL,
limit=NULL,
useLocalTime=FALSE,
seenUnansweredRecode=NULL,
includedQuestionIds = NULL) {
paste0(
'{"format": ', '"', 'csv', '"' ,
', "surveyId": ', '"', surveyID, '"',
ifelse(
is.null(lastResponseId),
"",
paste0(
', "lastResponseId": ',
'"',
lastResponseId,
'"')
) ,
ifelse(
is.null(startDate),
"",
paste0(
', "startDate": ',
'"',
paste0(startDate,"T00:00:00Z"),
'"')
) ,
ifelse(
is.null(endDate),
"",
paste0(
', "endDate": ',
'"',
paste0(endDate,"T00:00:00Z"),
'"')
) ,
ifelse(
is.null(seenUnansweredRecode),
"",
paste0(
', "seenUnansweredRecode": ',
'"',
seenUnansweredRecode,
'"')
),
ifelse(
!useLocalTime,
"",
paste0(
', "useLocalTime": ',
tolower(useLocalTime)
)
),
ifelse(
is.null(includedQuestionIds),
"",
paste0(
', "includedQuestionIds": ',
'[', paste0('"',includedQuestionIds, '"', collapse=", "), ']'
)
),
ifelse(
is.null(limit),
"",
paste0(
', "limit": ',
limit
)
),
', ',
'"useLabels": ', tolower(useLabels),
'}'
)
}
# Send httr requests to qualtrics API
#
# @param verb type of request to be sent (@seealso ?httr::VERB)
# @param url qualtrics endpoint url created by appendRootUrl() function
# @param body options created by createRawPayload() function
#
# @author: Jasper Ginn
qualtricsApiRequest <- function(verb = c("GET", "POST"), url = url,
body = NULL) {
# Match arg
verb <- match.arg(verb)
# Construct header
headers <- constructHeader(Sys.getenv("QUALTRICS_API_KEY"))
# Send request to qualtrics API
res <- httr::VERB(verb,
url = url,
httr::add_headers(
headers
),
body = body)
# Check if response type is OK
cnt <- qualtRicsResponseCodes(res)
# Check if OK
if(cnt$OK) {
# If notice occurs, raise warning
w <- checkForWarnings(cnt)
# return content
return(cnt$content)
}
}
# Download response export
#
# @param check_url url provided by qualtrics API that shows the download percentage completneness
# @param verbose see getSurvey()
#
# @author Jasper Ginn
downloadQualtricsExport <- function(check_url, verbose = FALSE) {
# Construct header
headers <- constructHeader(Sys.getenv("QUALTRICS_API_KEY"))
# Create a progress bar and monitor when export is ready
if(verbose) {
pbar <- utils::txtProgressBar(min=0,
max=100,
style = 3)
}
# While download is in progress
progress <- 0
while(progress < 100) {
# Get percentage complete
CU <- qualtricsApiRequest("GET", url = check_url)
progress <- CU$result$percentComplete
# Set progress
if(verbose) {
utils::setTxtProgressBar(pbar, progress)
}
}
# Kill progress bar
if(verbose) {
close(pbar)
}
# Download file
f <- tryCatch({
httr::GET(paste0(check_url, "/file"), httr::add_headers(headers))
}, error = function(e) {
# Retry if first attempt fails
httr::GET(paste0(check_url, "/file"), httr::add_headers(headers))
})
# If content is test request, then load temp file (this is purely for testing)
# httptest library didn't work the way it needed and somehow still called the API
# leading to errors
if(f$request$url == "t.qualtrics.com/API/v3/responseexports/T_123/file"){
if(f$request$headers["X-API-TOKEN"] == "1234") {
ct <- readRDS("files/file_getSurvey.rds")
f$content <- ct
}
}
#browser()
# Load raw zip file
ty <- qualtRicsResponseCodes(f, raw=TRUE)
# To zip file
tf <- paste0(tempdir(),
ifelse(substr(tempdir(),
nchar(tempdir()),
nchar(tempdir())) == "/",
"temp.zip",
"/temp.zip"))
# Write to temporary file
writeBin(ty$content, tf)
# Try to unzip
u <- tryCatch({
utils::unzip(tf, exdir = tempdir())
}, error = function(e) {
stop(paste0("Error extracting ",
"csv",
" from zip file. Please re-run your query."))
})
## There is an issue with survey names that contain special characters such as colons.
## Temporarily change all names to 'temp.csv'
# Rename file
temp_name <- paste0(tempdir(), "/temp.csv")
io <- file.rename(u, temp_name)
# Remove zipfile
p <- file.remove(tf)
# Return file location
return(temp_name)
}
# Set proper data types on survey data.
#
# @param data imported qualtrics survey
# @author Jasper Ginn
inferDataTypes <- function(data,
surveyID,
verbose = FALSE) {
# Download survey metadata
md <- metadata(surveyID, get=list("questions"=TRUE,
"metadata"=FALSE,
"responsecounts"=FALSE))[[1]]
# Check which questions are of type allowed
interest <- lapply(md, function(x) {
# Check if question type supported
type_supp <- ifelse(!is.null(x$questionType$type),
x$questionType$type %in%
getOption("QUALTRICS_INTERNAL_SETTINGS")$question_types_supported$type,
FALSE
) # This one is the most important so ifelse
selector_supp <- ifelse(!is.null(x$questionType$selector),
x$questionType$selector %in%
getOption("QUALTRICS_INTERNAL_SETTINGS")$question_types_supported$selector,
FALSE)
if(!is.null(x$questionType$subSelector)) {
subselector_supp <- x$questionType$subSelector %in%
getOption("QUALTRICS_INTERNAL_SETTINGS")$question_types_supported$subSelector
} else {
subselector_supp <- NA
}
# Evaluate
supported <- ifelse(all(selector_supp, type_supp), TRUE, FALSE)
# Check if question in survey
question_is_in_survey <- x$questionName %in% names(data)
# If both true, return element
if(supported & question_is_in_survey) {
return(x)
}
})
# Remove NULL values
interest <- interest[!vapply(interest, is.null, FALSE)]
# Get value names
mc <- vapply(interest, function(x) x$questionName, "character", USE.NAMES = FALSE)
# Unfortunately, something goes wrong with the labels so we need to do this
lab <- sjlabelled::get_label(data)
# For each, convert
#browser()
for(m in mc) {
data <- data %>%
wrapper_mc(m, interest)
}
# Return labels
data <- sjlabelled::set_label(data, lab)
# Check if warning given
if(Sys.getenv("QUALTRICS_WARNING_DATE_GIVEN") == "") {
warning("The 'StartDate', 'EndDate' and 'RecordedDate' variables were converted without passing\na specific timezone. If you like to set these timestamps to your own timezone, please\nvisit https://www.qualtrics.com/support/survey-platform/getting-started/managing-your-account/\n(under 'User Settings'). See https://api.qualtrics.com/docs/dates-and-times for more\ninformation about how the Qualtrics API handles dates and times.")
Sys.setenv("QUALTRICS_WARNING_DATE_GIVEN"=TRUE)
}
# Return data
return(data)
}
# Convert multiple choice questions to ordered factors
# Idea: add ORDER = TRUE/FALSE (if user wants factors to be ordered). Add # REVERSE = TRUE/FALSE if user wants the factor levels to be reversed
wrapper_mc <- function(data, col_name, survey_meta) {
# Get question data from metadata
meta <- survey_meta[vapply(survey_meta,
function(x) x$questionName == col_name, TRUE)]
# Level names
ln <- vapply(meta[[1]]$choices,
function(x) x$choiceText, "character", USE.NAMES = FALSE)
# Convert
data %>%
mutate(!!col_name := readr::parse_factor(data %>% select(!!col_name) %>% pull(),
levels=ln,
ordered = TRUE))
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.