Trigger query based on selected date range in Shiny R - r

I have exctracted below mentioned dataframe in R using SQL query.
Query<-paste0("select ID, Date, Value, Result
From Table1
where date(date)>='2018-07-01'
and date(date)<='2018-08-31');")
Dev1<-dbgetquery(database,Query)
Dev1:
ID Date Value Result
KK-112 2018-07-01 15:37:45 ACR Pending
KK-113 2018-07-05 18:14:25 ACR Pass
KK-114 2018-07-07 13:21:55 ARR Accepted
KK-115 2018-07-12 07:47:05 ARR Rejected
KK-116 2018-07-04 11:31:12 RTR Duplicate
KK-117 2018-07-07 03:27:15 ACR Pending
KK-118 2018-07-18 08:16:32 ARR Rejected
KK-119 2018-07-21 18:19:14 ACR Pending
Using above mentioned dataframe, I have created below mentioned pivot dataframe in R.
Value Pending Pass Accepted Rejected Duplicate
ACR 3 1 0 0 0
ARR 0 0 1 2 0
RTR 0 0 0 0 0
And I just want a little help here to trigger those query based on a date range (for example, if one selects some date range on shiny dashboard, data gets automatically updated).
For the sake of simplicity, I have used only 4 columns of dataframe but in my original data I have 30 columns and it's not fitting in the frame on ui dashboard. Please suggest how to structure the table and color the header.
I am using below mentioned sample code to pass the dataframe.
library(shiny)
library(dplyr)
library(shinydashboard)
library(tableHTML)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
tableHTML_output("mytable")
)
)
server <- function(input, output) {
Date<-Dev1$Date
{
output$mytable <- render_tableHTML( {
Pivot<-data.table::dcast(Dev1, Value ~ Result, value.var="ID",
fun.aggregate=length)
Pivot$Total<-rowSums(Pivot[2:3])
Pivot %>%
tableHTML(rownames = FALSE,
widths = rep(80, 7))
})
}
}
shinyApp(ui, server)
Rrequired sample design:

Here's how you can do it -
library(shiny)
library(dplyr)
library(data.table)
library(shinydashboard)
library(tableHTML)
library(DT)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
dateRangeInput("dates", "Select Dates"),
actionButton("run_query", "Run Query"),
br(), br(),
tags$strong("Query that will be run when user hits above button"),
verbatimTextOutput("query"),
br(),
tableHTML_output("mytable"),
br(),
DTOutput("scrollable_table")
)
)
server <- function(input, output) {
Dev1 <- eventReactive(input$run_query, {
# Query <- sprintf("select ID, Date, Value, Result From Table1 where date(date) >= '%s' and date(date) <= '%s');",
# input$dates[1], input$dates[2])
# dbgetquery(database, Query)
structure(list(ID = c("KK-112", "KK-113", "KK-114", "KK-115",
"KK-116", "KK-117", "KK-118", "KK-119"),
Date = c("2018-07-01 15:37:45", "2018-07-05 18:14:25", "2018-07-07 13:21:55", "2018-07-12 07:47:05",
"2018-07-04 11:31:12", "2018-07-07 03:27:15", "2018-07-18 08:16:32",
"2018-07-21 18:19:14"),
Value = c("ACR", "ACR", "ARR", "ARR", "RTR", "ACR", "ARR", "ACR"),
Result = c("Pending", "Pass", "Accepted", "Rejected", "Duplicate", "Pending", "Rejected", "Pending")),
.Names = c("ID", "Date", "Value", "Result"),
row.names = c(NA, -8L), class = "data.frame")
})
output$mytable <- render_tableHTML({
req(Dev1())
Pivot <- data.table::dcast(Dev1(), Value ~ Result, value.var="ID",
fun.aggregate=length)
Pivot$Total <- rowSums(Pivot[, 2:6])
Pivot %>%
tableHTML(rownames = FALSE, widths = rep(80, 7)) %>%
add_css_header(., css = list(c('background-color'), c('blue')), headers = 1:7)
})
output$query <- renderPrint({
sprintf("select ID, Date, Value, Result From Table1 where date(date) >= '%s' and date(date) <= '%s');",
input$dates[1], input$dates[2])
})
output$scrollable_table <- renderDT({
data.frame(matrix("test", ncol = 30, nrow = 5), stringsAsFactors = F) %>%
datatable(options = list(scrollX = TRUE, paginate = F))
})
}
shinyApp(ui, server)
You would take dates as inputs using dateRangeInput() which feeds the query (commented out in my code) in Dev1. Live query is shown under verbatimTextOutput("query"). I have made Dev1 eventReactive meaning the data will be pulled only when user hits 'Run Query' button. This will allow user to set both, from and to, dates before running the query (useful if you are pulling lot of data). mytable will update whenever Dev1 updates.
Have also added color to tableHTML header.
For horizontally scroll-able table I'd recommend DT package as demonstrated under DTOutput("scrollable_table").
Hope this is what you were looking for.
Note: Make sure you sanitize Query to avoid any SQL injection possibilities. Basic google search should help with that.

