Using Shiny App and R, I want to build a dashboard where only the authenticated users can use. The structure of the app is:
Simple login page with user name box and password box, where users put user name and password
Dashboard page where only the users who are authenticated on login page can access
I looked through several examples such as:
https://github.com/treysp/shiny_password
https://github.com/aoles/shinypass
https://gist.github.com/withr/9001831
but here I want to address the problem when following the first example.
The problems I have:
When I put dashboardPage() inside output$ui <- renderUI({ }) it did not work. So I removed renderUI and assigned dashboardPage function directly to output$ui, like output$ui <- dashboardPage(). But unfortunately it still returns this:
Error in tag("section", list(...)) : objet 'user_input_authenticated' introuvable. (it's in french but it's saying that it cannot find the object).
Here are my ui.R and server.R. Other than these, you need to clone admin.R and global.R from the repository(https://github.com/treysp/shiny_password).
To create a password, please run credentials_init() and then add_users("USER NAME", "PASSWORD") with your desired user name and password. Both functions are defined in admin.R. Once you create a password, it's stored in credentials/credentials.rds and now you can use the app.
What I want to make is a simple dashboard with authentication. If anyone help me solve this it would be great. Also if there is any other solutions than these examples, please tell me. Thanks.
ui.R(same as the original one in the Github repository)
shinyUI(
uiOutput("ui")
)
server.R(modified for my custom use)
shinyServer(function(input, output, session) {
#### UI code --------------------------------------------------------------
output$ui <- dashboardPage(dashboardHeader(title = "My Page"),
dashboardSidebar(
if (user_input$authenticated == FALSE) {
NULL
} else {
sidebarMenuOutput("sideBar_menu_UI")
}
),
dashboardBody(
if (user_input$authenticated == FALSE) {
##### UI code for login page
uiOutput("uiLogin")
uiOutput("pass")
} else {
#### Your app's UI code goes here!
uiOutput("obs")
plotOutput("distPlot")
}
))
#### YOUR APP'S SERVER CODE GOES HERE ----------------------------------------
# slider input widget
output$obs <- renderUI({
sliderInput("obs", "Number of observations:",
min = 1, max = 1000, value = 500)
})
# render histogram once slider input value exists
output$distPlot <- renderPlot({
req(input$obs)
hist(rnorm(input$obs), main = "")
})
output$sideBar_menu_UI <- renderMenu({
sidebarMenu(id = "sideBar_Menu",
menuItem("Menu 1", tabName="menu1_tab", icon = icon("calendar")),
menuItem("Menu 2", tabName="menu2_tab", icon = icon("database"))
)
})
#### PASSWORD server code ----------------------------------------------------
# reactive value containing user's authentication status
# user_input <- reactiveValues(authenticated = FALSE, valid_credentials = FALSE,
# user_locked_out = FALSE, status = "")
# authenticate user by:
# 1. checking whether their user name and password are in the credentials
# data frame and on the same row (credentials are valid)
# 2. if credentials are valid, retrieve their lockout status from the data frame
# 3. if user has failed login too many times and is not currently locked out,
# change locked out status to TRUE in credentials DF and save DF to file
# 4. if user is not authenticated, determine whether the user name or the password
# is bad (username precedent over pw) or he is locked out. set status value for
# error message code below
observeEvent(input$login_button, {
credentials <- readRDS("credentials/credentials.rds")
row_username <- which(credentials$user == input$user_name)
row_password <- which(credentials$pw == digest(input$password)) # digest() makes md5 hash of password
# if user name row and password name row are same, credentials are valid
# and retrieve locked out status
if (length(row_username) == 1 &&
length(row_password) >= 1 && # more than one user may have same pw
(row_username %in% row_password)) {
user_input$valid_credentials <- TRUE
user_input$user_locked_out <- credentials$locked_out[row_username]
}
# if user is not currently locked out but has now failed login too many times:
# 1. set current lockout status to TRUE
# 2. if username is present in credentials DF, set locked out status in
# credentials DF to TRUE and save DF
if (input$login_button == num_fails_to_lockout &
user_input$user_locked_out == FALSE) {
user_input$user_locked_out <- TRUE
if (length(row_username) == 1) {
credentials$locked_out[row_username] <- TRUE
saveRDS(credentials, "credentials/credentials.rds")
}
}
# if a user has valid credentials and is not locked out, he is authenticated
if (user_input$valid_credentials == TRUE & user_input$user_locked_out == FALSE) {
user_input$authenticated <- TRUE
} else {
user_input$authenticated <- FALSE
}
# if user is not authenticated, set login status variable for error messages below
if (user_input$authenticated == FALSE) {
if (user_input$user_locked_out == TRUE) {
user_input$status <- "locked_out"
} else if (length(row_username) > 1) {
user_input$status <- "credentials_data_error"
} else if (input$user_name == "" || length(row_username) == 0) {
user_input$status <- "bad_user"
} else if (input$password == "" || length(row_password) == 0) {
user_input$status <- "bad_password"
}
}
})
# password entry UI componenets:
# username and password text fields, login button
output$uiLogin <- renderUI({
wellPanel(
textInput("user_name", "User Name:"),
passwordInput("password", "Password:"),
actionButton("login_button", "Log in")
)
})
# red error message if bad credentials
output$pass <- renderUI({
if (user_input$status == "locked_out") {
h5(strong(paste0("Your account is locked because of too many\n",
"failed login attempts. Contact administrator."), style = "color:red"), align = "center")
} else if (user_input$status == "credentials_data_error") {
h5(strong("Credentials data error - contact administrator!", style = "color:red"), align = "center")
} else if (user_input$status == "bad_user") {
h5(strong("User name not found!", style = "color:red"), align = "center")
} else if (user_input$status == "bad_password") {
h5(strong("Incorrect password!", style = "color:red"), align = "center")
} else {
""
}
})
})
A kind githubber #skhan8 just submitted a pull request demonstrating how to use shiny_password in a shinydashboard. It will be incorporated into the main repo soon.
Related
Hi i am building an R code as follow to have an shiny app
ui = fluidPage(
shinyjs::useShinyjs(),
shinyjs::inlineCSS(appCSS),
shinyFeedback::useShinyFeedback(),
titlePanel("Predicting concrete strength",""),
numericInput("CEM","Cement (kg)",""),
numericInput("Water","Water (kg)",""),
numericInput("PFA","Flyash (kg)",""),
actionButton("submit", "Get the results", class = "btn-primary"),
textOutput("class"),
textOutput("class_prob")
)
and the server code is
server <- function(input, output, session) {
inputsValues = reactiveValues(inputs = NULL)
## to disable action button until all inputs are given
observe({
if(input$CEM!="" && input$Water!= "" && input$PFA!=""){
shinyjs::enable("submit")
} else {
shinyjs::disable("submit")
}
})
# putting some feedback if inputs are wrongly given
observeEvent(input$submit,{
cem_con<- (as.numeric(input$CEM) > 163 & as.numeric(input$CEM) < 3307)
shinyFeedback::feedbackDanger("CEM", !cem_con , " abc")
wat_con<- (as.numeric(input$Water) > 131 & as.numeric(input$Water) < 1640)
shinyFeedback::feedbackDanger("Water",!wat_con , "abc")
pfa_con<-(as.numeric(input$PFA) > 55 & as.numeric(input$PFA) < 1617)
shinyFeedback::feedbackDanger("PFA", !pfa_con, "abc")
req(cem_con,wat_con)
inputsValues$inputs<-c("CEM"=input$CEM,"Water"=input$Water,"PFA"=input$PFA)
inputsValues$inputs<-as.numeric(inputsValues$inputs)
})
output$class_prob<- renderText(inputsValues$inputs)
output$class <- renderText(sum(inputsValues$inputs))
}
and when I run the app using
shinyApp(ui, server)
its stops and give the following error
Listening on http://126.0.0.1:3739
Warning: Error in enable: could not find function "enable"
[No stack trace available]
To check for missing value, you could use is.na() as shown below.
observe({
if (is.na(input$CEM) | is.na(input$Water) | is.na(input$PFA) ) {
shinyjs::disable("submit")
} else {
shinyjs::enable("submit")
}
})
I am new to the R language. I can't figure out a solution to the problem I am currently facing. I have made a registration page for users. Whenever the user clicks the "submit" button it checks whether the specific conditions are met. If no, then an error message is displayed. Now the problem is that the error message is repeated continuously until the user enters the correct information. It also repeats each time the user clicks the button.
I want the error message to be displayed only once regardless of how many times the user clicks the "submit" button. Also, the error should not repeat when the user is filling the text fields. This might be a stupid question but I would really appreciate some help. I am sharing my code for a better understanding of the problem.
ui <- fluidPage(
tags$style(
type = "text/css",
#".shiny-output-error",
" .has-error{color: #B31B1B;}"
),
#User Account
div(id ="account", actionBttn("OPEN"," Register",
color = "success", style = "gradient", icon = icon("user"))),
)
# Define server logic
server <- function(input, output) {
#User Account
#User-Registration Button
observeEvent(input$OPEN,{
showModal(modalDialog( id = "form",
h3(strong("User Sign-Up Portal"), align = "center"),
br(),
textInput("Username", "Enter Username:", value = "", placeholder = "Username"),
textInput("Email", "Enter Email:", value = "", placeholder = "Email"),
passwordInput("Password", "Enter Password:", value = "", placeholder = "Password"),
passwordInput("rePassword", "Retype Password:", value = "", placeholder = "Retype Password"),
easyClose = TRUE,
footer=tagList(
p("Already have an account ? Click to Sign In"),actionButton('signin', 'Sign-In'),
div(style = "margin-right: 300px", actionButton('submit', 'Submit'), actionButton("refresh", "Refresh"),
modalButton('cancel'))
)
)
)
}
)
observeEvent(input$submit,{
urname <- input$Username
uemail <- input$Email
upass <- input$Password
urepass <- input$rePassword
iv <- InputValidator$new()
result = fn$dbGetQuery(con, "Select Username from register where Username = '$urname'")
iv$add_rule("Username", sv_required())
iv$add_rule("Username", ~ if (!isValidFormat(.)) "The username must contain Atleast: 8 characters \n One Upper Case Letter \n One Lower case Character \n One special Character")
iv$add_rule("Username", function(un){
if (count(result) != 0){
"Username already exists. Please enter a unique Username!"
}
})
iv$add_rule("Username", function(unl){
if (str_length(unl) >= 21){
"The Username cannot exceed 20 characters!"
}
})
result1 = fn$dbGetQuery(con, "Select Email from register where Email = '$uemail'")
iv$add_rule("Email", sv_required())
iv$add_rule("Email", ~ if (!isValidEmail(.)) "Not a valid Emai!l")
iv$add_rule("Email", function(ue){
if (count(result1) != 0){
"Email already exists. Please enter a unique Email!"
}
})
iv$add_rule("Password", sv_required())
iv$add_rule("Password", ~ if (!isValidFormat(.)) "The password must contain Atleast: 8 characters \n One Upper Case Letter \n One Lower case Character \n One special Character")
iv$add_rule("Password", function(pass){
if (str_length(pass) <= 7){
"The password should have a minimum of 8 characters!"
}
})
iv$add_rule("Password", function(pass){
if (str_length(pass) >= 13){
"The password should have a maximum of 12 characters!"
}
})
iv$add_rule("rePassword", sv_required())
iv$add_rule("rePassword", function(repass) {
if (repass != upass) {
"Your password and retype password do not match!"
}
})
iv$enable()
req(iv$is_valid())
})
I did not follow your example because it is not reproducible.
To make and event occure only once, or twice, or more, you can initialize a counter and stop the event when the counter is reached.
Here I want an alert to appear if the user submits a number >=5. Whenever the button is clicked, I increase the counter by one. The alert needs the counter to be 0 or it won't appear.
The counter is initialize at 0, so it appears once, and then it won't appear again.
library(shiny)
library(shinyWidgets)
counter <- 0 #init counter
ui <- fluidPage(
useSweetAlert(),
actionButton(
inputId = "register",
label = "register"
)
)
# Define server logic
server <- function(input, output, session) {
rv <- reactiveValues(count=0)
observeEvent(input$register, {
showModal(
modalDialog(
id = "form",
textInput("input1", "Enter a number < 5", value = ""),
actionButton(
inputId = "submit",
label = "Submit"
)
)
)
})
observeEvent(input$submit,{
req(rv$count == 0)
rv$count <- rv$count+1
if(as.numeric(input$input1)>=5){
sendSweetAlert(
session = session,
title = "Error...",
text = "The number you ented is not < 5",
type = "error"
)
}
})
}
shinyApp(ui,server)
With the Shiny selectizeInput widget, the user can type in text as well as select a value from a list of values. Is there a way in R to read the current value of the text?
(Added)
I should make it clear that I want to be able to read the text the user enters before he has made a selection. As zimia points out, after he has made a selection, the value of whatever he selected becomes available as input$input_id (assuming that the selectize input has the id "input_id").
you can just use the input$input_id. See below
ui <- fluidRow(
selectizeInput("input1","Enter Text",choices=c("A","B") ,options = list(create=TRUE)),
textOutput("output1")
)
server<- function(input, output, session){
output$output1 <- renderText({
req(input$input1)
input$input1
})
}
Shiny's selectizeInput still gives access to the internal properties, methods and callbacks of Selectize.js through "options" argument of updateSelectizeInput. Selectize.js exposes callback "onType", so you can use like that:
updateSelectizeInput(
session,
'input1',
options = list(
onType = I('
text => Shiny.setInputValue("input1_searchText", text)
'),
onBlur = I('
() => Shiny.setInputValue("input1_searchText", null)
')
)
)
and consume it with observer:
observeEvent(input$input1_searchText, {
print(input$input1_searchText)
}, ignoreNULL = FALSE
)
Please, note, that I was also interested to know when the select looses focus and hence used "onBlur" event to set the search text to NULL.
I was thinking that there would be a solution at the level of R/shiny. But I have found a solution that uses javascript.
library(shiny)
js <- '
$(document).on("keyup", function(e) {
minChars = 4;
tag1 = document.activeElement.getAttribute("id");
val1 = document.activeElement.value;
if (tag1 == "input1-selectized") {
if (Math.sign(val1.length +1 - minChars) == 1) {
obj = { "val": val1 };
Shiny.onInputChange("valueEntered", obj);
}
}
});
'
ui <- fluidRow(
tags$script(js),
selectizeInput(
"input1",
"Enter text",
choices = c("A", "B"),
options = list(create = FALSE)),
textOutput("output1")
)
server <- function(input, output, session) {
output$output1 <- renderText({
req(input$valueEntered$val)
input$valueEntered$val
})
}
shinyApp(ui = ui, server = server)
The javascript looks for text entered into the element with id "input1-selectized", and if the value is length 4 or more, sets the shiny variable "valueEntered" to an object with val = the text.
Then the observeEvent uses the shiny variable input$valueEntered to set the output text.
The reason in the javascript for using the Math.sign function rather than >, and the reason for nested if's is because for some reason, Shiny replaces infix operators such as > and && by their html equivalents, > and &&.
Note that if the selectizeInput widget has id "input1", then the corresponding text field has id "input1-selectized".
How can I create Vector Output in R Shiny code.
I read this stackechange question, but instead of using textbox, I am using colourpicker::colourInput
Working R code is in GitHub
How do I capture the checked boxes and store color values into a vector? If user unchecks a box, the color value should be removed.
Please give hint on doing this.
Below is animated screenshot and the function
CherryPickPalette <- function (name, name2=NULL, name3=NULL){
if ((nargs() < 2) || (nargs() > 3)){
stop("Enter 2 or 3 valid palettes. Run ListPalette() for list of palettes.")
}
if (nargs() == 2){
new_pal <- MergePalette(name,name2)
}
else if (nargs() == 3){
new_pal <- MergePalette(name,name2,name3)
}
if (interactive()){
shinyApp(
ui = fluidPage(
titlePanel("Cherry Pick Your Own Palette!"),
sidebarPanel (
colourpicker::colourInput("col","Choose colors","white", palette="limited", allowedCols = new_pal)),
mainPanel(
h5('Your custom colors',style = "font-weight: bold;"),
fluidRow(column(12,verbatimTextOutput("value"))))
),
server = function(input,output,session){
output$value<-renderPrint({
paste(input$col,sep=" ")
}
)
}
)
}
}
> CherryPickPalette("Jutti3","Kulfi","Gidha")
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