Tthe given R shiny script produces a box panel with a number of selectInputs as shown in the snapshot below. The box panel is such that when we hide or present the sidebar, the panel adjusts the size of the boxes and they remain intact.
However, when I remove or add even one extra widget like a selectinput, the widgets do not span the length of the box panel end to end and break out of the panel. How to make it such that when I add an extra widget or remove one, the end to end spanning gets maintained?
## app.R ##
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
box(title = "Data", status = "primary", solidHeader = T, width = 12,
fluidPage(
fluidRow(
column(2,offset = 0, style='padding:1px;',
selectInput("select1","select1",c("A1","A2","A3"), selected = "A1")),
column(2,offset = 0, style='padding:1px;',
selectInput("select2","select2",c("A3","A4","A5"), selected = "A3")),
column(2, offset = 0,
style='padding:1px;',selectInput("select2","select2",c("A3","A4","A5"),
selected = "A3")),
column(2, offset = 0,
style='padding:1px;',selectInput("select2","select2",c("A3","A4","A5"),
selected = "A3")),
column(2, offset = 0,
style='padding:1px;',selectInput("select2","select2",c("A3","A4","A5"),
selected = "A3")),
column(2, offset = 0,
style='padding:1px;',selectInput("select2","select2",c("A3","A4","A5"),
selected = "A3")),
tags$head(
tags$style("
.input-sm,.selectize-input {
min-height: 34px; font-size: 11.2px;
}
")))))))
server <- function(input, output) { }
shinyApp(ui, server)
With splitLayout you could try this. Just uncomment to have all six sliderInput in your box.
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
box(title = "Data", status = "primary", solidHeader = T, width = 12,
splitLayout(
cellArgs = list(style = "padding: 10px"),
selectInput("select1","select1",c("A1","A2","A3"), selected = "A1"),
selectInput("select2","select2",c("A3","A4","A5"), selected = "A3")
# selectInput("select2","select2",c("A3","A4","A5"), selected = "A3"),
# selectInput("select2","select2",c("A3","A4","A5"), selected = "A3")
# selectInput("select2","select2",c("A3","A4","A5"), selected = "A3")
# selectInput("select2","select2",c("A3","A4","A5"), selected = "A3")
))))
server <- function(input, output) { }
shinyApp(ui, server)
Related
I have multiple HTML files, and I would like to create a reactive function that changes according to the user input selections as follow:
library(shiny)
library(shinydashboard)
ui <-
dashboardPage(
dashboardSidebar( sliderTextInput(
inputId = "mySliderText",
label = "Story line",
grid = TRUE,
force_edges = TRUE,
choices = c('1','2')
)
),
dashboardBody(
fluidRow(
column(9,
box(
title = "Operations ",
closable = FALSE,
width = 9,
status = "primary",
solidHeader = FALSE,
collapsible = TRUE,
uiOutput("operations")
)
)
)
)
)
server <- function(input, output,session) {
operations_reactive <- reactive({
if (input$mySliderText ==1)
{
return(includeHTML("trial1.html"))
}
else
{
return(includeHTML("trial2.html"))
}
})
output$operations<-renderUI({operations_reactive()})
}
shinyApp(ui = ui, server = server)
it works but not in a proper way, the operations_reactive does not change when input$mySliderText changes
Is it possible to add an icon to the title of an input widget in Shiny and Shiny and Shiny dashboard? Below is an example. I want to add an icon to each input widget to indicate if it is a numeric input (using a bar-chart icon) or a text input (using a font icon). For now, I am using two columns. One with width = 1 for the icon, and the other is for the input widget. It would be great if I can add the icon to the title directly. Please let me know if there are ways to achieve this.
library(shiny)
library(shinydashboard)
header <- dashboardHeader(
title = "Icon Example"
)
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem(
text = "Input",
tabName = "Input"
)
)
)
body <- dashboardBody(
tabItem(
tabName = "Input",
fluidRow(
column(
width = 6,
box(
status = "primary", solidHeader = TRUE,
width = 12,
title = "Box 1",
fluidRow(
column(width = 1,
tags$div(HTML('<i class="fa fa-bar-chart" style = "color:#0072B2;"></i>'))
),
column(width = 11,
numericInput(inputId = "Num", label = "This is a numeric input", value = 1000))
),
fluidRow(
column(width = 1,
tags$div(HTML('<i class="fa fa-font" style = "color:#D55E00;"></i>'))
),
column(width = 11,
textInput(inputId = "Text", label = "This is a text input")
)
)
)
)
)
)
)
# User Interface
ui <- dashboardPage(
header = header,
sidebar = sidebar,
body = body
)
# Server logic
server <- function(input, output, session){}
# Complete app with UI and server components
shinyApp(ui, server)
Here is a screenshot of my code example. I would like to have the beginning of the input field aligned with the icon (as indicated by the red arrows). In other words, I hope the icon can be part of the title of the input widget.
Edit:
To increase the readability of the code we can use icon instead of HTML:
numericInput(inputId = "Num", label = div(icon("bar-chart", style = "color:blue;"), " This is a numeric input"), value = 1000)
Initial answer:
Just use your div as the label:
library(shiny)
library(shinydashboard)
header <- dashboardHeader(title = "Icon Example")
sidebar <- dashboardSidebar(sidebarMenu(menuItem(text = "Input", tabName = "Input")))
body <- dashboardBody(tabItem(tabName = "Input",
fluidRow(column(
width = 6,
box(
status = "primary",
solidHeader = TRUE,
width = 12,
title = "Box 1",
fluidRow(column(
width = 11,
numericInput(
inputId = "Num",
label = tags$div(HTML('<i class="fa fa-bar-chart" style = "color:#0072B2;"></i> This is a numeric input')),
value = 1000
)
)),
fluidRow(column(
width = 11,
textInput(
inputId = "Text",
label = tags$div(HTML('<i class="fa fa-font" style = "color:#D55E00;"></i> This is a text input'))
)
))
)
))))
# User Interface
ui <- dashboardPage(header = header,
sidebar = sidebar,
body = body)
# Server logic
server <- function(input, output, session) {}
# Complete app with UI and server components
shinyApp(ui, server)
Result:
You can achieve this by wrapping icon() to span() and tagList(). Check the updated code below:
library(shiny)
library(shinydashboard)
header <- dashboardHeader(
title = "Icon Example"
)
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem(
text = "Input",
tabName = "Input"
)
)
)
body <- dashboardBody(
tabItem(
tabName = "Input",
fluidRow(
column(
width = 6,
box(
status = "primary", solidHeader = TRUE,
width = 12,
title = span(tagList(icon("bar-chart"), "Box 1")),
fluidRow(
column(width = 1,
tags$div(HTML('<i class="fa fa-bar-chart" style = "color:#0072B2;"></i>'))
),
column(width = 11,
numericInput(inputId = "Num", label = "This is a numeric input", value = 1000))
)
),
box(
status = "primary", solidHeader = TRUE,
width = 12,
title = span(tagList(icon("font"), "Box 2")),
fluidRow(
column(width = 1,
tags$div(HTML('<i class="fa fa-font" style = "color:#D55E00;"></i>'))
),
column(width = 11,
textInput(inputId = "Text", label = "This is a text input")
)
)
)
)
)
)
)
# User Interface
ui <- dashboardPage(
header = header,
sidebar = sidebar,
body = body
)
# Server logic
server <- function(input, output, session){}
# Complete app with UI and server components
shinyApp(ui, server)
I have an example, where dateRangeInput and actionButton are added dynamically.
I need elements to be positioned side by side and not in the block.
library(shiny)
library(shinydashboard)
library(shinyjs)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
useShinyjs(), #Set up shinyjs
tabsetPanel(
tabPanel("Settings",
br(),
fluidRow(
column(width = 8,
box(
title = "Set parameters", id = "RO_05_param_box", width = NULL, solidHeader = TRUE, status ="primary", collapsible = TRUE,
fluidRow(
box(radioButtons("RO_05_param_radio", h6("Company"), choices = list("A" = 1,
"B" = 2), selected = 1), br(),
dateRangeInput("date_range_view", h6("Timeline"), start = "2019-06-30", end = "2020-06-30"), br(),
selectInput("RO_05_param_select", h6("Distribute over time"), choices = list("Stepped line" = 2, "Linear funcion" = 1))
),
box(id= "step_box", dateRangeInput("RO05_date1", h6("Start and end date"), start = "2019-06-30", end = "2020-06-30"),
tags$div(id = 'placeholder_dateRangeInput'),
actionButton("add_lag", "Add dates")
)
)
)
)
)
)
)
)
)
server <- function(input, output) {
observeEvent(input$RO_05_param_select, {
if(input$RO_05_param_select == 2){
show(id = "step_box")
} else {
hide(id = "step_box")
}
})
observeEvent(input$add_lag, {
add <- input$add_lag + 1
addID <- paste0("NO", add)
daterangeID <- paste0('RO05_date', add)
removeID <- paste0('remove_lag', add)
insertUI(
selector = '#placeholder_dateRangeInput',
ui = tags$span(id = addID,
tags$span(dateRangeInput(daterangeID, h6("Near lag and far lag"), start = "2019-06-30", end = "2020-06-30")),
tags$span(actionButton(removeID, label= '', icon("minus")))
)
)
observeEvent(input[[removeID]], {
removeUI(selector = paste0('#', addID))
})
})
}
# Run the application
shinyApp(ui = ui, server = server)
I tried adding this css:
#placeholder_dateRangeInput {
display: inline-block;
}
But all it does it only shrinks dateRangeInput widget.
However, #placeholder_dateRangeInput wraps all added elements, so I think that css should be wrapped around addID.
Here is a way that you can use to make your elements side by side. In css, you tell the element that your want on the left to be
float:left;
and the element that you want on the right to be
float:right;
This should make them side by side.
Here is an example of this being used:
https://www.geeksforgeeks.org/how-to-float-three-div-side-by-side-using-css/
I am trying to align the image I calling from the web to be in the center on my shiny app. I am using the html tag here because the image file is not saved in my computer, but I am calling it from the web. fifa_data[fifa_data$Name==input$player_name,]$Photo in my server.R file looks something like this: "https://cdn.sofifa.org/players/4/19/200104.png"
Here is an snapshot of what it looks like now, and the red square is where I want the image to be displayed:
Here is a snippet of my ui.R
ui2<- dashboardPage(
dashboardHeader(title="BIG Player Hunter"),
dashboardSidebar(
fluidRow(
uiOutput(outputId = "image")),
fluidRow(
uiOutput(outputId = "image2")),
fluidRow(
uiOutput(outputId = "image3")),
# uiOutput(outputId = "image2"),
# uiOutput(outputId = "image3")),
selectizeInput('player_name',"Player Name:",
choices=fifa_data$Name,
selected=NULL,
multiple=TRUE),
sliderInput("player_count",
"Number of players:",
min=1,
max=50,
value=5),
sliderInput("proximity",
"How close:",
min=0.01,
max=0.99,
value=0.05),
sliderInput("valuerange", "Price Range", min = 0, max = max(fifa_data$ValueNumeric_pounds),
value = c(25, 75)),
actionButton("search", "Search"),
sidebarMenu(
menuItem("Shoot 소개", tabName = "shoot_info", icon= icon("heart", lib= "glyphicon")),
menuItem("점수순위 및 분석", tabName = "leaderboard", icon= icon("bar-chart-o")),
menuItem("참가신청서", tabName = "signup", icon=icon("pencil", lib= "glyphicon"),
badgeLabel = "관리자", badgeColor = "red")
),
uiOutput("checkbox")
),
dashboardBody(
tabItem(tabName = "shoot_info",
fluidRow(
dataTableOutput("table1"),
chartJSRadarOutput("radarchart1")
)
)
)
)
Here is a sinner of my server.R
output$image<- renderUI({
tags$img(src= fifa_data[fifa_data$Name==input$player_name,]$Photo)
})
output$image2<- renderUI({
tags$img(src= fifa_data[fifa_data$Name==input$player_name,]$Flag)
})
output$image3<- renderUI({
tags$img(src= fifa_data[fifa_data$Name==input$player_name,]$`Club Logo`)
})
Try the below code for your requirement
library(shiny)
library(shinydashboard)
header <- dashboardHeader()
body <- dashboardBody()
sidebar <- dashboardSidebar(uiOutput("images"),
sliderInput("player_count",
"Number of players:",
min = 1,
max = 50,
value = 5),
sliderInput("proximity",
"How close:",
min = 0.01,
max = 0.99,
value = 0.05),
actionButton("search", "Search")
)
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output) {
output$images <- renderUI({
tags$div(img(src = "image1.png", width = 70, height = 90), img(src = "image2.png", width = 70, height = 90), img(src = "image3.png", width = 70, height = 90))
})
}
shinyApp(ui, server)
The screenshot of output
After the success of the dynamic box in shiny here : R/Shiny : Color of boxes depend on select I need you to use these boxes but in a loop.
Example :
I have an input file which give this :
BoxA
BoxB
BoxC
I want in the renderUI loop these values as a variable to generate dynamically a Box A, B and C. (if I have 4 value, i will have 4 boxes etC.)
Here is my actually code:
for (i in 1:nrow(QRSList))
{
get(QRSOutputS[i]) <- renderUI({
column(4,
box(title = h3(QRSList[1], style = "display:inline; font-weight:bold"),
selectInput("s010102i", label = NULL,
choices = list("Non commencé" = "danger", "En cours" = "warning", "Terminé" = "success"),
selected = 1) ,width = 12, background = "blue", status = get(QRSIntputS[i])))
})
column(4,
observeEvent(input$s010102i,{
get(QRSOutputS[i]) <- renderUI({
box(title = h3(QRSList[1], style = "display:inline; font-weight:bold"),
selectInput("s010102i", label = NULL,
choices = list("Not good" = "danger", "average" = "warning", "good" = "success"),
selected = get(QRSIntputS[i])) ,width = 12, background = "blue",status = get(QRSIntputS[i]))
})
The aim is to replace these box names to a variable like input$s010102 for example. But get and assign function does not exist.
Any idea ?
Thanks a lot
Here is an example how to generate boxes dynamically
library(shinydashboard)
library(shiny)
QRSList <- c("Box1","Box2","Box3","Box4","Box5")
ui <- dashboardPage(
dashboardHeader(title = "render Boxes"),
dashboardSidebar(
sidebarMenu(
menuItem("Test", tabName = "Test")
)
),
dashboardBody(
tabItems(
tabItem(tabName = "Test",
fluidRow(
tabPanel("Boxes",uiOutput("myboxes"))
)
)
)
)
)
server <- function(input, output) {
v <- list()
for (i in 1:length(QRSList)){
v[[i]] <- box(width = 3, background = "blue",
title = h3(QRSList[i], style = "display:inline; font-weight:bold"),
selectInput(paste0("slider",i), label = NULL,choices = list("Not good" = "danger", "average" = "warning", "good" = "success"))
)
}
output$myboxes <- renderUI(v)
}
shinyApp(ui = ui, server = server)