Using validation in an action button - r

I am a little confused about the difference between req and validate in R shiny. The only real difference I can see is that validate gives a message to the user. I am building an interface and was using a bunch of hidden messages and conditional statements. I would like to condense my code and like the idea of using validate. I only want to show my message when the user tries to click the button and tries to continue to another part of the UI.
I provide a simplified version of the code, the message "Success" will only show when the text input for the id and the agreement button is clicked. If one or both are missing, a conditional panel will display the validation text.
I am concerned that displaying an output inside of an action button destroys the environment and essentially turns it into a reactive environment. I used the req after the validation check so that the success message will not display unless the input is provided for both. Is this the best way to do this? Or is there a more efficient/proper way? My main concern is that when I build up the complexity, I will break the app.
library(shiny)
ui <- fluidPage(
textInput(inputId = "id",
label = 'Please enter your id'
),
checkboxInput("agree", label = "I agree", value = FALSE),
conditionalPanel(condition = "input.id == '' || !input.agree",
textOutput('error_msg')
),
actionButton("submit_info", "Submit"),
textOutput('success_msg')
)
server <- function(input, output) {
observeEvent(input$submit_info, {
output$error_msg <- renderText({
shiny::validate(
shiny::need(input$id != '', 'You must enter your id above to continue.'
),
shiny::need(input$agree, "You must agree to continue")
)
})
shiny::req(input$id)
shiny::req(input$agree)
output$success_msg <- renderText({"Success"})
})
}
shinyApp(ui = ui, server = server)

Update: I have solved this issue. Essentially, I make the conditional panel only show once the button is clicked and moved the validate outside of the observe event. Here is the code:
library(shiny)
ui <- fluidPage(
textInput(inputId = "id",
label = 'Please enter your id'
),
checkboxInput("agree", label = "I agree", value = FALSE),
conditionalPanel(condition = "(input.submit_info >= 1) & ((input.id == '') || (!input.agree))",
textOutput('error_msg')
),
actionButton("submit_info", "Submit"),
textOutput('success_msg')
)
server <- function(input, output) {
output$error_msg <- renderText({
shiny::validate(
shiny::need(input$id != '', 'You must enter your id above to continue.'
),
shiny::need(input$agree, "You must agree to continue")
)
})
observeEvent(input$submit_info, {
shiny::req(input$id)
shiny::req(input$agree)
output$success_msg <- renderText({"Success"})
})
}
shinyApp(ui = ui, server = server)

Related

How to alert if user not log in in shiny?

I use the googleAuthR package in shiny, I want to alert users if they are not log in and I also want to save user's google id if they have successfully logged in. But sign_ins() is reactive consumer that I cannot do this. Any suggestions?
library(shiny)
library(googleAuthR)
library(shinyWidgets)
options(googleAuthR.webapp.client_id = "**********************")
ui <- fluidPage(
titlePanel("Sample Google Sign-In"),
sidebarLayout(
sidebarPanel(
googleSignInUI("demo")
),
mainPanel(
with(tags, dl(dt("Name"), dd(textOutput("g_name")),
dt("Email"), dd(textOutput("g_email")),
dt("Image"), dd(uiOutput("g_image")) ))
)
)
)
server <- function(input, output, session) {
sign_ins <- shiny::callModule(googleSignIn, "demo")
output$g_name = renderText({ sign_ins()$name })
output$g_email = renderText({ sign_ins()$email })
output$g_image = renderUI({ img(src=sign_ins()$image) })
if(is.null(sign_ins())){
shinyWidgets::show_alert(title = "not log in",
type = NULL,
btn_labels = "Ok")
else{
write.csv(sign_ins(),"file.csv")
}
}
}
# Run the application
shinyApp(ui = ui, server = server)
I'm not familiar with googleAuthR but every google-api product in R is most likely has "*_has_token" feature to validate if there is an active credential logged in the session. I've checked the googleAuthR package and i think you can use googleAuthR::gar_has_token(). So instead of
if(is.null(sign_ins())) {...}
you can use
if(googleAuthR::gar_has_token() == FALSE){...}
to check if there is an active credentials and do your things.
Hope this helpful

