Using dashboardPage I made a dashboard made out of boxes.
I would like to be able to click somewhere on the header of a box to trigger some action. The only case I know where the header has a button is the case of expandable boxes. Would it be possible to generalize that so that, upon a click somewhere in the header of a box, some action is triggered?
My design goal is to have the info in the box update when the user clicks on this button, i.e., to have the content of the box change.
Thanks!
body <- dashboardBody(
fluidRow(
box(
title = "Title 1", width = 4, solidHeader = TRUE, status = "primary",
"Box content"
),
box(
title = "Title 1", width = 4, solidHeader = TRUE, status = "warning",
"Box content"
)
)
)
# We'll save it in a variable `ui` so that we can preview it in the console
ui <- dashboardPage(
dashboardHeader(title = "Row layout"),
dashboardSidebar(),
body
)
# Preview the UI in the console
shinyApp(ui = ui, server = function(input, output) { })
If you want a button in the right corner of the box header you could modify the original box function or you could use some JavaScript to add the button after the creation of the box.
An even simpler solution is to create a box title with an actionLink or with an actionButton. Bellow is a example for both cases. The first box has an actionLink as title, when the user clicks on it, the content of the box is updated. On the second box the title is created with plain text and with a small actionButton that will also update the box content. For the second box you could add some custom style to create a header of the same size of a normal box.
library(shiny)
library(shinydashboard)
body <- dashboardBody(
fluidRow(
box(
title = actionLink("titleId", "Update", icon = icon("refresh")),
width = 4, solidHeader = TRUE, status = "primary",
uiOutput("boxContentUI")
),
box(
title = p("Title 1",
actionButton("titleBtId", "", icon = icon("refresh"),
class = "btn-xs", title = "Update")
),
width = 4, solidHeader = TRUE, status = "warning",
uiOutput("boxContentUI2")
)
)
)
ui <- dashboardPage(
dashboardHeader(title = "Row layout"),
dashboardSidebar(),
body
)
server = function(input, output, session) {
output$boxContentUI <- renderUI({
input$titleId
pre(paste(sample(letters,10), collapse = ", "))
})
output$boxContentUI2 <- renderUI({
input$titleBtId
pre(paste(sample(LETTERS,10), collapse = ", "))
})
}
shinyApp(ui = ui, server = server)
Related
I am trying to hide the conditional panel illustrated below when there is any user input other than the user clicking on the action button "Delete" or making a selection in the selectInput() function rendered in the conditional panel, as shown in the below image. Other user inputs will be added (action buttons, radio buttons, selectInputs, etc.) so it isn't feasible to list each action that causes the conditional panel to hide. That conditional panel should always render upon the click of "Delete". Any suggestions for how to do this? Code is shown at the bottom.
Code:
library(rhandsontable)
library(shiny)
mydata <- data.frame('Col 1' = c(1,24,0,1), check.names = FALSE)
rownames(mydata) <- c('Term A','Term B','Term C','Term D')
ui <- fluidPage(br(),
rHandsontableOutput("mytable"),br(),
fluidRow(
column(1,actionButton("addCol", "Add",width = '70px')),
column(1,actionButton("delCol","Delete",width = '70px')),
column(3,conditionalPanel(condition = "input.delCol",uiOutput("delCol"))) # js here
)
)
server <- function(input, output) {
output$mytable = renderRHandsontable(df())
df <- eventReactive(input$addCol, {
if(input$addCol > 0){
newcol <- data.frame(mydata[,1])
names(newcol) <- paste("Col",ncol(mydata)+1)
mydata <<- cbind(mydata, newcol)
}
rhandsontable(mydata,rowHeaderWidth = 100, useTypes = TRUE)
}, ignoreNULL = FALSE)
observeEvent(input$delCol,
{output$delCol<-renderUI(selectInput("delCol",label=NULL,choices=colnames(mydata),selected="Col 1"))}
)
}
shinyApp(ui,server)
Per Mike´s comment I started with shinyjs and this simple example from the shinyjs reference manual, with minor modification for 2 buttons:
library(shiny)
library(shinyjs)
ui = fluidPage(
useShinyjs(), # Set up shinyjs
actionButton("btn", "Click to show"),
actionButton("btn1","Click to hide"),
hidden(p(id = "element", "I was invisible"))
)
server = function(input, output) {
observeEvent(input$btn, {show("element")})
observeEvent(input$btn1,{hide("element")})
}
shinyApp(ui,server)
Then I expanded it to my code in the OP per the below. Note that this will still require an observeEvent() for each user action that triggers selectInput() to hide instead of a global hide every time there's any user input other than a click of "Delete" action button. I'm not sure this is possible but will continue researching. Multiple observeEvents() won't be too bad of an option in any case.
Resolving code:
library(rhandsontable)
library(shiny)
library(shinyjs)
mydata <- data.frame('Col 1' = c(1,24,0,1), check.names = FALSE)
rownames(mydata) <- c('Term A','Term B','Term C','Term D')
ui <- fluidPage(
useShinyjs(), # set up shinyjs
br(),
rHandsontableOutput("mytable"),br(),
fluidRow(
column(1,actionButton("addCol", "Add",width = '70px')),
column(1,actionButton("delCol","Delete",width = '70px')),
column(3, hidden(uiOutput("delCol2")))) # hide selectInput()
)
server <- function(input,output,session){
output$mytable = renderRHandsontable(dat())
dat <- eventReactive(input$addCol, {
if(input$addCol > 0){
newcol <- data.frame(mydata[,1])
names(newcol) <- paste("Col",ncol(mydata)+1)
mydata <<- cbind(mydata, newcol)
}
rhandsontable(mydata,rowHeaderWidth = 100, useTypes = TRUE)
}, ignoreNULL = FALSE)
observeEvent(input$delCol, show("delCol2")) # clicking Delete button reveals selectInput()
observeEvent(input$addCol, hide("delCol2")) # clicking Add hides selectInput()
output$delCol2 <-renderUI({
selectInput(
"delCol3",
label=NULL,
choices=colnames(mydata),
selected="Col 1"
)
})
}
shinyApp(ui,server)
Taking example from this thread, I added a dropdown menu to select table columns.
However, the list menu should be closed when the modal opens.
Is there a way using javascript or other to get the modal dialog opens with the dropdown menu closed by default?
library(shiny)
library(shinyjs)
library(shiny.semantic)
library(DT)
modal.js <- "$('.ui.modal').modal('show');
$('#my_table').show().trigger('shown');"
ui <- semanticPage(
suppressDependencies("bootstrap"),
useShinyjs(),
div(
class = "ui modal",
div(class = "header", "Modal header"),
div(class = "content",
div(class = "ui raised segment",
selectInput(inputId = "picker",
label = "Select column",
choices = names(iris),
selected = names(iris)[-1],
multiple=T),
br(),
DT::dataTableOutput("my_table")))
),
div(class = "ui basic button action-button", id = "open_modal", "Open modal ui")
)
server <- function(input, output, session) {
output$my_table = DT::renderDataTable(head(iris[,input$picker]))
observeEvent(input$open_modal, runjs(modal.js))
}
shinyApp(ui, server, options = list(launch.browser = TRUE))
Try the option openOnFocus = FALSE in selectizeInput as shown below.
selectizeInput(inputId = "picker",
label = "Select column",
choices = names(iris),
selected = names(iris)[-1],
options = list(openOnFocus = FALSE),
multiple=T),
I would like to add a slider in a collapsible sidebar. I am having some issues displaying the content that is associated with the tabName in the body. Ie. When I click the tab, the content in the body does not show.
This is the code and how it looks like when we comment out the slider input.
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Dynamic Menu"),
dashboardSidebar(
sidebarMenu(
menuItem("hello", tabName = "helloWorld", icon = icon("calendar")#,
#sliderInput("slide", "chose Slide", min = 5, max = 10, value = 10)
)
)
),
dashboardBody(
tabItems(
tabItem(tabName = "helloWorld",
tags$h1("hey")
)
)
)
)
server <- function(input, output, session){
}
shinyApp(ui, server)
If we use the slider input, the body disappears. I have tried using some java script but I can not seem to get the result I am looking for. Keep in my the sidebar should be collapsible if I decide to add in another menuItem.
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Dynamic Menu"),
dashboardSidebar(
sidebarMenu(
menuItem("hello", tabName = "helloWorld", icon = icon("calendar"),
sliderInput("slide", "chose Slide", min = 5, max = 10, value = 10)
)
)
),
dashboardBody(
tabItems(
tabItem(tabName = "helloWorld",
tags$h1("hey")
)
)
)
)
server <- function(input, output, session){
}
shinyApp(ui, server)
What if you remove tabItems and tabItem entirely of your Body?
Try with this:
dashboardBody(
tags$h1("hey")
)
Or do you want to have multiple bodies depending on which menuItem is selected?
I'm working on a shiny app in which I only want to want textouput on hover or mouse over action
I tried adding an action button
UI:
fluidRow(box (title = p("Rates by Gender and Race", actionButton("titleBtId", "", icon=icon('question-circle'),class = "btn-xs", title = "Info"),textOutput("text_id"),hover=T), width = 15, status = 'primary', solidHeader = TRUE,tabPanel('',plotlyOutput("racegender",height = "100%"))%>% withSpinner(color="#0dc5c1")))
Server:
output$text_id <- renderText({
paste0("hi")
})
I'm not sure how would I edit it to only display text on hover
An alternative to modal popups, depending on what user experience you want, is to use tooltips from the shinyBS package, which has functions for subtle but effective popups and tooltips. Here is an example of the different functionality of hovering or clicking, and putting the tooltips in the UI or in the server, with equivalent experience. Note that theoretically you could put a hover tooltip in the UI using tipify(), but for some reason this doesn't seem to be working with actionButtons though it continues to work for other input elements.
library(shiny)
library(shinyBS)
ui <- fluidPage(
titlePanel("ShinyBS tooltips"),
actionButton("btn", "On hover"),
tipify(actionButton("btn2", "On click"), "Hello again! This is a click-able pop-up", placement="bottom", trigger = "click")
)
server <- function(input, output, session) {
addTooltip(session=session,id="btn",title="Hello! This is a hover pop-up. You'll have to click to see the next one.")
}
shinyApp(ui, server)
Got it working using ModalDialog
UI
fluidRow(
box (title = p("Rates by Gender and Race", tags$head( tags$style(HTML('#titleBtId{background-color:black}'))), actionButton("titleBtId", "", icon=icon('question-circle'),class = "btn-xs", title = "Info"),hover=T), width = 15, status = 'primary', solidHeader = TRUE, tabPanel('',plotlyOutput("racegender",height = "100%"))%>% withSpinner(color="#0dc5c1")))
Server:
observeEvent(input$titleBtId, {
showModal(modalDialog(
title = "Note",
"This chart if independent of Date-range and Age-range selections",
easyClose = TRUE
))
})
Is there a way (other than a 'colvis' button) to dynamically update which columns are visible in a DT::datatabe while using the DT::replaceData to update the table?
(The reason I can not use the 'colvis' button (as shown here:https://rstudio.github.io/DT/extensions.html) is I need to have a few different short cut convenient buttons that hide and show multiple complex patterns at once.)
This is an example of how I would initiate my app. Is there a way in js or the server-side to hide and show columns? Thanks!
library(shiny)
library(DT)
shinyApp(
ui = fluidPage(
fluidRow(
column(2, actionButton('refresh', 'Refresh Data', icon = icon('refresh'))),
column(10, DT::dataTableOutput('foo'))
)
),
server = function(input, output, session) {
df = iris
n = nrow(df)
df$ID = seq_len(n)
loopData = reactive({
input$refresh
df$ID <<- c(df$ID[n], df$ID[-n])
df
})
output$foo = DT::renderDataTable(isolate(DT::datatable(loopData(),
options = list(
columnDefs = list(list(visible=FALSE,targets=c(0,1,2))))
)))
proxy = dataTableProxy('foo')
observe({
replaceData(proxy, loopData(), resetPaging = FALSE)
})
}
)