Shiny slider on logarithmic scale - r

I'm using Shiny to build a simple web application with a slider that controls what p-values should be displayed in the output.
How can I make the slider act on a logarithmic, rather than linear, scale?
At the moment I have:
sliderInput("pvalue",
"PValue:",
min = 0,
max = 1e-2,
value = c(0, 1e-2)
),
Thanks!

UPDATE (May 2018):
This is now possible through the shinyWidgets::sliderTextInput() control. You can specify custom steps (e.g., logarithmic intervals), and the slider steps through those. The downside is that you need to specify each step, rather than a max and min and have the slider calculate the steps, but it works well for this kind of application.
Small example:
library(shiny)
ui <- fluidPage(
shinyWidgets::sliderTextInput("pvalue2","PValue:",
choices=c(0, 0.0001, 0.001, 0.01),
selected=0, grid = T)
)
server <- function(input, output) {}
shinyApp(ui, server)

I wasn't sure exactly what you wanted as the output, but what I did was have the possible p-values be [0, 0.00001, 0.0001, 0.001, 0.01]. If you want something a little different, hopefully this answer is a good enough starting point.
Basically, first I created an array that holds the values of the numbers (0, 0.0000.1, ...), and then I just use the special update function from the slider's API to make these values stick to the slider. It's pretty simple once you figure out how to use the slider's API. Also, for some reason running this inside RStudio looks weird, but in a browser it's fine. Also, note that I have a 5ms delay because I want to make sure this runs after the slider gets initialized. Not the cleanest solution, there's probably a better way to do that, but it works.
library(shiny)
JScode <-
"$(function() {
setTimeout(function(){
var vals = [0];
var powStart = 5;
var powStop = 2;
for (i = powStart; i >= powStop; i--) {
var val = Math.pow(10, -i);
val = parseFloat(val.toFixed(8));
vals.push(val);
}
$('#pvalue').data('ionRangeSlider').update({'values':vals})
}, 5)})"
runApp(shinyApp(
ui = fluidPage(
tags$head(tags$script(HTML(JScode))),
sliderInput("pvalue",
"PValue:",
min = 0,
max = 1e-2,
value = c(0, 1e-2)
)
),
server = function(input, output, session) {
}
))

Not sure this thread is still active but just in case wanted to add a more generic way of "logifying" an inputSlider using the prettify function attribute of the ionRangeSlider rather than overwriting the values with the advantage being that you can define the min, max, step and default value of the inputSlider as usual and then all that happens on the Javascript side is a change of the displayed values (two options presented, one for numeric output, one for scientific notation):
library(shiny)
# logifySlider javascript function
JS.logify <-
"
// function to logify a sliderInput
function logifySlider (sliderId, sci = false) {
if (sci) {
// scientific style
$('#'+sliderId).data('ionRangeSlider').update({
'prettify': function (num) { return ('10<sup>'+num+'</sup>'); }
})
} else {
// regular number style
$('#'+sliderId).data('ionRangeSlider').update({
'prettify': function (num) { return (Math.pow(10, num)); }
})
}
}"
# call logifySlider for each relevant sliderInput
JS.onload <-
"
// execute upon document loading
$(document).ready(function() {
// wait a few ms to allow other scripts to execute
setTimeout(function() {
// include call for each slider
logifySlider('log_slider', sci = false)
logifySlider('log_slider2', sci = true)
}, 5)})
"
ui <- fluidPage(
tags$head(tags$script(HTML(JS.logify))),
tags$head(tags$script(HTML(JS.onload))),
sliderInput("log_slider", "Log Slider (numbers):",
min = -5, max = 3, value = -4, step = 1),
sliderInput("log_slider2", "Log Slider (sci. notation):",
min = -5, max = 3, value = 1, step = 0.5),
br(),
textOutput("readout1"),
textOutput("readout2")
)
server <- function(input, output, session) {
output$readout1 <- reactive({
paste0("Selected value (numbers): ", input$log_slider, " = ", 10^input$log_slider)
})
output$readout2 <- reactive({
paste0("Selected value (sci. notation): ", input$log_slider2, " = ", 10^input$log_slider2)
})
}
shinyApp(ui, server)

I don't have shiny at the moment with me, I have extended the range a little, what will happen if you try something like this:
sliderInput("pvalue",
"PValue:",
min = 1e-02,
max = 1e+02,
value = -10^seq(-2, 2)
),
your post it is mentioned 1e-2, i have used 1e-02, i checked like below
> 1e-2==1e-02
[1] TRUE

