I am developing a Shiny application which has two components Sankey Diagram and one action button which pop up "SaveMsg" dialog box on click of button .
I am seeing unexpected behavior where, If I user actionbutton and Sankeyvisualization in one dashboard, on click of action button, dashboard screen greyed out.
however If I comment Sankey code and keep only Action button on UI, Action button works as expected by showing pop up message of "save successfull".
If I comment action button code and keep only Sankey code in UI, I am able to see sankey output on dashboard.
Sankey code and action button both are working as expected separately, however if I place both in one dashboard action button greyed outscreen dashboard screen.
I have also attached sample code-
library(shiny)
library(networkD3)
library(shinydashboard)
value <- c(12,21,41,12,81)
source <- c(4,1,5,2,1)
target <- c(0,0,1,3,3)
edges2 <- data.frame(cbind(value,source,target))
names(edges2) <- c("value","source","target")
indx <- c(0,1,2,3,4,5)
ID <- c('CITY_1','CITY_2','CITY_3','CITY_4','CITY_5','CITY_6')
nodes <-data.frame(cbind(ID,indx))
ui <- dashboardPage(
dashboardHeader(
),
dashboardSidebar(disable = TRUE),
dashboardBody(
fluidPage(
actionLink("savebtn", "Save button")
,sankeyNetworkOutput("simple")
)
)
)
server <- function(input, output,session) {
# Show modal when button is clicked.
observeEvent(input$savebtn, {
showModal(modalDialog(
title = "Save successful"))
})
output$simple <- renderSankeyNetwork({
sankeyNetwork(Links = edges2, Nodes = nodes,
Source = "source", Target = "target",
Value = "value", NodeID = "ID"
,units = "SSN" )
})
}
shinyApp(ui = ui, server = server)
I haven't dug into the problem so I'm not sure why that's happening. But in case the modal you want to show is just some text (doesn't contain shiny elements), you can use shinyalert which also does modals (not on CRAN yet, haven't published it yet). Here's your code using shinyalert. Hope that helps
library(shiny)
library(networkD3)
library(shinyalert)
value <- c(12,21,41,12,81)
source <- c(4,1,5,2,1)
target <- c(0,0,1,3,3)
edges2 <- data.frame(cbind(value,source,target))
names(edges2) <- c("value","source","target")
indx <- c(0,1,2,3,4,5)
ID <- c('CITY_1','CITY_2','CITY_3','CITY_4','CITY_5','CITY_6')
nodes <-data.frame(cbind(ID,indx))
ui <- dashboardPage(
dashboardHeader(
),
dashboardSidebar(disable = TRUE),
dashboardBody(
fluidPage(
useShinyalert()
,actionLink("savebtn", "Save button")
,sankeyNetworkOutput("simple")
)
)
)
server <- function(input, output,session) {
# Show modal when button is clicked.
observeEvent(input$savebtn, {
shinyalert("Save successful")
})
output$simple <- renderSankeyNetwork({
sankeyNetwork(Links = edges2, Nodes = nodes,
Source = "source", Target = "target",
Value = "value", NodeID = "ID"
,units = "SSN" )
})
}
shinyApp(ui = ui, server = server)
UPDATE (2019.05.20)
This issue has been resolved with the dev version of shiny and should be released on CRAN soon as shiny v1.3.3.
This issue has already been reported here, and I believe it's similar to what was reported here. The JavaScript used by sankeyNetwork() adds a <foreignObject><xhtml:body>... to wrap the SVG titles to facilitate multi-line titles in older versions of IE. That structure apparently conflicts with what bootstrap-datepicker does, and after a little bit of testing, I can verify that this seems to be at the root of what is happening here as well. There is a pull request already that should fix this on the networkD3 end, but it has not been vetted and merged yet. Once it has, installing and using the dev version of networkD3 should resolve this problem. I think this should also be fixed upstream since the <foreignObject><xhtml:body>... structure seems to be valid HTML/SVG.
Related
It appears that DT::dataTableProxy is not possible with SearchPanes extension because:
SearchPanes requires Select extension.
Select extension requires DT::renderDT(server = FALSE) option.
DT::dataTableProxy does not work on the client side and throws DT error.
library(shiny)
library(shinydashboard)
library(tidyverse)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
shiny::selectInput("rows", label = "Rows", choices = 1:nrow(mtcars)),
shiny::actionButton("new", label = "New Data")
),
dashboardBody(DT::dataTableOutput("cars"))
)
server <- function(input, output) {
rows <- reactive({ input$rows })
output$cars <- DT::renderDataTable(server = FALSE, {
expr = DT::datatable(
data = mtcars |> head(rows())
#,
#extensions = c("SearchPanes", "Select", "Buttons"),
#options = list(
# dom = "Btip",
# buttons = list("searchPanes")
#)
)
})
dtProxy <- DT::dataTableProxy("cars")
observeEvent(input$new, label = "Observe button proxy update", {
doubledata <- bind_rows(mtcars, mtcars)
DT::replaceData(proxy = dtProxy,
data = doubledata,
resetPaging = FALSE)
})
}
shinyApp(ui, server)
Try this code using server = FALSE, click New Data, you will receive DT Warning:
DataTables warning: table id=DataTables_Table_0 - Invalid JSON response. For more information about this error, please see http://datatables.net/tn/1
Remove server = FALSE and proxy runs.
Remove the commented section, and search panes appear, but with no actual filters represented, and message stating that if we really want to use select extension then set select = 'none'.
Here are some reference materials:
RStudio DT Extensions
Matt Herman Tutorial
What I ended up doing was use only the DT::datatableProxy feature, then use a custom button for the search panes. Custom button was found here How to add custom button in R Shiny datatable. This required making a new reactive which was invalidated by the first, and checking if the inputs had any new values. Then the proxy received the filtered data.
Maybe someday they will add support for search panes.
Add server-side support for SearchPanes extension #877
Is it possible to create a tick-box to record an user's input without using Shiny?
For example
A program is launched
A window with boxes to tick is open
The user ticks one of the boxes
The input is sent to a variable
Is this possible?
its done with the runGadget ability that miniUI adds to shiny
i.e. make a lightweight shiny app that can pop up in a dialog window and the values get returned to the calling environment. example for you .
library(miniUI)
library(shiny)
checker <- function() {
ui <- miniPage(
gadgetTitleBar(paste("Tick Boxes")),
miniButtonBlock(
checkboxInput(inputId = "check_1",
label = "check 1 ?"),
checkboxInput(inputId = "check_2",
label = "check 2 ?")
)
)
server <- function(input, output) {
observeEvent(input$done, {
stopApp(list(
c1 = input$check_1,
c2 = input$check_2
))
})
observeEvent(input$cancel, {
stopApp(NULL)
})
}
runGadget(ui, server,viewer = dialogViewer("my diag"))
}
checker()
I have downloaded and would like to incorporate in my R Shiny app the following JavaScript library: GitHub link
As you can see in the snippet below, I have incorporated the sequence-viewer.min.js file in the head of the UI. Additionally, using the tags$div(id="sequence-viewer") I am able to see the corresponding <div> tag in the source of the web page, so up to this point I think everything is fine.
Using the following code, I construct and render a sample Datatable with sequences. From the link of the last column, I would like to dynamically change the value of the var seq=new Sequence(''); with the sequences of the Datatable and draw the result in the sequence-viewer div every time a link is clicked.
library(shiny)
ui <- fluidPage(
theme = shinytheme("yeti"),
useShinyjs(),
useShinyalert(),
tags$head(tags$script(src = "handlebars.js"),
tags$script(src = "sequence-viewer.min.js")),
mainPanel( DT::dataTableOutput("DTtable"),
br(),
tags$div(id="sequence-viewer")
)
)
server <- function(input, output) {
exp1 <- reactive({
tbl <- as.data.frame(c("MALWMPGPGAGSL", "MALKYTFDCVBJUYGFGPGAGSL", "IUYTFVBNMKIUYF"))
names(tbl) <- "Sequence"
tbl$link <- createLink(tbl$Sequence)
return(tbl)
})
createLink <- function(val) {
link <- paste0("<a href='#' onclick='var seq=new Sequence('",val,"'); seq.render('#sequence-viewer');'>Show seq</a>", sep="")
return(link)
}
output$DTtable <- DT::renderDataTable({ exp1()
}, escape = FALSE, options = list(scrollX = TRUE, dom = 'lfrtip', pageLength = 10,
lengthMenu=c(10, 25, 50, 100)), rownames = FALSE)
}
# Run the application
shinyApp(ui = ui, server = server)
I have read many threads and tutorials on how to run custom javascript code in R Shiny, but all the examples that I've found make the call in the ui , not in the server side, could you please advice me how to get the desired output?
NOTE: According to the instructions on github page, the dependencies jquery, handlebars and bootstrap.min.css are required. I suppose that only the handlebars.js has to manually be added given that R Shiny comes already with bootstrap and jquery?
UPDATE 1: Ok, I think I'm now almost there. Thanks to the comments of #YBS I managed to get the idea of how to work with external javascript libraries. The code below works fine if I click the actionLink but it does not work when clicking the custom links inside the Datatable that I create using the createLink function. I get the following exception in the console of the browser: Uncaught ReferenceError: js$seque is not defined. Any ideas why this is happening?
library(shiny)
library(shinyjs)
jsCode = '
shinyjs.seque = function(params) {
var defaultParams = {
seq : "LKJHGFVBJKUGFKGFFGHJKUYTRFGHJUYTGHJIUYT"
};
params = shinyjs.getParams(params, defaultParams);
var seq=new Sequence(params.seq);
seq.render("#sequence-viewer");
}
'
ui <- fluidPage(
useShinyjs(),
extendShinyjs(text = jsCode, functions = c("seque")),
tags$head(tags$script(src = "handlebars.js"),
tags$script(src = "sequence-viewer.min.js")
),
mainPanel( DT::dataTableOutput("DTtable"),
br(),
actionLink(inputId = "action",
label = "action"),
br(),
tags$div(id="sequence-viewer")
)
)
server <- function(input, output) {
exp1 <- reactive({
tbl <- as.data.frame(c("MALWMPGPGAGSL", "MALKYTFDCVBJUYGFGPGAGSL", "IUYTFVBNMKIUYF"))
names(tbl) <- "Sequence"
tbl$link <- createLink(tbl$Sequence)
return(tbl)
})
createLink <- function(val) {
link <- paste0("<a href='#' onclick='js$seque(",val,")' id='",val,"' class='action-button shiny-bound-input'>Show sequence</a>", sep="")
return(link)
}
observeEvent(input$action, {
js$seque("MALKYTFDCVBJUYGFGPGAGSL")
})
output$DTtable <- DT::renderDataTable({
exp1()
}, escape = FALSE, options = list(scrollX = TRUE, dom = 'lfrtip', pageLength = 10,
lengthMenu=c(10, 25, 50, 100)), rownames = FALSE)
}
# Run the application
shinyApp(ui = ui, server = server)
UPDATE 2:
After many hours of debbugging I managed to solve the issue by replacing the onclick='js$seque(",val,")' event of the button in the createLink function with the following: onclick='shinyjs.seque(\"",val,"\")' - or alternatively even clearer onclick='shinyjs.seque(JSON.stringify(val))'
In short, the js$seque call was incorrect at this point, I had to replace this line with shinyjs.seque, namely with the actual name of the function in JS. On the other hand, a typical R actionButton element requires js$seque. I will try to write a clear MRE code and provide it as an answer of this thread.
The usage of shinyjs is an overkill in your case, because you do not want to call the JS function from R but anyways through the client. Thus you can simply use plain JavaScript like in this toy example:
library(shiny)
js <- HTML("seque = function(seq) {
alert(seq);
}")
ui <- fluidPage(tags$head(tags$script(js)),
tags$a(hreg = "#", onclick = "seque('test message')",
"Click me to send test message"))
server <- function(...) {}
shinyApp(ui, server)
Don't get me wrong shinyjs: has its merits, but the typical use case is that you want to trigger JavaScript code from the R side like in this example:
library(shiny)
library(shinyjs)
js_code <- HTML("shinyjs.seque = function(par) {
var def_par = {seq: 'test message'};
par = shinyjs.getParams(par, def_par);
alert(par.seq);
}")
ui <- fluidPage(useShinyjs(),
extendShinyjs(text = js_code, functions = "seque"),
actionButton("click", "Click me to send message"))
server <- function(input, output, session) {
observeEvent(input$click, {
js$seque("test message from R")
})
}
shinyApp(ui, server)
In this example I use shinyjs to call JS directly from R, while in the previous example the JS is called via the onclick.
For your example you could use an actionLink in your table and add an observer and in this you call js$queue but since you will have one link per line this may be tricky (yet not impossible) to code (basically you need dynamic listeners),
Thus, relying on pure JS (onclick) as in your example may be the better option, but then you don't need shinyjs.
I'm trying to use an action button in R Shiny to start a slow-running JAGS model. I would like some text to appear when the user first hits the button that displays what time they pressed the button so that they know something is happening.
So far, the action button is working but it waits until the slow-running model is done to display both the model output and the text.
I have looked at the following questions but they don't seem to answer my question, at least not in a way I understand:
R Shiny execute order
Pattern for triggering a series of Shiny actions
I am new to Shiny so I'm hoping this is a simple problem.
Run.me <- function(a){
# some fake slow function
# This actually takes about 8 hours in real life
for (i in 2:a) {
Foo[i] <<- Foo[i-1] + sample(1:20,1)
}}
library(shiny)
Define server logic ----
server <- function(input, output) {
observeEvent(input$runmodel, {
output$model.running <- renderText({paste("Model started at", Sys.time())})
})
observeEvent(input$runmodel, {
Foo <<- rep(1, 1e6)
Run.me(1e6)
output$model.ran <- renderTable({head(Foo)})
})
}
Define UI ----
ui <- fluidPage(
fluidRow(
column(5, align = "center",
actionButton("runmodel", "Run the Model")),
textOutput("model.running")
),
fluidRow(
column(5, align = "center", tableOutput("model.ran"))
)
)
Run the app ----
shinyApp(ui = ui, server = server)
A possibility, if I correctly understand the question:
server <- function(input, output) {
observeEvent(input$runmodel, {
Foo <<- rep(1, 1e6)
Run.me(1e6)
output$modelran <- renderTable({head(Foo)})
})
}
js <- "
$(document).ready(function() {
$('#runmodel').on('click', function(){
var date = new Date().toLocaleString();
$('#busy').html('Model started: ' + date);
});
$('#modelran').on('shiny:value', function(event) {
$('#busy').html('');
});
});
"
ui <- fluidPage(
tags$head(
tags$script(HTML(js))
),
fluidRow(
column(5, align = "center",
actionButton("runmodel", "Run the Model")),
tags$p(id = "busy")
),
fluidRow(
column(5, align = "center", tableOutput("modelran"))
)
)
In my app which is also building a model slowly I use a progress bar in the server. I know this is not exactly what you are asking for but you might find it an acceptable solution.
modeloutput= reactive(withProgress(message = 'Generating JAGs model', value = 0, {
incProgress(50); generate_jags(params)
}))
output$jags = renderPlot(modeloutput())
I will also follow answers to this question as I would also prefer a solution that has a message or loading bar in the actual plotting window where the output will appear.
I've also found another solution that works by blocking out the action button after it has been clicked and has a small loading bar and completion message. It is available here:
https://github.com/daattali/advanced-shiny/tree/master/busy-indicator
I have created a datatable in an R shiny app at the top of the page with input controls at the bottom that determine the data displayed in that table.
The table is long, and the user must therefore scroll down to access the input controls. But upon changing any single input control, the app will automatically scroll to the top of the page.
How can I prevent automatic scrolling to the top of the page when changing the inputs? (Note that I do not want to delay updating of the table until all inputs are changed by having, for example, an 'Update table' button that must be clicked, in which case automatic scrolling would be OK.)
Note that this hasn't worked for me:
R shiny: how to stop sliderInput label click from causing scroll to top of page?
Example code:
library(shiny)
library(DT)
# Define UI
ui <- shinyUI(
fluidRow(
column(3,
DT::dataTableOutput("exampleOutput"),
numericInput("var", h5("Row value"), value = 100)
)
)
)
server <- function(input, output) {
exampleTable <- reactive({
transactionCostsDataFrame <- data.frame(
"Transaction" = rep(input$var, 100))
})
output$exampleOutput <- DT::renderDataTable(
DT::datatable(exampleTable(), escape = FALSE,
options = list(dom = "t", ordering = FALSE,
bFilter = 0, pageLength = 100))
)
}
# Run the app
shinyApp(ui = ui, server = server)