I am trying to figure out how to better visualize ggiraph charts on Shiny apps. Here is the problem: the charts look awesome on desktop and mobile but they leave too much space underneath them when on mobile.
On desktop
Here is what I see on mobile:
Vertical mess
This is the layout of the app:
# Define UI for application
ui <- fixedPage(
tags$style(HTML("
body {
background-color: white;
color: black;
font-family: 'Garamond'
}
h2 {
font-family: 'Garamond';
}
.shiny-input-container {
color: #474747;
}")),
fluidRow(girafeOutput('ggplot'),
selectInput(
inputId = 'Country',
label = 'Countries and territories',
choices = c(unique(speed_data$location)),
multiple = FALSE,
selected = 'Europe'
)),
fluidRow(style='height:40vh')
)
# Define server logic required to draw a histogram
server <- function(input, output,session) {
dat = reactive({
speed_data %>%
filter(location == input$Country)
})
map = reactive({
subset(world, !(is.na(world$value)))
})
output$ggplot <- renderGirafe({gg = ggplot(dat(), aes(
x = date, y = value)) +
geom_line_interactive(aes(group = location, y = value, tooltip = location, color = location)) +
scale_y_continuous(labels = scales::comma) +
scale_color_brewer(palette = 'Set1') +
picci + theme(legend.title = element_blank(),
axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1),
legend.position = 'none') +
labs(title = paste("Pandemic's speed |", c(dat()$location)),
subtitle = 'Daily new cases difference (rolling average, 20 days)',
caption = 'SOURCE: Our world in data',
x = '',
y = '')
ggiraph(code = print(gg),
options = list(
opts_hover(css = "stroke:#5eba7d88;cursor:pointer;")))
})
}
# Run the application
shinyApp(ui = ui, server = server)
THe solution for this problem is to put
girafeOutput('myggiraphplot',height = '75%')
And it works just fine.
Related
I'm struggling with the map tilt. I would like help to change the tilt of the following map. Thanks!
The first map is my result, the second map is how I would like the slope to be.
library(usmap)
library (ggplot2)
read.table("NY_data.txt", header = T)->NY_data
NY1 <- plot_usmap(regions = "county", include = c("NY"), data = NY_data, values = "YEAR_2010") +
labs(title = "New York by county", subtitle = "2010") +
theme(plot.title = element_text(face="bold", size=18, hjust = 0.5),
plot.subtitle = element_text(face="bold", size=16)) +
scale_fill_continuous(low = "white", high = "#CB454A", limits=c(0, 35),
name = "Cumulative cases",
guide = guide_colourbar(barwidth = 27, barheight = 0.5,
title.position = "top"),
label = scales::comma) +
theme(legend.position = "bottom",
legend.title=element_text(size=12, face = "bold"),
legend.text=element_text(size=10))
NY1
map1
map2
I'm struggling with getting my plot title to the center using ggsurvplot...
I've seen some posts mentioning something like xxxx$plot + theme(....)
but this solution does not seem to work for me.
Here's my code, maybe you can see what I'm missing:
surv_object_CA19.9 <- Surv(time = data_OS$OS_Days / 30, event = data_OS$Status.Death)
CA19.9_surv_fit <- survfit(surv_object_CA19.9 ~ CA19.9.initial_status, data = data_OS)
CA19.9_OS <- ggsurvplot(CA19.9_surv_fit, data = data_OS, pval = TRUE, xlab = "Time [Months]",
ylab = "Overall survival", risk.table = TRUE, legend.title = "",
risk.table.col. = "strata", risk.table.y.text = FALSE, surv.scale = "percent",
break.x.by = 6, xlim = c(0, 60), legend.labs = c("Pathological", "Normal"),
title = "Overall survival for patients with initially pathological or normal CA19-9 values",
CA19.9_OS$plot + theme(plot.title = element_text(hjust = 0.5)))
Thank you for any help! I'm still new to R and not particularly a friend of it yet, so any tips are highly appreciated!
One relatively easy solution is to define your own custom theme based off of the theme that is used in ggsurvplot(). Looking at the documentation for the function shows us that it is applying via ggtheme= the theme theme_survminer(). We can create a custom function that uses %+replace% to overwrite one of the theme elements of interest from theme_survminer():
custom_theme <- function() {
theme_survminer() %+replace%
theme(
plot.title=element_text(hjust=0.5)
)
}
Then, you can use that theme by association with the ggtheme= argument of ggsurvplot():
library(ggplot2)
library(survminer)
require("survival")
fit<- survfit(Surv(time, status) ~ sex, data = lung)
ggsurvplot(fit, data = lung, title='Awesome Plot Title', ggtheme=custom_theme())
#Add parameters to your theme as follows
centr = theme_grey() + theme(plot.title = element_text(hjust = 0.5, face = "bold"))
#Fit the model
fit<- survfit(Surv(time, status) ~ sex, data = lung)
#create survival plot
ggsurvplot(fit, data = lung, title="Your Title Here", ggtheme=centr)
I created my own theme and now I also want to standardize the color set that is used. I tried to do this with the list solution, provided in the answer of Viktor in this feed:
Associate a color palette with ggplot2 theme
df <- mtcars
uwvPalet <- c("#0078D2","#003282","#C4D600")
theme_uwv <- function(base_size = 22, base_family = "Verdana"){theme_hc(base_size = base_size, base_family = base_family)%+replace%theme(plot.title = element_text(color = rgb(0, 120, 210)), complete = TRUE)}
theme_uwv2 <- list(theme_uwv, scale_color_manual(values = uwvPalet))
ggplot(df, aes(fill = cyl, x = am, y = mpg)) + geom_bar(position = "dodge", stat="identity") + theme_uwv2()
Unfortunately, I get the error:
Error in theme_uwv2() : could not find function "theme_uwv2"
Anyone know how I can fix this?
The following worked for me. theme_uwv2 needed the value returned from theme_uwv() as a list element, not the function itself. Also, you were making a plot where the fill was the dominant colour variable, so I've substituted scale_color_manual() with scale_fill_manual() for demonstration purposes.
library(ggplot2)
library(ggthemes)
df <- mtcars
uwvPalet <- c("#0078D2","#003282","#C4D600")
theme_uwv <- function(base_size = 22, base_family = "Verdana"){
theme_hc(base_size = base_size, base_family = base_family) %+replace%
theme(plot.title = element_text(color = rgb(0, 120, 210, maxColorValue = 255)),
complete = TRUE)}
theme_uwv2 <- list(theme_uwv(), scale_fill_manual(values = uwvPalet))
ggplot(df, aes(fill = as.factor(cyl), x = am, y = mpg)) +
geom_col(position = "dodge") +
ggtitle("test") +
theme_uwv2
I have a working app that uses multiple filters to plot some data and i want the filters to be dynamic and dependent on the filter above by only showing available options for the selection. For instance if the Location_Id == 1 then only 'Bike' User_Type is available in the 'User Type' filter. This all works when the app starts with the filters all constrained by the initial Location_ID starting value but as soon as i change the initial input (Location_Id) nothing is getting updated automatically and i have to do an Select All to see which data is available for the new selected Location Id. I have been reading all morning and it seems i need to perhaps include a reactive() somewhere in the server but its not clear how then i update the ui and if i need a render type function somewhere.
#Example for stack overflow
library(shiny)
library(datasets)
library(dplyr)
library(shinyWidgets)
library(lubridate)
#Create test data
set.seed(10)
Dates. <- sample(c(seq(as.Date("2017-01-01"),as.Date("2017-12-28"),1),seq(as.Date("2018-01-01"),as.Date("2019-12-28"),1)),1000)
Facility_Type. <- sample(c("Bikelane","No facility"),length(Dates.),replace = T)
Data.. <- data.frame(Date = Dates., Facility_Type = Facility_Type.)
Data..$User_Type_Desc<- sample(c("Bike","Pedestrian"),nrow(Data..),replace = T)
Data..$Counts <- sample(1:100,nrow(Data..),replace = T)
Data..$Location_Id <- sample(c("01","02","03","04"),nrow(Data..),replace = T)
Data..$Month <- months(Data..$Date)
Data..$Year <- year(Data..$Date)
Data..$User_Type_Desc <- as.character(Data..$User_Type_Desc)
Data..$Facility_Type <- as.character(Data..$Facility_Type)
#Force some changes on data to highlight problem
Data..$User_Type_Desc[Data..$Location_Id%in%"01"] <- "Bike"
Data..$User_Type_Desc[Data..$Location_Id%in%"04"] <- "Pedestrian"
ui <-
#shinyUI(fluidPage(
navbarPage(title = "Bend Bike/PedTraffic Counts",
#Graphics panel
tabPanel("Charting",
#headerPanel(title = "Bend Traffic Count Data Viewer"),
sidebarLayout(
sidebarPanel(
#Select Location Id
selectInput("Location_Id","Select a Location Id",choices = unique(Data..$Location_Id)),
#Select Year
pickerInput(inputId = "Year", label = "Select/deselect all + format selected", choices = NULL,
options = list(`actions-box` = TRUE, size = 10,`selected-text-format` = "count > 3"), multiple = TRUE),
#Select Month
pickerInput(inputId = "Month", label = "Select/deselect all + format selected", choices = NULL,
options = list(`actions-box` = TRUE, size = 10,`selected-text-format` = "count > 3"), multiple = TRUE),
#Location details
##################
#Select User Types
pickerInput(inputId = "User_Type", label = "Select/deselect all + format selected", choices = NULL,
options = list(`actions-box` = TRUE, size = 10,`selected-text-format` = "count > 3"), multiple = TRUE),
#Select Facility Types
pickerInput(inputId = "Facility_Type", label = "Select/deselect all + format selected", choices = NULL,
options = list(`actions-box` = TRUE, size = 10,`selected-text-format` = "count > 3"), multiple = TRUE)
#dateRangeInput("Date", "Input date range")
#selectInput("Date","Select a Product",choices = NULL)
#Panel end
),
mainPanel( plotOutput("location_plot"))
#Sidebar panel layout end
)
# Sidebar panel end
)
#PAge end
)
server <-
#print(str(product_list))
shinyServer(function(session,input,output) {
#Create selection menus
##########################
#Year selection with choices constrained by Location_Id
observe({
Years. <- unique(Data..$Year[Data..$Location_Id%in%input$Location_Id])
updatePickerInput(session,"Year","Select Year(s)",choices = Years.,selected = Years.[1])
})
#Month selection with Year choices
observe({
Months. <- unique(Data..$Month[Data..$Year%in%input$Year])
updatePickerInput(session,"Month","Select Month(s)",choices = Months., selected = Months.[1] )
})
#User Type
observe({
User_Type. <- unique(Data..$User_Type_Desc[Data..$Year%in%input$Year & Data..$Month%in%input$Month])
updatePickerInput(session,"User_Type","Select User Type(s)",choices = User_Type., selected = User_Type.[1])
})
#Facility Type
observe({
Facility_Type. <- unique(Data..$Facility_Type[Data..$Year%in%input$Year & Data..$Month%in%input$Month
& Data..$User_Type_Desc%in%input$User_Type])
updatePickerInput(session,"Facility_Type","Select Facility Type(s)",choices = Facility_Type., selected = Facility_Type.[1])
})
#Plot data
##########################
#Select final data and chart
output$location_plot <- renderPlot({
#Select data
dat <- Data..[Data..$Location_Id%in%input$Location_Id & Data..$Month%in%input$Month &
Data..$Year%in%input$Year & Data..$User_Type_Desc%in%input$User_Type,]
#Initialze chart
ggplot(data = dat, x=Date, y = Counts) +
geom_bar(aes(x = Date,y = Counts),color = "black", position = "dodge", stat = "identity")+
facet_wrap(Facility_Type~User_Type_Desc)
})
})
#Run App
shinyApp(ui,server)
I have developed a solution for the above problem that started this issue (making filters update with proper reactive-ness) but now that i have added a map the app tends to break after making selections in the first selector, in this example that would be the state.
I created a new example below that answers the above question but poses a new one: Why is my app crashing and does it have to do with improper way i handle the reactive-ness?
In order to get the app to crash you have to select a couple of different states and let it render. It seems to do it on California so it makes me wonder if its a matter of the amount of data the map is attempting to render. Unfortunately there is no error given RStudio just crashes. Not sure if this is the proper way to pose this question but if the reactive-ness is the problem with the RStudio crash i think its still relevant to this thread. Thx for any help!
library(shiny) # for shiny apps
library(ggplot2)
library(plotly)
library(dplyr)
library(shinyWidgets)
library(tigris)
library(mapview)
library(leaflet)
library(raster)
library(rgeos)
# Load(Create) data
State_01_Tracts_Sp <- tracts("01")
State_02_Tracts_Sp <- tracts("02")
State_04_Tracts_Sp <- tracts("04")
State_05_Tracts_Sp <- tracts("05")
State_06_Tracts_Sp <- tracts("06")
Tracts_Sp <- rbind(State_01_Tracts_Sp ,State_02_Tracts_Sp, State_04_Tracts_Sp,
State_05_Tracts_Sp , State_06_Tracts_Sp )
#Decode fips into descriptive state and county names
Tracts_Sp#data$State <-
fips_codes$state_name[match(Tracts_Sp#data$STATEFP,fips_codes$state_code)]
Tracts_Sp#data$County <-
fips_codes$county[match(Tracts_Sp#data$COUNTYFP,fips_codes$county_code)]
#Create a copy of the spatial data's data frame
Data.. <- Tracts_Sp#data
#Set up User Interface
ui <- fluidPage(
titlePanel("Census Viewer Test"),
tabsetPanel(
#Daily Counts Panel
##############
#Hourly Counts Panel
#######################
tabPanel("Tab 1",
#Call plot
fluidRow(column(width = 12,plotlyOutput("county_plot" ))),
#Location Details
fluidRow(
column(3,
h4("Select Details"),
uiOutput("State_selector"),
uiOutput("County_selector"),
uiOutput("Tract_selector")),
column(6,
#h4("Selected Location"),
leafletOutput("map_plot",height = 500))
#Close row
)
#Close panel
)
#Close setPanel
)
#PAge end
)
#Set up Server
#---------------------------
server <- shinyServer(function(session,input,output){
#Temporal Details
##################
#State
output$State_selector <- renderUI({
selectInput(inputId = "State",
label = "State", multiple = FALSE,
choices = c( unique(Data..$State)),
selected = unique(Data..$State)[1])
})
#County selection----
output$County_selector <- renderUI({
available0 <- as.character(unique(Data..$County[Data..$State %in% input$State ]
))
pickerInput(inputId = "County", label = "Select/deselect all + format selected",
choices = as.character(unique(available0)),
options = list(`actions-box` = TRUE, size = 10,`selected-text-format`
= "count > 3"), multiple = TRUE,selected = as.character(unique(available0)))
})
#Tract selection----
output$Tract_selector <- renderUI({
available1 <- as.character(unique(Data..$GEOID[Data..$State %in% input$State ] ))
pickerInput(inputId = "Tract", label = "Select/deselect all + format selected",
choices = as.character(unique(available1)),
options = list(`actions-box` = TRUE, size = 10,`selected-text-format`
= "count > 3"), multiple = TRUE,selected = as.character(unique(available1)))
})
#Graphics
#Select final data and chart-----
output$county_plot <- renderPlotly({
#Select data
dat <- Data..[Data..$State%in%input$State & Data..$County%in%input$County &
Data..$GEOID%in%input$Tract ,]
#Set up axis parameters depending on amount of data
angle = 90
#Initialze chart
ggplotly(ggplot(data = dat, x=GEOID, y = ALAND, fill = State) +
geom_bar(aes(x=GEOID, y = ALAND, fill = State),color = "black",
position = "dodge", stat = "identity")+
ggtitle(paste("Land Area of Select Counties
",unique(dat$State),sep="")) +
#Center plot
theme(plot.title = element_text(hjust = 0.5)) +
ylab("LAnd Area") +
xlab("") +
guides(color=guide_legend("State")) +
theme(axis.text.x = element_text(angle = angle, hjust =
1),plot.background = element_rect(fill = "darkseagreen"))) %>% layout(dragmode =
"select")
})
#Select final data and map-----
output$map_plot <- renderLeaflet({
#Select data
Map_Data_Sp <- Tracts_Sp[Tracts_Sp#data$State%in%input$State,]
class(Map_Data_Sp )
#Create map
Map <- mapview(Map_Data_Sp, map.types = "OpenStreetMap", legend = FALSE,
col.regions = "red",color = "black",cex = 10)
Map#map
#Close map
})
})
#Run App
shinyApp(ui,server)
I am working on a Shiny app that allows the user to upload their own data and analyze them. At a certain point, I'd like to allow the user to introduce new data as numeric input and to build a new table including them.
I'd like my app to do it dynamically, i.e. creating a box in the sidebar panel containing new numeric input accordingly and with the name of the variables of my uploaded dataset.
I can do it by indicating a priori specific variables, but I'd like to make it dynamic.
I'd be really glad if somebody could attend to this matter.
Here's included a simple example of my code and a screenshot showing how it looks like (but with a priori specified variables).
library(shiny)
ui <- fluidPage(
tabPanel("New Cases", icon=icon("edit"),
sidebarLayout(
sidebarPanel(width=3, #sidebarPanel "New Cases"
conditionalPanel(
'input.dataset02 === "Edit Table"',
textInput('NewID', HTML('<h5><b>Enter Name</b></h5>')), #Enter Factor?
numericInput('NewVal1', HTML('<h5><b>Enter Item</b></h5>'), NULL),
br(),
fluidRow(
column(2, HTML('<h5><b>E14</b></h5>')),
column(4, numericInput("NewVal3", label = NULL, value = NULL)),
column(2, HTML('<h5><b>E16</b></h5>')),
column(4, numericInput("NewVal4", label = NULL, value = NULL))
),
fluidRow(
column(2, HTML('<h5><b>E18_1</b></h5>')),
column(4, numericInput("NewVal5", label = NULL, value = NULL)),
column(2, HTML('<h5><b>E18</b></h5>')),
column(4, numericInput("NewVal6", label = NULL, value = NULL))
),
fluidRow(
column(2, HTML('<h5><b>FAEE</b></h5>')),
column(4, numericInput("NewVal7", label = NULL, value = NULL)),
column(2, HTML('<h5><b>EtG</b></h5>')),
column(4, numericInput("NewVal8", label = NULL, value = NULL))
),
br(),
actionButton("goButton", "Update Table",icon("cloud-upload"),
style="width: 100%; height: 60px; color: steelblue; background-color: #337ab7; border-color: #2e6da4"),
br()
)),
mainPanel(
tabsetPanel(
id = 'dataset02',
tabPanel("Edit Table",
br(),
dataTableOutput("table3"))
))
)))
server <- function(input, output) {
mydata3 = data.frame(Name=letters[NULL], Item=sample(NULL),Piece=sample(NULL), E14=sample(NULL), E16=sample(NULL),
E18_1=sample(NULL), E18=sample(NULL), FAEE=sample(NULL), ETG=sample(NULL))
output$table3 <- renderDataTable( df3())
df3 <- eventReactive(input$goButton, {
if(input$NewID!=" " && !is.null(input$NewVal1)
&& !is.null(input$NewVal3) && !is.null(input$NewVal4) && !is.null(input$NewVal5)
&& !is.null(input$NewVal6) && !is.null(input$NewVal7) && !is.null(input$NewVal8)
&& input$goButton>0)
{
newrow = data.frame(
Name = input$NewID,
Item = input$NewVal1,
Piece = 1,
E14 = input$NewVal3,
E16 = input$NewVal4,
E18_1 = input$NewVal5,
E18 = input$NewVal6,
FAEE = input$NewVal7,
ETG = input$NewVal8)
mydata3 <<- rbind(mydata3, newrow)
}
mydata3
}, ignoreNULL = FALSE)
}
shinyApp(ui = ui, server = server)
Screenshot of the app (in the "desired" format) is the following:
You can create inputs dynamically with renderUI and uiOutput.
Example:
# LIBRARIES & SOURCING --------------
library(shiny)
library(shinydashboard)
# UI -----------------
ui <- dashboardPage(title="App Title",
dashboardHeader(disable = TRUE),
dashboardSidebar(disable = TRUE),
dashboardBody(
fluidRow(
uiOutput("uiOut1")
)
))
# SERVER -----------------
server <- function(input, output) {
output$uiOut1 = renderUI(
list(
numericInput("dynInput1", "First dynamic input:", 20, 0, 40),
numericInput("dynInput2", "Second dynamic input:", 20, 0, 40)
)
)
}
shinyApp(ui = ui, server = server)
You can then refer to the inputs with input$dynInput1 or input[["dynInput1"]] if you need to use a variable to select which input you want.
More info here: https://shiny.rstudio.com/articles/dynamic-ui.html