The reason the question hasn't gotten more attention is that its hard to answer. To do what the asker wants, you have to write javascript and inject it into the webpage. Below is code I adapted to properly format a shiny slider as dates. I haven't tried to modify it for logarithmic because I only learned enough javascript to tinker with this one script, and then promptly deleted it from memory to make room for more important things like the seasonal beer menu at the bar down the block.
Anyhoo:
output$selectUI <-
renderUI(
list(sliderInput(inputId = "target", label = "Date",
min = 0, max = diff_months(targetEnd(),targetStart()) - 1,
value = diff_months(targetEnd(),targetStart()) - 1,
animate = animationOptions( loop = T)),
singleton(HTML(
'
<script type="text/javascript">
$(document).ready(function() {
var monthNames = [ "Jan.", "Feb.", "Mar.", "Apr.", "May", "June",
"July", "Aug.", "Sept.", "Oct.", "Nov.", "Dec." ];
var endDate = new Date(',
year(Sys.Date()),',', month(Sys.Date())
,', 1);
var slider = $("#dates").slider();
var labels = slider.domNode.find(".jslider-label span");
labels.eq(0).text("Jan., 1962");
labels.eq(1).text([monthNames[endDate.getUTCMonth() +1], endDate.getUTCFullYear()].join(", "));
// override the default "nice" function.
slider.nice = function(value) {
alert("hi")
var ref_date = new Date(1962, 1, 1);
var slider_date = new Date(ref_date.setMonth(ref_date.getMonth() + value));
return [monthNames[slider_date.getUTCMonth()], slider_date.getUTCFullYear()].join(", ");
}
$(slider).trigger("slidechange");
})
$(document).ready(function() {
var monthNames = [ "Jan.", "Feb.", "Mar.", "Apr.", "May", "June",
"July", "Aug.", "Sept.", "Oct.", "Nov.", "Dec." ];
var slider = $("#target").slider();
var labels = slider.domNode.find(".jslider-label span");
labels.eq(0).text([monthNames[', month(targetStart()) +1, '],', year(targetStart()), '].join(", "));
labels.eq(1).text([monthNames[', month(targetEnd()) + 1, '], ', year(targetEnd()), '].join(", "));
// override the default "nice" function.
slider.nice = function(value) {
alert("hi")
var ref_date = new Date(', year(targetStart()), ', ', month(targetStart()),',1 );
// each slider step is 4 weeks, translating to 24 * 3600 * 1000 milliseconds
var slider_date = new Date(ref_date.setMonth(ref_date.getMonth() + value - 1));
return [monthNames[slider_date.getUTCMonth()],
slider_date.getUTCFullYear()].join(", ");
}
$(slider).trigger("slidechange");
})
</script>
')
)
)
)

Related

Paste into selectizeInput with high number of options

I want to be able to paste into selectizeInput to select multiple items at once. There are good solutions for this:
https://github.com/rstudio/shiny/issues/1663
The issue is that my list contains huge amounts of items, so the app will lag like crazy and sometimes crash. Setting maxOptions = 50 takes care of the lag, but pasting something that's not within the first 100 items, will only return "undefined", i.e., I can paste gene_1,gene_2,gene_3, but not gene_51,gene_52,gene_53 when all items are included.
Any ideas? Could you grep the list of items in the return function that would take some more time but not make the app lag like crazy?
genes <- paste0("gene_",1:50000)
ui = fluidPage(
selectizeInput("x", "Paste multiple genes:",
genes[1:100],
multiple = TRUE,
options = list(maxOptions = 50,
splitOn = I("(function() { return /[,;]/; })()"),
create = I("function(input, callback){
return {
value: input,
text: input
};
}")
)
),actionButton("button","update")
)
server<- function(input, output,session){
observeEvent(input$button,{
updateSelectizeInput(session,"x", "Paste multiple genes:",
genes,
server = TRUE,
options = list(maxOptions = 50,
splitOn = I("(function() { return /[,;]/; })()"),
create = I("function(input, callback){
return {
value: input,
text: input
};
}")
)
)
})
}
shinyApp(ui=ui, server = server)

Sift through each row in a dataframe and manually classify it

Can someone recommend an efficient way to sift through each row in a dataframe and manually classify it? For example I might be wanting to separate spam from e-mail, or shortlist job adverts, job applicants, or dating agency profiles (I understand Tinder does this by getting you to swipe left or right).
My dataset is small enough to classify manually. I suppose if it was larger I might only want to manually classify a portion of it in order to train a machine-learning algorithm such as Naive Bayes to finish the task for me.
I'll show you what I've got at the moment, but this isn't a particularly original task, so there must be a less crude way to do this that someone has already thought of! (As a newcomer, I'm impressed by the power of R, but also nonplussed when little tasks like clearing the screen or capturing a keystroke turn out to be non-trivial)
# Let us suppose I am using this built-in dataset to draw up a
# shortlist of where I might wish to go on holiday
df <- data.frame(state.x77);
# pp - define a task-specific pretty print function
pp <- function(row) {
print(row); # Example dataset is simple enough to just print the entire row
}
# cls - clear the screen (this hack works on Windows but I've commented it for now)
cls <- function() {
#system("powershell -ExecutionPolicy Bypass -command (New-Object -ComObject Wscript.Shell).SendKeys([string][char]12)");
}
# It would halve the number of keystrokes needed if I knew a way to read
# a single character
readcharacter <- readline;
sift <- function(df, pp)
{
classification = rep('', nrow(df));
for (nRow in 1:nrow(df))
{
cls();
pp(df[nRow,]);
cat("\nEnter 'a' to discard, 'd' to keep, 'q' to quit\n");
char <- '';
while (char != 'a' && char != 'd' && char != 'q') {
char <- readcharacter();
}
if (char == 'q')
break;
classification[nRow] = char;
}
return(cbind(df,classification=classification));
}
result = sift(df, pp);
cls();
cat("Shortlist:\n");
print(row.names(result[result$classification=='d',]));
So how does the StackOverflow community feel about me using this Shiny app to solve my problem? I wouldn't expect to see Shiny used in this early part of data analysis - normally it only comes into play once we have some results we'd like to explore or present dynamically.
Learning Shiny was fun and useful, but I'd much prefer it if a less complicated answer could be found.
library(shiny);
#
# shortlist - function that allows us to shortlist through the rows in a data frame efficiently
#
shortlist <- function(df, sTitle, sRowName) {
createUI <- function() {
listHeading <- list(
textOutput(outputId = "Progress"),
tags$br(),
fluidRow(
column(width=1, sRowName),
column(width=9, textOutput(outputId = "RowName"))));
listFields <- lapply(names(df), function(sFieldname) {
return(fluidRow(
column(width=1, sFieldname),
column(width=9, textOutput(outputId = sFieldname))));
});
listInputs <- list(
tags$br(),
tags$table(
tags$tr(
tags$td(" "),
tags$td(actionButton(inputId="Up", label="W", disabled=TRUE, width="100%"))),
tags$tr(
tags$td(width="100px", actionButton(inputId="Discard", label="Discard, A", width="100%")),
tags$td(width="100px", actionButton(inputId="Down", label="S", disabled=TRUE, width="100%")),
tags$td(width="100px", actionButton(inputId="Keep", label="Keep, D", width="100%")))),
tags$script("
// JavaScript implemented keyboard shortcuts, including lots of conditions to
// ensure we're finished processing one keystroke before we start the next.
var bReady = false;
$(document).on('shiny:recalculating', function(event) {
bReady = false;
});
$(document).on('shiny:recalculated', function(event) {
setTimeout(function() {bReady = true;}, 500);
});
$(document).on('keypress', function(event) {
if (bReady) {
switch(event.key.toLowerCase()) {
case 'a':
document.getElementById('Discard').click();
bReady = false;
break;
case 'd':
document.getElementById('Keep').click();
bReady = false;
break;
}
}
});
// End of JavaScript
"));
listPanel <- list(
title = sTitle,
tags$br(),
conditionalPanel(
condition = paste("input.Keep + input.Discard <", nrow(df)),
append(append(listHeading, listFields), listInputs)));
listShortlist <- list(
tags$hr(),
tags$h4("Shortlist:"),
dataTableOutput(outputId="Shortlist"));
ui <- do.call(fluidPage, append(listPanel, listShortlist));
return(ui);
}
app <- shinyApp(ui = createUI(), server = function(input, output) {
classification <- rep('', nrow(df));
getRow <- reactive({
return (input$Keep + input$Discard + 1);
});
classifyRow <- function(nRow, char) {
if (nRow <= nrow(df)) {
classification[nRow] <<- char;
}
# In interactive mode, automatically stop the app when we're finished
if ( interactive() && nRow >= nrow(df) ) {
stopApp(classification);
}
}
observeEvent(input$Discard, {classifyRow(getRow() - 1, 'a')});
observeEvent(input$Keep, {classifyRow(getRow() - 1, 'd')});
output$Progress = renderText({paste("Showing record", getRow(), "of", nrow(df))});
output$RowName = renderText({row.names(df)[getRow()]});
lapply(names(df), function(sFieldname) {
output[[sFieldname]] <- renderText({df[getRow(), sFieldname]});
});
output$Shortlist <- renderDataTable(options = list(paging = FALSE, searching = FALSE), {
# Mention the 'keep' input to ensure this code is called when the 'keep' button
# is pressed. That way the shortlist gets updated when an item to be added to it.
dummy <- input$Keep;
# Construct the shortlist
shortlist <- data.frame(row.names(df[classification == 'd',]));
colnames(shortlist) <- sRowName;
return(shortlist);
});
});
if (interactive()) {
classification <- runApp(app);
return(cbind(df, classification = classification));
} else {
return(app);
}
}
#
# And now some example code.
# Shortlist the built in state.x77 data set (let us suppose I am drawing up
# a shortlist of where I might wish to go on holiday)
#
df <- data.frame(state.x77);
result <- shortlist(df = df, "Choose states", "State");
if (interactive()) {
cat("Shortlist:\n");
print(row.names(result[result$classification == 'd',]));
} else {
return (result);
}

Dynamically creating tabs with plots in shiny without re-creating existing tabs

I would like to create dynamic tabs, where each time the user clicks a button, a new tab would be created. Each tab has the same content, with a variety of widgets that the user can use to select which sets of data to be plotted.
Currently, I am using the solution here to dynamically create my tabs, but with the change that lapply is calling a function that calls tabPanel and adds content to the tabs
`
renderUI({
some_data <- # Dataframe that data is extracted goes here
createTabs <- function(tabNum, some_data)
{
tabPanel(title = paste("Map", tabNum, sep=" "),
fluidRow(
column(
width = 3,
wellPanel(
#widgets are added here
}
mTabs <- lapply(0:input$map, createTabs, some_data)
do.call(tabsetPanel, mTabs)
})
`
And the methods of for loops posted here to create the plots on each tab.
However, it seems like instead of creating a new tab, the 2 solutions above both re-create all the existing tabs. So if there are currently 10 tabs open, all 10 tabs get re-created. Unfortunately, this also resets all the user settings on each tab (in addition to slowing down the app), and extra provisions must be taken as shown here , which further slows down the app because of the large number of input objects that must be created.
I saw a solution for menu items that seems to solve this problem by simply storing all the menu items in a list, and each time a new menu item is generated, it is simply added to the list so that all the other existing items don't need to be created. Is something like this possible for tabs and rendering plots as well?
This is the code:
newTabs <- renderMenu({
menu_list <- list(
menu_vals$menu_list)
sidebarMenu(.list = menu_list)
})
menu_vals = reactiveValues(menu_list = NULL)
observeEvent(eventExpr = input$placeholder,
handlerExpr = {
menu_vals$menu_list[[input$placeholder]] <- menuSubItem(paste("Saved Simulation", length(menu_vals$menu_list) + 1, sep = " "),
tabName = paste("saved_sim", length(menu_vals$menu_list) + 1))
})
If someone can explain to me what menu_list <- list(menu_vals$menu_list) is doing , why Rstudio says it must be inside a reactive expression, and why a new list called menu_vals is created with menu_list = null, it would be greatly appreciated as well :)
Edit: I think I was able to prevent the plots from being re-created each time a new tab is created and also bypass the need for a max number of plots using
observeEvent(eventExpr = input$map,
handlerExpr = {
output[[paste0("outputComparePlot",simNum,"-",input$map)]] <- outputComparePlot(sessionEnv, config, react, input, simNum, input$map) #This function contains the call to renderPlot
})
However, I still cannot figure out how to use this for creating tabs. I tried the same method but it didnt work.
I would like to present a solution that adds a feature to shiny which should have been implemented into shiny base long ago. A function to append tabPanels to existing tabsetPanels. I already tried similar stuff here and here, but this time, I feel like this solution is way more stable and versatile.
For this feature, you need to insert 4 parts of code into your shiny app. Then you can add any set of tabPanels each having any content to an existing tabsetPanel by calling addTabToTabset. Its arguments are a tabPanel (or a list of tabPanels) and the name (id) of your target tabsetPanel. It even works for navbarPage, if you just want to add normal tabPanels.
The code which should be copy-pasted, is inside the "Important!" comments.
My comments will probably not be enough to grasp what's really happening (and why, of course). So if you want to get more into detail, please leave a message and I will try to elaborate.
Copy-Paste-Run-Play!
library(shiny)
ui <- shinyUI(fluidPage(
# Important! : JavaScript functionality to add the Tabs
tags$head(tags$script(HTML("
/* In coherence with the original Shiny way, tab names are created with random numbers.
To avoid duplicate IDs, we collect all generated IDs. */
var hrefCollection = [];
Shiny.addCustomMessageHandler('addTabToTabset', function(message){
var hrefCodes = [];
/* Getting the right tabsetPanel */
var tabsetTarget = document.getElementById(message.tabsetName);
/* Iterating through all Panel elements */
for(var i = 0; i < message.titles.length; i++){
/* Creating 6-digit tab ID and check, whether it was already assigned. */
do {
hrefCodes[i] = Math.floor(Math.random()*100000);
}
while(hrefCollection.indexOf(hrefCodes[i]) != -1);
hrefCollection = hrefCollection.concat(hrefCodes[i]);
/* Creating node in the navigation bar */
var navNode = document.createElement('li');
var linkNode = document.createElement('a');
linkNode.appendChild(document.createTextNode(message.titles[i]));
linkNode.setAttribute('data-toggle', 'tab');
linkNode.setAttribute('data-value', message.titles[i]);
linkNode.setAttribute('href', '#tab-' + hrefCodes[i]);
navNode.appendChild(linkNode);
tabsetTarget.appendChild(navNode);
};
/* Move the tabs content to where they are normally stored. Using timeout, because
it can take some 20-50 millis until the elements are created. */
setTimeout(function(){
var creationPool = document.getElementById('creationPool').childNodes;
var tabContainerTarget = document.getElementsByClassName('tab-content')[0];
/* Again iterate through all Panels. */
for(var i = 0; i < creationPool.length; i++){
var tabContent = creationPool[i];
tabContent.setAttribute('id', 'tab-' + hrefCodes[i]);
tabContainerTarget.appendChild(tabContent);
};
}, 100);
});
"))),
# End Important
tabsetPanel(id = "mainTabset",
tabPanel("InitialPanel1", "Some Text here to show this is InitialPanel1",
actionButton("goCreate", "Go create a new Tab!"),
textOutput("creationInfo")
),
tabPanel("InitialPanel2", "Some Text here to show this is InitialPanel2 and not some other Panel")
),
# Important! : 'Freshly baked' tabs first enter here.
uiOutput("creationPool", style = "display: none;")
# End Important
))
server <- function(input, output, session){
# Important! : creationPool should be hidden to avoid elements flashing before they are moved.
# But hidden elements are ignored by shiny, unless this option below is set.
output$creationPool <- renderUI({})
outputOptions(output, "creationPool", suspendWhenHidden = FALSE)
# End Important
# Important! : This is the make-easy wrapper for adding new tabPanels.
addTabToTabset <- function(Panels, tabsetName){
titles <- lapply(Panels, function(Panel){return(Panel$attribs$title)})
Panels <- lapply(Panels, function(Panel){Panel$attribs$title <- NULL; return(Panel)})
output$creationPool <- renderUI({Panels})
session$sendCustomMessage(type = "addTabToTabset", message = list(titles = titles, tabsetName = tabsetName))
}
# End Important
# From here: Just for demonstration
output$creationInfo <- renderText({
paste0("The next tab will be named NewTab", input$goCreate + 1)
})
observeEvent(input$goCreate, {
nr <- input$goCreate
newTabPanels <- list(
tabPanel(paste0("NewTab", nr),
actionButton(paste0("Button", nr), "Some new button!"),
textOutput(paste0("Text", nr))
),
tabPanel(paste0("AlsoNewTab", nr), sliderInput(paste0("Slider", nr), label = NULL, min = 0, max = 1, value = 1))
)
output[[paste0("Text", nr)]] <- renderText({
if(input[[paste0("Button", nr)]] == 0){
"Try pushing this button!"
} else {
paste("Button number", nr , "works!")
}
})
addTabToTabset(newTabPanels, "mainTabset")
})
}
shinyApp(ui, server)
Probably thanks to #k-rohde, there's now natively available in Shiny a set of methods to add/remove/append tabs in a tabset:
library(shiny)
runApp(list(
ui=fluidPage(
fluidRow(
actionLink("newTab", "Append tab"),
actionLink("removeTab", "Remove current tab")
),
tabsetPanel(id="myTabs", type="pills")
),
server=function(input, output, session){
tabIndex <- reactiveVal(0)
observeEvent(input$newTab, {
tabIndex(tabIndex() + 1)
appendTab("myTabs", tabPanel(tabIndex(), tags$p(paste("I'm tab", tabIndex()))), select=TRUE)
})
observeEvent(input$removeTab, {
removeTab("myTabs", target=input$myTabs)
})
}
))

Shiny: use shinyjs to fetch cookie data

I want to fetch cookie data from my Shiny app using shinyjs. I have created a cookie, "samplecookie=testval"; and I want to be able to retrieve the value of samplecookie. I use the below javascript function (where I pass the cookieName and it returns the corresponding value).
function fetchCookie(name) {
var nameEQ = name + "=";
var ca = document.cookie.split(";");
for(var i=0;i < ca.length;i++) {
var c = ca[i];
while (c.charAt(0)==" ") c = c.substring(1,c.length);
if (c.indexOf(nameEQ) == 0) return c.substring(nameEQ.length,c.length);
}
return "No such cookie";
Below is the javascript code in the shiny app
jsCode<-'shinyjs.tstfunc=
function (name) {
var nameEQ = name + "=";
var ca = document.cookie.split(";");
for(var i=0;i < ca.length;i++) {
var c = ca[i];
while (c.charAt(0)==" ") c = c.substring(1,c.length);
if (c.indexOf(nameEQ) == 0) return c.substring(nameEQ.length,c.length);
return "No such cookie";
}
}'
ui <- shinyUI(fluidPage(mainPanel(
useShinyjs(),
extendShinyjs(text = jsCode)
)))
server <- function(input, output)
{
observe({
x=js$tstfunc("samplecookie")
print(x)
})
}
shinyApp(ui=ui, server=server)
I am expecting that when I pass "samplecookie" as a parameter to the tstfunc() function, it should print "testval" on the console. But every time I keep getting a NULL value returned. Can someone help me understand what I am doing wrong? Appreciate any help. Thanks.
I'm the author of shinyjs. You cannot use it like that to pass values from JS to R. The only way to pass a value from JS to R is to use inputs. In JavaScript you'd have to call the Shiny.onInputChange() function, and in R you need to add an observe/reactive statement that listens to that input being changed.
Read this page to learn about passing values from JS to R
The code you provide is a bit weird and hard to read so here's a simple example of how to do this. This code simply asks JavaScript to pass the current time to R, it's simple but it shows how to do this
library(shiny)
library(shinyjs)
jsCode <- 'shinyjs.gettime = function(params) {
var time = Date();
Shiny.onInputChange("jstime", time);
}'
ui <- fluidPage(
useShinyjs(),
extendShinyjs(text = jsCode, functions = "gettime")
)
server <- function(input, output) {
js$gettime()
observe({
cat(input$jstime)
})
}
shinyApp(ui = ui, server = server)

Shiny saving URL state subpages and tabs

I would like to have a shiny website that keeps the dynamic choices in the URL as output, so you can copy and share the URL.
I took this code as an example:
https://gist.github.com/amackey/6841cf03e54d021175f0
And modified it to my case, which is a webpage with a navbarPage and multiple tabs per element in the bar.
What I would like is the URL to direct the user to the right element
in the first level tabPanel, and the right tab in the second level
tabPanel.
This is, if the user has navigated to "Delta Foxtrot" and then to
"Hotel", then changed the parameters to
#beverage=Tea;milk=TRUE;sugarLumps=3;customer=mycustomer, I would
like the URL to send the user to "Delta Foxtrot" -> "Hotel", instead
of starting at the first tab of the first panel element.
Ideally I would like a working example, since everything I tried so far hasn't worked.
Any ideas?
# ui.R
library(shiny)
hashProxy <- function(inputoutputID) {
div(id=inputoutputID,class=inputoutputID,tag("div",""));
}
# Define UI for shiny d3 chatter application
shinyUI(navbarPage('URLtests', id="page", collapsable=TRUE, inverse=FALSE,
tabPanel("Alfa Bravo",
tabsetPanel(
tabPanel("Charlie",
tags$p("Nothing to see here. Everything is in the 'Delta Foxtrot' 'Hotel' tab")
)
)
)
,tabPanel("Delta Foxtrot",
tabsetPanel(
tabPanel("Golf",
tags$p("Nothing to see here. Everything is in the 'Delta Foxtrot' 'Hotel' tab")
)
,tabPanel("Hotel",
tags$p("This widget is a demonstration of how to preserve input state across sessions, using the URL hash."),
selectInput("beverage", "Choose a beverage:",
choices = c("Tea", "Coffee", "Cocoa")),
checkboxInput("milk", "Milk"),
sliderInput("sugarLumps", "Sugar Lumps:",
min=0, max=10, value=3),
textInput("customer", "Your Name:"),
includeHTML("URL.js"),
h3(textOutput("order")),
hashProxy("hash")
)
)
)
))
# server.R
library(shiny)
url_fields_to_sync <- c("beverage","milk","sugarLumps","customer");
# Define server logic required to respond to d3 requests
shinyServer(function(input, output, clientData) {
# Generate a plot of the requested variable against mpg and only
# include outliers if requested
output$order <- reactiveText(function() {
paste(input$beverage,
if(input$milk) "with milk" else ", black",
"and",
if (input$sugarLumps == 0) "no" else input$sugarLumps,
"sugar lumps",
"for",
if (input$customer == "") "next customer" else input$customer)
})
firstTime <- TRUE
output$hash <- reactiveText(function() {
newHash = paste(collapse=";",
Map(function(field) {
paste(sep="=",
field,
input[[field]])
},
url_fields_to_sync))
# the VERY FIRST time we pass the input hash up.
return(
if (!firstTime) {
newHash
} else {
if (is.null(input$hash)) {
NULL
} else {
firstTime<<-F;
isolate(input$hash)
}
}
)
})
})
# URL.js
<script type="text/javascript">
(function(){
this.countValue=0;
var changeInputsFromHash = function(newHash) {
// get hash OUTPUT
var hashVal = $(newHash).data().shinyInputBinding.getValue($(newHash))
if (hashVal == "") return
// get values encoded in hash
var keyVals = hashVal.substring(1).split(";").map(function(x){return x.split("=")})
// find input bindings corresponding to them
keyVals.map(function(x) {
var el=$("#"+x[0])
if (el.length > 0 && el.val() != x[1]) {
console.log("Attempting to update input " + x[0] + " with value " + x[1]);
if (el.attr("type") == "checkbox") {
el.prop('checked',x[1]=="TRUE")
el.change()
} else if(el.attr("type") == "radio") {
console.log("I don't know how to update radios")
} else if(el.attr("type") == "slider") {
// This case should be setValue but it's not implemented in shiny
el.slider("value",x[1])
//el.change()
} else {
el.data().shinyInputBinding.setValue(el[0],x[1])
el.change()
}
}
})
}
var HashOutputBinding = new Shiny.OutputBinding();
$.extend(HashOutputBinding, {
find: function(scope) {
return $(scope).find(".hash");
},
renderError: function(el,error) {
console.log("Shiny app failed to calculate new hash");
},
renderValue: function(el,data) {
console.log("Updated hash");
document.location.hash=data;
changeInputsFromHash(el);
}
});
Shiny.outputBindings.register(HashOutputBinding);
var HashInputBinding = new Shiny.InputBinding();
$.extend(HashInputBinding, {
find: function(scope) {
return $(scope).find(".hash");
},
getValue: function(el) {
return document.location.hash;
},
subscribe: function(el, callback) {
window.addEventListener("hashchange",
function(e) {
changeInputsFromHash(el);
callback();
}
, false);
}
});
Shiny.inputBindings.register(HashInputBinding);
})()
</script>
EDITED: I ran the example code in the answer, but couldn't get it to work. See screenshot.
UPDATE
Shiny .14 now available on CRAN supports saving app state in a URL. See this article
This answer is a more in-depth answer than my first that uses the entire sample code provided by OP. I've decided to add it as a new answer in light of the bounty. My original answer used a simplified version of this so that someone else coming to the answer wouldn't have to read through any extraneous code to find what they're looking for. Hopefully, this extended version will clear up any difficulties you're having. Parts I've added to your R code are surrounded with ### ... ###.
server.r
# server.R
library(shiny)
url_fields_to_sync <- c("beverage","milk","sugarLumps","customer");
# Define server logic required to respond to d3 requests
shinyServer(function(input, output, session) { # session is the common name for this variable, not clientData
# Generate a plot of the requested variable against mpg and only
# include outliers if requested
output$order <- reactiveText(function() {
paste(input$beverage,
if(input$milk) "with milk" else ", black",
"and",
if (input$sugarLumps == 0) "no" else input$sugarLumps,
"sugar lumps",
"for",
if (input$customer == "") "next customer" else input$customer)
})
firstTime <- TRUE
output$hash <- reactiveText(function() {
newHash = paste(collapse=";",
Map(function(field) {
paste(sep="=",
field,
input[[field]])
},
url_fields_to_sync))
# the VERY FIRST time we pass the input hash up.
return(
if (!firstTime) {
newHash
} else {
if (is.null(input$hash)) {
NULL
} else {
firstTime<<-F;
isolate(input$hash)
}
}
)
})
###
# whenever your input values change, including the navbar and tabpanels, send
# a message to the client to update the URL with the input variables.
# setURL is defined in url_handler.js
observe({
reactlist <- reactiveValuesToList(input)
reactvals <- grep("^ss-|^shiny-", names(reactlist), value=TRUE, invert=TRUE) # strip shiny related URL parameters
reactstr <- lapply(reactlist[reactvals], as.character) # handle conversion of special data types
session$sendCustomMessage(type='setURL', reactstr)
})
observe({ # this observer executes once, when the page loads
# data is a list when an entry for each variable specified
# in the URL. We'll assume the possibility of the following
# variables, which may or may not be present:
# nav= The navbar tab desired (either Alfa Bravo or Delta Foxtrot)
# tab= The desired tab within the specified nav bar tab, e.g., Golf or Hotel
# beverage= The desired beverage selection
# sugar= The desired number of sugar lumps
#
# If any of these variables aren't specified, they won't be used, and
# the tabs and inputs will remain at their default value.
data <- parseQueryString(session$clientData$url_search)
# the navbar tab and tabpanel variables are two variables
# we have to pass to the client for the update to take place
# if nav is defined, send a message to the client to set the nav tab
if (! is.null(data$page)) {
session$sendCustomMessage(type='setNavbar', data)
}
# if the tab variable is defined, send a message to client to update the tab
if (any(sapply(data[c('alfa_bravo_tabs', 'delta_foxtrot_tabs')], Negate(is.null)))) {
session$sendCustomMessage(type='setTab', data)
}
# the rest of the variables can be set with shiny's update* methods
if (! is.null(data$beverage)) { # if a variable isn't specified, it will be NULL
updateSelectInput(session, 'beverage', selected=data$beverage)
}
if (! is.null(data$sugarLumps)) {
sugar <- as.numeric(data$sugarLumps) # variables come in as character, update to numeric
updateNumericInput(session, 'sugarLumps', value=sugar)
}
})
###
})
ui.r
library(shiny)
hashProxy <- function(inputoutputID) {
div(id=inputoutputID,class=inputoutputID,tag("div",""));
}
# Define UI for shiny d3 chatter application
shinyUI(navbarPage('URLtests', id="page", collapsable=TRUE, inverse=FALSE,
tabPanel("Alfa Bravo",
tabsetPanel(
###
id='alfa_bravo_tabs', # you need to set an ID for your tabpanels
###
tabPanel("Charlie",
tags$p("Nothing to see here. Everything is in the 'Delta Foxtrot' 'Hotel' tab")
)
)
)
,tabPanel("Delta Foxtrot",
tabsetPanel(
###
id='delta_foxtrot_tabs', # you need to set an ID for your tabpanels
###
tabPanel("Golf",
tags$p("Nothing to see here. Everything is in the 'Delta Foxtrot' 'Hotel' tab")
)
,tabPanel("Hotel", id='hotel',
tags$p("This widget is a demonstration of how to preserve input state across sessions, using the URL hash."),
selectInput("beverage", "Choose a beverage:",
choices = c("Tea", "Coffee", "Cocoa")),
checkboxInput("milk", "Milk"),
sliderInput("sugarLumps", "Sugar Lumps:",
min=0, max=10, value=3),
textInput("customer", "Your Name:"),
#includeHTML("URL.js"),
###
includeHTML('url_handler.js'), # include the new script
###
h3(textOutput("order")),
hashProxy("hash")
)
)
)
))
url_handler.js
<script>
Shiny.addCustomMessageHandler('setNavbar',
function(data) {
// create a reference to the desired navbar tab. page is the
// id of the navbarPage. a:contains says look for
// the subelement that contains the contents of data.nav
var nav_ref = '#page a:contains(\"' + data.page + '\")';
$(nav_ref).tab('show');
}
)
Shiny.addCustomMessageHandler('setTab',
function(data) {
// pick the right tabpanel ID based on the value of data.nav
if (data.page == 'Alfa Bravo') {
var tabpanel_id = 'alfa_bravo_tabs';
} else {
var tabpanel_id = 'delta_foxtrot_tabs';
}
// combine this with a reference to the desired tab itself.
var tab_ref = '#' + tabpanel_id + ' a:contains(\"' + data[tabpanel_id] + '\")';
$(tab_ref).tab('show');
}
)
Shiny.addCustomMessageHandler('setURL',
function(data) {
// make each key and value URL safe (replacing spaces, etc.), then join
// them and put them in the URL
var search_terms = [];
for (var key in data) {
search_terms.push(encodeURIComponent(key) + '=' + encodeURIComponent(data[key]));
}
window.history.pushState('object or string', 'Title', '/?' + search_terms.join('&'));
}
);
</script>
To test this, call runApp(port=5678) in the directory with your source files. By default, no parameters are specified in the URL, so this will default to the first navbar item and the first tab within that item. To test it with URL parameters, point your browser to: http://127.0.0.1:5678/?nav=Delta%20Foxtrot&tab=Hotel&beverage=Coffee. This should point you to the second navbar tab and the second tab in that navbar item with coffee as the selected beverage.
Here's an example demonstrating how to update the navbar selection, tabset selection, and widget selection using variables defined in the URL
ui <- navbarPage('TEST', id='page', collapsable=TRUE, inverse=FALSE,
# define a message handler that will receive the variables on the client side
# from the server and update the page accordingly.
tags$head(tags$script("
Shiny.addCustomMessageHandler('updateSelections',
function(data) {
var nav_ref = '#page a:contains(\"' + data.nav + '\")';
var tabpanel_id = data.nav == 'Alpha' ? '#alpha_tabs' : '#beta_tabs';
var tab_ref = tabpanel_id + ' a:contains(\"' + data.tab + '\")';
$(nav_ref).tab('show');
$(tab_ref).tab('show');
}
)
")),
tabPanel('Alpha',
tabsetPanel(id='alpha_tabs',
tabPanel('Tab')
)
),
tabPanel('Beta',
tabsetPanel(id='beta_tabs',
tabPanel('Golf'),
tabPanel('Hotel',
selectInput("beverage", "Choose a beverage:", choices = c("Tea", "Coffee", "Cocoa"))
)
)
)
)
server <- function(input, output, session) {
observe({
data <- parseQueryString(session$clientData$url_search)
session$sendCustomMessage(type='updateSelections', data)
updateSelectInput(session, 'beverage', selected=data$beverage)
})
}
runApp(list(ui=ui, server=server), port=5678, launch.browser=FALSE)
Point your browser to this URL after starting the app: http://127.0.0.1:5678/?nav=Beta&tab=Hotel&beverage=Coffee

Resources