We Keep Coding

Radio Buttons in Shiny Modal Dialog

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)

STRING interactive network in Shiny in R

Problem Statement:
I am trying to load interactive networks of STRING into a Shiny website using R
What I've Tried:
According to STRING, I can embed the interactive network but I need a couple of elements:
Javascript libary
<script type="text/javascript" src="http://string-db.org/javascript/combined_embedded_network_v2.0.2.js"></script>
Embed the div item
<div id="stringEmbedded"></div>
Call the specific protein with parameters e.g. TP53
getSTRING('https://string-db.org', {'ncbiTaxonId':'9606', 'identifiers':['TP53'], 'network_flavor':'confidence'})"
In theory, the produced network should be targetted to wherever the <div id="stringEmbedded"></div> is placed.
So I did this for Shiny:
library(shiny)
library(shinydashboard)
header <- dashboardHeader(title = "Test")
tags$head(HTML("<script type='text/javascript' src='http://string-db.org/javascript/combined_embedded_network_v2.0.2.js'></script>"))
sidebar <- dashboardSidebar(sidebarMenu(
menuItem("Item1", tabName = "dashboard", icon = icon("dashboard")),
menuItem("Item2", tabName = "widgets", icon = icon("th")),
sidebarSearchForm(textId = "searchText", buttonId = "searchButton",label = "Search...") #input$searchText and input$searchButton
))
body <-dashboardBody(
fluidRow(
tags$body(tags$script(HTML("getSTRING('https://string-db.org', {'ncbiTaxonId':'9606', 'identifiers':['TP53'], 'network_flavor':'confidence'})")),
fluidRow(
tabBox(
side = "left", height = "250px",
selected = "Tab3",
tabPanel("Tab1", tags$div(id="stringEmbedded")),
tabPanel("Tab2", "Tab content 2"),
tabPanel("Tab3", "Note that when side=right, the tab order is reversed.")
)
)
ui <- fluidPage(dashboardPage(header, sidebar, body))
server <- function(input, output) {}
shinyApp(ui = ui, server = server)

Following my comments from above, here is a minimal working example on how to embed a STRING gene network into a shiny app. I've made use of shinyjs which -- while not strictly necessary -- makes working with custom JS code easier.
library(shiny)
library(shinyjs)
jsCode <- "
shinyjs.loadStringData = function(gene) {
getSTRING('https://string-db.org', {
'ncbiTaxonId':'9606',
'identifiers': gene,
'network_flavor':'confidence'})
}"
ui <- fluidPage(
useShinyjs(),
extendShinyjs(text = jsCode),
tags$head(tags$script(src = "http://string-db.org/javascript/combined_embedded_network_v2.0.2.js")),
textInput("gene", "Gene symbol", value = "TP53"),
actionButton("button", "Show"),
h3("Network:"),
tags$div(id = "stringEmbedded")
)
server <- function(input, output, session) {
onclick("button", {
req(input$gene)
js$loadStringData(input$gene)
})
}
shinyApp(ui, server)

Override dismiss button in R Shiny modal dialogue

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)

add the response of a google api's address autocomplete into a shinyapp in R

I would like to have the address that is filled in by the autocomplete function in the javascript+html script to be added to a textInput() box in Shiny. Also, once I have submitted my form with that address I would like the autocompleted address to be reset. I have some experience in Shiny/R but none in Js. I'm fairly certain I need to add some lines in js to send information to Shiny but I'm not sure how. My script is below:
library(shiny)
library(googlesheets)
library(DT)
# Define the fields we want to save from the form
fields <- c("Title", "Description", "Order Type", "Existing", "Due Date", "Address")
gs_auth()
table <- "responses"
saveData <- function(data) {
# Grab the Google Sheet
sheet <- gs_title(table)
# Add the data as a new row
gs_add_row(sheet, input = data)
}
# Load all previous responses
# ---- This is one of the two functions we will change for every storage type ----
loadData <- function() {
# Grab the Google Sheet
sheet <- gs_title(table)
# Read the data
gs_read_csv(sheet)
}
# Shiny app with 3 fields that the user can submit data for
shinyApp(
ui = fluidPage(
titlePanel("Sign Form"),
fluidRow(
DT::dataTableOutput("responses", width = 300), tags$hr(),
column(3, textInput("Title", "Title", "")),
column(3, textInput("Description", "Description", "")),
column(3, selectInput("Order Type", label = ("Select Box"), choices = list("Installation",
"Installation/Maintenance",
"Replace Existing")))
),
fluidRow(
column(3,checkboxInput("Existing", "Is there an existing sign", FALSE)),
column(3, dateInput("Due Date", label = ('Date input'), format = "mm-dd-yyyy"))
),
fluidRow(
**column(3, textInput("Address","Address", includeHTML("www/autocomplete.html")))**
),
fluidRow(
column(3, actionButton("submit", "Submit"))
)
),
server = function(input, output, session) {
# Whenever a field is filled, aggregate all form data
formData <- reactive({
data <- sapply(fields, function(x) input[[x]])
data
})
# When the Submit button is clicked, save the form data
observeEvent(input$submit, {
saveData(formData())
})
# Show the previous responses
# (update with current response when Submit is clicked)
output$responses <- DT::renderDataTable({
input$submit
loadData()
})
}
)
The line with the autocomplete.html is where I would like some kind of textInput() that is populated when an end user fills in the address form
Here is the autocomplete.html file it is the example "Javascript + HTML"

Using observe function in shiny R

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)
})
}
))