Related
I am trying to include LateX formulas inside a table and I am using the MathJack library to do so. Everthing is working smoothly outside a modalDialog, but when the table is produced within the modalDialog, it does not show as expected. I guess it has do to with what is written in the help page "It only needs to be called once in an app unless the content is rendered after the page is loaded, e.g. via renderUI(), in which case we have to call it explicitly every time we write math expressions to the output.". But I can't figure out how to solve the issue.
Here is a repex :
library(shiny)
ui <- shinyUI(
fluidPage(
withMathJax(),
actionButton("open", "Open")))
server <- function(input, output, session){
output$mytable <- renderTable({
df <- data.frame(A = c(HTML("$$\\alpha+\\beta$$"), "$$\\alpha+\\gamma$$", "$$\\alpha+\\lambda$$"),B = c(111111, 3333333, 3123.233))
df
}, sanitize.text.function = function(x) x)
observeEvent(input$open, {
showModal(modalDialog(
withMathJax(),
h2("$$\\mbox{My Math example }\\sqrt{2}$$"),
tableOutput('mytable')))
})
}
shinyApp(ui = ui, server = server)
Oddly, that works like this:
observeEvent(input$open, {
showModal(withMathJax(modalDialog(
h2("$$\\mbox{My Math example }\\sqrt{2}$$"),
withMathJax(tableOutput('mytable')))))
})
EDIT
Since there are some problems with this solution, here is a solution using KaTeX instead of MathJax:
library(shiny)
js <- "
$(document).on('shiny:value', function(event) {
if(event.name === 'mytable'){
// h2 element
var $h2 = $('#title');
var title = $h2.html();
var matches_title = title.match(/(%%+[^%]+%%)/g);
var i, code;
for(i=0; i<matches_title.length; i++){
code = matches_title[i].slice(2,-2);
title = title.replace(matches_title[i], katex.renderToString(code));
}
$h2.html(title);
$h2.css('visibility', 'visible');
// table:
var matches = event.value.match(/(%%+[^%]+%%)/g);
var newvalue = event.value;
for(i=0; i<matches.length; i++){
code = matches[i].slice(2,-2);
newvalue = newvalue.replace(matches[i], katex.renderToString(code));
}
event.value = newvalue;
}
})
"
css <- "#mytable td:nth-child(3) {display: none;}"
ui <- fluidPage(
tags$head(
tags$link(rel="stylesheet", href="https://cdn.jsdelivr.net/npm/katex#0.15.2/dist/katex.min.css", integrity="sha384-MlJdn/WNKDGXveldHDdyRP1R4CTHr3FeuDNfhsLPYrq2t0UBkUdK2jyTnXPEK1NQ", crossorigin="anonymous"),
tags$script(defer="", src="https://cdn.jsdelivr.net/npm/katex#0.15.2/dist/katex.min.js", integrity="sha384-VQ8d8WVFw0yHhCk5E8I86oOhv48xLpnDZx5T9GogA/Y84DcCKWXDmSDfn13bzFZY", crossorigin="anonymous"),
tags$script(HTML(js)),
tags$style(HTML(css))
),
titlePanel("Hello Shiny!"),
br(),
actionButton("open", "Open")
)
server <- function(input, output, session){
output$mytable <- renderTable({
data.frame(
A = c("%%\\alpha+\\beta%%", "%%\\alpha+\\gamma%%", "%%\\alpha+\\lambda%%"),
B = c(111111, 3333333, 3123.233),
` ` = rep(input$open, 3),
check.names = FALSE
)
}, sanitize.text.function = function(x) x)
observeEvent(input$open, {
showModal(modalDialog(
h2(
id = "title",
style = "visibility: hidden;",
"%%\\boxed{Math}\\sqrt{2}%%"
),
tableOutput("mytable")
))
})
}
shinyApp(ui, server)
Note that I include a reactive column in the dataframe:
` ` = rep(input$open, 3)
That's because the KaTeX rendering works only one time if I don't do that. Then I hide this column with some CSS.
I have two tables and I'm trying to show one at a time based on user input in radio buttons. If the input from the radio buttons is "table", i'd like to show table1. If the input is else i'd like to show table2.
observeEvent(input$visuBtn,{
req(input$visuBtn)
print(input$visubtn)
if(input$visuBtn == "table"){
hide("table2")
#DT::dataTableOutput("table1")
renderUI(
DT::dataTableOutput("table1")
)
}else{
print("Should show table2")
# removeUI(
# selector = "table"
# )
renderUI(
DT::dataTableOutput("table2")
)
#DT::dataTableOutput("table2")
#show("table2")
}
})
I've tried doing this by showing and hiding the two tables and can't figure out how to get that to work. I"ve also tried using renderUI as well. What would be the best methodology to go about this?
mainPanel(
tabsetPanel(id = "sim.tabset",
tabPanel(title = "Results",
# tableOutput("table")
DT::dataTableOutput("table"),
DT::dataTableOutput("table2")
),
)
Depending on your app, you can toggle the visibility of the table in the frontend with a little bit of javascript. In the UI, create a button and wrap the dataTableOutput in a generic container.
# some where in your UI
actionButton("toggleTable", "Toggle Table"),
tags$div(
id = "tableContainer",
DT::dataTableOutput("table")
)
...
There are many ways to toggle the visibility of an element (changing the display properties, toggling css classes, modifying other attributes, etc.). The following function toggles the html attribute hidden when the button is clicked. This can be defined in the UI using the tags$script function or loaded from an external javascript file.
const btn = document.getElementById('toggle');
const elem = document.getElementById('tableContainer');
btn.addEventListener('click', function(event) {
if (elem.hasAttribute('hidden')) {
elem.removeAttribute('hidden');
} else {
elem.setAttribute('hidden', '');
}
});
In the server, render the datatable as normal and you can remove the toggling (unless you need additional things to happen when the button is clicked).
Here is the full example.
library(shiny)
shinyApp(
ui = tagList(
tags$main(
id = "main",
tags$h1("Collapsible Table Example"),
actionButton("toggleTable", "Toggle Table"),
tags$div(
id = "tableContainer",
DT::dataTableOutput("table")
)
),
tags$script(
type = "text/javascript",
"
const btn = document.getElementById('toggleTable');
const elem = document.getElementById('tableContainer');
btn.addEventListener('click', function(event) {
if (elem.hasAttribute('hidden')) {
elem.removeAttribute('hidden');
} else {
elem.setAttribute('hidden', '');
}
});
"
)
),
server = function(input, output, session) {
output$table <- DT::renderDataTable({
data.frame(
group = sample(c("A", "B"), 20, replace = TRUE),
x = rnorm(n = 20, mean = 50, sd = 2),
y = rnorm(n = 20, mean = 50, sd = 2)
)
})
}
)
I opted to go with a simple solution, just having one table that renders based on the choice of the radiobuttons. Meaning the if/else is just within the renderDataTable function
library(shiny)
library(DT)
ui <- fluidPage(
radioButtons("Buttons", "CHOOSE!", choices = c("MTCARS", "IRIS")),
DT::dataTableOutput("THETABLE")
)
server <- function(input, output, session) {
output$THETABLE<-DT::renderDataTable({
req(input$Buttons)
if(input$Buttons == "MTCARS") {
DT::datatable(mtcars)
} else {
DT::datatable(iris)
}
})
}
shinyApp(ui, server)
Alternatively, you could use conditional panel, so it shows the table based on the radiobutton selection:
library(shiny)
library(DT)
ui <- fluidPage(
radioButtons("Buttons", "CHOOSE!", choices = c("MTCARS", "IRIS")),
conditionalPanel("input.Buttons == 'MTCARS'",
DT::dataTableOutput("TABLEMTCARS")
),
conditionalPanel("input.Buttons == 'IRIS'",
DT::dataTableOutput("TABLEIRIS"))
)
server <- function(input, output, session) {
output$TABLEMTCARS<-DT::renderDataTable({
DT::datatable(mtcars)
})
output$TABLEIRIS<-DT::renderDataTable({
DT::datatable(iris)
})
}
shinyApp(ui, server)
I want to make a little animation in R shiny.
The core is to put a sample(1:100, 1), in a valueBox, but I'd like to make an animation by printing random numbers for some seconds and and in the end print the sample result.
I've found the following code, which uses JavaScript. The problem is that the code generates an animation from 0 to the random number generated in sample.
library(shiny)
library(shinydashboard)
js <- "
Shiny.addCustomMessageHandler('anim',
function(x){
var $box = $('#' + x.id + ' div.small-box');
var value = x.value;
var $icon = $box.find('i.fa');
var $s = $box.find('div.inner h3');
var o = {value: 0};
$.Animation( o, {
value: value
}, {
duration: 1000
}).progress(function(e) {
$s.text((e.tweens[0].now).toFixed(0));
});
}
);"
# UI
ui <- dashboardPage(
skin = "black",
dashboardHeader(title = "Test"),
dashboardSidebar(disable = TRUE),
dashboardBody(
tags$head(tags$script(HTML(js))),
fluidRow(
tagAppendAttributes(
valueBox("", subtitle = "Número sorteado",
icon = icon("server"),
color = "blue"
),
id = "mybox"
)
),
br(),
actionButton("btn", "Change value")
)
)
# Server response
server <- function(input, output, session) {
rv <- reactiveVal()
observeEvent(input[["btn"]], {
rv(sample(1:100, 1))
})
observeEvent(rv(), {
for(i in 1:30){
session$sendCustomMessage("anim", list(id = "mybox", value = rv()))
}
})
}
shinyApp(ui, server)
I've also found this code that makes exactly what I want in JS, but I couldn't put it in shiny.
There's no need to resort to Javascript. Shiny has a built-in timer.
This MWE creates a value box displaying an integer chosen at random in the range 1 to 100 that updates once a second.
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
valueBoxOutput("random")
)
)
server <- function(input, output, session) {
output$random <- renderValueBox({
invalidateLater(1000, session)
valueBox("Value", sample(1:100, 1))
})
}
shinyApp(ui = ui, server = server)
I have an app which works with tabpanels that use many of the same inputs, and must be rendered using renderUI to respond to user data. I've noticed my modulated inputs give priority to the first menu they're rendered in and disregard changes made in different panels
The following is a simplified working example of the basic issue
library(shiny)
addexButtons <- function(id, label = "ROCParam") {
ns <- NS(id)
uiOutput(ns("roccondicionals"), label = label)
}
numbmod <- function(input, output, session, ndata) {
output$roccondicionals <- renderUI({
tagList(numericInput('numb', 'Choose Num', value = 0,))
})
}
ui <- fluidPage(navbarPage(
'App',
tabPanel(title = 'Menu 1',
sidebarLayout(
sidebarPanel(addexButtons("counter1", "Adder")),
mainPanel(textOutput('sumtotal'))
)),
tabPanel(title = 'Menu 2',
sidebarLayout(
sidebarPanel(addexButtons("counter2", "Multiplier"),),
mainPanel(textOutput('multiplytotal'))
))
))
server <- function(input, output) {
callModule(numbmod, "counter1")
callModule(numbmod, "counter2")
output$sumtotal <-
renderText(paste0('5 + ', input$numb, ' = ', input$numb + 5))
output$multiplytotal <-
renderText(paste0('5 x ', input$numb, ' = ', input$numb * 5))
}
shinyApp(ui = ui, server = server)
If you run this example you will see that, by changing to menu 2 the value retains the information modified in Menu 1 (which is intended) however if I choose to modify this same value in the same tab I can't and must return to Menu 1 to do so.
Is there a way to be able to modify the same rendered input on two different tabs where the last modification is the one retained?
As #YBS has already mentioned you cannot define two inputs with the same id. I would use updateNumericInput to automatically update the inputs when of the inputs is changed (triggered).
library(shiny)
addexButtons <- function(id, label = "ROCParam") {
ns <- NS(id)
uiOutput(ns("roccondicionals"), label = label)
}
numbmod <- function(input, output, session, ndata, n) {
output$roccondicionals <- renderUI({
numericInput(paste0("numb",n), 'Choose Num', value = 0)
})
}
ui <- fluidPage(navbarPage(
'App', id = "App",
tabPanel(title = 'Menu1',
tab_id = "tab1",
sidebarLayout(
sidebarPanel(addexButtons("counter1", "Adder")),
mainPanel(textOutput('sumtotal'))
)),
tabPanel(title = 'Menu2',
tab_id = "tab2",
sidebarLayout(
sidebarPanel(addexButtons("counter2", "Multiplier"),),
mainPanel(textOutput('multiplytotal'))
))
))
server <- function(input, output, session) {
observeEvent(input$numb1, {
updateNumericInput(session, "numb2", value = input$numb1)
updateNavbarPage(session,"App", "Menu2")
})
observeEvent(input$numb2, {
updateNumericInput(session, "numb1", value = input$numb2)
updateNavbarPage(session,"App", "Menu1")
})
callModule(numbmod, "counter1",n = 1)
callModule(numbmod, "counter2",n = 2)
output$sumtotal <-
renderText(paste0('5 + ', input$numb1, ' = ', input$numb1 + 5))
output$multiplytotal <-
renderText(paste0('5 x ', input$numb2, ' = ', input$numb2 * 5))
}
shinyApp(ui = ui, server = server)
I'm making an app and I need to add a button to refresh page (same function to press F5). Is there anyone can share a piece of code to implement it?
Thanks a lot!
I do have a very simple and nice solution but it won't work for a file input.
Here's a solution that'll work for all inputs except a file input:
UPDATE 2017: this solution did not work on file inputs for the first 2 years, but it does now.
library(shiny)
library(shinyjs)
runApp(shinyApp(
ui = fluidPage(
shinyjs::useShinyjs(),
div(
id = "form",
textInput("text", "Text", ""),
selectInput("select", "Select", 1:5),
actionButton("refresh", "Refresh")
)
),
server = function(input, output, session) {
observeEvent(input$refresh, {
shinyjs::reset("form")
})
}
))
When you press "Refresh", all inputs will be reset to their initial values. This is what the poster said in a comment that they actually want to do.
But file inputs are very strange and it's hard to "reset" them. See here. You could hack some JavaScript together to try to almost kind of reset an input field if you want.
However, for completeness, you can also refresh the entire page. The easiest way to do that is with session$reload(). You can also do it with {shinyjs}:
library(shiny)
library(shinyjs)
runApp(shinyApp(
ui = fluidPage(
shinyjs::useShinyjs(),
shinyjs::extendShinyjs(text = "shinyjs.refresh_page = function() { location.reload(); }", functions = "refresh_page"),
textInput("text", "Text", ""),
actionButton("refresh", "Refresh")
),
server = function(input, output, session) {
observeEvent(input$refresh, {
shinyjs::js$refresh_page()
})
}
))
Disclaimer: both these solutions use a package I wrote, shinyjs
I have a drop-down list input:
selectInput("domain", label = h4("Domain:"), choices = Domain, selected = CurrentDomain)
The choices set is based on a table in the database. It should change after I add or delete record from the table.
When I was experimenting with your reset or refresh function, the choice set could not reflect the changes and always stay the same. However, when I use the "reload" button provided by the browser, the choice set will update immediately. I am wondering whether you have a reset/refresh solution that is equivalent to the "reload" button of the browser.
I provided my code here, which will not work but will give you an idea what I want to do.
conn<-odbcDriverConnect(connString)
SystemInfo<-sqlQuery(conn, 'SELECT * FROM [DQ].[DQSystemInfo]', stringsAsFactors = FALSE)
close(conn)
Domain<-unique(SystemInfo$Domain)
Domain<-c(Domain,'NEW')
SubDomain<-unique(SystemInfo$SubDomain[SystemInfo$Domain==Domain[1]])
SubDomain<-c(SubDomain,'NEW')
CurrentDomain<-Domain[1]
CurrentSubDomain<-SubDomain[1]
SystemInfo1<-SystemInfo[SystemInfo$Domain==CurrentDomain & SystemInfo$SubDomain==CurrentSubDomain,]
jsResetCode <- "shinyjs.reset = function() {history.go(0)}"
shinyApp(
ui = fluidPage(
shinyjs::useShinyjs(),
shinyjs::extendShinyjs(text = "shinyjs.refresh = function() { location.reload(); }"),
# div(
# id = "form",
fluidRow(
column(6, selectInput("domain", label = h4("Domain:"),
choices = Domain, selected = CurrentDomain)),
column(6,uiOutput("Condition2"))
),
# fluidRow(column(2, verbatimTextOutput("value"))),
fluidRow(
column(6, uiOutput("Condition1")),
column(6,uiOutput("Condition3"))
),
extendShinyjs(text = jsResetCode),
fluidRow(
column(2, actionButton("submit", "Save", class="btn btn-primary btn-lg")),
column(2, actionButton("cancel", "Cancel", class="btn btn-primary btn-
lg")),
column(2, actionButton("delete", "Delete", class="btn btn-primary btn-lg"))
)
#)
),
server = function(input, output) {
observeEvent(input$domain, {
if (input$domain=='NEW') {
shinyjs::disable("domain")
shinyjs::disable("delete")
CurrentSubDomain<-'NEW'
output$Condition1 = renderUI({
textInput("domainT",label = "", value = "")
})
output$Condition3 = renderUI({
textInput("subdomainT", label = "",value = "")
})
})
} else {
CurrentDomain<-input$domain
SubDomain<-unique(SystemInfo$SubDomain[SystemInfo$Domain==input$domain])
SubDomain<-c(SubDomain,'NEW')}
output$Condition2 = renderUI({
selectInput("subdomain", label = h4("SubDomain:"),
choices = SubDomain, selected =CurrentSubDomain)
})
})
observeEvent(input$subdomain, {
if (input$subdomain=='NEW') {
shinyjs::disable("domain")
shinyjs::disable("subdomain")
shinyjs::disable("delete")
output$Condition3 = renderUI({
textInput("subdomainT", label = "", value = "")
})
} else {
CurrentSubDomain<-input$subdomain
conn<-odbcDriverConnect(connString)
SystemInfo<-sqlQuery(conn, 'SELECT * FROM [DQ].[DQSystemInfo]', stringsAsFactors = FALSE)
close(conn)
SystemInfo1<-SystemInfo[SystemInfo$Domain==input$domain & SystemInfo$SubDomain==input$subdomain,]
}
})
observeEvent(input$submit, {
conn<-odbcDriverConnect(connString)
DQ.DQSystemInfo<-SystemInfo[FALSE,c("Domain","SubDomain")]
DQ.DQSystemInfo[1,]<-c("","","","","","","",0,48)
DQ.DQSystemInfo$Domain<-ifelse(input$domain=='NEW',input$domainT,input$domain)
DQ.DQSystemInfo$SubDomain<-input$subdomainT
varType1 <- c("varchar(20)", "varchar(20)" )
names(varType1)<-colnames(DQ.DQSystemInfo)
sqlSave(conn, DQ.DQSystemInfo, append = TRUE, rownames = FALSE, varTypes = varType1)
close(conn)
# js$reset()
#shinyjs::reset("form")
# js$reset("form")
conn<-odbcDriverConnect(connString)
SystemInfo<-sqlQuery(conn, 'SELECT * FROM [DQ].[DQSystemInfo]', stringsAsFactors = FALSE)
close(conn)
Domain<-unique(SystemInfo$Domain)
Domain<-c(Domain,'NEW')
SubDomain<-unique(SystemInfo$SubDomain[SystemInfo$Domain==Domain[1]])
SubDomain<-c(SubDomain,'NEW')
CurrentDomain<-Domain[1]
CurrentSubDomain<-SubDomain[1]
SystemInfo1<-SystemInfo[SystemInfo$Domain==CurrentDomain & SystemInfo$SubDomain==CurrentSubDomain,]
shinyjs::js$refresh()
})
observeEvent(input$cancel, {
#js$reset()
#shinyjs::reset("form")
#js$reset("form")
shinyjs::js$refresh()
})
observeEvent(input$delete, {
conn<-odbcDriverConnect(connString)
delete.query <- paste0("DELETE DQ.DQSystemInfo WHERE Domain='",
input$domain,"' and SubDomain='",input$subdomain,"'")
sqlQuery(conn, delete.query)
close(conn)
#js$reset()
# shinyjs::reset("form")
# js$reset("form")
conn<-odbcDriverConnect(connString)
SystemInfo<-sqlQuery(conn, 'SELECT * FROM [DQ].[DQSystemInfo]', stringsAsFactors = FALSE)
close(conn)
Domain<-unique(SystemInfo$Domain)
Domain<-c(Domain,'NEW')
SubDomain<-unique(SystemInfo$SubDomain[SystemInfo$Domain==Domain[1]])
SubDomain<-c(SubDomain,'NEW')
CurrentDomain<-Domain[1]
CurrentSubDomain<-SubDomain[1]
SystemInfo1<-SystemInfo[SystemInfo$Domain==CurrentDomain & SystemInfo$SubDomain==CurrentSubDomain,]
shinyjs::js$refresh()
})
},options = list(height = 520))