I am trying to find a straightforward solution to this problem. I understand that there are three ways to automate the creation of a Qualtrics survey with a txt file: either using the Simple format TXT file, the Advanced format TXT file, or using a QSF file, which is basically a serialized json object.
In order to automatically include the same javascript code in a massive set of questions (and avoid copy-pasting it manually), I wanted to create an importable file with the questions. However, none of the TXT file formats seems to allow including javascript.
It seems that the only option left would be to import a QSF file. Put if truth be told, given there is no API provided by Qualtrics to help understand this format, it's been hell of a nightmare to try to automatically build a QSF almost from scratch. So far I've been trying to make sense of an exported file, but I'm starting to consider that it's just not worth the effort.
Any ideas on how I could better solve this problem? To give you an idea of the magnitude, what I'm talking about is around 250 different questions with the same javascript code.
Thank you so much in advance for any insight I may receive.
EDIT:
I was asked for some sample javascript code, so here it is:
Qualtrics.SurveyEngine.addOnload(
function()
{
document.getElementById('SkinContent').style.backgroundColor = "Lightblue";
}
);
There are two solutions so that it will apply to all pages/questions:
The best way is just to add some custom CSS under Look&Feel/Advanced:
#SkinContent { background-color: Lightblue;}
To do it with JavaScript, under Look&Feel/Advanced add your Javascript inside a script tag to the header or footer:
<script type="text/javascript">
Qualtrics.SurveyEngine.addOnload(function() {
$('SkinContent').style.backgroundColor = "Lightblue";
});
</script>
It took me quite a while to do this, but I finally managed to find a solution (please note my javascript code is quite complex, interacting with embedded metadata and so, unlike the example I put above, so #T. Gibbons' solution didn't work for me).
I followed these steps to solve the problem:
Create a "prototype" survey with a few sample items.
Export this survey as a QSF file.
Read the QSF file as a JSON object.
Identify the properties that relate to the items. In my case, I used R and the package rjson, so the important properties of the resulting list object questionnaire were questionnaire$SurveyElements[[6]]$SecondaryAttribute (contains the number of items), questionnaire$SurveyElements[[1]]$Payload[[1]]$BlockElements (list of elements that form a block, in order), and the elements in questionnaire$SurveyElements, from element 8 on (sometimes it can be from element 7 on, I think it depends on whether the trash is empty or not) which are the definitions of the items themselves.
Create items from the sample ones present in the exported suvey, and add them to the questionnaire object, modifying those properties.
Serialize the object into the JSON format, and save it as a QSF file.
Import the QSF file as a new survey in Qualtrics.
Use the block with the new items at convenience (e.g. I copied the block to the library and then imported it into my master project).
Here is a simple code that can do the operations needed, in R:
library(rjson)
library(tidyverse)
library(magrittr)
PROTOTYPE.FILE <- "Prototype.qsf"
JAVASCRIPT.FILE <- "Item_javascript_code.txt"
# Computes the number of questions in the survey (returns a 'character', as stored in the QSF file)
get.item.count <- function(questionnaire)
questionnaire$SurveyElements %>% length() %>% subtract(7)
# Sets the property "nº of questions" in the questionnaire JSON object
set.num.items <- function(questionnaire, num.items = questionnaire %>% get.item.count) {
questionnaire$SurveyElements[[6]]$SecondaryAttribute <- num.items %>% as.character
return(questionnaire)
}
create.item <- function(item.num, stem, choices, javascript = NULL, html.text = FALSE) {
item <- list(
SurveyID = "SV_0rLrTOSkjnIWa2x",
Element = "SQ",
PrimaryAttribute = paste0("QID", item.num),
SecondaryAttribute = stem,
TertiaryAttribute = NULL,
Payload = list(
QuestionText = stem,
DataExportTag = paste0("Q", item.num),
QuestionType = "MC",
Selector = "SAVR",
SubSelector = "TX",
Configuration = list(
QuestionDescriptionOption = "UseText"
),
QuestionDescription = stem,
Choices = list(),
ChoiceOrder = choices %>% seq_along,
Validation = list(
Settings = list(
ForceResponse = "OFF", ForceResponseType = "ON", Type = "None"
)
),
Language = list(),
QuestionID = paste0("QID", item.num)
)
)
for(choice in choices) {
item$Payload$Choices <- item$Payload$Choices %>% append(list(list(Display = choice)))
}
names(item$Payload$Choices) <- item$Payload$Choices %>% seq_along %>% as.character
if(javascript %>% is.null %>% not) {
item$Payload$QuestionJS = javascript
item$Payload$PrivateData = FALSE
}
return(item)
}
add.item <- function(questionnaire, stem, choices, javascript = NULL, html.text = FALSE) {
item.num <- questionnaire %>% get.item.count +1
questionnaire$SurveyElements %<>% append(
list(
create.item(questionnaire %>% get.item.count +1, stem, choices, javascript)
)
)
questionnaire$SurveyElements[[1]]$Payload[[1]]$BlockElements %<>% append(
list(
list(
Type = "Question",
QuestionID = paste0("QID", item.num)
)
)
)
return(questionnaire)
}
questionnaire <- fromJSON(file = PROTOTYPE.FILE)
questionnaire$SurveyElements <- questionnaire$SurveyElements[1:7] # Drop items in the list
questionnaire$SurveyElements[[1]]$Payload[[1]]$BlockElements <- NULL # Empty item list in the block
for(question in 1:10) {
questionnaire %<>% add.item(
"Question stem here",
c("Choice 1", "Choice 2", "etc..."),
## Javascript code here
)
}
questionnaire %<>% set.num.items()
questionnaire %>% toJSON() %>% writeLines(con = "Output_prototype.qsf")
This can be much more sophisticated, including different types of questions, timers, page breaks, etc., but for the question at hand I think it's quite enough with this.
Related
The approach I am taking for my shiny app design would be easiest if the app could detect the ID of the last clicked or updated widget.
This question appears to solve the problem. However, when I run the MCVE with the accepted answer I get no reactivity at all.
Current code as follows. This is essentially the linked question with the obvious substitution made from the accepted answer.
library(shiny)
ui <- fluidPage(
tags$head(
# taken from accepted answer
tags$script(
HTML("$(document).on('shiny:inputchanged', function(event) {
Shiny.setInputValue('last_input', event.name);
});")
)
# through to here
),
numericInput("num1", "Numeric", 0),
textInput("text1", "Text"),
selectInput("select1", "Select", choices = LETTERS[1:4]),
selectInput("selectize1", "Selectize", choices = letters[1:4]),
textOutput("textout")
)
server <- function(input, output, session) {
output$textout <- renderText({
input$last_input
})
}
shinyApp(ui, server)
Expected behavior:
When the widgets are interacted with, then the id of the last widget interacted with is displayed.
Observed behavior:
Regardless of which widget I interact with, no widget ids are displayed.
Checked tried:
Updating Shiny version.
The other code suggestions on the original post - no change
Some, but not full, reactivity from using ....ready(function(){$('input').on('shiny:inputchanged'... instead of just .on('shiny:inputchanged'.
I am an R, not a JS, programmer. Can someone with both skills can advise how to get this working?
You need to exclude the input, which is set in the JS part regarding the events to monitor, otherwise you'll end up in an endless loop.
Please check my related answer here:
library(shiny)
ui <- fluidPage(
tags$head(
tags$script(
"$(document).on('shiny:inputchanged', function(event) {
if (event.name != 'changed') {
Shiny.setInputValue('changed', event.name);
}
});"
)
),
numericInput("num1", "Numeric", 0),
textInput("text1", "Text"),
selectInput("select1", "Select", choices = LETTERS[1:4]),
selectInput("selectize1", "Selectize", choices = letters[1:4]),
textOutput("textout")
)
server <- function(input, output, session) {
output$textout <- renderText({
input$changed
})
}
shinyApp(ui, server)
Here the according documentation can be found.
I am determined to learn R-Shiny, for this I am trying to implement an editable table using the DT package, that reads and writes the edits to a database using the RSQLite package, and this actually works so I am excluding this part of the code from the example below to drastically improve the readability.
I am able to write the edits with the approach suggested on the shiny website https://rstudio.github.io/DT/shiny.html that links to the examples in this page https://yihui.shinyapps.io/DT-edit/ .
With the following code code, once I inline edit a cell, I can print a couple of debug lines and using the dbExecute() function I can send the edit to the database.
observeEvent(input$data_cell_edit, {
info = input$data_cell_edit
str(info)
print(info)
print("Edit Triggered")
#Here I write my edits
}
Now I'd also like to add a dropdown menu for editing factorial columns, so I suggested to follow the approach suggested at this answer render dropdown for single column in DT shiny
Using the javascript below I can replace the cells with the corresponding dropdown menu. However the problem here is that once an edit is performed via the dropdown menu, the event data_cell_edit is not triggered, so the database update can't be performed.
While an option could be to enclose the write to the database directly in the javascript code, the best way for me would be to improve that javascript to trigger the data_cell_edit callback somehow.
Is this possible at all? Also, for some reasons
library(shiny)
library(DT)
ui <- fluidPage(
DT::dataTableOutput('foo'),
verbatimTextOutput('sel')
)
server <- function(input, output, session) {
data <- head(iris, 5)
for (i in 1:nrow(data)) {
data$species_selector[i] <- as.character(selectInput(paste0("sel", i), "", choices = unique(iris$Species), width = "100px"))
}
output$foo = DT::renderDataTable(
data,
escape = FALSE,
editable=TRUE,
callback = JS("table.rows().every(function(i, tab, row) {
var $this = $(this.node());
$this.attr('id', this.data()[0]);
$this.addClass('shiny-input-container');
});
Shiny.unbindAll(table.table().node());
Shiny.bindAll(table.table().node());")
)
observeEvent(input$foo_cell_edit, {
info = input$foo_cell_edit
print("event triggered")
#Here I write my edits
})
}
shinyApp(ui, server)
tldr:
with the code above, when I edit a normal cell, I trigger the event that writes "event triggered" to the console.
when I edit a cell with the dropdown menu, this event is not triggered.
How can I trigger that event?
I am building a Shiny app and leveraging the DTedit library to allow users to edit data tables inline in the UI. This is working well, but I want to add some additional formatting to the tables (making some columns appear as percents, making other columns appear as dollar amounts). The problem with this is that the output of a DTedit function is a rendered output object (it expects to be passed directly to the UI - I can't do any paste0 or sapply operations on it).
The only upside is that I can pass dataframe options arguments to the DTEdit function before the output gets rendered - this includes the ability to pass JS Callbacks. Something like this:
datatable(head(iris, 20), options = list(
initComplete = JS(
"function(settings, json) {",
"$(this.api().table().header()).css({'background-color': '#000', 'color': '#fff'});",
"}")
))
The example above is showing changing the background color of the header to black, but as I mentioned, I'm interested in formatting several columns as percents / dollar amounts.
So this is all well and good, but the only problem is I know nothing about JS! I'm looking for guidance on building the correct JS callback to format my data table - thanks in advance!
I'm afraid I don't know Javascript either, but I know enough R to have modified DTedit to allow formatting with DT's format*() functions.
A modified version of DTedit is available on my Github repository, and is referenced as a pull request on jbryer/DTedit.
A vignette is available, look under 'formatting columns', and the example code is reproduced below, using the mtcars dataset.
library(DTedit)
library(magrittr) # provides the pipe '%>%' operator
server <- function(input, output, session) {
dtedit(
input, output,
name = 'mtcarstable',
thedata = mtcars,
datatable.rownames = TRUE, # needed for the format*() functions to work
datatable.call = function(...) {
datatable(...) %>%
formatSignif('qsec', 2) %>%
formatCurrency('mpg') %>%
formatStyle(
'cyl',
color = 'red', backgroundColor = 'orange', fontWeight = 'bold'
)
# note, none of this is proper formatting for the mtcars data!
# but serves to demonstrate the formatting
}
)
}
ui <- fluidPage(
h3('mtcars'),
uiOutput('mtcarstable')
)
shinyApp(ui = ui, server = server)
The formatting done is, by and large, not actually appropriate to the mtcars dataset, but used just as an example. Picture of formatted mtcars table
In the first example of this website (https://cran.r-project.org/web/packages/canvasXpress/vignettes/getting_started.html#scatter-3d-plot), there's a 3d scatterplot made with canvasxpress package using R.
Just copying and pasting the code you can easily get the results on the example...
data <- t(iris[,1:4])
varAnnot <- as.matrix(iris[,5])
colnames(varAnnot) <- "Species"
canvasXpress(t(data), varAnnot=varAnnot, graphType='Scatter3D', colorBy='Species')
I'm wondering if there's a way to pass within the canvasXpress(t(data), varAnnot=varAnnot, graphType='Scatter3D', colorBy='Species')
an argument like:
canvasXpress(t(data), varAnnot=varAnnot, graphType='Scatter3D', colorBy='Species', colors="rgb(153,204,255)","rgb(204,102,0)","rgb(153,76,0)","rgb(169,131,7)","rgb(153,255,153)","rgb(105,150,150)","rgb(183,120,68)","rgb(131,172,208)","rgb(194,224,118)","rgb(250,220,90)","rgb(255,84,159)","rgb(255,175,84)","rgb(154,184,183)","rgb(210,166,131)","rgb(61,105,155)","rgb(135,172,34)","rgb(205,169,8)","rgb(208,33,88)","rgb(208,115,0)","rgb(86,118,118)")
In order to change the colors of the points in the graph...
I've tried to change in the menubar of the html generated...specifically on colors arguments (setting a new array of RGB colors), and then ctrl + alt + R to reproduce the changes...but nothing happened...
Any thoughts about it?
Thanks
Pass in a colorKey:
colorKey = list("Species"=list("setosa"="gold","versicolor"="silver","virginica"="red"))
and then call:
data <- t(iris[,1:4])
varAnnot <- as.matrix(iris[,5])
colnames(varAnnot) <- "Species"
canvasXpress(t(data),
varAnnot=varAnnot,
graphType='Scatter3D',
colorBy='Species',
colorKey=colorKey)
Actual question
How do I design(*) a shiny app where certain UI elements depend on multiple conditions that need to be systematically handled?
(*) in a maintainable way that won't drive you mad ;-)
Details
I've read Build a dynamic UI that reacts to user input and like conditionalPanel(), but I have the feeling it's too "one-dimensional" for the timetracking app I would like to build (source code on GitHub).
What I want to be able to do:
Have one (or more) UI element(s) that can trigger conditional UI parts:
State 1
Those conditional UI parts usually have some input fields and at least two action buttons: Create and Cancel:
State 2
If Create is clicked, the input should be appropriately processed (e.g. writing stuff to a DB) and then the conditional UI part should "disappear" again as its condition "expired":
State 3
State 4
If Cancel is clicked, the UI part should "disappear" again as its condition "expired":
State 4
A subsequent click on Trigger should "start the cycle" again
Problem with multiple dependencies and dynamic dependency states:
AFAIU, if I simply put the dependencies (i.e. input$action_trigger, input$action_create and input$action_cancel below) into the reactive context that builds the conditional UI, then I face multiple rounds of invalidation until all dependencies have reached a stable state (see output$ui_conditional <- renderUI({}) below).
From a UX-perspective, this feels like having to click on elements multiple times until you get what you want (check out an example of this "multiple-clicks-necessary" behavior in my timetracking app).
That's why I came up with the idea of introducing sort of a "dependency state clearance" layer (see ui_decision <- reactive({}) below)
Current solution
My current solution feels very wrong, very fragile and very high maintenance. You can also find it at GitHub
Globals:
library(shiny)
GLOBALS <- list()
GLOBALS$debug$enabled <- TRUE
# Auxiliary functions -----------------------------------------------------
createDynamicUi_conditional <- function(
input,
output,
ui_decision,
debug = GLOBALS$debug$enabled
) {
if (debug) {
message("Dynamic UI: conditional ----------")
print(Sys.time())
}
## Form components //
container <- list()
field <- "title"
name <- "Title"
value <- ""
container[[field]] <- textInput(field, name, value)
field <- "description"
name <- "Description"
value <- ""
container[[field]] <- textInput(field, name, value)
## Bundle in box //
value <- if (ui_decision == "hide") {
div()
} else if (ui_decision == "show" || ui_decision == "create") {
container$buttons <- div(style="display:inline-block",
actionButton("action_create", "Create"),
actionButton("action_cancel", "Cancel")
)
do.call(div, args = list(container, title = "conditional dynamic UI"))
} else {
"Not implemented yet"
}
# print(value)
value
}
UI part:
# UI ----------------------------------------------------------------------
ui <- fluidPage(
actionButton("action_trigger", "Trigger 1"),
h3("Database state"),
textOutput("result"),
p(),
uiOutput("ui_conditional")
)
Server part:
# Server ------------------------------------------------------------------
server <- function(input, output, session) {
#####################
## REACTIVE VALUES ##
#####################
db <- reactiveValues(
title = "",
description = ""
)
ui_control <- reactiveValues(
action_trigger = 0,
action_trigger__last = 0,
action_create = 0,
action_create__last = 0,
action_cancel = 0,
action_cancel__last = 0
)
#################
## UI DECISION ##
#################
ui_decision <- reactive({
## Dependencies //
## Trigger button:
value <- input$action_trigger
if (ui_control$action_trigger != value) ui_control$action_trigger <- value
## Create button:
## Dynamically created within `createDynamicUi_conditional`
value <- input$action_create
if (is.null(value)) {
value <- 0
}
if (ui_control$action_create != value) {
ui_control$action_create <- value
}
## Cancel button:
## Dynamically created within `createDynamicUi_conditional`
value <- input$action_cancel
if (is.null(value)) {
value <- 0
}
if (ui_control$action_cancel != value) {
ui_control$action_cancel <- value
}
if (GLOBALS$debug$enabled) {
message("Dependency clearance -----")
message("action_trigger:")
print(ui_control$action_trigger)
print(ui_control$action_trigger__last)
message("action_create:")
print(ui_control$action_create)
print(ui_control$action_create__last)
message("action_cancel:")
print(ui_control$action_cancel)
print(ui_control$action_cancel__last)
}
ui_decision <- if (
c (ui_control$action_trigger == 0 && ui_control$action_trigger == 0) ||
c(
ui_control$action_trigger > 0 &&
ui_control$action_trigger <= ui_control$action_trigger__last &&
ui_control$action_cancel > 0 &&
ui_control$action_cancel > ui_control$action_cancel__last
) ||
c(
ui_control$action_create == 0 &&
ui_control$action_create__last > 0
)
) {
"hide"
} else if (
ui_control$action_trigger >= ui_control$action_trigger__last &&
ui_control$action_create == ui_control$action_create__last
) {
## Synchronize //
ui_control$action_cancel__last <- ui_control$action_cancel
"show"
} else if (
ui_control$action_create > ui_control$action_create__last
) {
"create"
} else {
"Not implemented yet"
}
if (GLOBALS$debug$enabled) {
print(ui_decision)
}
## Synchronize //
ui_control$action_trigger__last <- ui_control$action_trigger
ui_control$action_create__last <- ui_control$action_create
ui_decision
})
output$ui_conditional <- renderUI({
createDynamicUi_conditional(input, output, ui_decision = ui_decision())
})
#################
## WRITE TO DB ##
#################
writeToDb <- reactive({
ui_decision <- ui_decision()
if (ui_decision == "create") {
db$title <- input$title
db$description <- input$description
}
})
###################
## RENDER RESULT ##
###################
output$result <- renderText({
writeToDb()
c(
paste0("Title: ", db$title),
paste0("Description: ", db$description)
)
})
}
Running the app:
shinyApp(ui, server)
Big picture
This is the app that I'm actually having in mind: timetrackr
Source code on GitHub.
It has been build without introducing a clearance layer as drafted above. While it does provide the desired functionality, very often, you need to click UI elements more than once until a stable dependency state is reached which is really irritating.
I'll start with the solution:
library(shiny)
ui <- fluidPage(
actionButton("action_trigger", "Trigger 1"),
h3("Database state"),
textOutput("result"),
p(),
uiOutput("ui_conditional")
)
server <- function(input, output, session) {
ui_control <- reactiveValues(show = FALSE)
output$ui_conditional <- renderUI({
if (!ui_control$show) return()
tagList(
textInput("title", "Title"),
textInput("description", "Description"),
div(style="display:inline-block",
actionButton("action_create", "Create"),
actionButton("action_cancel", "Cancel")
)
)
})
observeEvent(input$action_trigger, {
ui_control$show <- TRUE
})
observeEvent(input$action_create, {
writeToDb()
ui_control$show <- FALSE
})
observeEvent(input$action_cancel, {
ui_control$show <- FALSE
})
writeToDb <- function() {
# ...
}
}
shinyApp(ui, server)
I hope that this is sufficiently simple as to be self-explanatory. Let me know if it is not.
There are several principles that you can follow to make your Shiny reactive code much more robust and maintainable--and usually simpler, too.
Each action button should have its own observeEvent, and you generally shouldn't need to use the action button value anywhere but as the first argument to observeEvent. It's rarely advisable to use an action button any other way, even though it can be tempting; especially if you're comparing the action button's value to its previous value, that's a pretty sure sign that you're on the wrong track.
Reactive expressions should never have side effects--e.g. writing to disk, or assigning to non-local variables (and reactive value objects like ui_control count as non-local variables when you set them from inside a reactive expression). These type of actions should instead be done in an observe() or observeEvent(). I will elaborate much more on this in early 2016.
Like regular functions, reactive expressions and observers should ideally have a single responsibility--one calculation or coherent set of calculations (in the case of reactive expressions), or one action or coherent set of actions (in the case of observers). If you're having trouble thinking of an informative and specific name for a function, that can be a sign that the function is doing too much; the same is true for reactive expressions (in this case, ui_decision is pretty vague).
In response to your general concern about instability while dynamically built UI/inputs come online, when you need to use such inputs, you can guard their invocations with validate(need(input$foo, FALSE)). You can put this in e.g. the beginning of a reactive expression, and it will silently abort execution of itself and any callers if input$foo is not yet available (i.e. it's NULL, FALSE, "", or a number of other falsy values). This is a hugely helpful feature of Shiny that we have done a notably poor job of promoting. I also think we made the API too general and not easy enough to use, which I hope to rectify soon. In the meantime, see http://shiny.rstudio.com/articles/validation.html and/or https://www.youtube.com/watch?v=7sQ6AEDFjZ4.
The solution given by Joe is great (obviously, as he wrote Shiny...) and has lots of useful detailed information, so I don't want to take away from that, but I would like to offer another approach to solve the conditional UI problem.
You could use the shinyjs package to show or hide UI elements on demand. I find this to be a much simpler and cleaner solution when you do require a non-trivial condition for showing/hiding UI. Here's the code, modified slightly from Joe's answer:
library(shiny)
library(shinyjs)
ui <- fluidPage(
useShinyjs(),
actionButton("action_trigger", "Trigger 1"),
h3("Database state"),
textOutput("result"),
p(),
div(
id = "ui_control",
textInput("title", "Title"),
textInput("description", "Description"),
div(style="display:inline-block",
actionButton("action_create", "Create"),
actionButton("action_cancel", "Cancel")
)
)
)
server <- function(input, output, session) {
observeEvent(input$action_trigger, {
show("ui_control")
})
observeEvent(input$action_create, {
writeToDb()
hide("ui_control")
})
observeEvent(input$action_cancel, {
hide("ui_control")
})
writeToDb <- function() {
# ...
}
}
shinyApp(ui, server)
As you can see, the only difference here is that I moved the UI back into the ui portion instead of being created with a renderUI, added a div with an id to the UI section that you want to show/hide, and used shinyjs::show or shinyjs::hide instead of a reactive value.
I personally find this a bit easier because it keeps your UI in your UI rather than needing to move it into the server, and it also is more intuitive to me to just call a show/hide function rather than use a reactive value that will trigger a rewrite of the HTML.
However, since this isn't exactly the way Shiny is meant to be used (this solution bypasses reactivity), I'd be interested to know if Joe has any comments on using this approach vs the more native Shiny approach that he wrote.