I am using modal-dialogue in R Shiny to get input from the user. In this form, there is a dismiss button by default which closes the form when it is clicked. I want to add a confirmation popup (sweetAlert) when the dismiss button is clicked.
I am ready to use javascript as well but i need sweetAlert instead of the windows alert. I was not able to successfully generate a windows alert as well.
How do i override the functionality of this in-built "dismiss" button? I want to show a warning when someone clicks on dismiss and let them continue only if they are sure. Otherwise i want to let them stay on the modal-dialogue.
Any help is appreciated.
Here's a way. Code is fairly simple. -
library(shiny)
ui <- fluidPage(
actionButton("show", "Show Modal")
)
server <- shinyServer(function(input, output, session) {
observeEvent(input$show, {
showModal(
modalDialog(
"some messsage", title = "modal", footer = actionButton("confirm", "Close")
)
)
})
observeEvent(input$confirm, {
showModal(
modalDialog(
"are you sure?",
footer = tagList(
actionButton("yes", "Yes"),
modalButton("No")
)
)
)
})
observeEvent(input$yes, {
removeModal()
# do something after user confirmation
})
})
shinyApp(ui, server)
You don't need to write your own JS code, instead you might want to use the shinyWidgets package
Specifically, have a look at the Confirmation dialog:
http://shinyapps.dreamrs.fr/shinyWidgets/
Edit: Here you can find some examples, e.g.
library("shiny")
library("shinyWidgets")
ui <- fluidPage(
tags$h1("Confirm sweet alert"),
actionButton(
inputId = "launch",
label = "Launch confirmation dialog"
),
verbatimTextOutput(outputId = "res"),
uiOutput(outputId = "count")
)
server <- function(input, output, session) {
# Launch sweet alert confirmation
observeEvent(input$launch, {
confirmSweetAlert(
session = session,
inputId = "myconfirmation",
type = "warning",
title = "Want to confirm ?",
danger_mode = TRUE
)
})
# raw output
output$res <- renderPrint(input$myconfirmation)
# count click
true <- reactiveVal(0)
false <- reactiveVal(0)
observeEvent(input$myconfirmation, {
if (isTRUE(input$myconfirmation)) {
x <- true() + 1
true(x)
} else {
x <- false() + 1
false(x)
}
}, ignoreNULL = TRUE)
output$count <- renderUI({
tags$span(
"Confirm:", tags$b(true()),
tags$br(),
"Cancel:", tags$b(false())
)
})
}
shinyApp(ui, server)
Related
I need to block the user from accessing to other tabs until certain actions are fulfilled.
In this reproducible example, I want to block the user to access the Tab 2 until he pressed the button.
This is how the app looks:
Here's the code for the app:
library(shiny)
ui <- shinyUI(navbarPage("",
tabPanel(h1("Tab1"), value = "nav1",
mainPanel(
br(),
h2("The user must press this button to access the other tab."),
br(),
shiny::actionButton('button', 'press the button')
)
),
tabPanel(h1("Tab2"),
value = "nav2",
h3('Block access until user presses button')
)
)
)
server <- shinyServer(function(input, output) {
})
# Run the application
shinyApp(ui = ui, server = server)
I would like the user to be able to see that Tab2 exists, but make it unclickable until they press the button.
Any ideas?
There is no need of using any server side processing. One of the modern web app development concepts is front-end and back-end separation. If you can do it on front-end, then don't use server to do the job.
conditionalPanel is a better solution but users can still click the tab button, just give them an empty page.
Here is an even better solution, let's use some js to disable the tab button unless users click the action button. Users can see the tab button but it's gray and unclickable on start:
library(shiny)
ui <- shinyUI(navbarPage(
"",
tabPanel(
h1("Tab1"),
value = "nav1",
mainPanel(
br(),
h2("The user must press this button to access the other tab."),
br(),
shiny::actionButton('button', 'press the button', onclick = "$(tab).removeClass('disabled')")
)
),
tabPanel(
h1("Tab2"),
value = "nav2",
uiOutput("tab2contents")
),
tags$script(
'
var tab = $(\'a[data-value="nav2"]\').parent().addClass("disabled");
$(function(){
$(tab.parent()).on("click", "li.disabled", function(e) {
e.preventDefault();
return false;
});
});
'
)
))
server <- shinyServer(function(input, output) {
})
# Run the application
shinyApp(ui = ui, server = server)
Use conditionalPanel(). Condition? The button shouldn't have zero clicks.
Your example now becomes:
library(shiny)
ui <- shinyUI(
navbarPage(
title = "",
tabPanel(
title = h1("Tab1"),
value = "nav1",
mainPanel(
br(),
h2("The user must press this button to access the other tab."),
br(),
shiny::actionButton('button', 'press the button')
)
),
tabPanel(
h1("Tab2"),
value = "nav2",
# ----conditional panel here----
conditionalPanel(
condition = "input.button != 0",
h3('Block access until user presses button')
)
)
)
)
server <- shinyServer(function(input, output) {
})
# Run the application
shinyApp(ui = ui, server = server)
Adding detail to my comment above:
library(shiny)
ui <- shinyUI(navbarPage("",
tabPanel(
h1("Tab1"),
value = "nav1",
mainPanel(
br(),
h2("The user must press this button to access the other tab."),
br(),
shiny::actionButton('button', 'press the button')
)
),
tabPanel(
h1("Tab2"),
value = "nav2",
uiOutput("tab2contents")
)
)
)
server <- shinyServer(function(input, output) {
v <- reactiveValues(tab2Active=FALSE)
observeEvent(input$button, { v$tab2Active <- TRUE})
output$tab2contents <- renderUI({
if (v$tab2Active) {
h3('Tab 2 is active')
} else {
h3('Block access until user presses button')
}
})
})
# Run the application
shinyApp(ui = ui, server = server)
I am building a shiny app that, among other things, tries to identify a person's Census subdivision (in Canada) from an input postal code. Occasionally, postal codes overlap multiple subdivisions, so when that happens, I want users to be able to choose which subdivision they want to see. I was hoping to do it with a radio button input inside of a modal dialog. In the app below, the appropriate radio buttons appear, but I am unable to select a value. Each time I try to press one of the radio buttons, it appears to re-load the modal dialog without recording the choice. I am wondering if there is a) a way to make this work that has escaped me or b) a better way to accomplish this same goal? There are only two postal codes in the data frame that loads - A0A1P0 which exhibits the problem and N5X1G4, which has only a single census subdivision and thus doesn't trigger the modal.
library(shiny)
library(shinycssloaders)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
splitLayout(
textInput("pcode", NULL, value="", placeholder = "e.g., A1A1A1"),
actionButton("findpc", "Find Me!"))
),
mainPanel(
withSpinner(verbatimTextOutput("mygeog"))
)
)
)
server <- function(input, output, session) {
library(dplyr)
load(file("https://quantoid.net/files/so/pccf_reprex.rda"))
output$mygeog <- renderPrint({
validate(need(input$findpc, ""))
mypc <- gsub(" ", "", input$pcode)
tmp_pc <- pccf_reprex
tmp_pc <- as.data.frame(subset(tmp_pc, PC == mypc))
if(nrow(tmp_pc) > 1){
geog_chc <- c(tmp_pc$CSDuid)
names(geog_chc) <- c(tmp_pc$CSDname)
showModal(dedupModal(chc=geog_chc))
tmp_pc <- tmp_pc[which(geog_chc == input$chooseGeog), ]
}
paste0("Geographic Indicator CSD: ",
tmp_pc$CSDname[1])
})
dedupModal <- function(failed = FALSE, chc) {
modalDialog(
span('Your Post Code did not identify a unique CSD. Please pick the appropriate one from the list below.'),
radioButtons("chooseGeog", "Choose Region", choices = chc, selected=character(0)),
footer = tagList(
actionButton("ok", "OK")
)
)
}
observeEvent(input$ok, {
# Check that data object exists and is data frame.
removeModal()
})
}
shinyApp(ui, server)
I was able to find a suitable solution by putting an event observer around the "Find Me!" button and rendering the print output inside the event observer. Here's the solution:
library(shiny)
library(shinycssloaders)
ui <- fluidPage(
tags$script("
Shiny.addCustomMessageHandler('chooseGeog', function(value) {
Shiny.setInputValue('chooseGeog', value);
});
"),
sidebarLayout(
sidebarPanel(
splitLayout(
textInput("pcode", NULL, value="", placeholder = "e.g., A1A1A1"),
actionButton("findpc", "Find Me!"))
),
mainPanel(
verbatimTextOutput("mygeog")
)
)
)
server <- function(input, output, session) {
library(dplyr)
load(file("https://quantoid.net/files/so/pccf_reprex.rda"))
output$trig <- renderUI({
actionButton("trigger", "trigger")
})
observeEvent(input$findpc, {
mypc <- gsub(" ", "", input$pcode)
tmp_pc <- pccf_reprex
tmp_pc <- as.data.frame(subset(tmp_pc, PC == mypc))
if(nrow(tmp_pc) > 1){
geog_chc <- c(tmp_pc$CSDuid)
names(geog_chc) <- c(tmp_pc$CSDname)
showModal(dedupModal(chc=geog_chc))
}else{
session$sendCustomMessage("chooseGeog", tmp_pc$CSDuid[1])
}
output$mygeog <- renderPrint({
req(input$chooseGeog)
tmp_pc <- tmp_pc %>% filter(geog_chc == input$chooseGeog)
paste0("Geographic Indicator CSD: ",
tmp_pc$CSDname[1])
})
})
dedupModal <- function(failed = FALSE, chc) {
modalDialog(
span('Your Post Code did not identify a unique CSD. Please pick the appropriate one from the list below.'),
radioButtons("chooseGeog", "Choose Region", choices = chc, selected=character(0)),
footer = tagList(
actionButton("ok", "OK")
)
)
}
observeEvent(input$ok, {
# Check that data object exists and is data frame.
removeModal()
})
}
shinyApp(ui, server)
Can shinyjs do something like if(is_disabled("#my_element_id")) do_something()?
I'd like to be able to see if a specific HTML element is disabled (by shinyjs or other means) before doing something else with it.
There's no such function. The answer depends on what you want exactly. Here is something which could help:
library(shiny)
library(shinyjs)
jsCode <- 'shinyjs.isDisabled = function(params) {
var el = $("#radiobtns");
Shiny.setInputValue("disabled", el.prop("disabled"));
}'
ui <- fluidPage(
useShinyjs(),
extendShinyjs(text = jsCode, functions = "isDisabled"),
actionButton("button", "Disable radio buttons"),
radioButtons("radiobtns", "Radio buttons", c("Yes", "No"))
)
server <- function(input, output) {
observeEvent(input$button, {
toggleState("radiobtns")
js$isDisabled()
})
observeEvent(input$disabled, {
if(input$disabled){
cat("disabled\n")
}else{
cat("enabled\n")
}
})
}
shinyApp(ui = ui, server = server)
I don't know much of JavaScript, and I'm having a problem to override the default message in the Shiny R App, when I'm outputting table.
When table is empty, it's giving message "No data available in table" in the first row. I wanted to put some app-specific instructions instead.
I found that there's something like:
options = list(searching = FALSE,paging = FALSE) but don't know what option it would be to switch that text.
Also, I found JS code to reset the message (https://datatables.net/reference/option/language.zeroRecords),
but I wasn't able to attach this correctly to renderDataTable in Shiny.
I just don't know the correct syntax of incorporating JS into shiny, I tried
options = list(searching = FALSE,paging = FALSE, callback=DT:JS(
'
{
"language": {
"zeroRecords": "No records to display- custom text"
}
'
but it didn't work. I would appreciate some guidance on this.
Here's the whole code. Right now my attempts to replace the mesage are ignored:
library(ggplot2)
library(DT)
ui <- fluidPage(
titlePanel("Basic DataTable"),
# Create a new Row in the UI for selectInputs
fluidRow(
column(12,
selectInput("man",
"Manufacturer:",
c("All",
unique(as.character(mpg$manufacturer))))
)
),
# Create a new row for the table.
fluidRow(
DT::dataTableOutput("table")
)
)
server <-function(input, output) {
# Filter data based on selections
output$table <- DT::renderDataTable(DT::datatable({
data <- mpg
if (input$man != "All") {
data <- data[data$manufacturer == "dddddd",]
}
data
},options = list(searching = FALSE,paging = FALSE,callback=DT::JS(
'
{
"language": {
"zeroRecords": "No records to display- custom text"
}}
') )
))
}
shinyApp(ui = ui, server = server)
Do not use the callback, you can directly set the language -> zeroRecords attribute using the options parameter:
server <- function(input, output) {
# Filter data based on selections
output$table <- DT::renderDataTable(DT::datatable({
data <- mpg
if (input$man != "All") {
data <- data[data$manufacturer == "dddddd",]
}
data
}, options =
list(searching = FALSE,paging = FALSE,
language = list(
zeroRecords = "No records to display - custom text")
)))
}
This works for me.
I am trying to send the value of a JavaScript variable from ui.R to Server.R whenever it is changed.
When a user clicks on a link, its href value is alerted . Till here it works fine.
The links are of the form
Sample link
Now, the href value is stored in variable link in ui.R .
I am sending the value of link to server.R using Shiny.onInputChange function.
But the observe function in server.R is not giving me any value. Please tell me how to do this by using observe function or any other way if possible.
ui.r
library(shiny)
shinyUI(fluidPage(
tags$script(HTML("
function clickFunction(link){
alert(link);
Shiny.onInputChange(\"linkClicked\",link);
}
"))
//rest of the code which is not related
)
server.R
library(shiny)
shinyServer(function(input, output) {
observe({
input$linkClicked
print(input$linkClicked)
})
})
I don't really fully understand where the link is coming from and how the app looks since you didn't provide enough code (for example: what does it mean "variable in the UI"?). But here's a small example that shows how the javascript sends info to the server successfully. I'm using the shinyjs package which is a package I wrote.
library(shinyjs)
jscode <- "
shinyjs.clickfunc = function(link) {
alert(link);
Shiny.onInputChange('linkClicked', link);
}"
runApp(shinyApp(
ui = fluidPage(
useShinyjs(),
extendShinyjs(text = jscode),
textInput("link", ""),
actionButton("btn", "submit")
),
server = function(input, output, session) {
observeEvent(input$btn, {
js$clickfunc(input$link)
})
observe({
input$linkClicked
print(input$linkClicked)
})
}
))
EDIT:
If I understand correctly how the links are generated, this works
runApp(shinyApp(
ui = fluidPage(
tags$script(HTML("
function clickFunction(link){
alert(link);
Shiny.onInputChange('linkClicked',link);
}
")),
tags$a(href="www.google.com", onclick="clickFunction('rstudio.org'); return false;", "click me")
),
server = function(input, output, session) {
observe({
input$linkClicked
print(input$linkClicked)
})
}
))