Disabling selectizeInput in second page of datatable in RShiny

I have a datatable, in which I have embedded selectizeInputs. I have used jquery to enable some options in the selectizeInputs (like creation options).
Now, due to a business use case I would like to disable some selectizeInputs (dynamically selected, through some condition). These inputs could be on the 2nd, 3rd,.. nth page of the datatable as well.
However, I am only able to disable the inputs on the 1st page and not on the subsequent pages. I am attaching a minimal and reproducible example, it would be great if someone could help me out.
library(shiny)
library(DT)
ui <- fluidPage(
shinyjs::useShinyjs(),
selectizeInput(
inputId = "input",
label = "",
choices = letters[1:26],
selected = letters[1]
),
fluidRow(
DTOutput(outputId = "table"),
tags$script(HTML("Shiny.addCustomMessageHandler('unbind-DT', function(id) {
Shiny.unbindAll($('#'+id).find('table').DataTable().table().node());
})"))
)
)
df <- data.frame('a' = c(1,2), 'sel_input' = NA)
df[1,'sel_input'] <- as.character(
selectizeInput(inputId = 'mselect', choices=c('car','cars','dog'),
label=NULL, selected=NULL))
df[2,'sel_input'] <- as.character(
selectizeInput(inputId = 'nselect', choices=c('lambo','audi','merc'),
label=NULL, selected=NULL))
js <- c(
"function(){Shiny.bindAll(this.api().table().node());",
" $('#mselect').selectize({
delimiter: \',\',
persist: false,
create: function(input) {
return {
value: input,
text: input
}
}
});",
"$('#nselect').selectize({
delimiter: \',\',
persist: false,
create: function(input) {
return {
value: input,
text: input
}
}
});",
"$('#mselect')[0].selectize.enable()",
"$('#nselect')[0].selectize.disable()",
"}"
)
server <- function(input, output, session) {
observe({
print(input$mselect)
})
session$sendCustomMessage('unbind-DT', 'table')
output$table <- renderDT({
datatable(
data = df,
escape = FALSE,
options = list(
dom='tp',
pageLength=1,
processing=F,
preDrawCallback = JS('function(){Shiny.unbindAll(this.api().table().node());}'),
drawCallback = JS(js)
)
)
})
}
shinyApp(ui = ui, server = server)
So, I was able to resolve it on my own. Basically the problem here is not R/Rshiny based. It is actually a javascript bug in the code that I was overlooking.
When you do pagination, the elements only in current (selected) page are a part of the DOM. All others are removed/not created. In the code above, in the drawCallback (this is the piece of code that runs every time the datatable needs to be re-rendered) I am issuing commands for all the elements, irrespective if they are present in the DOM or not. Because of this the javascript code fails and the disabling/enabling does not happen.
The solution here is to first check if an element is active in the DOM or not and only then issue enabling/disabling command.
So, in essence, enclose the above commands in a if else statement
if ($('#mselect').length > 0){
$('#mselect').selectize()[0].selectize.enable();
}
if ($('#nselect').length > 0){
$('#nselect').selectize()[0].selectize.disable();
}
This way the javascript code will only run when that specific element exists in the DOM and then you would be able to implement disabling selectInput in second page of paginated datatable.

Generate warning message on R Shiny Dashboard Sidebar using "SelectizeInput"