You can add a sliderInput to let the user select the desired range of dates, and then make a reactive dataframe that'll subset data based on the user's selected range. I have used the sample data you provided, using minimum and maximum values of Date to assign the range for sliderInput.
library(shiny)
library(dplyr)
library(shinydashboard)
library(tableHTML)
library(DT)
structure(list(ID = structure(1:8, .Label = c("KK-112", "KK-113", "KK-114", "KK-115", "KK-116", "KK-117", "KK-118", "KK-119"),
class = "factor"),
Date = structure(c(17713, 17717, 17719, 17724, 17716, 17719, 17730, 17733),
class = "Date"),
Value = structure(c(1L, 1L, 2L, 2L, 3L, 1L, 2L, 1L), .Label = c("ACR", "ARR", "RTR"), class = "factor"),
Result = structure(c(4L, 3L, 1L, 5L, 2L, 4L, 5L, 4L), .Label = c("Accepted", "Duplicate", "Pass", "Pending", "Rejected"),
class = "factor")), class = "data.frame", row.names = c(NA, -8L))
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
# Add sliderInput for date - lets the user select a range of dates
sliderInput("dates.range",
"Dates:",
min = min(Dev1$Date),
max = max(Dev1$Date),
value = as.Date("2018-07-18"),
timeFormat="%Y-%m-%d")
),
dashboardBody(
tableHTML_output("mytable"),
dataTableOutput("mytable2")
)
)
server <- function(input, output) {
data.subsetted.by.date <- reactive({
# Subset data - select dates which are in the user selected range of dates
subset(Dev1, Date > min(Dev1$Date) & Date < input$dates.range)
})
# Output subsetted data as a DataTable
output$mytable2 <- renderDataTable(data.subsetted.by.date())
Date <- Dev1$Date
output$mytable <- render_tableHTML({
Pivot <- data.table::dcast(Dev1, Value ~ Result, value.var = "ID", fun.aggregate=length)
Pivot$Total <- rowSums(Pivot[2:3])
Pivot %>%
tableHTML(rownames = FALSE, widths = rep(80, 7))
})
}
shinyApp(ui, server)
You can see I have used renderDataTable and dataTableOutput from the DT package. These allow creating scroll-able tables for your shiny app.

