I am looking for a code snippet using which, I can enable/disable sidebar toggle button in shinydashboard header.
library(shiny)
library(shinydashboard)
library(shinyjs)
ui <- shinyUI(dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
useShinyjs()
)
))
server <- shinyServer(function(input, output, session) {
addClass(selector = "body", class = "sidebar-collapse") # Hide Side Bar
})
shinyApp(ui = ui, server = server)
Let me know if anybody can help???
If you use the shinyjs package, you can show or hide the sidebar toggle with a quick line of JavaScript.
library(shiny)
library(shinydashboard)
library(shinyjs)
ui <- shinyUI(dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
useShinyjs(),
actionButton("hide","Hide toggle"),
actionButton("show","Show toggle")
)
))
server <- shinyServer(function(input, output, session) {
observeEvent(input$hide,{
shinyjs::runjs("document.getElementsByClassName('sidebar-toggle')[0].style.visibility = 'hidden';")
})
observeEvent(input$show,{
shinyjs::runjs("document.getElementsByClassName('sidebar-toggle')[0].style.visibility = 'visible';")
})
})
shinyApp(ui = ui, server = server)
The JavaScript itself just refers to the first element with class sidebar-toggle (i.e. the menu button), and toggles the visibility depending on which button the user presses.
I have found a solution to this...If someone is stuck with same problem, can refer to below solution:
library(shiny)
library(shinydashboard)
library(shinyjs)
ui <- shinyUI(dashboardPage(
dashboardHeader(),
dashboardSidebar( tags$head(
tags$script(
HTML(#code for hiding sidebar tabs
"Shiny.addCustomMessageHandler('manipulateMenuItem1', function(message)
{
var aNodeList = document.getElementsByTagName('a');
for (var i = 0; i < aNodeList.length; i++)
{
if(aNodeList[i].getAttribute('data-toggle') == message.toggle && aNodeList[i].getAttribute('role') == message.role)
{
if(message.action == 'hide')
{
aNodeList[i].setAttribute('style', 'display: none;');
}
else
{
aNodeList[i].setAttribute('style', 'display: block;');
};
};
}
});"
)
)
)
),
dashboardBody(
useShinyjs(),
actionButton("h1","Hide toggle"),
actionButton("h2","Show toggle")
)
))
server <- shinyServer(function(input, output, session) {
observeEvent(input$h1,{
session$sendCustomMessage(type = "manipulateMenuItem1", message = list(action = "hide",toggle = "offcanvas", role = "button"))
})
observeEvent(input$h2,{
session$sendCustomMessage(type = "manipulateMenuItem1", message = list(action = "show",toggle = "offcanvas", role = "button"))
})
})
shinyApp(ui = ui, server = server)
Related
I'm trying to output a table via tableHTML that depends on some input in a Shiny app. In the example below, I want the table to depend on the radio button. I'm getting an error saying "Error: no function to return from, jumping to top level", so it seems it doesn't like my two return-statements. Any ideas how to go about this?
library(shiny)
library(tableHTML)
ui = fluidPage(
fluidRow(
radioButtons("radio", label = h3("Data on/off"),
choices = list("On", "Off"),
selected = "Off"),
tableHTML_output("mytable")
)
)
server = function(input, output) {
output$mytable <- render_tableHTML({
if ((input$radio == "On")) {
return(tableHTML(mtcars))
}
else {
return(NULL)
}
})
}
shinyApp(ui, server)
The above works when replacing tableHTML_output by tableOutput and render_tableHTML by renderTable and removing the tableHMTL() function.
It seems a package related issue.
Since we are dealing with plain html, we can use shiny::htmlOutput.
library(shiny)
library(tableHTML)
ui <- fluidPage(
fluidRow(
radioButtons("radio",
label = h3("Data on/off"),
choices = list("On", "Off"),
selected = "On"
),
htmlOutput("mytable")
)
)
server <- function(input, output) {
html_table <- eventReactive(input$radio, {
table <- if (input$radio == "On") {
tableHTML(mtcars)
}
return(table)
})
output$mytable <- renderText(
html_table()
)
}
shinyApp(ui, server)
Another workaround is to have two render_tableHTML inside an observeEvent like this:
library(shiny)
library(tableHTML)
ui <- fluidPage(
fluidRow(
radioButtons("radio",
label = h3("Data on/off"),
choices = list("On", "Off"),
selected = "Off"
),
tableHTML_output("mytable")
)
)
server <- function(input, output) {
observeEvent(input$radio, {
if (input$radio == "On") {
output$mytable <- render_tableHTML({
tableHTML(mtcars)
})
} else {
output$mytable <- render_tableHTML({
NULL
})
}
})
}
shinyApp(ui, server)
I am using boxSidebar for my non-english shiny app, and would really like to replace the 'More' text that appears on hovering over the icon. Can anyone help me with a solution for this?
Alternatively, I was thinking to remove it by using shinyjs::hide(), but the ID seems to change on every hover so I do not know if that's an option here.
minimum example:
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
shinyApp(
ui = dashboardPage(
header = dashboardHeader(),
body = dashboardBody(
box(
title = "Hover icon",
sidebar = boxSidebar(
id = "mycardsidebar",
p("Sidebar Content")
)
)
),
sidebar = dashboardSidebar()
),
server = function(input, output, session) {
}
)
We can use {htmltools} to do the work:
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(htmltools)
library(magrittr)
shinyApp(
ui = dashboardPage(
header = dashboardHeader(),
body = dashboardBody(
box(
title = "Hover icon",
sidebar = boxSidebar(
id = "mycardsidebar",
p("Sidebar Content")
)
) %>% {
tagQuery(.)$
find("#mycardsidebar")$
removeAttrs("data-original-title")$
addAttrs(`data-original-title`="whatever")$
allTags()
}
),
sidebar = dashboardSidebar()
),
server = function(input, output, session) {
}
)
change whatever to your text.
I'd like to display a modal dialog if users click a link. Currently, the modal dialog works if users click on the action button.
Any ideas are appreciated. Thanks.
## app.R ##
server <- function(input, output) {
observeEvent(input$act_guide, {
showModal(modalDialog(
h5("Data Guidelines"),
tags$ol(
tags$li("Must have Resp_ID as the first column, occasion_ID as second and dependent variable as the third"),
tags$li("Must have no missing value in any fields")
), easyClose = TRUE, footer = NULL)
)
})
}
ui <- fluidPage(
h4("Data guidelines"),
br(),
actionButton("act_guide", "Click Here!")
)
shinyApp(ui = ui, server = server)
You can use actionLink instead of actionButton to trigger the pop-up as shown below.
library(shiny)
library(shinyBS)
if(interactive()){
shinyApp(
ui <- fluidPage(
h4("Data guidelines"),
br(),
actionLink(inputId = "link1", label = "Click Here!")
),
server = function(input, output, session){
observeEvent(input$link1, {
showModal(modalDialog(
h5("Data Guidelines"),
tags$ol(
tags$li("Must have Resp_ID as the first column, occasion_ID as second and dependent variable as the third"),
tags$li("Must have no missing value in any fields")
), easyClose = TRUE, footer = NULL)
)
})
}
)
}
An alternate way is to use bsModal inside ui.R to trigger the pop-up as shown below:
library(shiny)
library(shinyBS)
if(interactive()){
shinyApp(
ui <- fluidPage(
h4("Data guidelines"),
br(),
actionLink(inputId = "link1", label = "Click Here!"),
bsModal(id = "modal1", title = "Test Modal", trigger = "link1",
h5("Data Guidelines"),
tags$ol(
tags$li("Must have Resp_ID as the first column, occasion_ID as second and dependent variable as the third"),
tags$li("Must have no missing value in any fields")
), easyClose = TRUE, footer = NULL)
),
server = function(input, output, session){
}
)
}
I working on a project where I have to create a form in shiny. I currently have a datatable in the UI which has email in the form of hyperlink. Once the hyperlink is clicked the modal window opens where I have another UI which shows the various fields to be filled. I have a save button here that should update my DB in the backend once the button is clicked.
The problem I am facing is that I am unable to reference each email to that particular modal window and my update query updates all the records in the DB. Is there a way to pass all the record details that has been clicked into the modal window??
What I basically need to know is how to update the record that I have clicked on and for which the pop up window is opened??
I am attaching the UI.R and server.R for use.
enter code here
ui.R
library(shiny)
library(DT)
library(shinyBS)
fluidPage(
fluidRow(
actionButton(inputId = "view",label = "Hi")),
#actionButton(inputId = "savepage1", label = "Save"),
DT::dataTableOutput('my_table'),
bsModal("FormModal", "My Modal", "",textOutput('mytext'),uiOutput("form1"),
actionButton("savepage2","Save"),DT::dataTableOutput("table1"),size = "large")
)
enter code here
server.R
library(shinyBS)
server <- function(session, input, output){
uedata<-c("","Prime","Optimus") ##add source data here
output$form1<-renderUI({
tagList(
column(width=6,selectInput("samplevalue","Select Custom Source*",choices=c("Please select",samplevaluedata))),
column(width=6,textInput("sampletext",label = "Enter Text",value = NULL,placeholder = NULL)))
})
on_click_js = "Shiny.onInputChange('mydata', '%s');
$('#FormModal').modal('show')"
convert_to_link = function(x) {
as.character(tags$a(href = "#", onclick = sprintf(on_click_js,x), x))
}
observeEvent(input$view,{
session$sendCustomMessage(type = "unbinding_table_elements", "my_table")
output$my_table <- DT::renderDataTable({
a=dbGetQuery(hcltcprod,paste0("select name,mobile,email,assignedto from public.tempnew order by 3;"))
a <- data.frame(a,row.names = NULL)
a$email <- sapply(a$email,convert_to_link)
a1 <- datatable(a,
escape = F,
options = list(paging = FALSE, ordering = FALSE, searching = FALSE, rownames = FALSE,
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node());}'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')))
a1
})
})
observeEvent(input$my_table_cell_clicked, {
print(Sys.time())
})
observe({
if(input$savepage2==0)
return()
isolate({
for(i in 1:nrow(a))
dbGetQuery(hcltcprod,paste0("update public.tempnew set s_text='",input$samplevalue,"',s_value='",input$sampletext,"' where mobile in ('",a$email,"');"))
})
})
}
As your example is connected to database and you didnt provide sample data I will go with mtcars dataset. Building on the example in the link you can view the selected data using the following:
rm(list = ls())
library(DT)
library(shiny)
library(shinyBS)
library(shinyjs)
library(shinydashboard)
# This function will create the buttons for the datatable, they will be unique
shinyInput <- function(FUN, len, id, ...) {inputs <- character(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(FUN(paste0(id, i), ...))}
inputs
}
ui <- dashboardPage(
dashboardHeader(title = "Simple App"),
dashboardSidebar(
sidebarMenu(id = "tabs",
menuItem("Menu Item 1", tabName = "one", icon = icon("dashboard"))
)
),
dashboardBody(
tabItems(
tabItem(tabName = "one",h2("Datatable Modal Popup"),
DT::dataTableOutput('my_table'),uiOutput("popup")
)
)
)
)
server <- function(input, output, session) {
my_data <- reactive({
testdata <- mtcars
as.data.frame(cbind(View = shinyInput(actionButton, nrow(testdata),'button_', label = "View", onclick = 'Shiny.onInputChange(\"select_button\", this.id)' ),testdata))
})
output$my_table <- DT::renderDataTable(my_data(),selection = 'single',options = list(searching = FALSE,pageLength = 10),server = FALSE, escape = FALSE,rownames= FALSE)
# Here I created a reactive to save which row was clicked which can be stored for further analysis
SelectedRow <- eventReactive(input$select_button,{
as.numeric(strsplit(input$select_button, "_")[[1]][2])
})
# This is needed so that the button is clicked once for modal to show, a bug reported here
# https://github.com/ebailey78/shinyBS/issues/57
observeEvent(input$select_button, {
toggleModal(session, "modalExample", "open")
})
DataRow <- eventReactive(input$select_button,{
my_data()[SelectedRow(),2:ncol(my_data())]
})
output$popup <- renderUI({
bsModal("modalExample", paste0("Data for Row Number: ",SelectedRow()), "", size = "large",
column(12,
DT::renderDataTable(DataRow())
)
)
})
}
shinyApp(ui, server)
I want to do some operations on the server side based on whether the box is collapsed or not. Is it possible to know on the server side if a box in shiny dashboard is collapsed or not?
[EDIT]:
After going through the link provided by warmoverflow and going through the following link I came up with the following code:
ui.R
library(shiny)
library(shinydashboard)
library(shinyjs)
ui <- shinyUI( dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
useShinyjs(),
extendShinyjs(text = jscode),
box(id="box1", title = "BOX 1", collapsible = TRUE, collapsed = TRUE ),
box(id="box2", title = "BOX2", collapsible = TRUE, collapsed = TRUE),
# a shiny element to display unformatted text
verbatimTextOutput("results"),
verbatimTextOutput("results1"),
# # javascript code to send data to shiny server
tags$script("
document.getElementsByClassName('btn btn-box-tool')[0].onclick = function() {
var number = document.getElementsByClassName('box-body')[0].style.display;
Shiny.onInputChange('mydata', number);
};
"),
tags$script("
document.getElementsByClassName('btn btn-box-tool')[1].onclick = function() {
var number = document.getElementsByClassName('box-body')[1].style.display;
Shiny.onInputChange('mydata1', number);
};
"),
actionButton("Collapse", "CollapseAll")
)
))
server.R
library(shiny)
library(shinydashboard)
library(shinyjs)
jscode <- "
shinyjs.collapse = function(boxid) {
$('#' + boxid).closest('.box').find('[data-widget=collapse]').click();
}
"
server <- shinyServer(function(input, output, session) {
output$results = renderPrint({
input$mydata
})
output$results1 = renderPrint({
input$mydata1
})
observeEvent(input$Collapse,{
if(input$mydata == "none" || input$mydata == "")
{
js$collapse("box1")
}
if(input$mydata1 == "none" || input$mydata == "")
{
js$collapse("box2")
}
})
})
I was wondering if there is a better way to do this. Instead of adding tags$script for each of the box is it possible to make changes to the code such that we can find out all the box that are not collapsed?
From your question, I'm not sure if you just want to collapse all expanded boxes or do something else. You can solve the first using a conditional statement in the JS code. Similarly, you can implement a button to expand all boxes using negation (if (!.....)).
library(shiny)
library(shinydashboard)
library(shinyjs)
jscode <- "
shinyjs.collapse = function(boxid) {
if (document.getElementById(boxid).parentElement.className.includes('collapsed-box')) {
$('#' + boxid).closest('.box').find('[data-widget=collapse]').click();
}
}"
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
useShinyjs(),
extendShinyjs(text = jscode),
box(id="box1", title = "BOX1", collapsible = TRUE, collapsed = FALSE ),
box(id="box2", title = "BOX2", collapsible = TRUE, collapsed = FALSE),
# a shiny element to display unformatted text
actionButton("Collapse", "CollapseAll")
))
server <- shinyServer(function(input, output, session) {
observeEvent(input$Collapse,{
for (i in 1:2) {
js$collapse(paste0('box',i))
}
})
})
shinyApp(ui = ui, server = server)