I'd like to know if there is a way to use an input in the UI component.
This is my sample code:
shinyApp(
ui <- fluidPage(
column(12,fluidRow(column(4, inputPanel(
selectInput("dx", label = "Diagnosis:",
choices = DX, selected = "LOW BACK PAIN")
))
)),
lapply(unique(allProc[dx.x==input$dx])$pat), function(patient) {
fluidRow(column(1, tags$p(patient)),
column(11, lapply(unique(allProc[pat == patient & dx.x == input$dx])$Clinic),
function(clinic){
fluidRow(column(1, tags$p(clinic)),
column(10, plotOutput(outputId = paste(patient, clinic), height = "100%")))
})))
})
),
server <- function(input, output) {
plot
)
Obviously this is wrong.. I can't just do allProc[dx.x==input$dx]), but the idea is the same. How would I filter in the UI component an element user selects in the same component?
TIA!
Related
Is there any way to render HTML in shiny's validation messages? I tried different approaches using the HTML wrapper, the tags$... functions, as well as a separate htmlOutput for the validation message, but could not get any of them to work. Here is a simple example app that shows this issue - the select should be bold in the validation message but the HTML tags are escaped (contrived example, I know, but hopefully conveys the idea, I would primarily like to use this to include fa icons in the messages):
runApp(
list(
ui = fluidPage(
titlePanel("Validation App"),
sidebarLayout(
sidebarPanel(
selectInput("data", label = "Data set", choices = c("", "mtcars"))
),
mainPanel(tableOutput("table"))
)
),
server = function(input, output) {
data <- reactive({
# validate test
validate(
need(input$data != "", HTML("Please <strong>select</strong> a data set"))
)
get(input$data, 'package:datasets')
})
output$table <- renderTable(head(data()))
}
)
)
The simplest solution is to use a uiOutput and inside the renderUI function put an if to validate the input. In the code below is an example using HTML and tags$... functions. You can can also put an icon.
library(shiny)
runApp(
list(
ui = fluidPage(
titlePanel("Validation App"),
sidebarLayout(
sidebarPanel(
selectInput("data", label = "Data set", choices = c("", "mtcars"))
),
mainPanel(uiOutput("tableUI"))
)
),
server = function(input, output) {
data <- reactive({
get(input$data, 'package:datasets')
})
output$tableUI <- renderUI({
if (input$data == "") {
div(
HTML("Please <strong>select</strong> a data set"),
tags$p(icon("exclamation"), "Please",tags$strong("select"), "a data set")
)
} else {
tableOutput("table")
}
})
output$table <- renderTable(head(data()))
}
)
)
This is a reproducible example. I'm trying to understand using the conditionalpanel function under shiny.
How do I tweak the code in a manner such that when I check both checkboxes, the plot and image will be rendered together? (with the plot on the top and image at the bottom on main panel)
library(shiny)
ui = fluidPage(
titlePanel("Plot or Example?"),
sidebarLayout(
sidebarPanel(
checkboxGroupInput("my_choices", "Example or Plot",choices = c("Plot", "Example"), selected = 1),width=2),
mainPanel(
conditionalPanel(
condition = "input.my_choices == 'Plot'",
plotOutput('my_test1')
),
conditionalPanel(
condition = "input.my_choices == 'Example'",
uiOutput("my_test2")
)
)
)
)
server = function(input, output) {
output$my_test1 <- renderPlot({plot(runif(100))})
output$my_test2 <- renderUI({
images <- c("http://www.i2symbol.com/images/abc-123/o/white_smiling_face_u263A_icon_256x256.png")
tags$img(src= images)
})
}
There are several things to do.
First, your selected argument of checkboxGroupInput should match one of the choices. Here I changed it to "Plot".
Second, I used "input.my_choices.includes('Example') && input.my_choices.includes('Plot')" as the condition when both are selected.
Third, Shiny doesn't allow the same output to be used more than once. To get around that, I made duplicates of the outputs in the server code, and referenced the duplicated names in the conditional Panel for the condition both boxes are checked.
library(shiny)
ui = fluidPage(
titlePanel("Plot or Example?"),
sidebarLayout(
sidebarPanel(
checkboxGroupInput("my_choices", "Example or Plot",choices = c("Plot", "Example"), selected = "Plot"),width=2),
mainPanel(
conditionalPanel(
condition = "input.my_choices == 'Plot'",
plotOutput("my_test1")
),
conditionalPanel(
condition = "input.my_choices == 'Example'",
uiOutput("my_test2")
),
conditionalPanel(
condition = "input.my_choices.includes('Example') && input.my_choices.includes('Plot')",
plotOutput("my_test1a"),
uiOutput("my_test2a")
)
)
)
)
server = function(input, output) {
output$my_test1 <- output$my_test1a <- renderPlot({plot(runif(100))})
output$my_test2 <- output$my_test2a <- renderUI({
images <- c("http://www.i2symbol.com/images/abc-123/o/white_smiling_face_u263A_icon_256x256.png")
tags$img(src= images)
})
}
shinyApp(ui, server)
I'm trying to create the scenario whereby using conditionalpanel, I am able to have an user input of checked boxes to display either 1 or 2 plots, one after another.
My reproducible code can be found below, however, I am unable to display the plots.
Could someone please share with me where did I make a mistake?
library(shiny)
ui = fluidPage(
titlePanel("Plot1 or Plot2?"),
sidebarLayout(
sidebarPanel(
checkboxGroupInput("my_choices", "Plot1 or Plot2",choices = c("Plot1", "Plot2"), selected = "Plot1"),width=2),
mainPanel(
conditionalPanel(
condition = "input.my_choices == 'Plot1'",
plotOutput("plot1")
),
conditionalPanel(
condition = "input.my_choices == 'Plot2'",
plotOutput("plot2")
),
conditionalPanel(
condition = "input.my_choices.includes('Plot1', 'Plot2')",
plotOutput("plot1"),
plotOutput("plot2")
)
)
)
)
server = function(input, output) {
output$plot1 <- renderPlot({plot(iris)})
output$plot2 <- renderPlot({plot(mtcars)})
}
shinyApp(ui, server)
Update:
I've got what I wanted but without using ConditionalPanel function. Here's the code below:
Would appreciate if someone can share with me the proper way of using ConditionalPanel Function! (:
library(shiny)
#data
df <- iris
#ui
ui <- fluidPage(
sidebarPanel(
checkboxGroupInput(inputId = "Question",
label = "Choose the plots",
choices = c("Plot1", "Plot2", "Plot3"),
selected = "")),
mainPanel(
uiOutput('ui_plot')
)
)
#server
server <- function(input, output)
{
# gen plot containers
output$ui_plot <- renderUI({
out <- list()
if (length(input$Question)==0){return(NULL)}
for (i in 1:length(input$Question)){
out[[i]] <- plotOutput(outputId = paste0("plot",i))
}
return(out)
})
# render plots
observe({
for (i in 1:3){
local({ #because expressions are evaluated at app init
ii <- i
output[[paste0('plot',ii)]] <- renderPlot({
if ( length(input$Question) > ii-1 ){
return(plot(runif(100)))
}
NULL
})
})
}
})
}
shinyApp(ui, server)
I would give you an alternative as you will need to create new plots with different id in order for that to work. The simplest one I can think of is using shinyjs package and its hide and show functions. You can also do this via renderUI but you shouldn't give unnecessary work to your server only if you're showing and hiding the elements
library(shiny)
library(shinyjs)
ui = fluidPage(
useShinyjs(),
titlePanel("Plot1 or Plot2?"),
sidebarLayout(
sidebarPanel(
checkboxGroupInput("my_choices", "Plot1 or Plot2",choices = c("Plot1", "Plot2"), selected = "Plot1"),width=2),
mainPanel(
plotOutput("plot1"),
plotOutput("plot2")
)
)
)
server = function(input, output,session) {
# hide plots on start
hide("plot1");hide("plot2")
output$plot1 <- renderPlot({plot(iris)})
output$plot2 <- renderPlot({plot(mtcars)})
observeEvent(input$my_choices,{
if(is.null(input$my_choices)){
hide("plot1"); hide("plot2")
}
else if(length(input$my_choices) == 1){
if(input$my_choices == "Plot1"){
show("plot1");hide("plot2")
}
if(input$my_choices == "Plot2"){
hide("plot1");show("plot2")
}
}
else{
if(all(c("Plot1","Plot2") %in% input$my_choices)){
show("plot1");show("plot2")
}
}
},ignoreNULL = F)
}
shinyApp(ui, server)
I am building a shiny dashboard and I want to implement a valueBox within the Dashboard.
body <- dashboardBody(
fluidRow(
valueBox(totalSales,"Total Sales",color="blue")
),
fluidRow(
DT::dataTableOutput("salesTable")
),
fluidRow(
DT::dataTableOutput("top10Sales")
)
)
And this is the result:
The number on the upper left is the variable totalSales but it isn't formatted in a valueBox.
Does anyone know what the problem is?
I appreciate your answers!!
My try with valueBoxOutput, but with the same result:
ui.R
body <- dashboardBody(
fluidRow(
valueBoxOutput("totalSales")
),
fluidRow(
DT::dataTableOutput("salesTable")
),
fluidRow(
DT::dataTableOutput("top10Sales")
)
)
server.R
function(input, output, session) {
output$salesTable = DT::renderDataTable(top10Sales)
output$top10Sales = DT::renderDataTable(top10Sales)
#output$totalSales = DT::renderDataTable(totalSales)
output$totalSales <- renderValueBox({
valueBox(totalSales, "Approval",color = "yellow")
})
}
And still the same result:
By the way: Infobox is working:
infoBox("test", value=1, width=3)
valueBox has to be used on the server side. To display a shiny dynamic UI element, there's generally a function (in this case valueBoxOutput) available to display it:
library(shinydashboard)
library(dplyr)
library(DT)
body <- dashboardBody(
fluidRow(
valueBoxOutput("totalCars")
),
fluidRow(
DT::dataTableOutput("table")
)
)
ui <- dashboardPage(header = dashboardHeader(),
sidebar = dashboardSidebar(),
body = body
)
server <- function(input, output) {
output$table = DT::renderDataTable(mtcars)
output$totalCars <- renderValueBox({
valueBox("Total", nrow(mtcars), color = "blue")
})
}
shinyApp(ui, server)
I need my Shiny module to hide/show a div outside of the namespace. I tried passing the div id to the module server function and using shinyjs to show/hide it but that is not working. I'm not getting an error, it just doesn't show/hide the div.
I know the Shiny module documentation says modules cannot access outputs outside the namespace. The docs do, though, give a way for the module to access inputs outside the namespace using reactives.
Does anyone know if there is a way for a Shiny module to access an output outside the namespace?
Here is what I'm trying to do:
### ui.R ###
header <- dashboardHeader(
title = a(href = 'http://google.com')
)
dashboardPage(
skin = 'black',
header,
dashboardSidebar(
sidebarMenu( id='tabs',
menuItem('Edit Existing Client', tabName = 'client-info')
)),
dashboardBody(
useShinyjs(),
fluidRow(
tabItems(
tabItem(tabName = "client-info",
div(selectClientModuleUI("clientinfons")),
div(id='editclientinfo', uiOutput('editclientstuff'))
)
)
)
)
)
### server.R ###
shinyServer(function(session,input, output) {
output$editclientstuff <- renderUI({
div(
fluidRow(
column(6,
textInput('editname', "Display name", value ='Testing name')
),
column(6,
numericInput('editastart','Start', value ='3')
)
)
)
})
callModule(selectClientModule, 'clientinfons', 'editclientinfo')
shinyjs::hide(id='editclientstuff')
})
### in global.R ###
selectClientModuleUI <- function(id){
ns <- NS(id)
clientlist = c(0, 1, 2)
names(clientlist) = c('Choose client', 'Fred', 'Kim')
div(
selectInput(ns('selectclient'), 'Select client to edit', choices = clientlist, selected = NULL, multiple = FALSE)
)
}
selectClientModule <- function(input, output, session, divtoshow = ''){
observeEvent(input$selectclient, {
if (!is.null(input$selectclient) && input$selectclient > 0){
print(paste0("showing ", divtoshow))
shinyjs::show(divtoshow)
}
})
}
That is possible by giving the value as a reactive (not as the value of the reactive) to the module. You can change the reactive Value in the module and return the reactive from the Module to the app (note, return the reactive itself, not its value). The following app switches the 'divtoshow' in the main app from inside the module. If nothing is selected, it's hidden, otherwise it's shown (note, I adjusted you code a little so it's working as a stand-alone app):
library(shinydashboard)
library(shinyjs)
# Module
selectClientModuleUI <- function(id){
ns <- NS(id)
clientlist = c(0, 1, 2)
names(clientlist) = c('Choose client', 'Fred', 'Kim')
div(
selectInput(ns('selectclient'), 'Select client to edit', choices = clientlist, selected = NULL, multiple = FALSE)
)
}
selectClientModule <- function(input, output, session, divtoshow){
observeEvent(input$selectclient, {
if (input$selectclient > 0){
print(paste0("showing editclientinfo"))
divtoshow("editclientinfo") # set the div to show to "editclientinfo", this will be visible outside the module
}else{
divtoshow("") # set the div to show to "", if nothing was chosen
}
})
# return the div to show as reactive to the main app
return(divtoshow)
}
# Main App
ui <- shinyUI(
dashboardPage(
skin = 'black',
dashboardHeader(
title = a(href = 'http://google.com')
),
dashboardSidebar(
sidebarMenu( id='tabs',
menuItem('Edit Existing Client', tabName = 'client-info')
)),
dashboardBody(
useShinyjs(),
fluidRow(
tabItems(
tabItem(tabName = "client-info",
div(selectClientModuleUI("clientinfons")),
div(id='editclientinfo', uiOutput('editclientstuff'))
)
)
)
)
))
server <- shinyServer(function(session,input, output) {
output$editclientstuff <- renderUI({
div(
fluidRow(
column(6,
textInput('editname', "Display name", value ='Testing name')
),
column(6,
numericInput('editastart','Start', value ='3')
)
)
)
})
# store the div to show in a reactive
divtoshow <- reactiveVal('')
# divtoshow can be changed in side this module, so it's a return value
divtoshow <- callModule(selectClientModule, 'clientinfons', divtoshow)
# observe the value of divtoshow and toggle the corresponding div
observeEvent(divtoshow(), {
if(divtoshow() == "editclientinfo"){
shinyjs::show("editclientinfo")
}else{
shinyjs::hide("editclientinfo")
}
})
})
shinyApp(ui, server)