I have an app with two Highcharts plot, when I start the app the width of the two plots are correct, but everytime I change the mean input, the width of the first plot is set to the width of the second, like this :
When I start the app :
When I change the input :
My code to produce the app :
library(rCharts)
library(shiny)
runApp(list(
ui = fluidPage(
title = "App title",
titlePanel(strong("App title", style="color: steelblue")),
sidebarLayout(
sidebarPanel(width = 2,
br()),
mainPanel(width = 10,
tabsetPanel(
tabPanel("Tab 1",
selectInput(inputId = "input_mean", label = "Mean : ", choices = c(20:30)),
fluidRow(
column(8,
showOutput(outputId = "chart1", lib = "highcharts")
, br(), br(), br(), br(), br(), br(), br(), br(), br(), br(), br()),
column(4,
showOutput(outputId = "chart2", lib = "highcharts"))
)
)
)
)
)
),
server = function(input, output) {
my_data <- reactive({
rnorm(n = 30, mean = as.numeric(input$input_mean))
})
output$chart1 <- renderChart2({
my_data = my_data()
h2 <- Highcharts$new()
h2$chart(type="line")
h2$series(data=my_data, name = "One", marker = list(symbol = 'circle'), color = "lightblue")
h2$set(width = 800, height = 400)
return(h2)
})
output$chart2 <- renderChart2({
my_data = my_data()
my_mean = as.numeric(input$input_mean)
part = data.frame(V1 = c("Sup", "Inf"), V2 = c(sum(my_data>my_mean), sum(my_data<my_mean)))
p = hPlot(x = "V1", y = "V2", data = part, type = "pie")
p$tooltip(pointFormat = "{series.name}: <b>{point.percentage:.1f}%</b>")
p$params$width <- 200
p$params$height <- 200
return(p)
})
}
))
I use rCharts_0.4.5 and shiny_0.9.1.
Thanks !
Replace these lines:
h2$chart(type="line")
h2$set(width = 800, height = 400)
as follows:
h2$chart(type="line", width = 800, height = 400)
This should help.
Related
I am creating a simple shiny app, and would love to structure my app in a certain way. See screenshot below -
Some things to highlight -
The solid line below the value boxes
In 3 sections with the sales map, sales trend plot and bar plot, is it possible to have a title for those sections, along with an info action button which I'll use to provide more info about the chart?
I am able to create the sidebar and value boxes with the code below, however I have trouble understanding how to use columns and/or boxes "below" the value boxes. See code below -
library(shiny)
library(shinydashboard)
# UI ----
ui <- navbarPage(
useShinydashboard(),
title = "My App",
tabPanel(
"Tab1", icon = icon("home"),
fluidPage(
sidebarLayout(
sidebarPanel(
width = 2,
dateRangeInput(inputId = "date_range",
label = h4("Date Range"),
start = as.Date("2018-01-01"),
end = as.Date("2020-12-31"),
min = as.Date("2018-01-01"),
max = as.Date("2020-12-31"),
startview = "year"
)
),
mainPanel(
# Value Box 1
valueBoxOutput(outputId = "box_1", width = 3),
# Value Box 2
valueBoxOutput(outputId = "box_2", width = 3),
# Value Box 3
valueBoxOutput(outputId = "box_3", width = 3),
# Value Box 4
valueBoxOutput(outputId = "box_4", width = 3),
br(),
hr()
)
)
)
)
)
# Server ----
server <- function(input, output) {
# Box 1
output$box_1 <- shinydashboard::renderValueBox({
valueBox(5, "box1", color = "green"
)
})
# Box 2
output$box_2 <- renderValueBox({
valueBox(10, "box2", color = "blue"
)
})
# Box 3
output$box_3 <- renderValueBox({
valueBox(15, "box1", color = "purple"
)
})
# Box 4
output$box_4 <- renderValueBox({
valueBox(20, "box1", color = "orange"
)
})
}
# Run the application
shinyApp(ui = ui, server = server)
Here is a possibility:
library(shiny)
library(shinydashboard)
library(shinyBS) # for popovers
# UI ----
ui <- navbarPage(
#useShinydashboard(),
title = "My App",
tabPanel(
"Tab1", icon = icon("home"),
fluidPage(
sidebarLayout(
sidebarPanel(
width = 2,
dateRangeInput(inputId = "date_range",
label = h4("Date Range"),
start = as.Date("2018-01-01"),
end = as.Date("2020-12-31"),
min = as.Date("2018-01-01"),
max = as.Date("2020-12-31"),
startview = "year"
)
),
mainPanel(
fluidRow(
# Value Box 1
valueBoxOutput(outputId = "box_1", width = 3),
# Value Box 2
valueBoxOutput(outputId = "box_2", width = 3),
# Value Box 3
valueBoxOutput(outputId = "box_3", width = 3),
# Value Box 4
valueBoxOutput(outputId = "box_4", width = 3),
),
tags$hr(),
br(),
fluidRow(
column(
width = 6,
tags$fieldset(
tags$legend("Plot 1", tags$span(id = "info1", icon("info-circle"))),
plotOutput("plot1", height = "600px")
)
),
bsPopover(
"info1",
title = "This is plot 1",
content = "This plot is nice",
placement = "left"
),
column(
width = 6,
tags$fieldset(
tags$legend("Plot 2"),
plotOutput("plot2", height = "300px")
),
tags$fieldset(
tags$legend("Plot 3", heigh = "300px"),
plotOutput("plot3")
)
),
)
)
)
)
)
)
# Server ----
server <- function(input, output) {
# Box 1
output$box_1 <- shinydashboard::renderValueBox({
valueBox(5, "box1", color = "green")
})
# Box 2
output$box_2 <- renderValueBox({
valueBox(10, "box2", color = "blue")
})
# Box 3
output$box_3 <- renderValueBox({
valueBox(15, "box1", color = "purple")
})
# Box 4
output$box_4 <- renderValueBox({
valueBox(20, "box1", color = "orange")
})
####
output$plot1 <- renderPlot({
plot(rnorm(10), rnorm(10))
})
output$plot2 <- renderPlot({
plot(rnorm(10), rnorm(10))
})
output$plot3 <- renderPlot({
plot(rnorm(10), rnorm(10))
})
}
# Run the application
shinyApp(ui = ui, server = server)
Help! For the life of me, I can't get values to populate from the server to the infoBox in the UI.
I've tried to define the infoboxes from the server section, but the infoboxes will only appear if I construct them in the UI (as shown below).
The goal is to populate the boxes with filtered data based on user inputs, but I've abandoned this at this stage because I can't even pass a value from the server to the UI infobox here:
infoBox("Participants Trained",
value = renderText("AYval"), # tried every combo here
width = 12,color = "blue", # tried width = NULL
icon = icon("fa-solid fa-people-group"), fill = F)
A value shows when I hardcode a value in "value = ", but none of the render options, renderText, verbatimText, output$AYval, valueTextbox, listen(),react() will get a value that is hard-coded in the server side to show up in this infobox.
To get the dashboard to display boxes, I'm using header = tagList(useShinydashboard()). My guess is this useShinydashboard() is the culprit.
I thought this comment might be relevant:
Your code using lapply and the navbarPage doesn't generate the UI in
the proper namespace, since when using the navbarPage construct your
modules are "one level deeper".
The script:
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyWidgets)
#library(shinyjs)
side_width <- 5
#completing the ui part with dashboardPage
ui <- navbarPage(fluid = TRUE,
theme = shinythemes::shinytheme("flatly"),
collapsible = TRUE,
header = tagList(
useShinydashboard()
),
tabPanel("START"),
tabPanel("Home Dashboard",
value = "Tab1",
# useShinyjs(),
fluidRow(
column(4,
# Selection Input ---------------------------------------------------------
selectInput(inputId = "AY","Academic Year",
multiple = T,
choices = unique(INDGEN$AcademicYear),
selected = unique(INDGEN$AcademicYear)
)),
column(4,
selectInput(inputId = "State","Select State",
choices = c("State","States"))),
column(4,
selectInput(inputId = "Program","Select Program",
choices = c("Program","Programs")))
),
fluidRow(column(12,
box(width = 4,
infoBox("Who?",
width = 12,color = "blue",
fill = F)
),
box(width = 4,
infoBox("Where?", width = 12,color = "blue",
fill = F)
),
box(width = 4,
infoBox("What?", width = 12,color = "blue",
fill = F))
)),
# UI Box R1 ---------------------------------------------------------------
fluidRow(column(12,
box(width = 4,
# uiOutput(infoBoxOutput("BOX1",width = NULL)),
infoBox("Participants Trained", value =
renderText("AYval"),
width = 12,color = "blue",
icon = icon("fa-solid fa-people-group"), fill = F)
),box(width = 4,
infoBox("Training Sites", nrow(data), width = 12,color = "blue",
icon = icon("fa-solid fa-school"), fill = F)
),box(width = 4,
infoBox("Training Programs Offered", nrow(data), width = 12,color = "blue",
icon = icon("fa-solid fa-book-open-reader"), fill = F))
)),
server <- function(input, output,session) {
output$AYval <- renderText({
textInput(13)
})
output$BOX1 <- renderInfoBox({
infoBox(title = "Participants Trained",
value = 13,
width = NULL,color = "blue",
icon = icon("fa-solid fa-people-group"), fill = T)
})
}#Server End
shinyApp(ui = ui,server = server,options = list(height = 1440))
Notice the "participant trained" box is empty. That's because that value isn't hard-coded. The rest are.
Here's a small reproducible example of how to change the value contents dynamically:
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyWidgets)
data(iris)
ui <- navbarPage(
fluid = TRUE,
theme = shinythemes::shinytheme("flatly"),
collapsible = TRUE,
header = tagList(
useShinydashboard()
),
tabPanel("START"),
tabPanel(
title = "Home Dashboard",
value = "Tab1",
selectInput("column",
label = "Select a column",
choices = c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width")
),
box(
width = 4,
infoBoxOutput("test")
)
)
)
server <- function(input, output, session) {
iris_sum <- reactive({
sum(iris[input$column])
})
output$test <- shinydashboard::renderInfoBox({
infoBox(
title = "Where?",
value = iris_sum(),
width = 12,
color = "blue",
fill = F
)
})
}
shinyApp(ui, server)
I'm trying to make this shiny app have a collapsible panel fixed at the top. But, whenever I make the position fixed, the collapse functionality doesn't work.
What do I have to do to fix this collapsible panel on top?
library(shiny)
library(shinyWidgets)
library(shinyBS)
library(DT)
ui <- fluidPage(
fluidRow(
column(4),
column(4,
div(
bsCollapse(id = "cntrlC1", open = "Panel 2",
bsCollapsePanel("Control Panel",
htmlOutput("dateSelector", inline = TRUE),
style = "info"
)
)
)
)
),
fluidRow(
DTOutput('sampleTbl')
)
)
server <- function(input, output, session){
output$dateSelector <- renderUI({
airDatepickerInput(
"dateSelector",
label = "Select Start & End Dates",
value = c("2020-01-01", "2020-01-10"),
multiple = 2
)
})
output$sampleTbl <- DT::renderDT(server = TRUE, {
data <- data.frame(A = rep(1, 100), B = rep(2, 100), C = rep(3, 100))
m <- datatable(
data,
options = list(pageLength = 100)
)
m
})
}
shinyApp(ui, server)
Perhaps you are looking for this
ui <- fluidPage(
fluidRow(
column(4),
column(4,
div(
bsCollapse(id = "cntrlC1", open = "Panel 2",
bsCollapsePanel("Control Panel",
htmlOutput("dateSelector", inline = TRUE),
style = "info"
)
), style="position:fixed;"
)
)
),
fluidRow(
column(width=2, textInput("searchField1", "Search")),
column(width=2, uiOutput("saveText1"), actionButton("saveBtn1", "Save"))
),
fluidRow(
DTOutput('sampleTbl')
)
)
server <- function(input, output, session){
output$dateSelector <- renderUI({
airDatepickerInput(
"dateSelector",
label = "Select Start & End Dates",
value = c("2020-01-01", "2020-01-10"),
multiple = 2
)
})
output$sampleTbl <- DT::renderDT(server = TRUE, {
data <- data.frame(A = rep(1, 100), B = rep(2, 100), C = rep(3, 100))
m <- datatable(
data,
options = list(pageLength = 100)
)
m
})
}
shinyApp(ui, server)
Layout-Question: Attached the following figure. I try to adjust the layout in the following way such that I achieve the "red" extensions. Any suggestions how to do that?
library(shiny)
# Define UI for application that draws a histogram
ui <- fluidPage(
mainPanel(width = 12,
fluidRow(
column(6, offset = 0, uiOutput("f1")),
column(6, offset = 0, uiOutput("f2"))
),
fluidRow(
column(4, offset = 0, uiOutput("f3")),
column(4, offset = 0, uiOutput("f4")),
column(4, offset = 0, uiOutput("f5"))
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output) {
output$f1 <- renderUI({
selectizeInput(inputId = "select_visualize_aggregation",
label = "F1",
choices = c("day", "week"),
selected = "week",
multiple = FALSE
)
})
...
}
# Run the application
shinyApp(ui = ui, server = server)
Set width = "100%" in selectizeInput:
output$f1 <- renderUI({
selectizeInput(inputId = "select_visualize_aggregation",
label = "F1",
choices = c("day", "week"),
selected = "week",
multiple = FALSE,
width = "100%"
)
})
The process_map() function in the server in the R shiny script creates the diagram image as below. My requirement is that there are two attributes "FUN" and "units" that are part of the performance() function. They have standard four values each that are available in the ui code below under PickerInput ID's Case4 and Case5. Currently, I am hard coding the value to create the map, can you help me to use the id's in the server code and make it dynamic such that when I select the value in the PickerInput, the formula fetches the value directly. Thanks and please help.
library(shiny)
library(shinydashboard)
library(bupaR)
library(processmapR)
library(lubridate)
library(dplyr)
library(edeaR)
library(shinyWidgets)
library(DiagrammeR)
ui <- dashboardPage(
dashboardHeader(title = "Diagram Plot",titleWidth = 290),
dashboardSidebar(width = 0),
dashboardBody(
tabsetPanel(type = "tab",
tabPanel("Overview", value = 1,
box(
column(1,
dropdown(
pickerInput(inputId = "resources",
label = "",
choices = c("Throughput Time"),
choicesOpt = list(icon = c("fa fa-bars",
"fa fa-bars",
"fa fa-safari")),
options = list(`icon-base` = "")),
circle = FALSE, status = "primary", icon = icon("list", lib = "glyphicon"), width = "300px"
),
conditionalPanel(
condition = "input.resources == 'Throughput Time' ",
tags$br(),
tags$br(),
tags$br(),
dropdown(
pickerInput(inputId = "Case4",
label = "Select the Process Time Summary Unit",
choices = c("min","max","mean","median"), options = list(`actions-box` = TRUE),
multiple = F),
circle = FALSE, status = "primary", icon = icon("eye-close", lib = "glyphicon"), width = "300px"
),
tags$br(),
tags$br(),
tags$br(),
dropdown(
pickerInput(inputId = "Case5",
label = "Select the Process Time Unit",
choices = c("mins","hours","days","weeks"), options = list(`actions-box` = TRUE),
multiple = F, selected = "days"),
circle = FALSE, status = "primary", icon = icon("eye-close", lib = "glyphicon"), width = "300px"
))),
title = "Process Map",
status = "primary",height = "575", width = "500",
solidHeader = T,
column(10,grVizOutput("State")),
align = "left")
),
id= "tabselected"
)))
server <- function(input, output) {
output$State <- renderDiagrammeR(
{
if(input$resources == "Throughput Time")
patients %>% process_map(performance(FUN = mean,units = "days"))
else
return()
})}
shinyApp(ui, server)
test this:
output$State <- renderDiagrammeR({
if(input$resources == "Throughput Time")
{
if(input$Case4=="mean"){
patients %>% process_map(performance(FUN = mean,units = input$Case5))}
else if(input$case4=="min"){
patients %>% process_map(performance(FUN = min,units = input$Case5))
}else if(input$case4=="max"){
patients %>% process_map(performance(FUN = max ,units = input$Case5))
}else{
patients %>% process_map(performance(FUN = median ,units = input$Case5))
}
}else
return()
})
or you can use this:
patients %>%
process_map(performance(FUN = eval(parse(text=input$Case4)) ,units = input$Case5))
enjoy;)
here is a sample:
library(shiny)
ui <- fluidPage(
selectInput(inputId = "func", label = "Choose The Function", choices = c("mean", "sum", "median"))
,
textOutput("text")
)
server <- function(input, output, session) {
main_data <- reactive({
data.frame(a= rnorm(100), b=rnorm(100) )
})
output$text <- renderText({
df <- main_data()
apply(df,2, FUN = eval(parse(text=input$func)) )
})
}
shinyApp(ui = ui, server = server)
You could use do.call to call a function from its name, see the example below. You can add arguments by adding them in the list in the do.call function, e.g. list(x,units=input$Case5).
library(shiny)
x=c(1,2,3,4,5,6,7)
ui <- fluidPage(
selectInput('select','Select Function: ', choices=c('mean','max','min','median')),
textOutput('text')
)
server <- function(input,output)
{
output$text <- renderText({
result = do.call(input$select, list(x))
paste0('The ', input$select, ' of [', paste(x,collapse=', '),'] is ', result)
})
}
shinyApp(ui,server)
Hope this helps!