shiny app not auto fitting web page size - r

I've built a shinydashboard app. it's working fine but the only problem is that it is not auto-fitting the webpage. Also, when opened in a mobile browser, it shows a desktop site rather than one customized for the mobile. Is there a problem with the bootstrap?
here's my code:
library(shiny)
library(shinyapps)
library(shinydashboard)
library(dygraphs)
library(htmltools)
library(htmlwidgets)
library(metricsgraphics)
library(RColorBrewer)
library(maps)
library(mapproj)
library(ggplot2)
library(dplyr)
library(plyr)
library(ggvis)
library(scales)
library(leaflet)
#library(RJSONIO)
#library(shinybootstrap2)
#shinybootstrap2::withBootstrap2()
#source("helpers.R")
test_bar <- read.csv("test_bar.csv")
channel_bar <- read.csv("channel_bar.csv")
time <- read.csv("time_enroll.csv")
#counties <- readRDS("counties.rds")
ui <- dashboardPage(skin="blue",
dashboardHeader(title="KPI Dashboard"),
dashboardSidebar(
fluidRow(),
fluidRow(),
box(width = 12.5,solidHeader=TRUE,title="Refresh Interval",
status = "warning",
selectInput("interval", "Data Time Period",
choices = c(
"Current Month" = 30,
"3MM" = 60,
"YTD" = 120,
"R12" = 300
),
selected = "30"
)
),
menuItem("", tabName = "widgets"),
menuItem("", tabName = "widgets"),
box(width = 12.5,solidHeader=TRUE,title="Refresh Interval",
status = "warning",
selectInput("interval", "Refresh interval",
choices = c(
"30 seconds" = 30,
"1 minute" = 60,
"2 minutes" = 120,
"5 minutes" = 300,
"10 minutes" = 600
),
selected = "60"
),
uiOutput("timeSinceLastUpdate"),
actionButton("refresh", "Refresh now")
# p(class = "text-muted",
# br(),
# "Source data updates every day."
# )
)
),
dashboardBody(
fluidRow(
infoBox("New Co-Pay Card Users", 100*10, icon = icon("credit-card"), fill = TRUE,color="olive"),
infoBox("Total Co-Pay Card Users", 500*10, icon = icon("credit-card"), fill = TRUE,color="olive"),
infoBox("Total Redemptions", 10000, icon = icon("thumbs-up"), fill = TRUE,color="lime")
),
fluidRow(
box(
title = "Enrollments by Specialty", status = "primary", solidHeader = TRUE,
collapsible = TRUE, width=6,height=315,
plotOutput("plots",click="plot_click1",height=240)
),
box(
title = "Trend", solidHeader = TRUE,status="primary",
collapsible = TRUE,width=6, dygraphOutput("plot2",height=250)
)
),
fluidRow(
box(title = "Enrollments by Channel", status = "primary", solidHeader = TRUE,
collapsible = TRUE, width=6,height=315,
plotOutput("plot_c")),
box(title="Map",
tags$head(tags$style("
.leaflet-container { background-color: white !important; }
")),
leafletMap(
"map", "100%", 500,
# By default OpenStreetMap tiles are used; we want nothing in this case
initialTileLayer = NULL,
initialTileLayerAttribution = NULL,
options=list(
center = c(40, -98.85),
zoom = 4,
maxBounds = list(list(17, -180), list(59, 180))
)
))
))
)
server <- function(input,output,session) {
output$plots <- renderPlot({
ggplot(test_bar,aes(x=factor(Specialty),y=Actual)) +geom_bar(stat="identity")+
theme(panel.background = element_rect(fill="white",
color="white"),panel.grid.major = element_line(color="white"),
axis.title.x=element_blank(),axis.title.y=element_blank())
})
output$plot2 <- renderDygraph({
if (is.null(input$plot_click1$x)) return()
keeprows <- round(input$plot_click1$x) == as.numeric(time$Spec)
time2 <- time[keeprows,]
time3 <- time2[2]
time_ts <- ts(time3$enroll,start=c(2014,1),end=c(2014,12),frequency=12)
dygraph(time_ts) %>% dyRangeSelector(height=20,strokeColor="") %>% dyOptions(fillGraph=TRUE)
})
output$test_table <- renderTable({
if (is.null(input$plot_click1$x)) return()
keeprows <- round(input$plot_click1$x) == as.numeric(time$Spec)
time[keeprows,]
})
output$plot_c <- renderPlot({
print(ggplot(channel_bar,aes(x=factor(Channel),y=Actual)) +geom_bar(stat="identity")+
theme(panel.background = element_rect(fill="white",
color="white"),panel.grid.major = element_line(color="white"),
axis.title.x=element_blank(),axis.title.y=element_blank()))
})
output$map <- reactive(TRUE)
map <- createLeafletMap(session, "map")
# session$onFlushed is necessary to delay the drawing of the polygons until
# after the map is created
session$onFlushed(once=TRUE, function() {
# Get shapes from the maps package
states <- map("state", plot=FALSE, fill=TRUE)
map$addPolygon(states$y, states$x, states$names,
lapply(brewer.pal(9, "Blues"), function(x) {
list(fillColor = x)
}),
list(fill=TRUE, fillOpacity=1,
stroke=TRUE, opacity=1, color="white", weight=1
)
)
})
}
shinyApp(ui, server)

You can try using the code below to control your chart size, place it right after your plotOutput or showOutput function.
HTML('<style>.rChart {width: 100%; height: 500px}</style>')
Example:
fluidRow(
box(
title = "Enrollments by Specialty", status = "primary",
solidHeader = TRUE,
collapsible = TRUE,
width=6,height=315,
plotOutput("plots",click="plot_click1",height=240),
HTML('<style>.rChart {width: 100%; height: 500px}</style>')
)

Related

Filtering data in shinydashboard

I'm having issues with a filter option in my R shinydashboard app. I'm able to filter a dataframe column (padj < 1) but when I incorporate this same filter into the app the data is missing padj rows that are very tiny like 1.41103072458963E-14. I get all rows up to 4 decimal places (0.00011014) but not rows with padj smaller than that. This cuts off dozens of wanted rows.
I may be coding something wrong and have tried searching for similar issues but haven't found any.
The select input I chose is:
pickerInput("FDR", "False Discovery Rate", choices = c(1, 0.1, 0.05, 0.01))
when I try to filter using above input:
genes1 <- reactive({
genes <- DEG2 %>% dplyr::filter(padj <= input$FDR) %>% dplyr::filter(log2FoldChange >= input$FC | log2FoldChange <= -input$FC)
})
Any help/advice is greatly appreciated.
data to be loaded here:
datafile.
See below for the app code.
library(shinydashboard)
library(dashboardthemes)
library(shiny)
library(shinythemes)
library(shinyWidgets)
library(shinycssloaders)
library(shinyjs)
library(htmlTable)
library(DT)
library(dplyr)
library(ggpubr)
library(ggplot2)
library(htmlwidgets)
library(plotly)
library(table1)
# load dataset
DEG2 <- read.csv("DEG2.csv")
# to add color to the spinner
options(spinner.color="#287894")
#############################################
### HEADER #################################
#############################################
header <- dashboardHeader(title = tagList(
tags$span(class = "logo-mini", "Cell"),
tags$span( class = "logo-lg", "My 1st App" )),
titleWidth = 300)
#############################################
### SIDEBAR #################################
#############################################
sidebar <- dashboardSidebar(width = 300, sidebarMenu(id = "sidebar", # id important for updateTabItems
menuItem("Pipeline", tabName = "pipe", icon = icon("bezier-curve")),
menuItem("Something", tabName = "plot", icon = icon("braille")),
menuItem("Something else", tabName = "pathways", icon = icon("connectdevelop")),
menuItem("Contact", tabName = "contact", icon = icon("address-card"))
)
)
#############################################
### BODY #################################
#############################################
body <- dashboardBody(
useShinyjs(), # Set up shinyjs
# changing theme
shinyDashboardThemes(theme = "blue_gradient"),
tabItems(
######### Tab 1 #########################################
tabItem("pipe",
fluidPage(
h2("Pipeline"),
#### STEP 1 ####
box(width = 12, title = "Step1: Filter for DEGs", collapsible = TRUE, collapsed = FALSE, status = "primary", solidHeader = TRUE,
fluidRow(
column(4, offset = 0,
sliderTextInput("FC", "Fold-Change (absolute value)", choices = seq(from= 0, to= 5, by=0.5), grid = TRUE),
pickerInput("FDR", "False Discovery Rate", choices = c(1, 0.1, 0.05, 0.01)),
setSliderColor(color = '#EE9B00', sliderId = 1),),
column(6, offset= 1,
valueBoxOutput("genes_filtered", width = 4))),
br(),
fluidRow(
column(10, offset =0,
DT::dataTableOutput("genetable") %>% withSpinner(type = 8, size=1))),
br(),
actionBttn("step1", "Select to advance:step 2", color = "warning", style = "fill", icon = icon("angle-double-down" ))
)),
#### STEP 2 ####
conditionalPanel(
condition = "input.step1 == 1",
fluidPage(
box(width = 12, title = "Step2: Filter for gene regulation", collapsible = TRUE, collapsed = FALSE, status = "primary", solidHeader = TRUE,
"Choose to subset the genes that are up or down regulated",
br(),
br(),
fluidRow(
column(6, offset = 0,
prettyRadioButtons("reg", "Choose:", choices = c("Up-regulated", "Down-regulated", "All"), status = "success", fill=TRUE, inline = TRUE))
),
br(),
fluidRow(
column(6, offset = 0,
valueBoxOutput("value", width = 6)))
) # box
)
) # conditional panel
)# end tab3
) # end tabItems
)#dashboardBody
ui <- dashboardPage(header = header,
sidebar = sidebar,
body = body
)
server <- function(input, output, session) {
############################################
###### TAB1 ##################
############################################
# step 1
genes1 <- reactive({
genes <- DEG2 %>% dplyr::filter(padj <= input$FDR) %>% dplyr::filter(log2FoldChange >= input$FC | log2FoldChange <= -input$FC)
})
output$genes_filtered <- renderValueBox({
valueBox(value=length(genes1()$symbol), subtitle = "Filtered genes", color = "purple", icon=icon("filter"))
})
output$genetable <- DT::renderDataTable({
genes1() }, server = FALSE, extensions =c("Responsive", "Buttons"), rownames = FALSE, options = list(dom = 'Blfrtip', buttons = list('copy', list(extend = "collection",
buttons = c("csv", "excel", "pdf"),
text = "Download")))
)
# step 2
genes2 <- reactive({
g2 <- if (input$reg == "Up-regulated"){
genes1() %>% filter(log2FoldChange > 0)
} else if (input$reg == "Down-regulated"){
genes1() %>% filter(log2FoldChange < 0)
} else {
genes1()
}
})
output$value <- renderValueBox({
if (input$reg == "Up-regulated"){
valueBox(value = length(genes2()$symbol), subtitle = "Up-regulated genes", color = "red", icon = icon("hand-point-up"))
} else if (input$reg == "Down-regulated"){
valueBox(value = length(genes2()$symbol), subtitle = "Down-regulated genes", color = "blue", icon = icon("hand-point-down"))
} else {
valueBox(value = length(genes2()$symbol), subtitle = "All genes", color = "orange", icon = icon("record-vinyl"))
}
})
} #server
shinyApp(ui, server)
Try as.numeric(input$FDR) in your filter as shown below.
genes <- DEG2 %>% dplyr::filter(padj <= as.numeric(input$FDR))

Error in dashboardPage(skin = "red", dashboardHeader(title = "My Dashboard"), : unused argument (skin = "red")

I tried to create a dashboard using the shinydashboard in rstudio. However the following error appeared when i try to run the app. How to able the dashboard to run without the following error of unused argument: skin = 'red; ? Am i missing library to be installed and called for it to happen?
sp <- read.csv("GSPC.csv", stringsAsFactors = FALSE, header = TRUE)
library(shiny)
library(semantic.dashboard)
library(shinydashboard)
library(ggplot2)
sp$Date = as.Date(sp$Date, format = "%m/%d/%Y")
ui <- dashboardPage(skin = "red",
# Application title
dashboardHeader(title = "My Dashboard"),
dashboardSidebar("Hello"),
# Show a plot of the generated distribution
dashboardBody(
frow1 <- fluidRow( valueBoxOutput("value1") ,
valueBoxOutput("value2") ,
valueBoxOutput("value3")),
frow2 <- fluidRow( box( title = "High" ,
status = "primary" ,
solidHeader = TRUE ,
collapsible = TRUE ,
plotOutput("highPlot", height = "300px") ) ,
box( title = "Low" ,
status = "primary" ,
solidHeader = TRUE ,
collapsible = TRUE ,
plotOutput("lowPlot", height = "300px") ),
# combine the two fluid rows to make the bodybody <- dashboardBody(frow1, frow2)
box( title = "Close Graph" ,
status = "primary" ,
solidHeader = TRUE ,
collapsible = TRUE ,
plotOutput("distPlot"),
width = 9),
box(selectInput("features", "Features:",
c("High", "Low", "Open","Close"))), width = 4,
#dateRangeInput("dates", "Date range",
# c("Date", start = "1927/12/31", end = as.character(Sys.Date()) )),
#start = "1927/12/31", end = as.character(Sys.Date())),
)
))
# Define server logic required to draw a histogram
server <- function(input, output) {
output$distPlot <- renderPlot({
plot(sp$Date, sp[[input$features]],
xlab = "Date", ylab = "Feature", col = 'brown', type = "l")
})
output$highPlot <- renderPlot({
hist(sp$High,
main = "Histogram of High",
col="purple",
border="white",)
})
output$lowPlot <- renderPlot({
hist(sp$Low,
main = "Histogram of Low",
col="chocolate",
border="brown",)
})}
# Run the application
shinyApp(ui = ui, server = server)
I know this is an old question, but I was struggling with the same issue. I solved it by just not loading "semantic.dashboard". Just delete library(semantic.dashboard). There seems to be a compatibility issue.

Use string from server.R as argument in a function within ui.r

I'm using shinydashboardPlus() to include a timeline in an app I'm developing. I want each timelineItem() icon to change colour depending on whether a stage is marked as complete. When a stage is incomplete, I would like the icon to be grey. When a checkboxInput() is selected, I would like the colour to change to olive.
I have written the server-side logic such that when checkboxInput is FALSE the string 'grey' is returned but when TRUE the string 'olive' is returned. I need to pass this string to the argument color in timelineItem(). I have tried passing the string to the argument using textOutput() but this doesn't work. Any ideas how I can pass the correct colour string to color?
Here's an MRE:
library(shiny)
library(shinyWidgets)
library(shinydashboard)
library(shinydashboardPlus)
ui <- dashboardPagePlus(
header = dashboardHeaderPlus(title = "Quality & Assurance Dashboard"),
sidebar = dashboardSidebar(
),
body = dashboardBody(
fluidRow(
box(width = 9,
title = "Assurance Timeline",
status = "info",
timelineBlock(
timelineEnd(color = "danger"),
timelineLabel("Start", color = "teal"),
timelineItem(
title = "Stage 1",
icon = "gears",
color = textOutput("survey_released_colour"), # Need to paste the correct colour string here
time = "now",
footer = "",
textOutput("survey_released_colour")
)
)
),
box(width = 3,
title = "Stage Sign-Off",
status = "info",
timelineBlock(
timelineEnd(color = "danger"),
timelineLabel("Start", color = "teal"),
timelineItem(
title = "Stage 1",
icon = "gears",
color = "olive",
time = "",
footer = "",
"Check here when Stage 1 complete.",
checkboxInput(inputId = "survey_release", "Surveys Released", value = FALSE, width = NULL)
)
)
)
)
),
)
server <- function(input, output) {
output$survey_released_colour<-renderText({
if (input$survey_release == TRUE){
paste0("olive")
}
else
paste0("grey")
})
}
app<-shinyApp(ui = ui, server = server)
runApp(app, host="0.0.0.0",port=5050, launch.browser = TRUE)
from the basic rules of Shiny you can't use any server component inside ui.R. You can use an condition for changing the color in server side.
My try:
library(shinydashboardPlus)
ui <- dashboardPagePlus(
header = dashboardHeaderPlus(title = "Quality & Assurance Dashboard"),
sidebar = dashboardSidebar(
),
body = dashboardBody(
fluidRow(
box(width = 9,
title = "Assurance Timeline",
status = "info",
uiOutput("timeline")
),
box(width = 3,
title = "Stage Sign-Off",
status = "info",
checkboxInput(inputId = "survey_release", "Surveys Released", value = FALSE, width = NULL)
)
)
)
)
server <- function(input, output) {
output$timeline<-renderUI({
if (input$survey_release == TRUE)
{
timelineBlock(
timelineEnd(color = "danger"),
timelineLabel("Start", color = "teal"),
timelineItem(
title = "Stage 1",
icon = "gears",
#color = textOutput("survey_released_colour"), # Need to paste the correct colour string here
color ='red',
time = "now",
footer = ""
)
)
}
else
{
timelineBlock(
timelineEnd(color = "danger"),
timelineLabel("Start", color = "teal"),
timelineItem(
title = "Stage 1",
icon = "gears",
#color = textOutput("survey_released_colour"), # Need to paste the correct colour string here
color ="green",
time = "now",
footer = ""
)
)
}
})
}
shinyApp(ui, server)
let me know if this helps.

Right Side Bar handling in R Shiny

I am using library(ygdashboard) from here for build a Right Side control bar in Shiny Apps. Which most like AdminLTE.io template.
In AdminLTE.io Right Side Control Bar there is an option,by enabling it the content part will adjust the width and display accordingly.
Can any body help me out here?? My Try:
Mycode:
UI.R
library(shinydashboard)
library(shinyjs)
library(plotly)
library(shinyWidgets)
library(ygdashboard)
library(c3)
library(flexdashboard)
source("helper.R")
dashboardPage( skin = 'green',
dashboardHeader(title=" Test Stand Report",
tags$li(a(img(src = 'logo.jfif',
height = "30px"),
style = "padding-top:10px; padding-bottom:10px;"),
class = "dropdown")),
dashboardSidebar(sidebarMenu(id="tabs",
menuItem("DashBoard", tabName = "dashboard", icon = icon("dashboard", lib = "glyphicon")),
menuItem("Drill Report",icon = icon("link",lib = "glyphicon"),
menuSubItem("Test Stand",tabName = "test_stand",icon = icon("database")),
menuSubItem("Test Code",tabName = "test_code",icon = icon("folder-open",lib = "glyphicon")),
menuSubItem("Product Based",tabName = "product_based",icon = icon("database")),
menuSubItem("Time Shift",tabName = "time_shift",icon = icon("folder-open",lib = "glyphicon"))
)
)
),
dashboardBody(
shinyjs::useShinyjs(),
tabItems(
tabItem(tabName = "dashboard",
fluidRow(
column(3,
gaugeOutput("gauge1",width = "100%", height = "auto"),
uiOutput("infobox_1")
#gaugeOutput("gauge2",width = "100%", height = "auto")
),
column(3,
gaugeOutput("gauge3",width = "100%", height = "auto"),
uiOutput("infobox_2")
#gaugeOutput("gauge4",width = "100%", height = "100px")
),
column(3,
gaugeOutput("gauge5",width = "100%", height = "auto"),
uiOutput("infobox_3")
#gaugeOutput("gauge6",width = "100%", height = "auto")
),
column(3,
gaugeOutput("gauge7",width = "100%", height = "auto"),
uiOutput("infobox_4")
#gaugeOutput("gauge8",width = "100%", height = "auto")
)
),
fluidRow(
)
),
tabItem(tabName = "test_stand",
fluidRow(
column(3,
wellPanel(
uiOutput("test_stand_select")
)
),
column(3,uiOutput("count_test_code")),
column(3,uiOutput("count_vehicle_tested")),
column(3,uiOutput("count_vehicle_failed"))
),
fluidRow(
box(title = "Success Faliure Ratio",solidHeader = TRUE,width = 4,collapsible = TRUE,height = 'auto',status="success",
plotlyOutput("sucess_faliure_pie",height = '250px')
#tableOutput("sucess_faliure_pie")
),
box(title = "Success Faliure rate with Test_Code",solidHeader = TRUE,width = 8,collapsible = TRUE,height = 'auto',status="success",
#tableOutput("test_stand_test_code_rel")
plotlyOutput("test_stand_test_code_rel",height = '250px')
)
)
),
tabItem(tabName = 'test_code',
fluidRow(
)
)
)
),
dashboardFooter(mainText = "My footer", subText = "2018"),
dashboardControlbar()
)
Server.R
library(shiny)
library(shinyjs)
library(RMySQL)
library(DT)
library(devtools)
library(woe)
library(sqldf)
library(plyr)
library(shinyalert)
source("helper.R")
shinyServer(function(input, output,session) {
######################### Date range Selection ################################
output$date_range<-renderUI({
if(input$tabs=="test_stand")
{
dateRangeInput("selected_date_range_test_stand", "Select Time Period:",
start = Sys.Date()-10,
end = Sys.Date(),
max=Sys.Date())
}
else if(input$tabs=="test_code")
{
dateRangeInput("selected_date_range_test_code", "Select Time Period:",
start = Sys.Date()-10,
end = Sys.Date(),
max=Sys.Date())
}
else if(input$tabs=="product_based")
{
dateRangeInput("selected_date_range_product_based", "Select Time Period:",
start = Sys.Date()-10,
end = Sys.Date(),
max=Sys.Date())
}
})
##########################report buttom ################################
output$action_btn<-renderUI({
if(input$tabs=="test_stand")
{
actionBttn("get_data_test_stand","Get Report")
}
else if(input$tabs=="test_code")
{
actionBttn("get_data_test_code","Get Report")
}
else if(input$tabs=="product_based")
{
actionBttn("get_data_product_based","Get Report")
}
})
#########################product group selection##################################
output$pg_list<-renderUI({
if(input$tabs=="test_stand")
{
selectInput("selected_pg_test_stand","Select your Product Group",choices = c("Back"="BHO","SKD"="SKD","ABC"="ABC"))
}
else if(input$tabs=="test_code")
{
selectInput("selected_pg_test_code","Select your Product Group",choices = c("Back"="BHO","SKD"="SKD","ABC"="ABC"))
}
else if(input$tabs=="product_based")
{
selectInput("selected_pg_product_based","Select your Product Group",choices = c("Back"="BHO","SKD"="SKD","ABC"="ABC"))
}
})
#############################top 8 gauge################################
output$gauge1<-renderGauge({
gauge(0.5,
min = 0,
max = 1,
sectors = gaugeSectors(success = c(0.5, 1),
warning = c(0.3, 0.5),
danger = c(0, 0.3)),label = 'Gauge 1')
})
output$infobox_1<-renderInfoBox({
infoBox("Total Test Stand Active",10 * 2,subtitle = "Subtitle", icon = icon("credit-card"),fill = TRUE,color = "yellow")
})
output$gauge3<-renderGauge({
gauge(0.7,
min = 0,
max = 1,
sectors = gaugeSectors(success = c(0.5, 1),
warning = c(0.3, 0.5),
danger = c(0, 0.3)),label = 'Gauge 3')
})
output$infobox_2<-renderInfoBox({
infoBox("Total Test Code Running ",10 * 2,subtitle = "Subtitle" ,icon = shiny::icon("bar-chart"),color = "fuchsia",width = 4,fill = TRUE)
})
output$gauge5<-renderGauge({
gauge(0.6,
min = 0,
max = 1,
sectors = gaugeSectors(success = c(0.5, 1),
warning = c(0.3, 0.5),
danger = c(0, 0.3)),label = 'Gauge 5')
})
output$infobox_3<-renderInfoBox({
infoBox(
"Total Vehicle Tested", "80%",subtitle = "Subtitle", icon = icon("list"),
color = "green", fill = TRUE
)
})
output$gauge7<-renderGauge({
gauge(0.3,
min = 0,
max = 1,
sectors = gaugeSectors(success = c(0.5, 1),
warning = c(0.3, 0.5),
danger = c(0, 0.3)),label = 'Gauge 7')
})
output$infobox_4<-renderInfoBox({
infoBox("Total Vehicle Passed ",10 * 2,subtitle = "Subtitle", icon = icon("check"),fill = TRUE, color = 'orange')
})
#############################test_stand value_box########################
})
Helper.R (from the link)
dashboardControlbar <- function() {
withTags(
div(
id = "right_sidebar",
# Control Sidebar Open
aside(class = "control-sidebar control-sidebar-dark",
# # # # # # # #
#
# Navigation tabs
#
# # # # # # # #
ul(class = "nav nav-tabs nav-justified control-sidebar-tabs",
# first tabs
li(class = "active",
a(href = "#control-sidebar-first-tab", `data-toggle` = "tab",
i(class = "fa fa-sliders")
)
),
# second tabs
li(
a(href = "#control-sidebar-second-tab", `data-toggle` = "tab",
i(class = "fa fa-search")
)
),
# third tab
li(
a(href = "#control-sidebar-third-tab", `data-toggle` = "tab",
i(class = "fa fa-paint-brush")
)
)
),
# # # # # # # #
#
# Tab Panels
#
# # # # # # # #
div(class = "tab-content",
#########################
# First tab content #
#########################
div(class = "tab-pane active", id = "control-sidebar-first-tab",
h3(class = "control-sidebar-heading", "Controller"),
# write elements here
uiOutput("date_range"),
#textOutput("date_validate"),
uiOutput("pg_list"),
uiOutput("action_btn")
#actionBttn("get_data","Get Report")
),
#########################
# Second tab content #
#########################
div(class = "tab-pane", id = "control-sidebar-second-tab",
h3(class = "control-sidebar-heading", "Search"),
# write other elements here
selectInput("selected_search_topic","Select Content Type to Seacrh",choices = c("Test Stand","Test Code","Product")),
searchInput("searchtext","Enter your Search Topic Here", placeholder = "A placeholder",btnSearch = icon("search"),btnReset = icon("remove"))
),
#########################
# Third tab content #
#########################
div(class = "tab-pane", id = "control-sidebar-third-tab",
# third tab elements here
radioButtons("dist", "Distribution type:",
c("Normal" = "norm",
"Uniform" = "unif",
"Log-normal" = "lnorm",
"Exponential" = "exp")
)
)
)
),
# control-sidebar
# Add the sidebar background. This div must be placed
# immediately after the control sidebar
div(class = "control-sidebar-bg", "")
)
)
}

Shiny radio button not getting rendered initially when the app starts

I am doing some timeseries analysis and have created a shiny app where when the app starts sample timeseries data is uploaded or the user can upload csv dataset from his local directory....
Sample Dataset:
df
month passengers
1 01-01-2000 2072798
2 01-02-2000 2118150
3 01-03-2000 2384907
4 01-04-2000 2260620
5 01-05-2000 2386165
6 01-06-2000 2635018
7 01-07-2000 2788843
8 01-08-2000 2942082
9 01-09-2000 2477000
10 01-10-2000 2527969
11 01-11-2000 2161170
12 01-12-2000 2175314
13 01-01-2001 2307525
14 01-02-2001 2196415
15 01-03-2001 2545863
library(signal)
library(shiny)
library(AnomalyDetection) #devtools::install_github("twitter/AnomalyDetection")
library(ggplot2)
# Define UI for application that draws a histogram
library(shinydashboard)
library(shinycssloaders)
library(googleVis)
shinyUI(dashboardPage(skin = "green",
dashboardHeader(title = "Anomaly Detection in Time series",
titleWidth = 350),
dashboardSidebar(
sidebarUserPanel("Nishant Upadhyay",
image = "nishantcofyshop.jpg"
),
sidebarMenu(
menuItem("Data", tabName = "data", icon = icon("database")),
menuItem("Filters", tabName = "filter", icon = icon("filter")),
menuItem("Anomalies", tabName = "anomaly", icon = icon("check")),
#menuItem("Save Data", tabName = "save", icon = icon("save"))
menuItem("About The App", tabName = "Help", icon = icon("info-circle"))
)
),
dashboardBody(
tabItems(
tabItem(tabName = "data",
fluidRow(
box(
title = "Data scatter Chart",
status = "primary",
solidHeader = T,
collapsible = T,
width = 12,
shinycssloaders::withSpinner(htmlOutput("dataChart"),type = getOption("spinner.type", default = 8),color = "red")
)
),
fluidRow(
box(
radioButtons(
"data_input","",
choices = list("Load sample data" = 1,
"Upload csv file" = 2
)
),
conditionalPanel(
condition = "input.data_input=='1'",
h5("Sample dataset of Lebron James basketball shots over the years")
),
conditionalPanel(
condition = "input.data_input=='2'",
fileInput('file1', 'Choose file to upload',
accept = c(
'text/csv',
'text/comma-separated-values',
'text/tab-separated-values',
'text/plain',
'.csv',
'.tsv'
)),
checkboxInput('header', 'Header', TRUE),
radioButtons('sep', 'Separator',
c(Comma=',',
Semicolon=';',
Tab='\t'),','),
radioButtons('quote', 'Quote',
c('None'='',
'Double Quote'='"',
'Single Quote'="'"),
'')
),
title = "Select Dataset",
status = "info",
solidHeader = T,
collapsible = T
),
box(
title = "Data",
status = "info",
solidHeader = T,
collapsible = T,
shinycssloaders::withSpinner(htmlOutput('contents'),type = getOption("spinner.type", default = 8),color = "red")
)# end of box
)## end of Fluid row
), ## end of tab item
tabItem(
tabName = "filter",
fluidRow(
box(
title = "Data Chart",
status = "primary",
solidHeader = T,
collapsible = T,
width = 12,
shinycssloaders::withSpinner(htmlOutput('dataChartFiltered'),type = getOption("spinner.type", default = 8),color = "red")
)
),
fluidRow(
box(
title = "Filters",
status = "info",
solidHeader = T,
collapsible = T,
width = 4,
radioButtons("filt", NULL,
c("None" = "none",
"Butterworth" = "butt",
"Type-II Chebyshev" = "cheby2")),
submitButton("Filter")
),
box(
title = "Butterworth",
status = "info",
solidHeader = T,
collapsible = T,
width = 4,
textInput("buttern", label = "Filter Order", value = "3"),
textInput("butterf", label = "Critical Frequencies", value = "0.1"),
radioButtons("buttert", "Type",
c("Low-Pass" = "low",
"High-Pass" = "high"))
),
box(
title = "Chebyshev",
status = "info",
solidHeader = T,
collapsible = T,
width = 4,
textInput("chebyn", label = "Filter Order", value = "5"),
textInput("chebyd", label = "dB of Pass Band", value = "20"),
textInput("chebyf", label = "Critical Frequencies", value = "0.2"),
radioButtons("chebyt", "Type",
c("Low-Pass" = "low",
"High-Pass" = "high"))
)
)
)
) ## end of tab items
) ## end of Dashboard
)
)
shinyServer(function(input, output){
dataframe<-reactive({
if (input$data_input == 1) {
tab <- read.csv("df.csv",header = T,stringsAsFactors = F)
} else if (input$data_input == 2) {
inFile <- input$file1
if (is.null(inFile))
return(data.frame(x = "Select your datafile"))
tab = read.csv(inFile$datapath, header = input$header,
sep = input$sep, quote = input$quote)
}
tt <- tryCatch(as.POSIXct(tab[,1]),error=function(e) e, warning=function(w) w)
if (is(tt,"warning") | is(tt,"error")) {
tab$Old = tab[,1]
tab[,1] = as.POSIXct(1:nrow(tab), origin = Sys.time())
} else {
tab[,1] = as.POSIXct(tab[,1])
}
tab
})
output$dataChart <- renderGvis({
if (!is.null(dataframe()))
gvisLineChart(dataframe()[,c(1,2)], xvar = colnames(dataframe())[1], yvar = colnames(dataframe())[2],
options = list(
crosshair.trigger = 'selection',
enableInteractivity = TRUE,
hAxis.maxTextLines = 10,
tooltip.trigger = 'none'
))
})
output$contents <- renderGvis({
if (!is.null(dataframe()))
gvisTable(dataframe(),
options = list(page='enable'))
})
output$dataChartFiltered <- renderGvis({
if (input$filt == "none") {
return(NULL)
} else if (input$filt == "butt") {
bf <- butter(as.numeric(input$buttern), as.numeric(input$butterf), type = input$buttert)
filtered = data.frame(timestamp = dataframe()[,1],
count = as.numeric(filter(bf, dataframe()[,2])))
gvisLineChart(filtered, xvar = colnames(filtered)[1], yvar = colnames(filtered)[2],
options = list(
crosshair.trigger = 'selection',
enableInteractivity = TRUE,
hAxis.maxTextLines = 10,
tooltip.trigger = 'none'
))
} else if (input$filt == "cheby2") {
ch <- cheby2(as.numeric(input$chebyn), as.numeric(input$chebyd),
as.numeric(input$chebyf), type = input$chebyt)
filtered = data.frame(timestamp = dataframe()[,1],
count = as.numeric(filter(ch, dataframe()[,2])))
gvisLineChart(filtered, xvar = colnames(filtered)[1], yvar = colnames(filtered)[2],
options = list(
crosshair.trigger = 'selection',
enableInteractivity = TRUE,
hAxis.maxTextLines = 10,
tooltip.trigger = 'none'
))
}
})
})
The problem i am facing is that once the shiny app is executed , the sample data is loaded properly as the this data is placed in the app folder in the directory (one can use R inbuilt data set or use the data i gave in the start) and subsequently all steps gets executed properly.
But if i want to upload some other csv file from local directory, the upload button selection does not get activated even after selecting it.But,in fact, if one goes to the second menu item in the sidebar panel i.e. filter tab and clicks on the filter button (under Filters box ) and then if i go back to Data menu in the sidebar panel again, i can see that now my upload csv file button has got activated and now i can browse the csv file in local directory and upload the same into the app and now everything works fine.
It seems somewhere the condition that makes the upload file button is not getting active initially when the app opens....
Need help to sort out the issue...Sorry for posting large chunk of code....
conditionalPanel and submitButton do not work well together. Replace your submitButton("Filter") with actionButton("Filter", "").
EDIT:
As per the comment, for the plot to be generated only after the actionButton is clicked you can put output$dataChartFiltered inside observeEvent of Filter with isolate for `input objects as follows:
observeEvent(input$Filter,{
output$dataChartFiltered <- renderGvis({
if (isolate(input$filt) == "none") {
return(NULL)
} else if (isolate(input$filt) == "butt") {
bf <- butter(as.numeric(isolate(input$buttern)), as.numeric(isolate(input$butterf)), type = isolate(input$buttert))
filtered = data.frame(timestamp = dataframe()[,1],
count = as.numeric(filter(bf, dataframe()[,2])))
gvisLineChart(filtered, xvar = colnames(filtered)[1], yvar = colnames(filtered)[2],
options = list(
crosshair.trigger = 'selection',
enableInteractivity = TRUE,
hAxis.maxTextLines = 10,
tooltip.trigger = 'none'
))
} else if (isolate(input$filt) == "cheby2") {
ch <- cheby2(as.numeric(isolate(input$chebyn)), as.numeric(isolate(input$chebyd)),
as.numeric(isolate(input$chebyf)), type = isolate(input$chebyt))
filtered = data.frame(timestamp = dataframe()[,1],
count = as.numeric(filter(ch, dataframe()[,2])))
gvisLineChart(filtered, xvar = colnames(filtered)[1], yvar = colnames(filtered)[2],
options = list(
crosshair.trigger = 'selection',
enableInteractivity = TRUE,
hAxis.maxTextLines = 10,
tooltip.trigger = 'none'
))
}
})
})

Resources