I would like to add a warning message, in my shiny dashboard sidebar, if user enters something that is not recognized. I found something very informative: Check Shiny inputs and generate warning on sidebar layout
But it is not exactly what I need, and would like to hear what you think. Below is my code
library(shiny)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
selectizeInput('email', 'Email', c("NYC#gmail.com", "LA#gmail.com","SF#gmail.com"), multiple = FALSE,
options = list(
placeholder = 'Email addresss',
onInitialize = I('function() { this.setValue(""); }')
)),
uiOutput('email_text')
),
dashboardBody()
)
server <- function(input, output) {
output$email_text <-
renderUI({
if(input$email == ""){
return(p("Please add your gmail e-mail address."))
}
#Update: Below checks for "gmail" - I would something to search list and return.
if(!grepl("gmail", input$email)){
return(p("Your email is not a gmail e-mail address!"))
}
})
}
shinyApp(ui = ui, server = server)
Current sidebar selection performs well to recognize email format, as long as I select from the dropdown list
However, what I also want to add in is, if I enter something that is not expected (not in the list given), the system can capture that and warn me (E.g. "Your email is not an expected email address!"). Currently, if I just enter some something not in the list, the system does not do anything:
I feel that comparing with post I mentioned above, my version has issue with "selectizeInput" function. It is designed to intake elements from the list, not everything user enters. Is there a way to work around it? I try to use validate() but had no luck.
Thanks so much in advance for your help!
By default selecticizeInput does not allow the user to enter new values. You have to enable this with options = list(create = TRUE). Once you have this option, you can check whether the newly created email is in the pre-defined list of emails using %in% and report a custom error message in the sidebar.
Here is the updated code:
library(shiny)
library(shinydashboard)
list_of_emails <- c("NYC#gmail.com", "LA#gmail.com", "SF#gmail.com")
ui <- dashboardPage(dashboardHeader(),
dashboardSidebar(
selectizeInput(
'email',
'Email',
c("NYC#gmail.com", "LA#gmail.com", "SF#gmail.com"),
multiple = FALSE,
options = list(
create=TRUE,
placeholder = 'Email addresss',
onInitialize = I('function() { this.setValue(""); }')
)
),
uiOutput('email_text')
),
dashboardBody())
server <- function(input, output) {
output$email_text <-
renderUI({
# print the input email to the console to help with debugging
message(input$email)
if (input$email == "") {
return(p("Please add your gmail e-mail address."))
}
#Update: Below checks for "gmail" - I would something to search list and return.
if (!input$email %in% list_of_emails) {
return(p("Your email is not in the list of emails!"))
}
})
}
runApp(list(ui = ui, server = server))

hideTab doesn't work when tabsetPanel and hideTab are inside an observer in R shiny

