Combining DT::datatable, DT::dataTableProxy and "SearchPanes" Extension in R Shiny - r

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

Related

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.

R Shiny: how to call a JavaScript function from a custom button inside a Datatable

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.

R Shiny only renderDataTable after actionbutton clicked

I want the user to click a button and then the renderDataTable function gets called
This is what I'm doing now:
The UI has this:
ui <- fluidPage(
actionButton("tbl","Show Table"),
DT::dataTableOutput("t_all")
)
Server:
server <- function(input, output){
summary_table_RCT <- eventReactive(input$tbl, {summary_table})
output$t_all <-
DT::renderDataTable(
summary_table_RCT(),
filter = 'top',
class = "cell-border stripe",
rownames = FALSE,
extensions = c("FixedColumns"),
options = list(searchHighlight = TRUE,
regex = TRUE,
scrollX = TRUE,
fixedColumns = list(leftColumns = 5))
)
}
shinyApp(ui, server)
Not sure why it's not working this is almost the same as some of the examples I've seen for eventReactive(). I see the button show up, but it doesn't do anything when clicked.
Found the answer, hopefully someone who has to go through the same frustration finds this before it makes them nuts. But in a different tab in the app, another developer used a submitButton(), which basically interrupts ALL reactive events until the button is pressed. Should only only be used in very simple apps, where you only have one button.

Shiny App-showModal does not pop up with renderSankeyNetwork

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.

R Shiny selectize.js item creation

selectize.js has an item creation option as mentioned on http://brianreavis.github.io/selectize.js/. I'm trying to add the same feature in an R Shiny implementation of selectize but unable to figure out how.
Thanks for your help!
PS: Some more details about what exactly I'm doing - I have some sort of free text vector that I let the user add to. However, I want Shiny to prompt the user with the existing free text values that have previously been added in case the user wants to repeat one of them.
All you have to do is to set create option to true:
library(shiny)
shinyApp(
server = function(input, output, session) {
observe({ print(input$foo) })
},
ui = fluidPage(
selectizeInput(
"foo", "foo", c(), selected = NULL, multiple = TRUE,
options = list(create = TRUE))
)
)

Resources