I am creating a table using renderTable and a plot (plotly) to be placed in ShinyDashboard. There is a whitespace that surrounds the table data that I am trying to get rid off. However, there is no whitespace around the plot.
How do I remove the whitespace that surround the table i have added to my shiny dashboard.
How do I align the header of the table "Recruitment" to the center?
I know there are some HTML solutions, but I am not familiar with those codes and will be glad if someone can explain.
Here are my codes:
Server codes
output$recruit_stats <- renderTable(recruit_stats, bordered = TRUE, colnames = TRUE)
output$Recruitment_bar_plot <- renderPlotly({
Recruitment_bar<-Recruitment_bar[(Recruitment_bar$hospital!="H"),];
R01 <- ggplot()+
geom_bar(data=Recruitment_bar,aes(x=hospital,y=count),stat = "identity", fill="navyblue")+
ylim(0,1200) +
geom_text(data=Recruitment_bar,aes(x=hospital,y=count*1.05,label=paste(count)),size=2.5, vjust=-1.0) +
theme(panel.background = element_blank(),
axis.text = element_text(size = 7),
axis.title = element_text(size=7),
axis.line = element_line(colour = "black", size = 0.5, linetype = "solid"),
plot.title = element_text(size=8, face="bold", hjust=0.5),
legend.position = "none", legend.text = element_text(size=6)) +
labs(fill="") + guides(fill = guide_legend(reverse=TRUE))+
ylab("No. Recruited") + ggtitle("No. of Patients Recruited (Jan 2017 to June 2018)")
ggplotly(R01, tooltip=c("count"));
})
UI codes
Recruitment<-tabItem(
tabName = "Recruitment",
fluidRow(
box(
box(title = "Recruitment",
status = "primary",
solidHeader = TRUE,column(12,tableOutput("recruit_stats"), align="c"),
width=8,
collapsed=TRUE)
),
box(
plotlyOutput("Recruitment_bar_plot", height = 400),
width=5,
status = "primary",
solidHeader = TRUE
)
)
)
I would drop boxes and try grid by columns. For table have a look at DT tutorials.
library(shiny)
library(shinydashboard)
dat5 <- c(rep("Female", 3376), rep("Male", 2180))
app <- shinyApp(
ui <- shinyUI(
dashboardPage(dashboardHeader(title = "PSM"),
dashboardSidebar(),
dashboardBody(
tabItem(
tabName = "Recruitment",
fluidRow(
column(width=6,
DT::dataTableOutput("recruit_stats")),
column(width=6,
plotOutput("pie_chart", height = 400))
)
)
))
),
server <- shinyServer(function(input,output){
output$pie_chart <- renderPlot({
df <- table(dat5)
cols <- rainbow(length(df))
barplot(df, col = cols)
})
output$recruit_stats <- DT::renderDataTable({
DT::datatable(as.data.frame(dat5), options = list(paging=TRUE, searching= TRUE ))
})
})
)
runApp(app)
Related
I have tried to customise my choropleth map tooltips in R shiny app, which doesn't work. I tried both paste0 and paste, and it does not work either.
Here is my code:
ui <- fixedPage(
titlePanel("Map"),
fixedRow(
column(5
),
),
column(
12,
plotlyOutput('map',
width = 1000,
height = 1000)
)
)
server <- function(input, output) {
output$map = renderPlotly({
map<- country_choropleth(AADS_map,
num_colors=8,
text = paste0("value:", value)
)+
scale_fill_brewer(palette="RdPu") +
theme(plot.title = element_text (h = 0.5, size = 18),
legend.title = element_text(size = 10),
legend.text = element_text(size = 12)
) +
labs(fill = "Number of Accident",
title = "The distribution of accidents in countries from 1981 to 2019")
map <- ggplotly(map,
tooltip = c("text"))
})}
I have my shiny app in AWS ubuntu server attached with mysql database, my app doesnot work sometimes when number of database connection exceeded(16 new connections). I tried several ways from various sources in internet but not able to get the required solution.
Furthure i am also getting warning you have leaked pool object . I am attaching the sample code.
library("shiny")
library("shinydashboard")
library("pool")
library(ggplot2)
library("DBI")
library(plotly)
pool <- dbPool(drv = RMySQL::MySQL(),dbname = "db",host = "database.cw5east-2.rds.amazonaws.com",username = "host",password = "host", port = 3306)
mychoices = dbGetQuery(pool,"select available_scenario from scenario_name;")
ui <- (fluidPage(
titlePanel("Demonstration of renderUI in shiny - Dymanically creating the tabs based on user inputs"),
sidebarLayout(
sidebarPanel(
selectInput(inputId = 'n', "available scenarios", choices = mychoices, multiple = TRUE),
verbatimTextOutput("selected")
),
mainPanel(
plotOutput('Cost'),
uiOutput('tabs')
)
)
))
server <- (function(input,output,session){
output$tabs = renderUI({
par(mfrow = c(2, 2))
if(!is.null(input$n)){
x <- input$n
y <- length(x)
z <- dbGetQuery(pool,paste0("select scenario_key from scenario_name where available_scenario = '",x[y],"'"))
frame <- dbGetQuery(pool,paste0("select x,price from plot1 where scenario_key ='",z,"'"))
frame1 <- dbGetQuery(pool,paste0("select obj,runs from plot2 where scenario_key ='",z,"'"))
frame2 <- dbGetQuery(pool,paste0("select V1,V2,V3 from tableee where scenario_key ='",z,"'"))
runs <- dbGetQuery(pool,paste0(" select count(*) from plot2 where scenario_key ='",z,"'"))
b<-dbGetQuery(pool, paste0("select scenario_key from scenario_name where available_scenario = '",input$n,"'"))
Tabs <- lapply(paste("Scenario name:", input$n, sep=" "), tabPanel,
renderPlotly({
ggplot(frame, aes(x=x,y=price,fill=price)) + # basic graphical object
geom_col(width = 0.3)+
#geom_bar(position = 'dodge',stat = "identity")+ # first layer
xlab(NULL)+ylab("Price in USD")+
geom_text(aes(label=price),size=5,position=position_dodge(width=0.9), vjust=-0.25)+
theme_minimal()+
theme(axis.text = element_text(size = 12),
axis.title = element_text(size=16),
axis.text.y =element_text(angle = 90,hjust = 1))
}),
renderPlotly({
ggplot(frame1,aes(x=runs,y=obj))+
geom_col(width=0.3,fill='orangered')+
geom_hline(aes(yintercept=mean(obj,na.rm = T),color="Mean"),linetype='dashed',size=1)+
scale_color_manual(values = "blue")+
labs(x= 'Day Number',y='Reveneue in USD',color=NULL)+
theme_minimal()+theme(axis.text = element_text(size = 12),
axis.title = element_text(size=16),
axis.text.y= element_text(angle = 90,hjust = 1) )
}),
DT::renderDataTable({
frame2
},colnames=c('Day','Total Wt(kg)','Total Pcs','Revenue($)')
)
)
do.call(tabsetPanel, Tabs)}
})
})
shinyApp(ui, server)
I am trying to use a conditional withSpinner such that when users select Ohio, both sexes and the year of 2010, I want the spinner to come up. Otherwise, I do not want the spinner to be shown. Please see this image for more information. In other words, I want to disable the spinner when, for example, the year is changed to 2015. Is there any way to do this.
.
Here is the simplified version of my codes:
UI
ui <- fluidPage(
navbarPage(
collapsible = T,
fluid = T,
selected = "Population Projections",
windowTitle = "Scripps Interactive Data Center",
"",
tabPanel(("Population Projections"),
# tags$hr(), #add a line between above command and the below one
tags$h5 (
strong("Current and Projected Population by County, Age Group, and Sex, 2010-2050"),
align = 'left'
),
br(),
#a line break
sidebarLayout(
sidebarPanel(
#"sidebar panel"),
helpText("Please select your county of interest"),
selectInput(
inputId = "county",
label = "Select County:",
selected = "Ohio",
selectize = FALSE,
multiple = FALSE,
choices = sort(unique(population$County))
),
radioButtons(
inputId = "sex",
label = strong("Select Sex:"),
selected = "Both Sexes",
choices = sort(unique(population$Sex))
),
sliderInput(
inputId = "years",
label = "Year",
min = 2010,
max = 2050,
value = 2010,
step = 5,
sep = "",
pre = "",
animate = animationOptions(
interval = 1000,
loop = F,
playButton = tags$button("Play", style =
"background-color: #B61E2E ; color:white; margin-top: 10px; border:solid"),
pauseButton = tags$button("Pause", style =
"background-color: #B61E2E !important; color:white; margin-top: 10px; border:solid")
),
round = T,
width = "150%",
ticks = T
),
# ### Download Button
downloadButton("downloadData", "Download Data"),
br(),
br()
# downloadButton("downloadPlot_1", "Download Bar Graph"),
# br(),
# br(),
# downloadButton("downloadPlot_2", "Download Pyramid"),
# br(),
# br()
# the number of visitors
# h5(textOutput("counter"))
),
######################
mainPanel(
tabsetPanel(
type = "tabs",
tabPanel(
"Plot",
plotOutput("bar") %>% withSpinner (color="#B61E2E"),
br(),
br(),
br(),
#a line break
(column (12, align="center", tableOutput("table")))
),
tabPanel(
"Pyramid",
plotOutput("pyramid", height=600)
#a line break
),
tabPanel("Data", tableOutput("data"))
)
)
Server
server <- function(input, output) {
bardata <- reactive ({
out <- population %>%
filter (County %in% input$county,
Year %in% input$years,
Sex %in% input$sex)
return(out)
})
blue.bold.14.text <- element_text(face = "bold", color = "black", size = 14)
blue.bold.10.text <- element_text(face = "bold", color = "black", size = 10)
blue.bold.12.text <- element_text(face = "bold", color = "black", size = 12)
bardataPlot <- reactive({
ggplot(bardata(), aes(x = Age_Group, y = Population)) + geom_bar(stat =
"identity",
position = "stack",
fill = "#B61E2E") +
geom_text(
aes(label = Percentage),
vjust = 1,
colour = "white",
position = position_dodge(width=0.9),
fontface = "bold",
size=5,
angle = 90,
hjust = 1
) +
labs(
x = "Age Groups",
y = "Population Size",
caption = (""),
face = "bold"
) +
theme_bw() + scale_y_continuous(labels = scales::comma) +
theme(plot.title = element_text(
hjust = 0.5,
size = 15,
colour = "Black",
face = "bold"
),axis.text=(blue.bold.12.text), axis.title=blue.bold.14.text, axis.text.x = element_text(angle = -75, vjust = 0, hjust=0)) +
ggtitle(
paste0(
input$sex,
" ",
"Population Size by 5-Year Age Groups in ",
input$county,
", ",
input$years
)
)
})
output$bar <- renderPlot ({
bardataPlot()
})
As your non-minimal example isn't working (parenthesis missing?) I made a new one showing a way to display a spinner conditionally:
library(shiny)
library(shinycssloaders)
ui <- fluidPage(
checkboxInput("toggle", "toggle"),
conditionalPanel(condition = "input.toggle", withSpinner(uiOutput("spinnerDummyID1"), type = 6))
)
server <- function(input, output, session) {}
shinyApp(ui, server)
I am trying to create a dynamic plot in R Shiny but the plot does not show in the Dashboard.
I have the following test data which I will upload in the shiny app:
Region.1=c( 375.00,375.00,370.00,350.00,350.00,305.00,300.00,250.00,245.00,240.00,235.00,225.00,215.00,200.00,100.00,100.00,100.00,100.00,100.00,100.00)
Region.2 =c(0.00,0.00,0.00,0.00,0.00,200.00,0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.00,20.00,500.00,235.00,0.00)
Region.3 =c(100000.00,76000.00,60000.00,50000.00,50000.00,30000.00,30000.00,26000.00,19000.00,11000.00,10000.00,8000.00,7000.00,5000.00,4070.00,4000.00,3660.00,2585.00,2550.00,250.00)
Type=c("B","F","F","B","B","A","A","F","F","B","A","B","F","B","F","F","A","A","F","B")
data <- data.frame("Region.1"=Region.1, "Region.2"=Region.2, "Region.3"=Region.3, "Type"=Type)
My Script for Shiny looks like this (simplified code)
server.R
function(input, output,session) {
myData <- reactive({
req(input$file)
inFile <- input$file
if(is.null(inFile)){return(NULL)}
read.csv(inFile$datapath, header = TRUE, sep = input$sep,
quote = '""')
})
df<-reactive({
df<-myData()
dfType <- df[ , grepl( "Type" , names( df ) ) ]
dfRegion<-df[ , grepl( "Region" , names( df ) ) ]
df4<-cbind(dfType, dfRegion)
colnames(df4)[which(names(df4) == "dfType")] <- "Type"
colnames(df4)[which(names(df4) == "dfRegion")] <- "Region"
df4[df4==""] <- NA
df4 <- na.omit(df4)
return(df4)
})
df.datasets <- reactive({
df<-df()
df<- melt(df,id.vars=c("Type"),
measure.vars=c("Region.1", "Region.2", "Region.3"))
test<-aggregate(df$value, by=list(Region=df$variable, Type=df$Type), FUN=sum)
test<-test %>% group_by(Region) %>% transmute(Type, percent = (x/sum(x))*100)
test$percent<-round(test$percent, digits = 0)
test[test==0] <- NA
test<-test[complete.cases(test),]
})
output$plot1<-renderPlot({
blank_theme <- theme_minimal()+
theme(
axis.title.x = element_blank(),
axis.title.y = element_blank(),
panel.border = element_blank(),
panel.grid=element_blank(),
axis.ticks = element_blank(),
plot.title=element_text(size=14, face="bold")
)
test<-df.datasets()
levels(test$"Region")[levels(test$"Region") %in% c("Region.1")] <- "Region 1"
levels(test$"Region")[levels(test$"Region") %in% c("Region.2")] <- "Region 2"
levels(test$"Region")[levels(test$"Region") %in% c("Region.3")] <- "Region 3"
levels(test$"Region")[levels(test$"Region") %in% c("Region.4")] <- "Region 4"
p<-ggplot(test,
aes(x =" ", y = percent, fill = Type))+
geom_bar(width = 1, stat = "identity",position="fill", color="grey35")+
coord_polar("y")+
facet_grid(.~Region)+
geom_text(aes( label= paste(percent, "%")) ,
position=position_fill(0.5), size=4.5)+
theme(axis.text.x=element_blank(),
strip.text.x = element_text(size=15, color="black", face="bold"),
strip.text.y = element_text(size=15, color="black", face="bold"),
legend.text = element_text(size=15),
legend.title = element_text(size=15, face="bold"),
plot.title = element_text(hjust = 0.5, size = 25),
axis.text=element_text(size=10))
})
}
my ui.R
myData <- NULL
sidebar <- dashboardSidebar(
sidebarMenu(
fileInput('file', 'Upload File (.csv | .txt)',
accept=c('text/csv',
'text/comma-separated-values,text/plain',
'.csv')),
radioButtons('sep', 'File Type',
c(CSV=';',
Text='\t'))
#actionButton("goButton", " Legenda", icon = icon("play-circle"))
)
)
dashboardPage(
dashboardHeader(title = "Overview"),
sidebar,
dashboardBody(tags$style("image {max-width: 100%; width: 100%; height: auto}"),
fluidRow(
tabBox(
title = " ",
# The id lets us use input$tabset1 on the server to find the current tab
id = "tabset1",
height = "1200px", width = "1000px"
,
tabPanel( "Plots",
column(12,
plotOutput("plot1"))
)
)
)))
I tried to strip down my code to detect the error but I can't find it. When I run the code outside of Shiny, the plot does show like it suppose to:
I Also don't get any error message. So I think that the plot is working but somehow it doesn't show. I tried modifying the size of the column but that didn't work..
I would like a result like this:
Anybody got an idea? I would really appreciate it, thank you :)
It looks like you assigned the plot to p then never called p in the renderPlot block, what happens if you just add p at the end of the block?
I did a sample app in R and it is working fine in R-studio. I managed to deploy the code successfully into www.shinyapps.io. After deployment the app link is not working. It is hang-up by "please wait" for long time then show error "disconnected from server". Could anyone please help me with this.
ui.r
library(shiny)
require(shinydashboard)
library(ggplot2)
library(dplyr)
head(recommendation)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody()
)
server <- function(input, output) { }
header <- dashboardHeader(title = "Basic Dashboard")
#Sidebar content of the dashboard
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),
menuItem("Visit-us", icon = icon("send",lib='glyphicon'),
href = "https://www.salesforce.com")
)
)
frow1 <- fluidRow(
valueBoxOutput("value1")
,valueBoxOutput("value2")
,valueBoxOutput("value3")
)
frow2 <- fluidRow(
box(
title = "Revenue per Account"
,status = "primary"
,solidHeader = TRUE
,collapsible = TRUE
,plotOutput("revenuebyPrd", height = "300px")
)
,box(
title = "Revenue per Product"
,status = "primary"
,solidHeader = TRUE
,collapsible = TRUE
,plotOutput("revenuebyRegion", height = "300px")
)
)
# combine the two fluid rows to make the body
body <- dashboardBody(frow1, frow2)
ui <- dashboardPage(title = 'This is my Page title', header, sidebar, body, skin='red')
shinyApp(ui, server)
library(rsconnect)
rsconnect::setAccountInfo(name='', token='', secret='')
deployApp(appName="myApp")
server.R
server <- function(input, output) {
#some data manipulation to derive the values of KPI boxes
total.revenue <- sum(recommendation$Revenue)
sales.account <- recommendation %>% group_by(Account) %>% summarise(value = sum(Revenue)) %>% filter(value==max(value))
prof.prod <- recommendation %>% group_by(Product) %>% summarise(value = sum(Revenue)) %>% filter(value==max(value))
#creating the valueBoxOutput content
output$value1 <- renderValueBox({
valueBox(
formatC(sales.account$value, format="d", big.mark=',')
,paste('Top Account:',sales.account$Account)
,icon = icon("stats",lib='glyphicon')
,color = "purple")
})
output$value2 <- renderValueBox({
valueBox(
formatC(total.revenue, format="d", big.mark=',')
,'Total Expected Revenue'
,icon = icon("gbp",lib='glyphicon')
,color = "green")
})
output$value3 <- renderValueBox({
valueBox(
formatC(prof.prod$value, format="d", big.mark=',')
,paste('Top Product:',prof.prod$Product)
,icon = icon("menu-hamburger",lib='glyphicon')
,color = "yellow")
})
#creating the plotOutput content
output$revenuebyPrd <- renderPlot({
ggplot(data = recommendation,
aes(x=Product, y=Revenue, fill=factor(Region))) +
geom_bar(position = "dodge", stat = "identity") + ylab("Revenue (in Euros)") +
xlab("Product") + theme(legend.position="bottom"
,plot.title = element_text(size=15, face="bold")) +
ggtitle("Revenue by Product") + labs(fill = "Region")
})
output$revenuebyRegion <- renderPlot({
ggplot(data = recommendation,
aes(x=Account, y=Revenue, fill=factor(Region))) +
geom_bar(position = "dodge", stat = "identity") + ylab("Revenue (in Euros)") +
xlab("Account") + theme(legend.position="bottom"
,plot.title = element_text(size=15, face="bold")) +
ggtitle("Revenue by Region") + labs(fill = "Region")
})
}
shinyApp(ui, server)
Log file is not showing any error. Any help is much appreciated.