R/tools.R
In bpresentati/surveyR: surveyR: Get things done with LimeSurvey!
Defines functions
Get_Question_List
Get_Group_List
Get_Group_Properties
Update_Group_Properties
JavaScript_Hide_LS_Questions
Delete_Groups
Add_New_Groups
Get_Question_Properties
Activate_Surveys
Documented in
Activate_Surveys
Add_New_Groups
Delete_Groups
Get_Group_List
Get_Group_Properties
Get_Question_List
Get_Question_Properties
JavaScript_Hide_LS_Questions
Update_Group_Properties
#' Activate a batch of surveys
#'
#' This function activates all of the survey IDs listed in the argument Survey_IDs (a vector)
#' @param Survey_IDs A vector listing all of the Survey IDs to be activated.
#' @export
#' @examples \dontrun{
#' Activate_Surveys(12345)
#' }
#'
Activate_Surveys <- function(Survey_IDs){
get_session_key()
survey_codes_to_activate <- Survey_IDs
results <- list()
for (i in survey_codes_to_activate)
{
results[[paste0(i)]] <- call_limer(method = "activate_survey",
params = list(iSurveyID = i))
} # end for loop
return(results)
} # end function
#' Download a List of Question Properties for a List of Limesurvey Question IDs
#'
#' This will download all of the question properties available in the API for the inputted vector of Question IDs
#' @param Question_IDs A vector listing all of the Survey IDs to be activated.
#' @export
#' @examples \dontrun{
#' Get_Question_Properties(12345)
#' }
#'
Get_Question_Properties <- function(Question_IDs){
get_session_key()
get_question_properties <- list()
for(i in Question_IDs){
get_question_properties[[paste0(i)]] <- call_limer(method = "get_question_properties",
params = list(iQuestionID = i
))
} # end of for loop
return(get_question_properties)
} # end of function
#' Add Survey Groups Quickly
#'
#' This allows you to batch create a set of groups in the survey, which saves a lot of clicking around in the GUI.
#' \cr\cr Provide a data.table for the Group_Add_Table argument that has the following columns:
#' \itemize{
#' \item sid
#' \item group_name
#' }
#' The function will create the groups in the respective surveys, and return the same table with a new column, "new_gid" with the assigned gids for those newly added groups.
#' @param Group_Add_Table This should be a data.table that has the columns:
#' \itemize{
#' \item \strong{sid}: the sid of the survey where you want to add the respective group
#' \item \strong{group_name}: the name that you would like to assign the group
#' }
#' @export
#' @examples \dontrun{
#' Add_New_Groups(Group_Add_Table)
#' }
#'
Add_New_Groups <- function(Group_Add_Table){
get_session_key() # Log in
Group_Add_Table <- setDT(Group_Add_Table)
for(i in 1:nrow(Group_Add_Table)){
possibleError <- tryCatch(
{
Group_Add_Table[i, new_gid := call_limer(method = "add_group",
params = list(iSurveyID = Group_Add_Table[i]$sid,
sGroupTitle = Group_Add_Table[i]$group_name
))]
}, # end first part of tryCatch
error = function(e) e)
# If there's a problem:
if(inherits(possibleError, "error"))
{
Group_Add_Table[i, new_gid := NA]
}
} # end for loop
return(Group_Add_Table)
} # end of function
#' Batch Group Deletion
#'
#' Allows you to delete a batch of groups, as listed in a table with at least the columns gid and sid
#' @param Group_Deletion_Table This should be a data.table that has the columns:
#' \itemize{
#' \item \strong{sid}: the sid of the survey where you want to delete the respective group
#' \item \strong{gid}: the gid of the group you would like to delete
#' }
#' This function returns the same table with the added column "group_deleted" that has a TRUE value if successful, and a FALSE if unsuccessful.
#' @export
#' @examples \dontrun{
#' Delete_Groups(Group_Deletion_Table)
#' }
#'
Delete_Groups <- function(Group_Deletion_Table){
get_session_key() # Log in
Group_Deletion_Table <- setDT(Group_Deletion_Table)
results <- list()
for(i in 1:nrow(Group_Deletion_Table)){
Group_Deletion_Table[i, group_deleted := call_limer(method = "delete_group",
params = list(iSurveyID = Group_Deletion_Table[i]$sid,
iGroupID = Group_Deletion_Table[i]$gid
))]
}# end for loop
return(Group_Deletion_Table)
}
#' Inject Javascript to hide question
#'
#' This allows you to batch hide questions using javascript. The questions will continue to function, but they will not be visible. This is not the same as the "hide" option in LS!
#' @param QuestionIDs Vector of Question IDs that should have this added to them.
#' @export
#' @examples \dontrun{
#' JavaScript_Hide_LS_Questions(123456)
#' }
#'
JavaScript_Hide_LS_Questions <- function(QuestionIDs){
get_session_key() # Log in
j <- 1
set_question_properties_result <- list()
for(i in QuestionIDs){
# This part puts the results straight into the appropriate questions:
get_question_properties_current <- call_limer(method = "get_question_properties",
params = list(iQuestionID = i
))
get_question_properties_current["question"] <- paste0('<script type="text/javascript">','\n',
"var QID = '{QID}';",'\n',
'$(document).ready(function() {','\n',
"$('#question'+QID).hide();});",'\n',
'</script>')
set_question_properties_result[paste0(i)] <- call_limer(method = "set_question_properties",
params = list(iQuestionID = i,
aQuestionData = get_question_properties_current
))
j <- j+1
} # end for loop
return(set_question_properties_result)
} # end function
#' Batch update group properties
#'
#' This allows you to change the group properties of as many groups as you like.
#' @param Group_Update_Table This is a data.table that has the column "gid" and one or more of the following columns: "new_grelevance", "new_group_name", "new_group_order", "new_description", "new_language", "new_randomization_group". These columns contain the information that you want to use to update the respective group parameters.
#' \itemize{
#' \item \strong{gid}: the gid of the group you would like to update <this column is mandatory!>
#' \item \strong{new_grelevance}: <optional> the group relevance you want to update- simply a string with a relevance equation
#' \item \strong{new_group_name}: <optional> change the group name
#' \item \strong{new_group_order}: <optional> change the order in which the groups are presented (this has restrictions)
#' \item \strong{new_description}: <optional> change group description
#' \item \strong{new_language}: <optional> change language of group
#' \item \strong{new_randomization_group}: <optional> assign the group to a randomization group- simply a string with the randomization group's name
#' }
#' @export
#' @examples \dontrun{
#' Update_Group_Properties(data.table(gid = 123455, new_grelevance = 1))
#' }
#'
Update_Group_Properties <- function(Group_Update_Table){
get_session_key() # Log in
Group_Update_Table <- setDT(Group_Update_Table)
Return_Values <- list()
for(i in 1:nrow(Group_Update_Table)){
current_group_properties <- call_limer(method = "get_group_properties",
params = list(iGroupID = Group_Update_Table[i]$gid
))
# Use the base language if there's either no language column, or if there's an NA in it
if("language" %in% names(Group_Update_Table)){
target_language <- ifelse(!is.na(Group_Update_Table[i]$language), Group_Update_Table[i]$language, current_group_properties[["language"]])
}
else{
target_language <- current_group_properties[["language"]]
}
# Get rid of columns that cannot be updated:
current_group_properties <- within(current_group_properties, rm(sid,gid))
# Block to eliminate the update if the column doesn't exist:
if(!("new_grelevance" %in% names(Group_Update_Table))){
current_group_properties <- within(current_group_properties, rm(grelevance))
}
else{
if(!is.na(Group_Update_Table[i]$new_grelevance)){
current_group_properties[["grelevance"]] <- Group_Update_Table[i]$new_grelevance
}
else{
current_group_properties <- within(current_group_properties, rm(grelevance))
}
}
if(!("new_group_name" %in% names(Group_Update_Table))){
current_group_properties <- within(current_group_properties, rm(group_name))
}
else{
if(!is.na(Group_Update_Table[i]$new_group_name)){
current_group_properties[["group_name"]] <- Group_Update_Table[i]$new_group_name
}
else{
current_group_properties <- within(current_group_properties, rm(group_name))
}
}
if(!("new_group_order" %in% names(Group_Update_Table))){
current_group_properties <- within(current_group_properties, rm(group_order))
}
else{
if(!is.na(Group_Update_Table[i]$new_group_order)){
current_group_properties[["group_order"]] <- Group_Update_Table[i]$new_group_order
}
else{
current_group_properties <- within(current_group_properties, rm(group_order))
}
}
if(!("new_description" %in% names(Group_Update_Table))){
current_group_properties <- within(current_group_properties, rm(description))
}
else{
if(!is.na(Group_Update_Table[i]$new_description)){
current_group_properties[["description"]] <- Group_Update_Table[i]$new_description
}
else{
current_group_properties <- within(current_group_properties, rm(description))
}
}
if(!("new_randomization_group" %in% names(Group_Update_Table))){
current_group_properties <- within(current_group_properties, rm(randomization_group))
}
else{
if(!is.na(Group_Update_Table[i]$new_randomization_group)){
current_group_properties[["randomization_group"]] <- Group_Update_Table[i]$new_randomization_group
}
else{
current_group_properties <- within(current_group_properties, rm(randomization_group))
}
}
# if(!("new_language" %in% names(Group_Update_Table))){
# current_group_properties <- within(current_group_properties, rm(language))
# }
# else{
# if(!is.na(Group_Update_Table[i]$new_language)){
# current_group_properties[["language"]] <- Group_Update_Table[i]$new_language
# }
# else{
# current_group_properties <- within(current_group_properties, rm(language))
# }
#
# }
# Update:
Return_Values[[paste0(Group_Update_Table[i]$gid)]] <- call_limer(method = "set_group_properties",
params = list(iGroupID = Group_Update_Table[i]$gid,
aGroupData = current_group_properties
))
}
Return_Table <- (rbindlist(Return_Values, idcol = "gid"))
setnames(Return_Table, old = names(Return_Table[, -c("gid")]), new = paste0(names(Return_Table[, -c("gid")]), ".update"))
Return_Table[, gid := as.numeric(gid)]
Group_Update_Table[, gid := as.numeric(gid)]
Group_Update_Table <- merge(Group_Update_Table, Return_Table, by = "gid", all.x = TRUE)
return(Group_Update_Table)
}
#' Batch query group properties
#'
#' This allows you to receive a list of the group properties of the groups specified by the gid column in the data.table given as Group_Properties_Query
#' @param Group_IDs A data.table specifying the groups of interest in the \strong{gid} column.
#' @export
#' @examples \dontrun{
#' Get_Group_Properties(data.table(gid = 12345))
#' }
#'
Get_Group_Properties <- function(Group_Properties_Query){
get_session_key() # Log in
Group_Properties_Query <- setDT(Group_Properties_Query)
Return_Values <- list()
for(i in 1:nrow(Group_Properties_Query)){
Return_Values[[paste0(Group_Properties_Query[i]$gid)]] <- call_limer(method = "get_group_properties",
params = list(iGroupID = Group_Properties_Query[i]$gid
))
}
Return_Table <- (rbindlist(Return_Values))
Return_Table[, gid := as.numeric(gid)]
Group_Properties_Query <- merge(Group_Properties_Query, Return_Table, by = "gid", all.x = TRUE)
return(Group_Properties_Query)
}
#' Get Group List
#'
#' This allows you to receive a list of the groups for the surveys specified by the sid column in the data.table given as Survey_IDs
#' @param Survey_IDs A data.table with a column specifying the \strong{sid} where the groups should be retrieved
#' @export
#' @examples \dontrun{
#' Get_Group_List(data.table(sid = 123456))
#' }
#'
Get_Group_List <- function(Survey_IDs){
get_session_key() # Log in
Survey_IDs <- setDT(Survey_IDs)
Survey_IDs[, sid := as.numeric(sid)]
Return_Values <- list()
for(i in 1:nrow(Survey_IDs)){
Return_Values[[paste0(Survey_IDs[i]$sid)]] <- call_limer(method = "list_groups",
params = list(iSurveyID = Survey_IDs[i]$sid
))
Return_Values[[paste0(Survey_IDs[i]$sid)]] <- within(Return_Values[[paste0(Survey_IDs[i]$sid)]], rm(id))
}
Return_Table <- (rbindlist(Return_Values))
setnames(Return_Table, old = c("language", "description"), new = c("language.group", "description.group"), skip_absent = TRUE)
Return_Table[, sid := as.numeric(sid)]
Survey_IDs <- merge(Survey_IDs, Return_Table, by = "sid", all = TRUE, suffixes = c("", ".group"))
Survey_IDs[, group_number := as.numeric(group_order)]
Survey_IDs[, group_number_ls := group_number+1]
return(Survey_IDs)
}
#' NEW NEW NEW (20210804)
#' This gets all of the questions from the surveys and binds them together in one table.
#'
#' @param Survey_IDs this is a data.table with at least one column \strong{sid} containing the Limesurvey survey IDs of all the parts in the correct order (if they are ordered survey parts)
#' @keywords Retrieve a list of the questions for the queries surveys
#' @export
#' @examples Question_List <- Get_Question_List(data.table(sid = 130394))
Get_Question_List <- function(Survey_IDs){
get_session_key()
Survey_IDs <- setDT(Survey_IDs)
Survey_IDs[, sid := as.numeric(sid)]
Survey_IDs <- unique(Survey_IDs[, .(sid)])
Question_List <- list()
for(i in 1:nrow(Survey_IDs)){
Question_List[[paste0(Survey_IDs[i]$sid)]] <- call_limer(method = "list_questions", params = list(iSurveyID = Survey_IDs[i]$sid))%>%select(-id)
} #end for loop
# Bind everything to have one list
Bound_Question_List <- rbindlist(Question_List, use.names = TRUE)%>%setDT
Bound_Question_List[, sid := as.numeric(sid)]
Group_List <- Get_Group_List(unique(Bound_Question_List[, .(sid)]))
Bound_Question_List <- merge(Bound_Question_List, Group_List, by = c("sid", "gid"), all.x = TRUE, suffixes = c("", ".group"), allow.cartesian = TRUE)
return(Bound_Question_List)
} #end function
#' Batch query survey properties
#'
#' This allows you to receive a list of the survey properties of the surveys specified by ID in the vector given as Survey_IDs
#' @param Survey_IDs A vector specifying the \strong{sid} of interest.
#' @export
#' @examples \dontrun{
#' Get_Survey_Properties_List(123456)
#' }
#'
Get_Survey_Properties_List <- function(Survey_IDs){
get_session_key()
Survey_Properties_List <- list()
for(i in Survey_IDs){
Survey_Properties_List[[paste0(i)]] <- call_limer(method = "get_survey_properties", params = list(iSurveyID = i))
} #end for loop
# Bind everything to have one list
Bound_Properties_List <- rbindlist(Survey_Properties_List, use.names = TRUE, idcol = TRUE)%>%setDT
return(Bound_Properties_List)
} #end function
#' Batch update question properties
#'
#' This allows you to change the question properties of as many questions as you like.
#' @param Question_Update_Table This is a data.table that has the following columns:
#' \itemize{
#' \item \strong{qid}: the qid of the question you would like to update <this column is mandatory!>
#' \item \strong{new_relevance}: <optional> the relevance equation you want to update- simply a string with a relevance equation
#' \item \strong{new_title}: <optional> this is what you might think of as the "question code"- it isn't visible to the participant and serves as the questions variable name in the export file
#' \item \strong{new_question}: <optional> the question text. This can also be html/css/javascript
#' \item \strong{new_help}: <optional> The help text for the question
#' \item \strong{new_preg}: <optional> I'm not even sure what this does. But, it is available for change.
#' \item \strong{new_other}: <optional> I'm not even sure what this does. But, it is available for change.
#' \item \strong{new_mandatory}: <optional> Here you can decide if the question is mandatory.
#' \item \strong{new_question_order}: <optional> Here you can set the question order.
#' \item \strong{new_scale_id}: <optional> I'm not even sure what this does. But, it is available for change.
#' \item \strong{new_same_default}: <optional> I'm not even sure what this does. But, it is available for change.
#' \item \strong{new_modulename}: <optional> I'm not even sure what this does. But, it is available for change.
#' \item \strong{language}: <optional> this is when you are changing different language versions of the question in a multilingual survey. If you do not add this column or leave it blank, the updates will default to only the base language of the survey. Please only one language per row. If you have 3 languages in your survey and you want to update all of them, you need a row for each language that sets, for example, the new_question or new_help. Multilingual surveys are tricky in that not all options will be available for all languages. Or, seen from another perspective, they need to be the same across all languages.
#' }
#' @export
#' @examples \dontrun{
#' Update_Question_Properties(data.table(qid = 123455, new_relevance = 1))
#' }
#'
Update_Question_Properties <- function(Question_Update_Table){
get_session_key() # Log in
Question_Update_Table <- setDT(Question_Update_Table)
Return_Values <- list()
for(i in 1:nrow(Question_Update_Table)){
current_question_properties <- call_limer(method = "get_question_properties",
params = list(iQuestionID = Question_Update_Table[i]$qid
))
# Use the base language if there's either no language column, or if there's an NA in it
if("language" %in% names(Question_Update_Table)){
target_language <- ifelse(!is.na(Question_Update_Table[i]$language), Question_Update_Table[i]$language, current_question_properties[["language"]])
}
else{
target_language <- current_question_properties[["language"]]
}
# get rid of all the fields that can't be updated
current_question_properties <- within(current_question_properties, rm(qid,parent_qid,sid,gid,type,language))
# Block to eliminate the update if the column doesn't exist:
if(!("new_relevance" %in% names(Question_Update_Table))){
current_question_properties <- within(current_question_properties, rm(relevance))
}
else{
if(!is.na(Question_Update_Table[i]$new_relevance)){
current_question_properties[["relevance"]] <- Question_Update_Table[i]$new_relevance
}
else{
current_question_properties <- within(current_question_properties, rm(relevance))
}
}
if(!("new_title" %in% names(Question_Update_Table))){
current_question_properties <- within(current_question_properties, rm(title))
}
else{
if(!is.na(Question_Update_Table[i]$new_title)){
current_question_properties[["title"]] <- Question_Update_Table[i]$new_title
}
else{
current_question_properties <- within(current_question_properties, rm(title))
}
}
if(!("new_question" %in% names(Question_Update_Table))){
current_question_properties <- within(current_question_properties, rm(question))
}
else{
if(!is.na(Question_Update_Table[i]$new_question)){
current_question_properties[["question"]] <- Question_Update_Table[i]$new_question
}
else{
current_question_properties <- within(current_question_properties, rm(question))
}
}
if(!("new_help" %in% names(Question_Update_Table))){
current_question_properties <- within(current_question_properties, rm(help))
}
else{
if(!is.na(Question_Update_Table[i]$new_help)){
current_question_properties[["help"]] <- Question_Update_Table[i]$new_help
}
else{
current_question_properties <- within(current_question_properties, rm(help))
}
}
if(!("new_preg" %in% names(Question_Update_Table))){
current_question_properties <- within(current_question_properties, rm(preg))
}
else{
if(!is.na(Question_Update_Table[i]$new_preg)){
current_question_properties[["preg"]] <- Question_Update_Table[i]$new_preg
}
else{
current_question_properties <- within(current_question_properties, rm(preg))
}
}
if(!("new_other" %in% names(Question_Update_Table))){
current_question_properties <- within(current_question_properties, rm(other))
}
else{
if(!is.na(Question_Update_Table[i]$new_other)){
current_question_properties[["other"]] <- Question_Update_Table[i]$new_other
}
else{
current_question_properties <- within(current_question_properties, rm(other))
}
}
if(!("new_mandatory" %in% names(Question_Update_Table))){
current_question_properties <- within(current_question_properties, rm(mandatory))
}
else{
if(!is.na(Question_Update_Table[i]$new_mandatory)){
current_question_properties[["mandatory"]] <- Question_Update_Table[i]$new_mandatory
}
else{
current_question_properties <- within(current_question_properties, rm(mandatory))
}
}
if(!("new_question_order" %in% names(Question_Update_Table))){
current_question_properties <- within(current_question_properties, rm(question_order))
}
else{
if(!is.na(Question_Update_Table[i]$new_question_order)){
current_question_properties[["question_order"]] <- Question_Update_Table[i]$new_question_order
}
else{
current_question_properties <- within(current_question_properties, rm(question_order))
}
}
if(!("new_scale_id" %in% names(Question_Update_Table))){
current_question_properties <- within(current_question_properties, rm(scale_id))
}
else{
if(!is.na(Question_Update_Table[i]$new_scale_id)){
current_question_properties[["scale_id"]] <- Question_Update_Table[i]$new_scale_id
}
else{
current_question_properties <- within(current_question_properties, rm(scale_id))
}
}
if(!("new_same_default" %in% names(Question_Update_Table))){
current_question_properties <- within(current_question_properties, rm(same_default))
}
else{
if(!is.na(Question_Update_Table[i]$new_same_default)){
current_question_properties[["same_default"]] <- Question_Update_Table[i]$new_same_default
}
else{
current_question_properties <- within(current_question_properties, rm(same_default))
}
}
if(!("new_modulename" %in% names(Question_Update_Table))){
current_question_properties <- within(current_question_properties, rm(modulename))
}
else{
if(!is.na(Question_Update_Table[i]$new_modulename)){
current_question_properties[["modulename"]] <- Question_Update_Table[i]$new_modulename
}
else{
current_question_properties <- within(current_question_properties, rm(modulename))
}
}
# Now update everything:
Return_Values[[paste0(Question_Update_Table[i]$qid)]] <- call_limer(method = "set_question_properties",
params = list(iQuestionID = Question_Update_Table[i]$qid,
aQuestionData = current_question_properties,
sLanguage = target_language
))
}
Return_Table <- (rbindlist(Return_Values, idcol = "qid"))
setnames(Return_Table, old = names(Return_Table[, -c("qid")]), new = paste0(names(Return_Table[, -c("qid")]), ".update"))
Return_Table[, qid := as.numeric(qid)]
Question_Update_Table[, qid := as.numeric(qid)]
Question_Update_Table <- merge(Question_Update_Table, Return_Table, by = "qid", all = TRUE)
return(Question_Update_Table)
}
#' Inject Javascript to hide question
#'
#' This allows you to batch hide questions using javascript. The questions will continue to function, but they will not be visible. This is not the same as the "hide" option in LS!
#' @param Questions_to_Hide data.table of Question \strong{qid} that should have this added to them, and optionally the \strong{language}, if it's a multilingual survey. Please remember, that the same question should have the same number of entries as the number of available language options- one for each language, when you want to hide them all.
#' @export
#' @examples \dontrun{
#' Hide_LS_Questions(123456)
#' }
#'
Hide_LS_Questions <- function(Questions_to_Hide){
get_session_key() # Log in
Questions_to_Hide <- setDT(Questions_to_Hide)
if(!("overwrite" %in% names(Questions_to_Hide))){
Questions_to_Hide[, overwrite := FALSE]
}
results <- list()
for(i in 1:nrow(Questions_to_Hide)){
# This part puts the results straight into the appropriate questions:
get_question_properties_current <- call_limer(method = "get_question_properties",
params = list(iQuestionID = Questions_to_Hide[i]$qid
))
if("language" %in% names(Questions_to_Hide)){
target_language <- ifelse(!is.na(Questions_to_Hide[i]$language), Questions_to_Hide[i]$language, get_question_properties_current[["language"]])
}else{
target_language <- get_question_properties_current[["language"]]
}
if(Questions_to_Hide[i]$overwrite){
Change <- data.table(qid = Questions_to_Hide[i]$qid, language = target_language, new_question = paste0("\n\n",
# Here's the hide script:
'<script type="text/javascript">','\n',
"var QID = '{QID}';",'\n',
'$(document).ready(function() {','\n',
"$('#question'+QID).hide();});",'\n',
'</script>'))
}else{
Change <- data.table(qid = Questions_to_Hide[i]$qid, language = target_language, new_question = paste0(get_question_properties_current[["question"]], "\n\n",
# Here's the hide script:
'<script type="text/javascript">','\n',
"var QID = '{QID}';",'\n',
'$(document).ready(function() {','\n',
"$('#question'+QID).hide();});",'\n',
'</script>'))
}
# get_question_properties_current[["question"]] <- paste0('<script type="text/javascript">','\n',
# "var QID = '{QID}';",'\n',
# '$(document).ready(function() {','\n',
# "$('#question'+QID).hide();});",'\n',
# '</script>')
# set_question_properties_result[paste0(i)] <- call_limer(method = "set_question_properties",
# params = list(iQuestionID = i,
# aQuestionData = get_question_properties_current
# ))
results[[paste0(Questions_to_Hide[i]$qid)]] <- Update_Question_Properties(Change)
} # end for loop
return(results)
} # end function
#' Find and replace text in a batch of questions
#'
#' This allows you to batch find and replace text that is in an unlimited number of questions
#' @param Questions data.table specifying the \strong{qid} and target \strong{language} (if you are looking/replacing for a different language than the base language)
#' @param Find_Text string of what the find
#' @param Replace_Text string of what to replace
#' @param Fixed this gets passed on to gsub- if it's TRUE (the default) then it will search for the exact string you enter. If it is FALSE, then you can use regex.
#' @export
#' @examples \dontrun{
#' Find_Replace_in_Question(data.table(qid = 123435, language = "en"), Find_Text = "Hello", Replace_Text = "Goodbye")
#' }
#'
Find_Replace_in_Question <- function(Questions, Find_Text, Replace_Text, Fixed = TRUE){
get_session_key() # Log in
Question_Update_Table <- setDT(Questions)
Question_Update_Table[, language.update := character()]
Question_Update_Table[, question.update := logical()]
Question_Update_Table[, text.found := logical()]
Return_Values <- list()
for(i in 1:nrow(Question_Update_Table)){
# # There is a bug in limesurvey that doesn't let you get the question properties for each language! If that bug is fixed, you could use this chunk!
# if("language" %in% names(Question_Update_Table)){
# current_question_properties <- call_limer(method = "get_question_properties",
# params = list(iQuestionID = Question_Update_Table[i]$qid,
# sLanguage = Question_Update_Table[i]$language
# ))
# }else{
# current_question_properties <- call_limer(method = "get_question_properties",
# params = list(iQuestionID = Question_Update_Table[i]$qid
# ))
# }
current_question_properties <- call_limer(method = "get_question_properties",
params = list(iQuestionID = Question_Update_Table[i]$qid
))
# Use the base language if there's either no language column, or if there's an NA in it
if("language" %in% names(Question_Update_Table)){
target_language <- ifelse(!is.na(Question_Update_Table[i]$language), Question_Update_Table[i]$language, current_question_properties[["language"]])
}else{
target_language <- current_question_properties[["language"]]
}
# Just to track progress
Question_Update_Table[i]$language.update <- target_language
# get rid of all the fields that can't be updated
current_question_properties <- within(current_question_properties, rm(qid,parent_qid,sid,gid,type,language, relevance, title, help, preg, other, mandatory, question_order, scale_id, same_default, modulename))
# This is just to confirm that the text was found
Question_Update_Table[i]$text.found <- !is_empty(grep(Find_Text, current_question_properties[["question"]], fixed = TRUE))
current_question_properties[["question"]] <- gsub(Find_Text, Replace_Text, current_question_properties[["question"]], fixed = Fixed)
Question_Update_Table[i]$question.update <- call_limer(method = "set_question_properties",
params = list(iQuestionID = Question_Update_Table[i]$qid,
aQuestionData = current_question_properties,
sLanguage = target_language
))
} # end of the for loop
return(Question_Update_Table)
} # end of find/replace function
#' Create new surveys by the batch
#'
#' This allows you to add one or a whole batch of new surveys
#' @param Surveys data.table specifying:
#' \itemize{
#' \item \strong{sid}: <this column is mandatory!> the sid of the survey that you would like to assign it. If it is already taken, Limesurvey will graciously assign you a random sid instead.
#' \item \strong{title}: <this column is mandatory!> What should the survey be called?
#' \item \strong{language}: <this column is mandatory!> What is the base language of the survey? This needs to be given as a code, for example, english would be "en". For a reference of language codes (but not all of these are supported!): \link[dest=https://www.w3schools.com/tags/ref_language_codes.asp]{Language Codes}
#' \item \strong{format}: <this column is mandatory!> A code to specify question appearance format (A, G or S) for "All on one page", "Group by Group", or "Single questions". The default is group by group (G).
#' }
#' @export
#' @examples \dontrun{
#' Create_Survey(Surveys = data.table(sid = c(123456), title = c("Fancy Test Survey"), language = c("en"), format = c("G")))
#' }
#'
Create_Survey <- function(Surveys){
get_session_key() # Log in
Surveys <- setDT(Surveys)
Surveys[, format := ifelse(!is.na(format), format, "G")]
Surveys[, language := ifelse(!is.na(language), language, "en")]
Return_Values <- list()
for(i in 1:nrow(Surveys)){
Return_Values[[paste0(Surveys[i]$sid)]] <- call_limer(method = "add_survey",
params = list(iSurveyID = Surveys[i]$sid,
sSurveyTitle = Surveys[i]$title,
sSurveyLanguage = Surveys[i]$language,
sformat = Surveys[i]$format
))
} # end of the for loop
return(Return_Values)
} # end of function
#' Delete surveys by the batch
#'
#' This allows you to delete one or a whole batch of surveys
#' @param Surveys data.table specifying the \strong{sid}(s) to be deleted
#' @export
#' @examples \dontrun{
#' Delete_Survey(Surveys = data.table(sid = c(123456))
#' }
#'
Delete_Survey <- function(Surveys){
get_session_key() # Log in
Surveys <- setDT(Surveys)
Return_Values <- list()
for(i in 1:nrow(Surveys)){
Return_Values[[paste0(Surveys[i]$sid)]] <- call_limer(method = "delete_survey",
params = list(iSurveyID = Surveys[i]$sid
))
} # end of the for loop
} # end of function
#' Add language
#'
#' This allows you to add a language (or multiple languages) to one or a whole batch of surveys
#' @param Surveys data.table specifying the \strong{sid}(s) where the languages should be added, and the respective \strong{language} that should be added. Remember, one row for each language.
#' \link[dest=https://www.w3schools.com/tags/ref_language_codes.asp]{Language Codes}
#' @export
#' @examples \dontrun{
#' Add_Language(Surveys = data.table(sid = c(123456, 123654), language = c("fr", "it"))
#' }
#'
Add_Language <- function(Surveys){
get_session_key() # Log in
Surveys <- setDT(Surveys)
Return_Values <- list()
for(i in 1:nrow(Surveys)){
Return_Values[[paste0(Surveys[i]$sid)]] <- call_limer(method = "add_language",
params = list(iSurveyID = Surveys[i]$sid,
sLanguage = Surveys[i]$language
))
} # end of the for loop
} # end of function
#' Delete language
#'
#' This allows you to delete a language (or multiple languages) to one or a whole batch of surveys
#' @param Surveys data.table specifying the \strong{sid}(s) where the languages should be deleted, and the respective \strong{language} that should be removed
#' \link[dest=https://www.w3schools.com/tags/ref_language_codes.asp]{Language Codes}
#' @export
#' @examples \dontrun{
#' Delete_Language(Surveys = data.table(sid = c(123456, 123654), language = c("fr", "it"))
#' }
#'
Delete_Language <- function(Surveys){
get_session_key() # Log in
Surveys <- setDT(Surveys)
Return_Values <- list()
for(i in 1:nrow(Surveys)){
Return_Values[[paste0(Surveys[i]$sid)]] <- call_limer(method = "delete_language",
params = list(iSurveyID = Surveys[i]$sid,
sLanguage = Surveys[i]$language
))
} # end of the for loop
} # end of function
#' Add Randomization Question
#'
#' This imports some randomizer questions that yeild a random value from 1 to the value specified in the randomizer variable
#' @param Import_Table data.table specifying the sid, gid, title, randomizer
#' \itemize{
#' \item \strong{sid}: <this column is mandatory!> the sid of the survey where you want to place a randomization question
#' \item \strong{gid}: <this column is mandatory!> the gid where the randomization question should live
#' \item \strong{title}: <this column is mandatory!> the name of the randomization question
#' \item \strong{randomizer}: <this column is mandatory!> the highest number of the randomization- it will randomize between 1 and this number (integers)
#' \item \strong{template}: <this column is mandatory!> the name of the question template for the randomization question. If you use one other than the "randomizer.lsq" provided, you'll need to make sure the lsq has the title stored as "PLACEHOLDER" and that the default value of the question is set to "RANDOMVALUES". Honestly, it's best to use the provided template.
#' }
#' @param Folder_Location_Templates <optional, defaults to "Templates">: this is where the randomization question template is stored.
#' @export
#' @examples \dontrun{
#' Import_Questions_Rand(Import_Table = data.table(sid = c(123456, 123654), gid = c(34244, 43242), title = c("Rand1, Rand2), randomizer = c(3, 4), template = "randomizer.lsq"), Folder_Location_Templates = "Templates")
#' }
#'
Import_Questions_Rand <- function(Import_Table, Folder_Location_Templates = "Templates"){
get_session_key() # Log in
if(is.na(Folder_Location_Templates)){
Template_Top_Folder <- ""
}
else{
Template_Top_Folder <- paste0(Folder_Location_Templates, "/")
}
results <- list()
for(i in 1:nrow(Import_Table)){
template <- read_file(paste0(Template_Top_Folder, Import_Table[i]$template))
template <- str_replace(template, pattern = "PLACEHOLDER", replacement = Import_Table[i]$title)
template <- str_replace(template, pattern = "RANDOMVALUES", replacement = paste0("rand(1,",Import_Table[i]$randomizer,")"))
template <- base64_enc(template)
results[[paste0(i)]] <- call_limer(method = "import_question",
params = list(iSurveyID = Import_Table[i]$sid,
iGroupID = Import_Table[i]$gid,
sImportData = template,
sImportDataType = "lsq"
))
}# end for loop
return(results)
} # end function
#' Figure out the groups questions belong to, when there is a capped number in any given group
#'
#' If there is a cap on the number of subquestions, you'll want to know which groups each subquestion belongs to, and you'll want to split them up sensibly and give them proper names/create their associated questions. This function helps you figure out their group belonging.
#' @param Questions_to_Group data.table with the question information and, most importantly, a grouping variable (\strong{grouping_variable})that specifies which subquestions belong to which group.
#' @param max_number default is 50 (max number currently allowed by LS)- this is the largest number of subquestions allowed in any given group
#' @param grouping_variable this is a character string that specifies which variable should be used for grouping.
#' @param even_split this is a boolean input that specifies whether you want the function to try to give you (more or less) even sized groups or not. Default is TRUE. FALSE would mean that there will be lists that go up to the max_number and then (possibly) one list that could be significantly shorter- e.g. you have 201 subquestions in a group- this would make 5 groups, four of which would have 50 and the last one would have 1. If you had the same situation and even_split was true you'd end up with 5 groups that have 41 subquestions each, and one with 37- 5 groups in total.
#' @export
#' @examples \dontrun{
#' Figure_Out_Groups(Questions_to_Group = Questions, max_number = 20, grouping_variable = "industry", even_split = TRUE)
#' }
Figure_Out_Groups <- function(Questions_to_Group, max_number = 50, grouping_variable, even_split = TRUE){
Questions_to_Group <- setDT(Questions_to_Group)
Questions_to_Group <- Questions_to_Group[, group_total := .N, by = grouping_variable]%>%
setorderv(cols = c(grouping_variable))
if(even_split == FALSE){
Questions_to_Group <- Questions_to_Group[, cap := rep(c(1:max_number), times = ceiling(max(group_total)/max_number), length.out = max(group_total)), by = grouping_variable]
Questions_to_Group <- Questions_to_Group[, question_group := seq(.N), by = c("cap", grouping_variable)]
Questions_to_Group <- Questions_to_Group[, possible_group_name := paste0(get(grouping_variable), "x", question_group)]
}else{
Questions_to_Group <- Questions_to_Group[, more_even_split := ceiling((group_total)/ceiling((group_total)/max_number))]
Questions_to_Group <- Questions_to_Group[, cap := rep(c(1:more_even_split), times = ceiling(max(group_total)/more_even_split), length.out = max(group_total)), by = grouping_variable]
Questions_to_Group <- Questions_to_Group[, question_group := seq(.N), by = c("cap", grouping_variable)]
Questions_to_Group <- Questions_to_Group[, possible_group_name := paste0(get(grouping_variable), "x", question_group)]
}
return(Questions_to_Group)
}
bpresentati/surveyR documentation built on March 19, 2022, 3:40 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 Get_Question_List Get_Group_List Get_Group_Properties Update_Group_Properties JavaScript_Hide_LS_Questions Delete_Groups Add_New_Groups Get_Question_Properties Activate_Surveys
Documented in Activate_Surveys Add_New_Groups Delete_Groups Get_Group_List Get_Group_Properties Get_Question_List Get_Question_Properties JavaScript_Hide_LS_Questions Update_Group_Properties
#' Activate a batch of surveys
#'
#' This function activates all of the survey IDs listed in the argument Survey_IDs (a vector)
#' @param Survey_IDs A vector listing all of the Survey IDs to be activated.
#' @export
#' @examples \dontrun{
#' Activate_Surveys(12345)
#' }
#'
Activate_Surveys <- function(Survey_IDs){
get_session_key()
survey_codes_to_activate <- Survey_IDs
results <- list()
for (i in survey_codes_to_activate)
{
results[[paste0(i)]] <- call_limer(method = "activate_survey",
params = list(iSurveyID = i))
} # end for loop
return(results)
} # end function
#' Download a List of Question Properties for a List of Limesurvey Question IDs
#'
#' This will download all of the question properties available in the API for the inputted vector of Question IDs
#' @param Question_IDs A vector listing all of the Survey IDs to be activated.
#' @export
#' @examples \dontrun{
#' Get_Question_Properties(12345)
#' }
#'
Get_Question_Properties <- function(Question_IDs){
get_session_key()
get_question_properties <- list()
for(i in Question_IDs){
get_question_properties[[paste0(i)]] <- call_limer(method = "get_question_properties",
params = list(iQuestionID = i
))
} # end of for loop
return(get_question_properties)
} # end of function
#' Add Survey Groups Quickly
#'
#' This allows you to batch create a set of groups in the survey, which saves a lot of clicking around in the GUI.
#' \cr\cr Provide a data.table for the Group_Add_Table argument that has the following columns:
#' \itemize{
#' \item sid
#' \item group_name
#' }
#' The function will create the groups in the respective surveys, and return the same table with a new column, "new_gid" with the assigned gids for those newly added groups.
#' @param Group_Add_Table This should be a data.table that has the columns:
#' \itemize{
#' \item \strong{sid}: the sid of the survey where you want to add the respective group
#' \item \strong{group_name}: the name that you would like to assign the group
#' }
#' @export
#' @examples \dontrun{
#' Add_New_Groups(Group_Add_Table)
#' }
#'
Add_New_Groups <- function(Group_Add_Table){
get_session_key() # Log in
Group_Add_Table <- setDT(Group_Add_Table)
for(i in 1:nrow(Group_Add_Table)){
possibleError <- tryCatch(
{
Group_Add_Table[i, new_gid := call_limer(method = "add_group",
params = list(iSurveyID = Group_Add_Table[i]$sid,
sGroupTitle = Group_Add_Table[i]$group_name
))]
}, # end first part of tryCatch
error = function(e) e)
# If there's a problem:
if(inherits(possibleError, "error"))
{
Group_Add_Table[i, new_gid := NA]
}
} # end for loop
return(Group_Add_Table)
} # end of function
#' Batch Group Deletion
#'
#' Allows you to delete a batch of groups, as listed in a table with at least the columns gid and sid
#' @param Group_Deletion_Table This should be a data.table that has the columns:
#' \itemize{
#' \item \strong{sid}: the sid of the survey where you want to delete the respective group
#' \item \strong{gid}: the gid of the group you would like to delete
#' }
#' This function returns the same table with the added column "group_deleted" that has a TRUE value if successful, and a FALSE if unsuccessful.
#' @export
#' @examples \dontrun{
#' Delete_Groups(Group_Deletion_Table)
#' }
#'
Delete_Groups <- function(Group_Deletion_Table){
get_session_key() # Log in
Group_Deletion_Table <- setDT(Group_Deletion_Table)
results <- list()
for(i in 1:nrow(Group_Deletion_Table)){
Group_Deletion_Table[i, group_deleted := call_limer(method = "delete_group",
params = list(iSurveyID = Group_Deletion_Table[i]$sid,
iGroupID = Group_Deletion_Table[i]$gid
))]
}# end for loop
return(Group_Deletion_Table)
}
#' Inject Javascript to hide question
#'
#' This allows you to batch hide questions using javascript. The questions will continue to function, but they will not be visible. This is not the same as the "hide" option in LS!
#' @param QuestionIDs Vector of Question IDs that should have this added to them.
#' @export
#' @examples \dontrun{
#' JavaScript_Hide_LS_Questions(123456)
#' }
#'
JavaScript_Hide_LS_Questions <- function(QuestionIDs){
get_session_key() # Log in
j <- 1
set_question_properties_result <- list()
for(i in QuestionIDs){
# This part puts the results straight into the appropriate questions:
get_question_properties_current <- call_limer(method = "get_question_properties",
params = list(iQuestionID = i
))
get_question_properties_current["question"] <- paste0('<script type="text/javascript">','\n',
"var QID = '{QID}';",'\n',
'$(document).ready(function() {','\n',
"$('#question'+QID).hide();});",'\n',
'</script>')
set_question_properties_result[paste0(i)] <- call_limer(method = "set_question_properties",
params = list(iQuestionID = i,
aQuestionData = get_question_properties_current
))
j <- j+1
} # end for loop
return(set_question_properties_result)
} # end function
#' Batch update group properties
#'
#' This allows you to change the group properties of as many groups as you like.
#' @param Group_Update_Table This is a data.table that has the column "gid" and one or more of the following columns: "new_grelevance", "new_group_name", "new_group_order", "new_description", "new_language", "new_randomization_group". These columns contain the information that you want to use to update the respective group parameters.
#' \itemize{
#' \item \strong{gid}: the gid of the group you would like to update <this column is mandatory!>
#' \item \strong{new_grelevance}: <optional> the group relevance you want to update- simply a string with a relevance equation
#' \item \strong{new_group_name}: <optional> change the group name
#' \item \strong{new_group_order}: <optional> change the order in which the groups are presented (this has restrictions)
#' \item \strong{new_description}: <optional> change group description
#' \item \strong{new_language}: <optional> change language of group
#' \item \strong{new_randomization_group}: <optional> assign the group to a randomization group- simply a string with the randomization group's name
#' }
#' @export
#' @examples \dontrun{
#' Update_Group_Properties(data.table(gid = 123455, new_grelevance = 1))
#' }
#'
Update_Group_Properties <- function(Group_Update_Table){
get_session_key() # Log in
Group_Update_Table <- setDT(Group_Update_Table)
Return_Values <- list()
for(i in 1:nrow(Group_Update_Table)){
current_group_properties <- call_limer(method = "get_group_properties",
params = list(iGroupID = Group_Update_Table[i]$gid
))
# Use the base language if there's either no language column, or if there's an NA in it
if("language" %in% names(Group_Update_Table)){
target_language <- ifelse(!is.na(Group_Update_Table[i]$language), Group_Update_Table[i]$language, current_group_properties[["language"]])
}
else{
target_language <- current_group_properties[["language"]]
}
# Get rid of columns that cannot be updated:
current_group_properties <- within(current_group_properties, rm(sid,gid))
# Block to eliminate the update if the column doesn't exist:
if(!("new_grelevance" %in% names(Group_Update_Table))){
current_group_properties <- within(current_group_properties, rm(grelevance))
}
else{
if(!is.na(Group_Update_Table[i]$new_grelevance)){
current_group_properties[["grelevance"]] <- Group_Update_Table[i]$new_grelevance
}
else{
current_group_properties <- within(current_group_properties, rm(grelevance))
}
}
if(!("new_group_name" %in% names(Group_Update_Table))){
current_group_properties <- within(current_group_properties, rm(group_name))
}
else{
if(!is.na(Group_Update_Table[i]$new_group_name)){
current_group_properties[["group_name"]] <- Group_Update_Table[i]$new_group_name
}
else{
current_group_properties <- within(current_group_properties, rm(group_name))
}
}
if(!("new_group_order" %in% names(Group_Update_Table))){
current_group_properties <- within(current_group_properties, rm(group_order))
}
else{
if(!is.na(Group_Update_Table[i]$new_group_order)){
current_group_properties[["group_order"]] <- Group_Update_Table[i]$new_group_order
}
else{
current_group_properties <- within(current_group_properties, rm(group_order))
}
}
if(!("new_description" %in% names(Group_Update_Table))){
current_group_properties <- within(current_group_properties, rm(description))
}
else{
if(!is.na(Group_Update_Table[i]$new_description)){
current_group_properties[["description"]] <- Group_Update_Table[i]$new_description
}
else{
current_group_properties <- within(current_group_properties, rm(description))
}
}
if(!("new_randomization_group" %in% names(Group_Update_Table))){
current_group_properties <- within(current_group_properties, rm(randomization_group))
}
else{
if(!is.na(Group_Update_Table[i]$new_randomization_group)){
current_group_properties[["randomization_group"]] <- Group_Update_Table[i]$new_randomization_group
}
else{
current_group_properties <- within(current_group_properties, rm(randomization_group))
}
}
# if(!("new_language" %in% names(Group_Update_Table))){
# current_group_properties <- within(current_group_properties, rm(language))
# }
# else{
# if(!is.na(Group_Update_Table[i]$new_language)){
# current_group_properties[["language"]] <- Group_Update_Table[i]$new_language
# }
# else{
# current_group_properties <- within(current_group_properties, rm(language))
# }
#
# }
# Update:
Return_Values[[paste0(Group_Update_Table[i]$gid)]] <- call_limer(method = "set_group_properties",
params = list(iGroupID = Group_Update_Table[i]$gid,
aGroupData = current_group_properties
))
}
Return_Table <- (rbindlist(Return_Values, idcol = "gid"))
setnames(Return_Table, old = names(Return_Table[, -c("gid")]), new = paste0(names(Return_Table[, -c("gid")]), ".update"))
Return_Table[, gid := as.numeric(gid)]
Group_Update_Table[, gid := as.numeric(gid)]
Group_Update_Table <- merge(Group_Update_Table, Return_Table, by = "gid", all.x = TRUE)
return(Group_Update_Table)
}
#' Batch query group properties
#'
#' This allows you to receive a list of the group properties of the groups specified by the gid column in the data.table given as Group_Properties_Query
#' @param Group_IDs A data.table specifying the groups of interest in the \strong{gid} column.
#' @export
#' @examples \dontrun{
#' Get_Group_Properties(data.table(gid = 12345))
#' }
#'
Get_Group_Properties <- function(Group_Properties_Query){
get_session_key() # Log in
Group_Properties_Query <- setDT(Group_Properties_Query)
Return_Values <- list()
for(i in 1:nrow(Group_Properties_Query)){
Return_Values[[paste0(Group_Properties_Query[i]$gid)]] <- call_limer(method = "get_group_properties",
params = list(iGroupID = Group_Properties_Query[i]$gid
))
}
Return_Table <- (rbindlist(Return_Values))
Return_Table[, gid := as.numeric(gid)]
Group_Properties_Query <- merge(Group_Properties_Query, Return_Table, by = "gid", all.x = TRUE)
return(Group_Properties_Query)
}
#' Get Group List
#'
#' This allows you to receive a list of the groups for the surveys specified by the sid column in the data.table given as Survey_IDs
#' @param Survey_IDs A data.table with a column specifying the \strong{sid} where the groups should be retrieved
#' @export
#' @examples \dontrun{
#' Get_Group_List(data.table(sid = 123456))
#' }
#'
Get_Group_List <- function(Survey_IDs){
get_session_key() # Log in
Survey_IDs <- setDT(Survey_IDs)
Survey_IDs[, sid := as.numeric(sid)]
Return_Values <- list()
for(i in 1:nrow(Survey_IDs)){
Return_Values[[paste0(Survey_IDs[i]$sid)]] <- call_limer(method = "list_groups",
params = list(iSurveyID = Survey_IDs[i]$sid
))
Return_Values[[paste0(Survey_IDs[i]$sid)]] <- within(Return_Values[[paste0(Survey_IDs[i]$sid)]], rm(id))
}
Return_Table <- (rbindlist(Return_Values))
setnames(Return_Table, old = c("language", "description"), new = c("language.group", "description.group"), skip_absent = TRUE)
Return_Table[, sid := as.numeric(sid)]
Survey_IDs <- merge(Survey_IDs, Return_Table, by = "sid", all = TRUE, suffixes = c("", ".group"))
Survey_IDs[, group_number := as.numeric(group_order)]
Survey_IDs[, group_number_ls := group_number+1]
return(Survey_IDs)
}
#' NEW NEW NEW (20210804)
#' This gets all of the questions from the surveys and binds them together in one table.
#'
#' @param Survey_IDs this is a data.table with at least one column \strong{sid} containing the Limesurvey survey IDs of all the parts in the correct order (if they are ordered survey parts)
#' @keywords Retrieve a list of the questions for the queries surveys
#' @export
#' @examples Question_List <- Get_Question_List(data.table(sid = 130394))
Get_Question_List <- function(Survey_IDs){
get_session_key()
Survey_IDs <- setDT(Survey_IDs)
Survey_IDs[, sid := as.numeric(sid)]
Survey_IDs <- unique(Survey_IDs[, .(sid)])
Question_List <- list()
for(i in 1:nrow(Survey_IDs)){
Question_List[[paste0(Survey_IDs[i]$sid)]] <- call_limer(method = "list_questions", params = list(iSurveyID = Survey_IDs[i]$sid))%>%select(-id)
} #end for loop
# Bind everything to have one list
Bound_Question_List <- rbindlist(Question_List, use.names = TRUE)%>%setDT
Bound_Question_List[, sid := as.numeric(sid)]
Group_List <- Get_Group_List(unique(Bound_Question_List[, .(sid)]))
Bound_Question_List <- merge(Bound_Question_List, Group_List, by = c("sid", "gid"), all.x = TRUE, suffixes = c("", ".group"), allow.cartesian = TRUE)
return(Bound_Question_List)
} #end function
#' Batch query survey properties
#'
#' This allows you to receive a list of the survey properties of the surveys specified by ID in the vector given as Survey_IDs
#' @param Survey_IDs A vector specifying the \strong{sid} of interest.
#' @export
#' @examples \dontrun{
#' Get_Survey_Properties_List(123456)
#' }
#'
Get_Survey_Properties_List <- function(Survey_IDs){
get_session_key()
Survey_Properties_List <- list()
for(i in Survey_IDs){
Survey_Properties_List[[paste0(i)]] <- call_limer(method = "get_survey_properties", params = list(iSurveyID = i))
} #end for loop
# Bind everything to have one list
Bound_Properties_List <- rbindlist(Survey_Properties_List, use.names = TRUE, idcol = TRUE)%>%setDT
return(Bound_Properties_List)
} #end function
#' Batch update question properties
#'
#' This allows you to change the question properties of as many questions as you like.
#' @param Question_Update_Table This is a data.table that has the following columns:
#' \itemize{
#' \item \strong{qid}: the qid of the question you would like to update <this column is mandatory!>
#' \item \strong{new_relevance}: <optional> the relevance equation you want to update- simply a string with a relevance equation
#' \item \strong{new_title}: <optional> this is what you might think of as the "question code"- it isn't visible to the participant and serves as the questions variable name in the export file
#' \item \strong{new_question}: <optional> the question text. This can also be html/css/javascript
#' \item \strong{new_help}: <optional> The help text for the question
#' \item \strong{new_preg}: <optional> I'm not even sure what this does. But, it is available for change.
#' \item \strong{new_other}: <optional> I'm not even sure what this does. But, it is available for change.
#' \item \strong{new_mandatory}: <optional> Here you can decide if the question is mandatory.
#' \item \strong{new_question_order}: <optional> Here you can set the question order.
#' \item \strong{new_scale_id}: <optional> I'm not even sure what this does. But, it is available for change.
#' \item \strong{new_same_default}: <optional> I'm not even sure what this does. But, it is available for change.
#' \item \strong{new_modulename}: <optional> I'm not even sure what this does. But, it is available for change.
#' \item \strong{language}: <optional> this is when you are changing different language versions of the question in a multilingual survey. If you do not add this column or leave it blank, the updates will default to only the base language of the survey. Please only one language per row. If you have 3 languages in your survey and you want to update all of them, you need a row for each language that sets, for example, the new_question or new_help. Multilingual surveys are tricky in that not all options will be available for all languages. Or, seen from another perspective, they need to be the same across all languages.
#' }
#' @export
#' @examples \dontrun{
#' Update_Question_Properties(data.table(qid = 123455, new_relevance = 1))
#' }
#'
Update_Question_Properties <- function(Question_Update_Table){
get_session_key() # Log in
Question_Update_Table <- setDT(Question_Update_Table)
Return_Values <- list()
for(i in 1:nrow(Question_Update_Table)){
current_question_properties <- call_limer(method = "get_question_properties",
params = list(iQuestionID = Question_Update_Table[i]$qid
))
# Use the base language if there's either no language column, or if there's an NA in it
if("language" %in% names(Question_Update_Table)){
target_language <- ifelse(!is.na(Question_Update_Table[i]$language), Question_Update_Table[i]$language, current_question_properties[["language"]])
}
else{
target_language <- current_question_properties[["language"]]
}
# get rid of all the fields that can't be updated
current_question_properties <- within(current_question_properties, rm(qid,parent_qid,sid,gid,type,language))
# Block to eliminate the update if the column doesn't exist:
if(!("new_relevance" %in% names(Question_Update_Table))){
current_question_properties <- within(current_question_properties, rm(relevance))
}
else{
if(!is.na(Question_Update_Table[i]$new_relevance)){
current_question_properties[["relevance"]] <- Question_Update_Table[i]$new_relevance
}
else{
current_question_properties <- within(current_question_properties, rm(relevance))
}
}
if(!("new_title" %in% names(Question_Update_Table))){
current_question_properties <- within(current_question_properties, rm(title))
}
else{
if(!is.na(Question_Update_Table[i]$new_title)){
current_question_properties[["title"]] <- Question_Update_Table[i]$new_title
}
else{
current_question_properties <- within(current_question_properties, rm(title))
}
}
if(!("new_question" %in% names(Question_Update_Table))){
current_question_properties <- within(current_question_properties, rm(question))
}
else{
if(!is.na(Question_Update_Table[i]$new_question)){
current_question_properties[["question"]] <- Question_Update_Table[i]$new_question
}
else{
current_question_properties <- within(current_question_properties, rm(question))
}
}
if(!("new_help" %in% names(Question_Update_Table))){
current_question_properties <- within(current_question_properties, rm(help))
}
else{
if(!is.na(Question_Update_Table[i]$new_help)){
current_question_properties[["help"]] <- Question_Update_Table[i]$new_help
}
else{
current_question_properties <- within(current_question_properties, rm(help))
}
}
if(!("new_preg" %in% names(Question_Update_Table))){
current_question_properties <- within(current_question_properties, rm(preg))
}
else{
if(!is.na(Question_Update_Table[i]$new_preg)){
current_question_properties[["preg"]] <- Question_Update_Table[i]$new_preg
}
else{
current_question_properties <- within(current_question_properties, rm(preg))
}
}
if(!("new_other" %in% names(Question_Update_Table))){
current_question_properties <- within(current_question_properties, rm(other))
}
else{
if(!is.na(Question_Update_Table[i]$new_other)){
current_question_properties[["other"]] <- Question_Update_Table[i]$new_other
}
else{
current_question_properties <- within(current_question_properties, rm(other))
}
}
if(!("new_mandatory" %in% names(Question_Update_Table))){
current_question_properties <- within(current_question_properties, rm(mandatory))
}
else{
if(!is.na(Question_Update_Table[i]$new_mandatory)){
current_question_properties[["mandatory"]] <- Question_Update_Table[i]$new_mandatory
}
else{
current_question_properties <- within(current_question_properties, rm(mandatory))
}
}
if(!("new_question_order" %in% names(Question_Update_Table))){
current_question_properties <- within(current_question_properties, rm(question_order))
}
else{
if(!is.na(Question_Update_Table[i]$new_question_order)){
current_question_properties[["question_order"]] <- Question_Update_Table[i]$new_question_order
}
else{
current_question_properties <- within(current_question_properties, rm(question_order))
}
}
if(!("new_scale_id" %in% names(Question_Update_Table))){
current_question_properties <- within(current_question_properties, rm(scale_id))
}
else{
if(!is.na(Question_Update_Table[i]$new_scale_id)){
current_question_properties[["scale_id"]] <- Question_Update_Table[i]$new_scale_id
}
else{
current_question_properties <- within(current_question_properties, rm(scale_id))
}
}
if(!("new_same_default" %in% names(Question_Update_Table))){
current_question_properties <- within(current_question_properties, rm(same_default))
}
else{
if(!is.na(Question_Update_Table[i]$new_same_default)){
current_question_properties[["same_default"]] <- Question_Update_Table[i]$new_same_default
}
else{
current_question_properties <- within(current_question_properties, rm(same_default))
}
}
if(!("new_modulename" %in% names(Question_Update_Table))){
current_question_properties <- within(current_question_properties, rm(modulename))
}
else{
if(!is.na(Question_Update_Table[i]$new_modulename)){
current_question_properties[["modulename"]] <- Question_Update_Table[i]$new_modulename
}
else{
current_question_properties <- within(current_question_properties, rm(modulename))
}
}
# Now update everything:
Return_Values[[paste0(Question_Update_Table[i]$qid)]] <- call_limer(method = "set_question_properties",
params = list(iQuestionID = Question_Update_Table[i]$qid,
aQuestionData = current_question_properties,
sLanguage = target_language
))
}
Return_Table <- (rbindlist(Return_Values, idcol = "qid"))
setnames(Return_Table, old = names(Return_Table[, -c("qid")]), new = paste0(names(Return_Table[, -c("qid")]), ".update"))
Return_Table[, qid := as.numeric(qid)]
Question_Update_Table[, qid := as.numeric(qid)]
Question_Update_Table <- merge(Question_Update_Table, Return_Table, by = "qid", all = TRUE)
return(Question_Update_Table)
}
#' Inject Javascript to hide question
#'
#' This allows you to batch hide questions using javascript. The questions will continue to function, but they will not be visible. This is not the same as the "hide" option in LS!
#' @param Questions_to_Hide data.table of Question \strong{qid} that should have this added to them, and optionally the \strong{language}, if it's a multilingual survey. Please remember, that the same question should have the same number of entries as the number of available language options- one for each language, when you want to hide them all.
#' @export
#' @examples \dontrun{
#' Hide_LS_Questions(123456)
#' }
#'
Hide_LS_Questions <- function(Questions_to_Hide){
get_session_key() # Log in
Questions_to_Hide <- setDT(Questions_to_Hide)
if(!("overwrite" %in% names(Questions_to_Hide))){
Questions_to_Hide[, overwrite := FALSE]
}
results <- list()
for(i in 1:nrow(Questions_to_Hide)){
# This part puts the results straight into the appropriate questions:
get_question_properties_current <- call_limer(method = "get_question_properties",
params = list(iQuestionID = Questions_to_Hide[i]$qid
))
if("language" %in% names(Questions_to_Hide)){
target_language <- ifelse(!is.na(Questions_to_Hide[i]$language), Questions_to_Hide[i]$language, get_question_properties_current[["language"]])
}else{
target_language <- get_question_properties_current[["language"]]
}
if(Questions_to_Hide[i]$overwrite){
Change <- data.table(qid = Questions_to_Hide[i]$qid, language = target_language, new_question = paste0("\n\n",
# Here's the hide script:
'<script type="text/javascript">','\n',
"var QID = '{QID}';",'\n',
'$(document).ready(function() {','\n',
"$('#question'+QID).hide();});",'\n',
'</script>'))
}else{
Change <- data.table(qid = Questions_to_Hide[i]$qid, language = target_language, new_question = paste0(get_question_properties_current[["question"]], "\n\n",
# Here's the hide script:
'<script type="text/javascript">','\n',
"var QID = '{QID}';",'\n',
'$(document).ready(function() {','\n',
"$('#question'+QID).hide();});",'\n',
'</script>'))
}
# get_question_properties_current[["question"]] <- paste0('<script type="text/javascript">','\n',
# "var QID = '{QID}';",'\n',
# '$(document).ready(function() {','\n',
# "$('#question'+QID).hide();});",'\n',
# '</script>')
# set_question_properties_result[paste0(i)] <- call_limer(method = "set_question_properties",
# params = list(iQuestionID = i,
# aQuestionData = get_question_properties_current
# ))
results[[paste0(Questions_to_Hide[i]$qid)]] <- Update_Question_Properties(Change)
} # end for loop
return(results)
} # end function
#' Find and replace text in a batch of questions
#'
#' This allows you to batch find and replace text that is in an unlimited number of questions
#' @param Questions data.table specifying the \strong{qid} and target \strong{language} (if you are looking/replacing for a different language than the base language)
#' @param Find_Text string of what the find
#' @param Replace_Text string of what to replace
#' @param Fixed this gets passed on to gsub- if it's TRUE (the default) then it will search for the exact string you enter. If it is FALSE, then you can use regex.
#' @export
#' @examples \dontrun{
#' Find_Replace_in_Question(data.table(qid = 123435, language = "en"), Find_Text = "Hello", Replace_Text = "Goodbye")
#' }
#'
Find_Replace_in_Question <- function(Questions, Find_Text, Replace_Text, Fixed = TRUE){
get_session_key() # Log in
Question_Update_Table <- setDT(Questions)
Question_Update_Table[, language.update := character()]
Question_Update_Table[, question.update := logical()]
Question_Update_Table[, text.found := logical()]
Return_Values <- list()
for(i in 1:nrow(Question_Update_Table)){
# # There is a bug in limesurvey that doesn't let you get the question properties for each language! If that bug is fixed, you could use this chunk!
# if("language" %in% names(Question_Update_Table)){
# current_question_properties <- call_limer(method = "get_question_properties",
# params = list(iQuestionID = Question_Update_Table[i]$qid,
# sLanguage = Question_Update_Table[i]$language
# ))
# }else{
# current_question_properties <- call_limer(method = "get_question_properties",
# params = list(iQuestionID = Question_Update_Table[i]$qid
# ))
# }
current_question_properties <- call_limer(method = "get_question_properties",
params = list(iQuestionID = Question_Update_Table[i]$qid
))
# Use the base language if there's either no language column, or if there's an NA in it
if("language" %in% names(Question_Update_Table)){
target_language <- ifelse(!is.na(Question_Update_Table[i]$language), Question_Update_Table[i]$language, current_question_properties[["language"]])
}else{
target_language <- current_question_properties[["language"]]
}
# Just to track progress
Question_Update_Table[i]$language.update <- target_language
# get rid of all the fields that can't be updated
current_question_properties <- within(current_question_properties, rm(qid,parent_qid,sid,gid,type,language, relevance, title, help, preg, other, mandatory, question_order, scale_id, same_default, modulename))
# This is just to confirm that the text was found
Question_Update_Table[i]$text.found <- !is_empty(grep(Find_Text, current_question_properties[["question"]], fixed = TRUE))
current_question_properties[["question"]] <- gsub(Find_Text, Replace_Text, current_question_properties[["question"]], fixed = Fixed)
Question_Update_Table[i]$question.update <- call_limer(method = "set_question_properties",
params = list(iQuestionID = Question_Update_Table[i]$qid,
aQuestionData = current_question_properties,
sLanguage = target_language
))
} # end of the for loop
return(Question_Update_Table)
} # end of find/replace function
#' Create new surveys by the batch
#'
#' This allows you to add one or a whole batch of new surveys
#' @param Surveys data.table specifying:
#' \itemize{
#' \item \strong{sid}: <this column is mandatory!> the sid of the survey that you would like to assign it. If it is already taken, Limesurvey will graciously assign you a random sid instead.
#' \item \strong{title}: <this column is mandatory!> What should the survey be called?
#' \item \strong{language}: <this column is mandatory!> What is the base language of the survey? This needs to be given as a code, for example, english would be "en". For a reference of language codes (but not all of these are supported!): \link[dest=https://www.w3schools.com/tags/ref_language_codes.asp]{Language Codes}
#' \item \strong{format}: <this column is mandatory!> A code to specify question appearance format (A, G or S) for "All on one page", "Group by Group", or "Single questions". The default is group by group (G).
#' }
#' @export
#' @examples \dontrun{
#' Create_Survey(Surveys = data.table(sid = c(123456), title = c("Fancy Test Survey"), language = c("en"), format = c("G")))
#' }
#'
Create_Survey <- function(Surveys){
get_session_key() # Log in
Surveys <- setDT(Surveys)
Surveys[, format := ifelse(!is.na(format), format, "G")]
Surveys[, language := ifelse(!is.na(language), language, "en")]
Return_Values <- list()
for(i in 1:nrow(Surveys)){
Return_Values[[paste0(Surveys[i]$sid)]] <- call_limer(method = "add_survey",
params = list(iSurveyID = Surveys[i]$sid,
sSurveyTitle = Surveys[i]$title,
sSurveyLanguage = Surveys[i]$language,
sformat = Surveys[i]$format
))
} # end of the for loop
return(Return_Values)
} # end of function
#' Delete surveys by the batch
#'
#' This allows you to delete one or a whole batch of surveys
#' @param Surveys data.table specifying the \strong{sid}(s) to be deleted
#' @export
#' @examples \dontrun{
#' Delete_Survey(Surveys = data.table(sid = c(123456))
#' }
#'
Delete_Survey <- function(Surveys){
get_session_key() # Log in
Surveys <- setDT(Surveys)
Return_Values <- list()
for(i in 1:nrow(Surveys)){
Return_Values[[paste0(Surveys[i]$sid)]] <- call_limer(method = "delete_survey",
params = list(iSurveyID = Surveys[i]$sid
))
} # end of the for loop
} # end of function
#' Add language
#'
#' This allows you to add a language (or multiple languages) to one or a whole batch of surveys
#' @param Surveys data.table specifying the \strong{sid}(s) where the languages should be added, and the respective \strong{language} that should be added. Remember, one row for each language.
#' \link[dest=https://www.w3schools.com/tags/ref_language_codes.asp]{Language Codes}
#' @export
#' @examples \dontrun{
#' Add_Language(Surveys = data.table(sid = c(123456, 123654), language = c("fr", "it"))
#' }
#'
Add_Language <- function(Surveys){
get_session_key() # Log in
Surveys <- setDT(Surveys)
Return_Values <- list()
for(i in 1:nrow(Surveys)){
Return_Values[[paste0(Surveys[i]$sid)]] <- call_limer(method = "add_language",
params = list(iSurveyID = Surveys[i]$sid,
sLanguage = Surveys[i]$language
))
} # end of the for loop
} # end of function
#' Delete language
#'
#' This allows you to delete a language (or multiple languages) to one or a whole batch of surveys
#' @param Surveys data.table specifying the \strong{sid}(s) where the languages should be deleted, and the respective \strong{language} that should be removed
#' \link[dest=https://www.w3schools.com/tags/ref_language_codes.asp]{Language Codes}
#' @export
#' @examples \dontrun{
#' Delete_Language(Surveys = data.table(sid = c(123456, 123654), language = c("fr", "it"))
#' }
#'
Delete_Language <- function(Surveys){
get_session_key() # Log in
Surveys <- setDT(Surveys)
Return_Values <- list()
for(i in 1:nrow(Surveys)){
Return_Values[[paste0(Surveys[i]$sid)]] <- call_limer(method = "delete_language",
params = list(iSurveyID = Surveys[i]$sid,
sLanguage = Surveys[i]$language
))
} # end of the for loop
} # end of function
#' Add Randomization Question
#'
#' This imports some randomizer questions that yeild a random value from 1 to the value specified in the randomizer variable
#' @param Import_Table data.table specifying the sid, gid, title, randomizer
#' \itemize{
#' \item \strong{sid}: <this column is mandatory!> the sid of the survey where you want to place a randomization question
#' \item \strong{gid}: <this column is mandatory!> the gid where the randomization question should live
#' \item \strong{title}: <this column is mandatory!> the name of the randomization question
#' \item \strong{randomizer}: <this column is mandatory!> the highest number of the randomization- it will randomize between 1 and this number (integers)
#' \item \strong{template}: <this column is mandatory!> the name of the question template for the randomization question. If you use one other than the "randomizer.lsq" provided, you'll need to make sure the lsq has the title stored as "PLACEHOLDER" and that the default value of the question is set to "RANDOMVALUES". Honestly, it's best to use the provided template.
#' }
#' @param Folder_Location_Templates <optional, defaults to "Templates">: this is where the randomization question template is stored.
#' @export
#' @examples \dontrun{
#' Import_Questions_Rand(Import_Table = data.table(sid = c(123456, 123654), gid = c(34244, 43242), title = c("Rand1, Rand2), randomizer = c(3, 4), template = "randomizer.lsq"), Folder_Location_Templates = "Templates")
#' }
#'
Import_Questions_Rand <- function(Import_Table, Folder_Location_Templates = "Templates"){
get_session_key() # Log in
if(is.na(Folder_Location_Templates)){
Template_Top_Folder <- ""
}
else{
Template_Top_Folder <- paste0(Folder_Location_Templates, "/")
}
results <- list()
for(i in 1:nrow(Import_Table)){
template <- read_file(paste0(Template_Top_Folder, Import_Table[i]$template))
template <- str_replace(template, pattern = "PLACEHOLDER", replacement = Import_Table[i]$title)
template <- str_replace(template, pattern = "RANDOMVALUES", replacement = paste0("rand(1,",Import_Table[i]$randomizer,")"))
template <- base64_enc(template)
results[[paste0(i)]] <- call_limer(method = "import_question",
params = list(iSurveyID = Import_Table[i]$sid,
iGroupID = Import_Table[i]$gid,
sImportData = template,
sImportDataType = "lsq"
))
}# end for loop
return(results)
} # end function
#' Figure out the groups questions belong to, when there is a capped number in any given group
#'
#' If there is a cap on the number of subquestions, you'll want to know which groups each subquestion belongs to, and you'll want to split them up sensibly and give them proper names/create their associated questions. This function helps you figure out their group belonging.
#' @param Questions_to_Group data.table with the question information and, most importantly, a grouping variable (\strong{grouping_variable})that specifies which subquestions belong to which group.
#' @param max_number default is 50 (max number currently allowed by LS)- this is the largest number of subquestions allowed in any given group
#' @param grouping_variable this is a character string that specifies which variable should be used for grouping.
#' @param even_split this is a boolean input that specifies whether you want the function to try to give you (more or less) even sized groups or not. Default is TRUE. FALSE would mean that there will be lists that go up to the max_number and then (possibly) one list that could be significantly shorter- e.g. you have 201 subquestions in a group- this would make 5 groups, four of which would have 50 and the last one would have 1. If you had the same situation and even_split was true you'd end up with 5 groups that have 41 subquestions each, and one with 37- 5 groups in total.
#' @export
#' @examples \dontrun{
#' Figure_Out_Groups(Questions_to_Group = Questions, max_number = 20, grouping_variable = "industry", even_split = TRUE)
#' }
Figure_Out_Groups <- function(Questions_to_Group, max_number = 50, grouping_variable, even_split = TRUE){
Questions_to_Group <- setDT(Questions_to_Group)
Questions_to_Group <- Questions_to_Group[, group_total := .N, by = grouping_variable]%>%
setorderv(cols = c(grouping_variable))
if(even_split == FALSE){
Questions_to_Group <- Questions_to_Group[, cap := rep(c(1:max_number), times = ceiling(max(group_total)/max_number), length.out = max(group_total)), by = grouping_variable]
Questions_to_Group <- Questions_to_Group[, question_group := seq(.N), by = c("cap", grouping_variable)]
Questions_to_Group <- Questions_to_Group[, possible_group_name := paste0(get(grouping_variable), "x", question_group)]
}else{
Questions_to_Group <- Questions_to_Group[, more_even_split := ceiling((group_total)/ceiling((group_total)/max_number))]
Questions_to_Group <- Questions_to_Group[, cap := rep(c(1:more_even_split), times = ceiling(max(group_total)/more_even_split), length.out = max(group_total)), by = grouping_variable]
Questions_to_Group <- Questions_to_Group[, question_group := seq(.N), by = c("cap", grouping_variable)]
Questions_to_Group <- Questions_to_Group[, possible_group_name := paste0(get(grouping_variable), "x", question_group)]
}
return(Questions_to_Group)
}
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.