I'm trying to use a date range function to alter the data used to display a histogram in R Shiny. I have some incomplete code as I cant figure out how to code this in the server function. see bellow for a minimal code example and where I think some code should go. :
library(shiny)
set.seed(123)
N<- 500
M<-56
EF<- matrix( rnorm(N*M,mean=23,sd=3), N, M)
WM<- matrix( rnorm(N*M,mean=20,sd=3), N, M)
DP<- matrix( rnorm(N*M,mean=25,sd=3), N, M)
Date <- seq(as.Date("2018-01-01"), as.Date("2018-02-25"), by="days")
Date <- as.POSIXct(Date, format = "%Y-%m-%d %H:%M")
ui <- fluidPage(
titlePanel(code(strong("Measures"), style = "color:black")),
sidebarLayout(
sidebarPanel(
strong("Tools:"),
selectInput("Test",
label = "Choose a measure to display",
choices = c("EF",
"WM",
"DP"
),
selected = "EF"),
dateRangeInput("DateRange", label= "Date Range:", start ="2018-01-01", end = "2018-02-25")),
mainPanel(
code(strong("Study Readout")),
plotOutput("distPlot")
))
)
server <- function(input, output) {
filterData <- reactive({
x <- switch(input$Test,
"EF" = EF,
"WM" = WM,
"DP" = DP)
return(x)
})
output$distPlot <- renderPlot({
x <-filterData()
DateRange <- #????
hist(x, #????)
})
}
# Run that shit ----
shinyApp(ui = ui, server = server)
You could just subset your vector x according to the date range, comment out the conversion to POSIXct and fill the blanks like this.
library(shiny)
set.seed(123)
N<-500
M<-56
EF<- matrix( rnorm(N*M,mean=23,sd=3), N, M)
WM<- matrix( rnorm(N*M,mean=20,sd=3), N, M)
DP<- matrix( rnorm(N*M,mean=25,sd=3), N, M)
Date <- seq(as.Date("2018-01-01"), as.Date("2018-02-25"), by="days")
#Date <- as.POSIXct(Date, format = "%Y-%m-%d")
ui <- fluidPage(
titlePanel(code(strong("Measures"), style = "color:black")),
sidebarLayout(
sidebarPanel(
strong("Tools:"),
selectInput("Test",
label = "Choose a measure to display",
choices = c("EF",
"WM",
"DP"
),
selected = "EF"),
dateRangeInput("DateRange", label= "Date Range:", start ="2018-01-01", end = "2018-02-25")),
mainPanel(
code(strong("Study Readout")),
plotOutput("distPlot")
))
)
server <- function(input, output) {
filterData <- reactive({
x <- switch(input$Test,
"EF" = EF,
"WM" = WM,
"DP" = DP)
return(x)
})
output$distPlot <- renderPlot({
x <-filterData()
hist(x[Date >= min(input$DateRange) & Date <= max(input$DateRange)])
})
}
shinyApp(ui = ui, server = server)
Related
I am struggling with getting the code to work for this log widget I want to add to my interactive plot in shiny. I am able to modify the graphs x and y axis to a log scale by adding log(dat()[[input$yvrbl]]) to the server coder
server <- function(input, output) {
x <- reactive({
log(dat()[[input$yvrbl]])
})
y <- reactive({
log(dat()[[input$yvrbl]])
})
I was able to create the widgets on the ui code as well. I am still unable to transform the data to the log version based on whether or not the widget is checked. I tried making a separate reactive expression to host the changed log version of the x and y axis depending on an if statement. Please let me know what else I can do.
library(shiny)
library(plotly)
library(tibble)
library(tidyverse)
library(tidyr)
library(readr)
library(dplyr)
library(ggplot2)
# set working directory
setwd("~/BDSWD")
#read data
gm <- read_csv("gapminder_clean.csv")
# Define UI ----
ui <- fluidPage(
column(3,offset = 4, titlePanel("Explore Gapminder Data with Shiny")),
headerPanel('Graphs'),
mainPanel(
plotlyOutput('plot')
),
sidebarPanel(
#variable selection for x-axis
selectInput(inputId ='xvrbl', #The input slot that will be used to access the value.
label = 'X-Axis Variable', #Display label for the control, or NULL for no label.
choices = colnames(gm), #List of values to select from
selected = 'CO2 emissions (metric tons per capita)'
),
checkboxInput(inputId = "LogX",
label = "Log Transform",
value = FALSE),
#variable selection for y-axis
selectInput(inputId ='yvrbl', #The input slot that will be used to access the value.
label = 'Y-Axis Variable', #Display label for the control, or NULL for no label.
choices = colnames(gm), #List of values to select from
selected = 'gdpPercap'
),
checkboxInput(inputId = "LogY",
label = "Log Transform",
value = FALSE),
#date range - slider
sliderInput(inputId = "time",
label = "Years",
min = min(gm$Year),
max = max(gm$Year),
step = 5,
value = c(min(gm$Year),max(gm$Year)))
)
)
server <- function(input, output) {
x <- reactive({
dat()[[input$xvrbl]]
})
y <- reactive({
dat()[[input$yvrbl]]
})
dat <- reactive({
subset(gm, Year %in% input$time)
})
lgrthmc <- reactive({
if(isTRUE(input$LogY)) {
y <- reactive({
log(dat()[[input$yvrbl]])
})
} else {}
if(isTRUE(input$LogX)) {
x <- reactive({
log(dat()[[input$xvrbl]])
})
} else {}
})
output$plot <- renderPlotly({
plot_ly(
x = x(),
y = y(),
type = "scatter",
mode = "markers",
color = dat()$continent
) %>%
layout(
title = 'Gapminder Dataset',
plot_bgcolor = "#e5ecf6",
xaxis = list(title = input$xvrbl),
yaxis = list(title = input$yvrbl),
legend = list(title=list(text='<b> Continent </b>'))
)
})
}
# Run the app
shinyApp(ui = ui, server = server)
Instead of wrapping reactives inside a reactive you could achieve your desired result by adding an if inside your reactives, e.g.
Note: I slightly adjusted the subsetting of your data to take the sliderInput into account.
x <- reactive({
x <- dat()[[input$xvrbl]]
if (input$LogX) x <- log(x)
return(x)
})
library(gapminder)
library(shiny)
library(plotly)
library(tidyverse)
gm <- gapminder |> rename(Year = year)
# Define UI ----
ui <- fluidPage(
column(3, offset = 4, titlePanel("Explore Gapminder Data with Shiny")),
headerPanel("Graphs"),
mainPanel(
plotlyOutput("plot")
),
sidebarPanel(
# variable selection for x-axis
selectInput(
inputId = "xvrbl", # The input slot that will be used to access the value.
label = "X-Axis Variable", # Display label for the control, or NULL for no label.
choices = colnames(gm), # List of values to select from
selected = "lifeExp"
),
checkboxInput(inputId = "LogX",
label = "Log Transform",
value = FALSE),
# variable selection for y-axis
selectInput(
inputId = "yvrbl", # The input slot that will be used to access the value.
label = "Y-Axis Variable", # Display label for the control, or NULL for no label.
choices = colnames(gm), # List of values to select from
selected = "gdpPercap"
),
checkboxInput(
inputId = "LogY",
label = "Log Transform",
value = FALSE
),
# date range - slider
sliderInput(
inputId = "time",
label = "Years",
min = min(gm$Year),
max = max(gm$Year),
step = 5,
value = range(gm$Year)
)
)
)
server <- function(input, output) {
x <- reactive({
x <- dat()[[input$xvrbl]]
if (input$LogX) x <- log(x)
return(x)
})
y <- reactive({
y <- dat()[[input$yvrbl]]
if (input$LogY) y <- log(y)
return(y)
})
dat <- reactive({
subset(gm, Year >= input$time[[1]], Year <= input$time[[2]])
})
output$plot <- renderPlotly({
plot_ly(
x = x(),
y = y(),
type = "scatter",
mode = "markers",
color = dat()$continent
)
})
}
# Run the app
shinyApp(ui = ui, server = server)
#>
#> Listening on http://127.0.0.1:6593
I am developing a shiny app for regression analysis. I get an error when I want to change some variables to factor using the factor() function.
I want the user to select the variables he\she wants to change to factor from a selectInoput() and use a reactive function to feed the results to a new dataframe but the result is very weird! :(
I put a simplified version of what I do here.
Spent a day and could find the solution. Would appreciate your help.
x <- c( 1:5 )
y <- c( 10:14)
df <- data.frame(
x = x,
y = y
)
library(shiny)
ui <- fluidPage(
titlePanel(""),
sidebarLayout(
sidebarPanel(
selectInput(inputId = "str", label = "which variables should be changed to factors",choices = names(df), multiple = T)
),
mainPanel(
verbatimTextOutput("output")
)
)
)
server <- function(input, output) {
df_2 <- reactive({
df[ , input$str ] <- factor(df[ , input$str ])
})
output$output <- renderPrint({
str( df_2() )
})
}
shinyApp(ui = ui, server = server)
Your code only needs minor modification in server.
x <- c( 1:5 )
y <- c( 10:14)
df <- data.frame(
x = x,
y = y
)
library(shiny)
ui <- fluidPage(
titlePanel(""),
sidebarLayout(
sidebarPanel(
selectInput(inputId = "vars", label = "which variables should be changed to factors",choices = names(df), multiple = T)
),
mainPanel(
verbatimTextOutput("output")
)
)
)
server <- function(input, output) {
selected_vars <- reactive(input$vars)
df_2 <- reactive({
df[selected_vars()] <- lapply(df[selected_vars()], as.factor)
return(df)
})
output$output <- renderPrint({
str(df_2())
})
}
shinyApp(ui = ui, server = server)
I would like to click on a point in dygraph and get its corresponding date in "%Y-%m-%d %H:%M:%S" format. Here I've reproduced my problem:
library(dygraphs)
library(tidyverse)
library(data.table)
library(shiny)
dates <- seq(as.POSIXct("2021-01-01 05:00:00"), as.POSIXct("2021-01-05 05:00:00"), by = 8*3600)
set.seed(24)
df <- data.table(date = dates,
percentage = round(runif(length(dates), min = 0, max = 1), digits = 2)
)
ui <- fluidPage(
fluidRow(
column(width = 12,
dygraphOutput("dygraph")
)
),
fluidRow(
verbatimTextOutput("click")
)
)
server <- function(input, output){
output$dygraph <- renderDygraph({
dygraph(df)
})
output$click <- renderPrint({
input$dygraph_click$x
})
}
shinyApp(ui = ui, server = server)
Here is how the output looks like:
My problem is that it doesn't give me the right format. I tried to use the format function, but it did not work. I used the following line inside my renderprint:
format(as.POSIXct(input$dygraph_click$x), "%Y-%m-%d %H:%M:%S")
And here is the output:
It does not show the hour:minute:second properly.
Does anyone know how I can print out the POSIXct format of a date upon clicking on its corresponding point? I would appreciate any help.
You can use lubridate::ymd_hms to convert input$dygraph_click$x in POSIXct format and use format to display the output.
output$click <- renderPrint({
format(lubridate::ymd_hms(input$dygraph_click$x, tz = Sys.timezone()))
})
Complete code -
library(dygraphs)
library(tidyverse)
library(data.table)
library(shiny)
dates <- seq(as.POSIXct("2021-01-01 05:00:00"),
as.POSIXct("2021-01-05 05:00:00"), by = 8*3600)
set.seed(24)
df <- data.table(date = dates,
percentage = round(runif(length(dates), min = 0, max = 1), digits = 2)
)
ui <- fluidPage(
fluidRow(
column(width = 12,
dygraphOutput("dygraph")
)
),
fluidRow(
verbatimTextOutput("click")
)
)
server <- function(input, output){
output$dygraph <- renderDygraph({
dygraph(df)
})
output$click <- renderPrint({
format(lubridate::ymd_hms(input$dygraph_click$x, tz = Sys.timezone()))
})
}
shinyApp(ui = ui, server = server)
I am trying to build a shiny app to show COVID-19 cases for the 10 worst affected countries with refreshes daily from the ECDC website. I want to be able to limit cases and deaths using slider inputs, and select date periods with date inputs, (all already added).
The code is below, but when I run the app I get a blank plot, the axis are displaying correctly but I can't get the points to appear. This should be able to run on any computer as the code just downloads the data set from the ECDC page.
Any solutions?
library(shiny)
library(readxl)
library(dplyr)
library(httr)
library(ggplot2)
library(plotly)
url <- paste("https://www.ecdc.europa.eu/sites/default/files/documents/COVID-19-geographic-disbtribution-worldwide-",format(Sys.time(), "%Y-%m-%d"), ".xlsx", sep = "")
GET(url, authenticate(":", ":", type="ntlm"), write_disk(tf <- tempfile(fileext = ".xlsx")))
data <- read_excel(tf)
include<-c("United_Kingdom","Italy","France","China",
"United_States_of_America","Spain","Germany",
"Iran","South_Korea","Switzerland")
ui <- fluidPage(
titlePanel("COVID-19 Daily Confirmed Cases & Deaths"),
sidebarLayout(
sidebarPanel(
checkboxGroupInput("Country", "Select Country", selected = NULL, inline = FALSE,
width = NULL),
dateRangeInput("DateRep","Select Date Range", start = "2019-12-31", end = NULL),
sliderInput("Cases","Select Cases Range", min = 1, max = 20000, value = NULL),
sliderInput("Deaths", "Select Death Range", min = 1, max = 10000, value = 100),
submitButton("Refresh")
),
mainPanel(
plotOutput("plot")
)
)
)
server <- function(input, output) {
output$plot <- renderPlot({
include<-input$Country
plot_data<-filter(data, `Countries and territories` %in% include)%>%
filter(between(input$Cases))
plot_data%>% ggplot(aes(x=input$DateRep, y=input$Cases, size =input$Deaths, color = input$Country)) +
geom_point(alpha=0.5) +
theme_light()
})
}
shinyApp(ui = ui, server = server)
I think it would be better to define and filter the data you want to plot in a reactive expression outside of renderPlot. It will allow you to re-use these data more easily and it is easier (from my point of view) to use ggplot without inputs directly in it.
I include as.Date(DateRep) >= input$DateRep[1] & as.Date(DateRep) <= input$DateRep[2]) in filter to select the interval between the two chosen dates. Since the column DateRep has a POSIXct format, you need to use as.Date on it to convert it to the format dateRangeInput produces.
Here's the result:
library(shiny)
library(readxl)
library(dplyr)
library(httr)
library(ggplot2)
library(plotly)
url <- paste("https://www.ecdc.europa.eu/sites/default/files/documents/COVID-19-geographic-disbtribution-worldwide-",format(Sys.time(), "%Y-%m-%d"), ".xlsx", sep = "")
GET(url, authenticate(":", ":", type="ntlm"), write_disk(tf <- tempfile(fileext = ".xlsx")))
data <- read_excel(tf)
include<-c("United_Kingdom","Italy","France","China",
"United_States_of_America","Spain","Germany",
"Iran","South_Korea","Switzerland")
ui <- fluidPage(
titlePanel("COVID-19 Daily Confirmed Cases & Deaths"),
sidebarLayout(
sidebarPanel(
checkboxGroupInput("Country", "Select Country", choices = include, selected = "France"),
dateRangeInput("DateRep","Select Date Range", start = "2019-12-31", end = NULL),
sliderInput("Cases","Select Cases Range", min = 1, max = 20000, value = NULL),
sliderInput("Deaths", "Select Death Range", min = 1, max = 10000, value = 100),
submitButton("Refresh")
),
mainPanel(
plotOutput("plot")
)
)
)
server <- function(input, output) {
plot_data <- reactive({
filter(data, `Countries and territories` %in% input$Country
& as.Date(DateRep) >= input$DateRep[1]
& as.Date(DateRep) <= input$DateRep[2]) %>%
filter(between(Cases, 1, input$Cases))
})
output$plot <- renderPlot({
plot_data() %>%
ggplot(aes(x = as.Date(DateRep), y= Cases, size = Deaths, color = `Countries and territories`)) +
geom_point(alpha=0.5) +
theme_light()
})
}
shinyApp(ui = ui, server = server)
I started to fix this, but ran out of time... so here's what I did, maybe you can complete it...
library(shiny)
library(readxl)
library(dplyr)
library(httr)
library(ggplot2)
library(plotly)
url <- paste("https://www.ecdc.europa.eu/sites/default/files/documents/COVID-19-geographic-disbtribution-worldwide-",format(Sys.time(), "%Y-%m-%d"), ".xlsx", sep = "")
GET(url, authenticate(":", ":", type="ntlm"), write_disk(tf <- tempfile(fileext = ".xlsx")))
data <- read_excel(tf)
ui <- fluidPage(
titlePanel("COVID-19 Daily Confirmed Cases & Deaths"),
sidebarLayout(
sidebarPanel(
uiOutput("country_checkbox"),
dateRangeInput("DateRep","Select Date Range", start = "2019-12-31", end = NULL),
sliderInput("Cases","Select Cases Range", min = 1, max = 20000, value = NULL),
sliderInput("Deaths", "Select Death Range", min = 1, max = 10000, value = 100)
#submitButton("Refresh")
),
mainPanel(
plotOutput("plot")
)
)
)
server <- function(input, output) {
output$country_checkbox <- renderUI({
countries <- unique(data.frame(data)[, "Countries.and.territories"])
checkboxGroupInput("country", "Select Country",
choices = countries,
selected = NULL, inline = FALSE,
width = NULL)
})
output$plot <- renderPlot({
include<-input$country
plot_data<-filter(data, `Countries and territories` %in% include)%>%
filter(between(Cases, 1, input$Cases))
plot_data%>% ggplot(aes(x=DateRep, y=Cases, size =Deaths, color = `Countries and territories`)) +
geom_point(alpha=0.5) +
theme_light()
})
}
shinyApp(ui = ui, server = server)
A simple table output of the count works when I change the dates, but my summed revenue table does not. I have tried using the group_by function and reactive but no to avail.
install.packages(c("shiny","shinydashboard","ggplot2","dplyr","tidyverse","scales","lubridate"))
#not all of these packages may be necesary. They are just the ones I have been playing with
df <- data.frame("Ship Date" = c(2020-01-05,2020-01-06,2020-01-05,2020-01-06,2020-01-05,2020-01-06
,2020-01-05,2020-01-06), "Team" = c("Blue","Blue","Green","Green"
,"Gold","Gold","Purple","Purple"), "Revenue" = c(20,15,17,23
,18,19,17,12))
ui <- fluidPage(
dashboardHeader(title = "Dashboard",titleWidth = 450),
dateRangeInput(
inputId = "daterange",
label = "Select the date range", start = Sys.Date(), end = Sys.Date(), min = min(df$`Ship Date`),
max = max(df$`Ship Date`), format = "yyyy/mm/dd", separator = "-" ),
textOutput("startdate"), textOutput("enddate"), textOutput("range"),
dashboardBody(
fluidRow(
column(width = 3, tableOutput('subdatavt')),
column(width = 3, tableOutput('subdatart'))
)))
server <- function(input, output, session) ({
output$startdate <- renderText({
as.character(input$daterange[1])
})
output$enddate <- renderText({
as.character(input$daterange[2])
})
output$range <- renderText({
paste("Selected date range is ", input$daterange[1], "to", input$daterange[2])
})
#volume by Team
output$subdatavt <- renderTable({
vt = subset(df, df$`Ship Date`>=input$daterange[1] & df$`Ship Date`<= input$daterange[2])
table(vt$Team)
})
#revenue by Team
# here is where I do not know how to go about it. I imagine something to do with the group_by function
Is this what you are looking for?
library(lubridate)
library(dplyr)
library(shiny)
library(shinydashboard)
df <- tibble("ShipDate" = as.Date(c("2020-01-05","2020-01-06","2020-01-05","2020-01-06","2020-01-05","2020-01-06","2020-01-05","2020-01-06")),
"Team" = c("Blue","Blue","Green","Green","Gold","Gold","Purple","Purple"),
"Revenue" = c(20,15,17,23,18,19,17,12))
ui <- fluidPage(
dashboardHeader(title = "Dashboard",titleWidth = 450),
dateRangeInput(
inputId = "daterange",
label = "Select the date range", start = Sys.Date(), end = Sys.Date(), min = min(df$ShipDate),
max = max(df$ShipDate), format = "yyyy/mm/dd", separator = "-" ),
textOutput("startdate"), textOutput("enddate"), textOutput("range"),
dashboardBody(
fluidRow(
column(width = 3, tableOutput('subdatavt')),
column(width = 3, tableOutput('subdatart'))
)))
server <- function(input, output, session) ({
output$startdate <- renderText({
as.character(input$daterange[1])
})
output$enddate <- renderText({
as.character(input$daterange[2])
})
output$range <- renderText({
paste("Selected date range is ", input$daterange[1], "to", input$daterange[2])
})
#volume by Team
output$subdatavt <- renderTable({
vt = df %>% filter(ShipDate >= input$daterange[1],
ShipDate <= input$daterange[2]) %>%
group_by(Team) %>%
summarise(Revenue = sum(Revenue), n=n()) %>%
na.omit
})
})
shinyApp(ui = ui, server = server)