I'm traying to create an app that reads some user and password and then create a tabsetPanel inside a renderUI.
The app is supposed to read a code and type number from a data base and if the type is 1 then hides some tabPanel, however all the tabpanels are always shown.
library(shiny)
library(RPostgreSQL)
con=dbConnect(........)
ui <- fluidPage(
textInput("user","User:"),
passwordInput("password", "Password:"),
actionButton("go", "Go",class = "btn-primary"),
uiOutput("panel")
)
server <- function(input, output, session) {
observeEvent({input$go}, {
code<-dbGetQuery(con,"SELECT type FROM table")[[1]]
#code is a number
if(dim(code)[1]==1){
type=reactive(dbGetQuery(con,"SELECT type FROM table2")[[1]])
#type() is a number
output$panel=renderUI(
tabsetPanel(id = "tab",
tabPanel("Tab1"),
tabPanel("Tab2")
)
)
observe({
if(type()==1){
hideTab(inputId = "tab", target = "Tab1")
}
})
}
})
}
shinyApp(ui, server)
The problem is that de observer is executed before the renderUI and doesn't re-execute, I think.
Generally speaking, you've mixed up 3 different processes.
Checking the user has access can be put in a separate function, outside of the scope of server, simply returning TRUE or FALSE (and possibly an error).
Dynamically loading the tabs. If this must only occur after the user has logged in, you can simply opt to not display Tab1. If the tabs has to be loaded regardless (but still dynamically), put it outside of the scope of observeEvent({input$go}, {...}). Consider, just for now, to setup the tabsetpanel with tabs in the ui.
Showing/hiding the tab.
Within a reactive/observe, you do not need to use additional reactives. They already are set to run. So type should be just be type = dbGetQuery(...), and the observe nested within an observe/observeEvent makes no sense.
Lastly, to debug why the tab is not hidden, use the good ol' fashioned print and look at your console. Try updating to
observe({
cat('Testing type: ', type(), '\n')
if(type()==1){
cat('Hiding tab...\n')
hideTab(inputId = "tab", target = "Tab1")
}
})
and watch out for those messages in your console. Are they printed? Then the fault might be on the client-side (perhaps you mispelled something). Are the messages missing? Then you know the code never executed, and you'll have to investigate why.
Update:
Looking further into the matters, try using the browsers Inspect-function. For the viewer in Rstudio (and Chrome), you can right-click and select "Inspect element". A new window appears (or is docked within the window), which allows you to inspect the HTML DOM and view the JavaScript console. Here, we notice an important message:
Uncaught There is no tabsetPanel (or navbarPage or navlistPanel) with id equal to 'tab'
Simply put, the hideTab command is sent before the client has finished loading the tabpanels.
One solution, that did not work, is as follows:
server <- function(input, output, session) {
type <- reactiveVal(0)
type_delayed <- debounce(type, Inf)
observeEvent({input$go}, {
code<-data.frame(code=1)
#code is a number
if(dim(code)[1]==1){
#type(dbGetQuery(con,"SELECT type FROM table2")[[1]])
type(1)
#type() is a number
output$panel=renderUI(
tabsetPanel(id = "tab",
tabPanel("Tab1"),
tabPanel("Tab2")
)
)
}
})
observe({
cat('Testing type: ', type_delayed(), '\n')
if( type_delayed() ==1){
cat('Hiding tab...\n')
hideTab(inputId = "tab", target = "Tab1")
}
})
}
I.e., we delay the execution of hiding the tab. Except it's a bad solution, because you have to choose a timing that is as soon as possible, but not so soon that the client isn't ready.
I suggest the following solution: Instead of hiding the panel, don't add it until you need it:
ui <- fluidPage(
textInput("user","User:"),
passwordInput("password", "Password:"),
actionButton("go", "Go",class = "btn-primary"),
actionButton("add", "Add tab"),
uiOutput("panel")
)
server <- function(input, output, session) {
i <- 1
observeEvent({input$go}, {
code<-data.frame(code=1)
#code is a number
if(dim(code)[1]==1){
#type <- dbGetQuery(con,"SELECT type FROM table2")[[1]]
type <- 1
#type() is a number
output$panel=renderUI({
if (type == 1) {
i <<- 1
tabsetPanel(
id = "tab",
tabPanel("Tab1")
)
} else {
i <<- 2
tabsetPanel(
id = "tab",
tabPanel("Tab1"),tabPanel("Tab2")
)
}
})
}
})
observeEvent(input$add, {
i <<- i + 1
appendTab('tab', tabPanel(paste0('Tab', i)))
})
}

Pausing function in order to wait for user input from modal, Shiny

I have a dialogue in shiny that allows the user to input credentials for a database.
The problem is that the module is opened inside of a called function, therefore somehow I need to pause the function from continuing until the user has put input the required fields. I have tried using req and can not make it work, observeEvent() also does not work since I can not return anything from that environment.
If I do not pause the program somehow, the function keeps on going without the username and password and will not get the data. The trigger to "un-pause" would be an input$Submit, the button in the Modal.
library(shiny)
ui<-
fluidPage(
sidebarLayout(position="left",
sidebarPanel("Parameters",width = 4,
radioButtons("Type","Test", choices= list("Test"="p",
"Test"="l")),
actionButton("GO","Open Modual")
),
mainPanel(
plotOutput("Test")
)))
server<- function(input,output){
Credential<-function(Test){
showModal(modalDialog(
title = "Credentials Required",
textInput("Username", "Enter User Name", value = ""),
textInput("Password", "Enter Password:", value = ""),
footer = actionButton("Submit", "Submit"),
modalButton("Cancel"))
)
#Use Assigned Username and Password to go fetch data.
#Note data must be returned, somehow need to pause or somthing here.
}
#Call Function
observeEvent(input$GO,{
data <- Credential("Test")
})
}
shinyApp(server=server,ui=ui)
Any ideas?
Thanks,
-Chaboes

Resources