For from - to data you can use dateRangeInput() and then use the input from there to filter your data.
For example:
in your UI:
dateRangeInput("ID", "Date", min = as.Date(min(Dev1$Date)), max = as.Date(max(Dev1$Date))
and then in Server:
Pivot <- Dev1 %>% filter(Date >= input$ID[1] & Date <= input$ID[2])
Did I understand your question correct?

Related

Select a variable based on two inputs in Rshiny

I have a dataset with variables for the ID of patients, different tests (MMT), and the treatment.
ID
MMT_II_week15_change
MMT_II_Week20_change
MMT_Tot_week15_change
MMT_Tot_Week20_change
Treatment
As you can see, we have two different tests (MMT_II_change and MMT_Tot_change), for two different timepoints (week15, week20).
What I want is the user to be able to select, first, the test, and then, the timepoint.
In reality, he would be picking just one of the variables, but in two different steps.
Something like:
**Select test:**
MMT_II
MMT_III
**Select timepoint:**
Week15
Week20
And after this, the variable selected would be:
e.g: MMT_II_Week20_change
I though of using regex for this, but it seems quite complicated and coulnd't find of a way of doing it.
Any help really appreciated, as I've been stuck with this for a while.
Would something like this work?
VAR = paste0(test,"_",timepoint,"_change")
...
# then later to use the variable...
.data[[VAR]]
You can wrap the checking of changess occured in a single reactive function in the server section of your code.
uptodateChoice <- reactive({
paste0(input$firstcontrol, "_", input$secondcontrol, "_change")
})
This function will be called once any of the two controls state change.
You can also add any validate(need(...)) checks inside the function if required or simply return() if some conditions are not satisfied.
You can access the string value calling uptodateChoice().
I'm thinking about pivoting the data to longer format, filter it and then pivot again to wider. This way we can filter using filter function directly.
library(tidyverse)
library(shiny)
# create some data
df <- tibble(
ID = 1:5, MMT_II_week15_change = sample(seq(0.01, 0.2, 0.01), 5), MMT_II_week20_change = sample(seq(0.01, 0.2, 0.01), 5),
MMT_Tot_week15_change = sample(seq(0.01, 0.2, 0.01), 5), MMT_Tot_week20_change = sample(seq(0.01, 0.2, 0.01), 5)
)
# pivot wider capturing MMT_* for the first column and the number of week in the second.
df_pivot <- pivot_longer(df, -ID, names_to = c("test", "week"), values_to = "change", names_pattern = "(MMT_.*)_week(\\d+)_change$")
## APP
library(shiny)
ui <- fluidPage(
selectInput("test", "Select Test", choices = unique(df_pivot$test)),
selectInput("timepoint", "Select Timepoint", choices = NULL),
tableOutput("table")
)
server <- function(input, output, session) {
table <- reactiveVal(NULL)
observeEvent(input$test, {
choices <- filter(.data = df_pivot, test == input$test) %>%
{
unique(.$week)
}
updateSelectInput(inputId = "timepoint", choices = choices)
})
# this could also be a reactive.
observe({
table(filter(df_pivot, test == input$test, week == input$timepoint) %>%
pivot_wider(names_from = "test", values_from = "change"))
})
output$table <- renderTable({
table()
})
}
shinyApp(ui, server)

SelectInput and dateRangeinput functions

I really need your help. I am new in R shiny and I have to use 2 reactives functions. I have a table of a DataBase which columns (id_cli, val_cli, date_cli) example (1, 12, 2020-02-01); (1,30,2020-02-02); (2, 80,2020-02-03), etc the id_cli is foreign key, so it isnt unique in this table. I want to select the id_cli using the function selectInput and from there select a date range using the dateRangeInput function
This is my code :
DB <- dbConnect(MySQL(),
user='xx',
host='xxx.xxx.x.xx')
req22 = dbGetQuery(DB, "select id_cli, val_cli, date_cli from t_client;")
agg22 = setNames(aggregate(req22[,1:2], list(req22$date_cli), mean), c("date_cli", "id_cli","val_cli"))
agg22$date_cli = as.Date(agg22$date_cli)
dates22 <- seq(from = min(agg22$date_cli),
to = max(agg22$date_cli),
by="days")
tweets22 <- data.frame(dateW = dates22, agg22$val_cli, agg22$id_cli)
selectInput(inputId = "id_cli2", label = h3("List of clients"), choices = tweets22$agg22.id_cli)
dateRangeInput(inputId="dateW", label ="Selectionne a Date",
start = min(tweets22$agg22.date_cli),
end = max(tweets22$agg22.date_cli),
min = min(tweets22$agg22.date_cli),
max= max(tweets22$agg22.date_cli))
query <- reactive({
tweets22 %>%
select(agg22.id_cli, dateW, agg22.val_cli) %>%
filter(agg22.id_cli == input$id_cli2)
})
newtweets22 <-reactive({
query()
filter(tweets22, between(dateW, input$dateW[1], input$dateW[2]))
})
renderPlot({
ggplot(newtweets22(), aes(x=dateW, y=agg22.val_cli))+ geom_line(size=1) + xlab ("Date") + ylab("Values")
})
The code takes all the date range of data but does not select by id_cli which is input$cli Someone can help me please ?
Edit: I added filter(id_cli == input$id_cli2) to respond to your update.
Do you want something like this?
library(tidyverse)
library(lubridate)
library(shiny)
ui <- fluidPage(
uiOutput("select_ui"),
uiOutput("date_ui"),
plotOutput("plot")
)
server <- function(input, output, session){
req22 <- reactive({
# Replace this with your database query:
tibble(id_cli = c(1,1,1,2,2,2),
val_cli = c(12,30,80,70,50,20),
date_cli = c(ymd("2020-02-01"), ymd("2020-02-02"), ymd("2020-02-03"),
ymd("2020-02-04"), ymd("2020-02-05"), ymd("2020-02-06")))
})
output$select_ui <- renderUI({
req(req22())
clients <- req22() %>% distinct(id_cli) %>% pull %>% sort
selectInput("id_cli2", "List of clients", choices = clients)
})
output$date_ui <- renderUI({
req(req22())
dates <- req22() %>%
filter(id_cli == input$id_cli2) %>%
summarize(mindate = min(date_cli),
maxdate = max(date_cli))
dateRangeInput("dateW", "Select a date",
start = dates$mindate,
min = dates$mindate,
max = dates$maxdate,
end = dates$maxdate)
})
output$plot <- renderPlot({
req(req22(), input$dateW, input$id_cli2)
req22() %>%
filter(date_cli >= input$dateW[[1]],
date_cli <= input$dateW[[2]],
id_cli == input$id_cli2) %>%
ggplot(aes(x=date_cli, y = val_cli)) +
geom_point() +
geom_line()
})
}
shinyApp(ui = ui, server = server)
I assume that each time the user changes the client ID, you want the dates to default to the widest range relevant to that client. If you want to remember the user's previous date selections, then you should store them in a reactiveVal using observeEvent and then also use this in the filtering.
Thanks a lot for your answer. Yes I want like this but there is something doesnt Ok.
If I consider your code with this new data :
req22 <- reactive({
# Replace this with your database query:
tibble(id_cli = c(1,1,1,2,2,2),
val_cli = c(12,30,80,70,50,20),
date_cli = c(ymd("2020-02-01"), ymd("2020-02-02"), ymd("2020-02-03"),
c(ymd("2020-02-04"), c(ymd("2020-02-05"), c(ymd("2020-02-06")))
})
In the user interface when I select 1 of List of cients, in the select date range I want to have automaticaly 2020-02-01 to 2020-02-03 and when I select 2 of List of clients I want to see in the Select a date automatcaly the date between 2020-02-04 to 2020-02-06
The plot is OK, but there is the prolem only in the DateRangeInput.
Thanks in advance for your help :)

Struggling to setup multi-step SelectInput in Shiny

You can see I'm trying to setup three different filters, all of them reactive to each other, but it keeps giving me errors when I test it out.
What I'm trying to accomplish is setting up these filters in a way where say I choose Territory 1, it'll only give me the corresponding states (Ohio) and cities (Columbus and Cleveland). At the same time, say I select both Territory 1 and 4, it will give me the states (Ohio and Michigan) and the cities (Columbus, Cleveland, and Grand Rapids, but not Detroit). At the same time, say I wanted to ignore the territory field and decided to just go right to the State filter, it will give me all the state options (keeping in mind, I haven't chosen anything in territory yet). Same thing if I just wanted to go right to the city filter.
So basically, I want all the filters to be reactively tied to each other, but with no rigid hierarchy where I have to choose territory first, then state, and finally cities.
Was I able to explain that well?
Here is the code.
The setup:
library(shiny)
library(dplyr)
library(highcharter)
df <- structure(list(territory = structure(c(1L, 1L, 2L, 2L, 3L, 4L
), .Label = c("1", "2", "3", "4"), class = "factor"), state = structure(c(3L,
3L, 1L, 1L, 2L, 2L), .Label = c("Indiana", "Michigan", "Ohio"
), class = "factor"), city = structure(c(2L, 1L, 6L, 4L, 3L,
5L), .Label = c("Cleveland", "Columbus", "Detroit", "Gary", "Grand Rapids",
"Indianapolis"), class = "factor"), sales = 5:10, leads = 11:16), class = "data.frame", row.names = c(NA,
-6L)) %>%
mutate_all(as.character)
ui <- {
fluidPage(
fluidRow(
selectizeInput(
inputId = 'selectTerritory',
label = 'Select Territory',
choices = c('All Territories', sort(unique(df$territory))),
multiple = TRUE,
selected = 'All Territories'),
uiOutput(
outputId = 'selectState'),
uiOutput(
outputId = 'selectCity'),
highchartOutput("test")
# plotOutput()
)
)
}
server <- function(input, output, session) {
output$selectState <- renderUI({
# if 'All Territories' is not selected, then filter df by selected Territories. Otherwise, just get all states.
if (!('All Territories' %in% input$selectTerritory)) {
df <- df %>%
filter(
territory %in% input$selectTerritory)
}
states <- sort(unique(df$state))
selectizeInput(
inputId = 'selectState',
label = 'Select State',
choices = c('All States', states),
multiple = TRUE,
selected = 'All States')
})
output$selectCity <- renderUI({
# same strategy
if (!('All States' %in% input$selectState)) {
df <- df %>%
filter(
state %in% input$selectState,
territory %in% input$selectTerritory)
} else {
df <- df %>%
filter(
territory %in% input$selectTerritory)
}
cities <- sort(unique(df$city))
selectizeInput(
inputId = 'selectCity',
label = 'Select City',
choices = c('All Cities', cities),
multiple = TRUE,
selected = 'All Cities')
})
geog <- reactive({
res <- df %>% filter(is.null(input$selectTerritory) | territory %in% input$selectTerritory,
is.null(input$selectState) | state %in% input$selectState,
is.null(input$selectCity) | city %in% input$selectCity)
})
output$test <- renderHighchart({
res <- geog() %>% select_all()
graph <- res %>% group_by_all() %>% summarise(totals=sum(sales))
highchart() %>% hc_add_series(data = graph, type = "bar", hcaes(y = totals),
showInLegend = TRUE) %>% hc_add_theme(hc_theme_flat())
})
}
shinyApp(ui, server)
Firstly, I prefer single-file Shiny apps (it's much easier to copy/paste the whole app rather than having separate files for ui and server).
The other benefit of single-file Shiny apps is that when you post the code to something like Stack Overflow, you can just copy and paste the whole thing, including your calls to library() which are very important! For example, I don't know what package you are using for highChartOutput(), so including those library() calls makes it easier when people are reproducing your code (and becomes the default if you just have a single-file Shiny app). On a related note, your question doesn't really have anything to do with a plot output, so I'm ignoring that part here (you should be able to access the outputs the same way you normally would in a Shiny app).
Secondly, I wouldn't use rbind() to make a df (it can do weird things with the data types). You can just define your variable columns, and directly call data.frame() (e.g., df <- data.frame(v1,v2)). I created the reproducible data by defining your variable columns, calling data.frame, and then running dput(df), which means we can define your dataframe in a single call (and so it's easy to reproduce and avoid any typos).
Thirdly, I'm using dplyr::mutate_all(as.character) because I don't know the package you use for this (taRifx).
Finally, to answer your question... The way I would approach this problem is to define extra variables to each class corresponding effectively to 'All variables', and have these selected as the default for each selectizeInput.
library(shiny)
library(dplyr)
df <- structure(list(territory = structure(c(1L, 1L, 2L, 2L, 3L, 4L
), .Label = c("1", "2", "3", "4"), class = "factor"), state = structure(c(3L,
3L, 1L, 1L, 2L, 2L), .Label = c("Indiana", "Michigan", "Ohio"
), class = "factor"), city = structure(c(2L, 1L, 6L, 4L, 3L,
5L), .Label = c("Cleveland", "Columbus", "Detroit", "Gary", "Grand Rapids",
"Indianapolis"), class = "factor"), sales = 5:10, leads = 11:16), class = "data.frame", row.names = c(NA,
-6L)) %>%
mutate_all(as.character)
ui <- {
fluidPage(
fluidRow(
selectizeInput(
inputId = 'selectTerritory',
label = 'Select Territory',
choices = c('All Territories', sort(unique(df$territory))),
multiple = TRUE,
selected = 'All Territories'),
uiOutput(
outputId = 'selectState'),
uiOutput(
outputId = 'selectCity')
# plotOutput()
)
)
}
server <- function(input, output, session) {
output$selectState <- renderUI({
# if 'All Territories' is not selected, then filter df by selected Territories. Otherwise, just get all states.
if (!('All Territories' %in% input$selectTerritory)) {
df <- df %>%
filter(
territory %in% input$selectTerritory)
}
states <- sort(unique(df$state))
selectizeInput(
inputId = 'selectState',
label = 'Select State',
choices = c('All States', states),
multiple = TRUE,
selected = 'All States')
})
output$selectCity <- renderUI({
# same strategy
if (!('All States' %in% input$selectState)) {
df <- df %>%
filter(
state %in% input$selectState,
territory %in% input$selectTerritory)
} else {
df <- df %>%
filter(
territory %in% input$selectTerritory)
}
cities <- sort(unique(df$city))
selectizeInput(
inputId = 'selectCity',
label = 'Select City',
choices = c('All Cities', cities),
multiple = TRUE,
selected = 'All Cities')
})
}
shinyApp(ui, server)

R - Group by Date then Sum by unique ID

Here is my code - creating a dashboard that will filter by date. One tab will show our wellness survey data, the other will show post-practice loading data. I am pulling in the first 3 columns from "post.csv" which are Date, Name, Daily. Then I am looking to create and add the next 3 columns with the math.
Where I am first stuck is that I need my Daily_Load to aggregate data for a specific athlete on the given Date. Then I need to create a rolling 7-day sum for each athlete using the Daily load data from the last 7 days (including Date selected). A 28-Day Rolling Sum/4 and 7-Day/28-Rolling is the last piece.
Thanks again for all of the help!
library(shiny)
library(dplyr)
library(lubridate)
library(ggplot2)
library(DT)
library(zoo)
library(tidyr)
library(tidyverse)
library(data.table)
library(RcppRoll)
AM_Wellness <- read.csv("amwell.csv", stringsAsFactors = FALSE)
Post_Practice <- read.csv("post.csv", stringsAsFactors = FALSE)
Post_Data <- Post_Practice[, 1:3]
Daily_Load <- aggregate(Daily~ ., Post_Data, sum)
Acute_Load <- rollsum(Post_Data$Daily, 7, fill = NA, align = "right")
Chronic_Load <- rollsum(Post_Data$Daily, 28, fill = NA, align = "right")/4
Post_Data['Day Load'] <- aggregate(Daily~ ., Post_Data, sum)
Post_Data['7-Day Sum'] <- Acute_Load
Post_Data['28-Day Rolling'] <- Chronic_Load
Post_Data['Ratio'] <- Acute_Load/Chronic_Load
ui <- fluidPage(
titlePanel("Dashboard"),
sidebarLayout(
sidebarPanel(
dateInput('date',
label = "Date",
value = Sys.Date()
),
selectInput("athleteInput", "Athlete",
choices = c("All"))
),
mainPanel(tabsetPanel(type = "tabs",
tabPanel("AM Wellness", tableOutput("amwell")),
tabPanel("Post Practice", tableOutput("post"))
)
)
)
)
server <- function(input, output) {
output$amwell <- renderTable({
datefilter <- subset(AM_Wellness, AM_Wellness$Date == input$date)
}, hover = TRUE, bordered = TRUE, spacing = "xs", align = "c")
output$post <- renderTable({
datefilter <- subset(Post_Data, Post_Data$Date == input$date)
}, hover = TRUE, bordered = TRUE, spacing = "xs", align = "c")
}
shinyApp(ui = ui, server = server)

Shiny - Web Framework for R › how to use an input switch to conditionally group

asked this on the shiny google group, w no help yet: I'm struggling with how to pass an input switch to dplyr's group_by_ in the code below.
I bolded the two parts of relevant code in the not-so-MRE below (ie, lines 9:11, and 24).
effectively, if the user selects "daily" in the UI, the resultant grouping should be group_by(year = year(my_date), month = month(my_date), day = day(my_date) in line 24, or remove ANY grouping as the data is already daily.
selecting "monthly", should yield group_by(year = year(my_date), month = month(my_date))
"yearly", should yield group_by(year = year(my_date))
I welcome meta-suggestions/ criticism about how my code/ structures are organized.
Thank you
library(shiny)
library(dplyr)
library(lubridate)
ui <- fluidPage(
dateInput("start", label = "start date", value = "2010-01-01"),
dateInput("end", label = "end date", value = "2020-01-01"),
selectInput("grouping_freq", label = "Granularity",
choices = list("daily" = 1,"monthly" = 2, "Yearly" = 3),
selected = 2),
tableOutput("my_table")
)
server <- function(input, output) {
df <- reactive({ data_frame(my_date = seq(input$start, input$end, by = 'day')) }) ## 10 years of daily data
df2 <- reactive({ df() %>% mutate(dummy_data = cumsum(rnorm( nrow( df() ) ))) })
output$my_table <- renderTable({
df2() %>% group_by(year = year(my_date), month = month(my_date)) %>%
summarise(dummy_data = sum(dummy_data), my_date = as.Date(min(my_date)))
})
}
shinyApp(ui = ui, server = server)
You can use the value chosen in selectInput to create a list of formulas that are passed into group_by_, the version of dplyr::group_by that uses standard evaluation.
group_list <- switch(input$grouping_freq,
list(yr=~year(my_date), mn=~month(my_date), dy=~day(my_date)),
list(yr=~year(my_date), mn=~month(my_date))
list(yr=~year(my_date)))
or if you prefer if statements,
group_list <- if (input$grouping_freq == 1) {
list(yr=~year(my_date), mn=~month(my_date), dy=~day(my_date))
} else if (input$grouping_freq == 2) {
list(yr=~year(my_date), mn=~month(my_date))
} else if (input$grouping_freq == 3) {
list(yr=~year(my_date))
} else {
list()
}
and then you can pass group_list into the renderTable expression
output$my_table <- renderTable({
df2() %>%
group_by_(.dots=group_list) %>%
summarise(dummy_data = sum(dummy_data), my_date = as.Date(min(my_date)))
})
I am not sure what you meant by "remove ANY grouping as the data is already daily." but if the data might already be grouped you can use the ungroup function to remove any groups before applying the groupings in group_list.
Edit: Forgot to include ~ in the list elements so that they evaluate correctly.

Resources