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/
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
I'm working on a shiny app that requires a lot of interaction with plots. Its quite complex, therefore I'll provide minimal examples that try to abstract the problem and reduce the code you have to copy and paste to a minimum.
One problem that I faced regarding computational efficiency when the plot changes has been solved here.
With this solution however I'm running into a different problem. Before incorporating the solution the app looked like this.
library(shiny)
ui <- fluidPage(
wellPanel(
fluidRow(
column(
width = 12,
fluidRow(
sliderInput(inputId = "slider_input", label = "Reactive values (Number of red points):", min = 1, max = 100, value = 10),
plotOutput(outputId = "plotx")
),
fluidRow(
selectInput(
inputId = "color_input",
label = "Choose color:",
choices = c("red", "blue", "green")
),
sliderInput(
inputId = "size_input",
min = 1,
max = 5,
step = 0.25,
value = 1.5,
label = "Choose size:"
)
)
)
)
)
)
slow_server <- function(input, output, session){
base_data <- reactiveVal(value = data.frame(x = rnorm(n = 200000), y = rnorm(n = 200000)))
output$plotx <- renderPlot({
# slow non reactive layer
plot(x = base_data()$x, y = base_data()$y)
# reactive layer
points(
x = sample(x = -4:4, size = input$slider_input, replace = T),
y = sample(x = -4:4, size = input$slider_input, replace = T),
col = input$color_input,
cex = input$size_input,
pch = 19
)
})
}
shinyApp(ui = ui, server = slow_server)
It differs from the example given in the solved question in so far as that it now features a well panel and some additional inputs below the plot. I had not mentioned this before because I thought it was not important to the problem.
Incorporating the solution the app now looks like this:
library(shiny)
library(ggplot2)
ui <- fluidPage(
wellPanel(
fluidRow(
column(
width = 12,
fluidRow(
sliderInput(inputId = "slider_input", label = "Reactive values (Number of red points):", min = 1, max = 100, value = 10),
div(
class = "large-plot",
plotOutput(outputId = "plot_bg"),
plotOutput(outputId = "plotx")
),
tags$style(
"
.large-plot {
position: relative;
}
#plot_bg {
position: absolute;
}
#plotx {
position: absolute;
}
"
)
),
fluidRow(
selectInput(
inputId = "color_input",
label = "Choose color:",
choices = c("red", "blue", "green")
),
sliderInput(
inputId = "size_input",
min = 1,
max = 5,
step = 0.25,
value = 1.5,
label = "Choose size:"
)
)
)
)
)
)
quick_server <- function(input, output, session){
base_data <- reactiveVal(value = data.frame(x = rnorm(n = 200000), y = rnorm(n = 200000)))
output$plot_bg <- renderPlot({
ggplot(base_data()) +
geom_point(aes(x,y)) +
scale_x_continuous(breaks = -4:4) +
scale_y_continuous(breaks = -4:4) +
xlim(-5, 5) +
ylim(-5, 5)
})
output$plotx <- renderPlot({
data.frame(
x = sample(x = -4:4, size = input$slider_input, replace = T),
y = sample(x = -4:4, size = input$slider_input, replace = T)
) %>%
ggplot() +
geom_point(mapping = aes(x,y), color = input$color_input, size = input$size_input) +
scale_x_continuous(breaks = -4:4) +
scale_y_continuous(breaks = -4:4) +
theme(
panel.background = element_rect(fill = "transparent"),
plot.background = element_rect(fill = "transparent", color = NA),
panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
legend.background = element_rect(fill = "transparent"),
legend.box.background = element_rect(fill = "transparent")
)+
xlim(-5, 5) +
ylim(-5, 5)
}, bg="transparent")
}
shinyApp(ui = ui, server = quick_server)
The plot has become way quicker. But now the plot inputs are placed on top of it. I assume it is due to the relative positioning in the new CSS class 'large-plot'. I have been fiddling around with shiny::tags$style() and shiny::verticalLayout() but my knowledge of CSS only allows my to understand CSS code not reakky to change it and I'm not making any progress.
How can I keep the relative positioning of the two overlapping plots (like in example 2) and place the additional inputs in the row below the plot (as in example 1)?
Any help is appreciated. If you need more information about the app please tell me and I'll provide it!
Thanks in advance!!
so just add some height to the large-plot class. I didn't know you wanted to add content below. So the absolute position of plots will make container large-plot have no height.
Fix is very easy. Since the plotOutput is fixed height of 400px, you can just add the same height to the container:
.large-plot {
position: relative;
height: 400px;
}
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)
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)
Please run the R shiny script below, I shall attach two screens and need a little assistance with positioning of the widgets here:
Screen 1:
I want to increase the width of the selectInput widget such that the options are clearly visible with equal spacing from the KPI boxes.
I want same width and height for the two big boxes such that it entirely covers the screen from left to right.
Note: The left border of the box should coincide with the left border of selectInput widget.
Screen 2:
1. Please help with shifting of the first and second selectInput widget, and kpi boxes above such that the box plots width can be increased like the requirement in the above screen. Please help.
## app.R ##
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Iris Chart"),
dashboardSidebar(
width = 0
),
dashboardBody(
tags$head(tags$style(HTML('.info-box {min-height: 45px;} .info-box-icon
{height: 45px; line-height: 45px;} .info-box-content {padding-top: 0px;
padding-bottom: 0px;}
'))),
fluidRow(
column(1,
selectInput("Position", "",
c("User_Analyses","User_Activity_Analyses"),selected = "Median", width =
"400"),
conditionalPanel(
condition = "input.Position == 'User_Analyses'",
selectInput("stats", "", c("Time","Cases"),selected = "Median", width =
"400"))),
tags$br(),
column(10,
infoBox("User1", paste0(10), icon = icon("credit-card"), width = "3"),
infoBox("User2",paste0(10), icon = icon("credit-card"), width =
"3"),
infoBox("User3",paste0(10), icon = icon("credit-card"), width =
"3"),
infoBox("User4",paste0(16), icon = icon("credit-card"), width =
"3")),
column(10,
conditionalPanel(
condition = "input.Position == 'User_Analyses'",
box(title = "Plot1", status = "primary",height = "537" ,solidHeader = T,
plotOutput("case_hist",height = "466")),
box(title = "Plot2", status = "primary",height = "537" ,solidHeader = T,
plotOutput("trace_hist",height = "466"))
),
conditionalPanel(
condition = "input.Position == 'User_Activity_Analyses'",
box(title = "Plot3",status = "primary",solidHeader = T,height = "537",width = "6",
plotOutput("sankey_plot")),
box(title = "Plot4",status = "primary",solidHeader = T,height = "537",width = "6",
plotOutput("sankey_table"))
)
)
)
)
)
server <- function(input, output)
{
output$case_hist <- renderPlot(
plot(iris$Sepal.Length)
)
output$trace_hist <- renderPlot(
plot(mtcars$mpg)
)
output$sankey_plot <- renderPlot({
plot(diamonds$carat)
})
#Plot for Sankey Data table
output$sankey_table <- renderPlot({
plot(iris$Petal.Length)
})
}
shinyApp(ui, server)
Is this somewhat what you want.
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Iris Chart"),
dashboardSidebar(
width = 0
),
dashboardBody(
tags$head(tags$style(HTML('.info-box {min-height: 45px;} .info-box-icon
{height: 45px; line-height: 45px;} .info-box-content {padding-top: 0px;
padding-bottom: 0px;}
'))),
fluidRow(
column(
width = 12,
column(
width = 2,
selectInput("Position", "",
c("User_Analyses","User_Activity_Analyses"),selected = "Median", width =
"400"),
conditionalPanel(
condition = "input.Position == 'User_Analyses'",
style = "margin-top:-22px;",
selectInput("stats", "", c("Time","Cases"),selected = "Median", width = "400"))
),
column(
style = "padding-top:20px;",
width = 10,
infoBox("User1", paste0(10), icon = icon("credit-card"), width = "3"),
infoBox("User2",paste0(10), icon = icon("credit-card"), width ="3"),
infoBox("User3",paste0(10), icon = icon("credit-card"), width ="3"),
infoBox("User4",paste0(16), icon = icon("credit-card"), width ="3"))
),
column(
width = 12,
conditionalPanel(
condition = "input.Position == 'User_Analyses'",
box(title = "Plot1", status = "primary",height = "537" ,solidHeader = T,
plotOutput("case_hist",height = "466")),
box(title = "Plot2", status = "primary",height = "537" ,solidHeader = T,
plotOutput("trace_hist",height = "466"))
),
conditionalPanel(
condition = "input.Position == 'User_Activity_Analyses'",
box(title = "Plot3",status = "primary",solidHeader = T,height = "537",width = "6",
plotOutput("sankey_plot")),
box(title = "Plot4",status = "primary",solidHeader = T,height = "537",width = "6",
plotOutput("sankey_table"))
)
)
)
)
)
server <- function(input, output)
{
output$case_hist <- renderPlot(
plot(iris$Sepal.Length)
)
output$trace_hist <- renderPlot(
plot(mtcars$mpg)
)
output$sankey_plot <- renderPlot({
plot(diamonds$carat)
})
#Plot for Sankey Data table
output$sankey_table <- renderPlot({
plot(iris$Petal.Length)
})
}
shinyApp(ui, server)