R - Group by Date then Sum by unique ID - r

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)

Related

can a returned reactive expression works in another reactive

I tried to achieve when with a chosen split percentage, it returns the train set and then with a sampling method to resample train set and calculate its class freq and perc.
The error I got: object 'split.df' not found when I choose check box 'over'.
Should I use eventReactive or other syntax to achieve? The final return the table with either freq or perc should be dependent on 'split', 'sample' and dropdown 'freq' or 'perc'.
Here is portion that relates in ui:
sidebarLayout(
sidebarPanel(
h3("Train/test set"),
tags$br(),
selectInput(
"trainset",
"Select train component",
choices = list('freq'='freq', 'percentage'='perc'),
),
sliderInput(
"split",
label = "split percentage",
min = 0,
max = 1,
value = 0,
step = 0.1
),
h3("resampling train set"),
checkboxGroupInput('sample', label = "sampling method",
choices = list('original'='original','over'='over', 'under'='under', 'both'='both','ROSE'='ROSE'),
selected = list('original'='original'))
),
Here is a code relates for server:
split.df <- reactive({
index <- createDataPartition(df$class, p=input$split, list=FALSE)
Training_Data <- df[index,]
return(Training_Data)
})
train_set <- reactive({
if(input$sample == 'original')
Training_Data_class <- data.frame(class = split.df()$class)
return(Training_Data_class)
})
over_train_set <- reactive({
split.df <- split.df()
if(input$sample == 'over'){
over <- ovun.sample(class~., data = split.df, method = 'over')$data
Training_Data_class_over <- data.frame(class = over$class)
return(Training_Data_class_over)}
})
trainset_df <- reactive({
freq.df.train <- data.frame(table(train_set()))
colnames(freq.df.train) <- c('class', 'freq')
perc.df.train.=data.frame(prop.table(table(train_set()))*100)
colnames(perc.df.train) <- c('class','perc')
if(input$trainset == 'freq')
return(freq.df.train)
if(input$trainset == 'perc')
return(perc.df.train)
})
over_trainset_df <- reactive({
freq.df.train.over <- data.frame(table(over_train_set()))
colnames(freq.df.train.over) <- c('class', 'freq')
perc.df.train.over=data.frame(prop.table(table(over_train_set()))*100)
colnames(perc.df.train.over) <- c('class','perc')
if(input$trainset == 'freq')
return(freq.df.train.over)
if(input$trainset == 'perc')
return(perc.df.train.over)
})
output$trainsetdistr <- DT::renderDataTable({
if(input$sample == 'over'){
return(over_trainset_df())
}
if(input$sample == 'original'){
return(trainset_df())
}
}
)

How to solve the error in highcharOutput in shiny tool?

I'm working on cancer data from TCGA.
Im new to shiny and creating web applications (learning it!!)
I'm working on a shiny tool to plot the volcanoplot using highcharter package.
sometimes I'm successfully able to plot the volcanoplot in the UI. but sometimes it fails to plot it and throws an error saying,
"An error has occurred!
could not find function "highchartOutput"
and one warning message is given for the error;
Listening on http://127.0.0.1:5335
Warning: Error in highchartOutput: could not find function "highchartOutput"
83: dots_list
82: div
81: tabPanel
I think there is some problem with the tabset panel.
is this error has anything to do with indentation? (wherever I adjust the brackets it works magically. not sure how it works for sometimes.)
I am attaching the UI and server files with this post.
code is attached for one type of comparison
UI file below:
library(shiny)
# Define UI for application
shinyUI(fluidPage(
# Application title
titlePanel("miR-Gyn-Explorer"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
## select the count matrix
selectInput("file", label = h3("Count Matrix"),
choices = list("Stage I - Normal" = list("TCGA-BRCA" = "Data/TCGA-BRCASI_NT.rda", "TCGA-UCEC" = "Data/TCGA-UCECSI_NT.rda"))),
## select the phenodata of samples
selectInput("phenofile", label = h3("Sample Phenodata"),
choices = list("Stage I - Normal" = list("TCGA-BRCA" = "Data/TCGA-BRCA_phenoSI_NT.rda", "TCGA-UCEC" = "Data/TCGA-UCEC_phenoSI_NT.rda"))),
submitButton("Update View")
),
# Show a plot of the generated distribution
mainPanel(
tabsetPanel(
tabPanel("DEmiRNA", DT::dataTableOutput("DEmiRNA"),
"Volcano-Plot", highchartOutput("volcanoPlot", height = "500px"))
#tabPanel("miRNA-Targets", DT::dataTableOutput('miRTarget'),
#plotOutput("GO"))
)
)
)
)
)
server file:
library(shiny)
library(R.utils)
##function to find the DEmiRNA by edgeR method
library(limma)
library(edgeR)
library(DT)
library(dplyr)
library(multiMiR)
library(miRBaseConverter)
library(ggplot2)
#library(ggrepel)
library(tidyverse)
library(highcharter)
library(org.Hs.eg.db)
library(clusterProfiler)
library(purrr)
gdcDEmiRNA <- function(counts, groups, comparison, filter=TRUE) {
## method = edgeR
dge = DGEList(counts = counts, samples = groups)
group <- factor(groups$group)
design <- model.matrix(~0+group)
colnames(design) <- levels(group)
contrast.matrix <- makeContrasts(contrasts=comparison,
levels=design)
keep = filterByExpr(dge,design)
dge <- dge[keep,,keep.lib.sizes = TRUE]
dge <- calcNormFactors(dge)
dge <- estimateDisp(dge, design)
fit <- glmFit(dge, design)
lrt <- glmLRT(fit, contrast=contrast.matrix)
DEGAll <- lrt$table
DEGAll$FDR <- p.adjust(DEGAll$PValue, method = 'fdr')
o <- order(DEGAll$FDR)
DEGAll <- DEGAll[o,]
return (DEGAll)
}
# Define server logic required to perform the DEmiRNA analysis
server <- function(input, output) {
d <- reactive({
#DEmiRNA calculation
file <- load(input$file)
phenofile <- load(input$phenofile)
if(file == "SI_NT"){
if(phenofile == "phenoSI_NT"){
DEmiRNA <- gdcDEmiRNA(counts = SI_NT, groups = phenoSI_NT,
comparison = 'StageI-Normal')
}
}
})
output$DEmiRNA <- DT::renderDataTable({
mir <- d()
#mir <- mir[mir$FDR < input$FDR,]
})
output$volcanoPlot <- renderHighchart({
x <- d()
x$mirna <- rownames(x)
x$sig <- ifelse(x$PValue < 0.05 & abs(x$logFC) > 0.57, "DEmiRNA", "Not Regulated")
hc <- highchart() %>%
hc_add_series(x, "scatter", hcaes(logFC, -log10(PValue), group = sig, value = mirna),
color = c('rgba(67, 67, 72, 0.6)', 'rgba(124, 181, 236, 0.6)'),
enableMouseTracking = c(TRUE, TRUE),
showInLegend = TRUE, marker = list(radius = 4)) %>%
hc_tooltip(pointFormat = "{point.value}", headerFormat = "") %>%
hc_xAxis(title = list(text = "Log fold change"), gridLineWidth = 1,
tickLength = 0, startOnTick = "true", endOnTick = "true", min = -6, max = 6) %>%
hc_yAxis(title = list(text = "-Log10(p-value)")) %>%
hc_chart(zoomType = "xy", width=700) %>%
hc_exporting(enabled = TRUE, filename = "volcano")
hc
})
}
any comment and help from you guys is appreciated
Thank you in advance!
-Ankita

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.

table command fails with shiny input variable

I'm creating my first shiny app, everything works fantastic when using ggplot2 but using other base R or vcd plots has me stuck. I'd like the user to be able to select a tabling variable and then view a resulting mosaic or association plot. My server code fails at the table command. Things I've already tried are commented out below.
Thanks for the help.
library(shiny)
library(shinydashboard)
library(vcd)
header = dashboardHeader(title = 'Min Reproducible Example')
sidebar = dashboardSidebar()
body = dashboardBody(
fluidRow(plotOutput('plot'), width=12),
fluidRow(box(selectInput('factor', 'Select Factor:', c('OS', 'Gender'))))
)
ui = dashboardPage(header, sidebar, body)
server = function(input, output){
set.seed(1)
df = data.frame(Condition = rep(c('A','B','C','D'), each = 300),
Conversion = c(sample(c('Convert','Not-Convert'), 300, replace = TRUE, prob = c(0.9, 0.1)),
sample(c('Convert','Not-Convert'), 300, replace = TRUE, prob = c(0.7, 0.3)),
sample(c('Convert','Not-Convert'), 300, replace = TRUE, prob = c(0.5, 0.5)),
sample(c('Convert','Not-Convert'), 300, replace = TRUE, prob = c(0.2, 0.8))),
Gender = sample(c('M','F'), 1200, replace = TRUE),
OS = rep(sample(c('Web','iOS','Android'), 1200, replace = TRUE), times = 2))
#tried this
#table1 = reactive({
# with(df, table(Condition, Conversion, input$factor))
#})
output$plot = renderPlot({
#fails here:
table1 = with(df, table(Condition, Conversion, input$factor))
#also tried these
#table1 = with(df, table(Condition, Conversion, as.character(isolate(reactiveValuesToList(input$factor)))))
#also tried table1 = with(df, table(Condition, Conversion, input$factor))
#also tried table1 = table(df$Condition, df$Conversion, paste0('df$', input$factor))
#then I want some categorical plots
assoc(table1, shade=TRUE)
#or mosaicplot(table1, shade=TRUE)
})
}
shinyApp(ui, server)
An easy fix would be to use 'starts_with' from dplyr in a select() statement on your input variable
library('dplyr')
output$plot = renderPlot({
df <- select(df, Condition, Conversion, tmp_var = starts_with(input$factor))
table1 = with(df, table(Condition, Conversion, tmp_var))
mosaicplot(table1, shade=TRUE)
})
}

How to make fill color consistent when plotting subsets of a dataframe with ggvis

I am trying to make the colors in a ggvis plot remain consistent whenever the data is re-plotted based on the factors (unfortunately I apparently lack enough reputation to include pictures to show you).
I could only find one other post about this controlling-color-of-factor-group-in-ggvis-r but none of his solutions or workarounds work in my situation.
my data looks like this:
month year date entity_name prefix module module_entry_key entity_table_name count
0 January 2011 2011.000 AbLibrary LIB Base BS AB_LIBRARY 0
1 February 2011 2011.083 AbLibrary LIB Base BS AB_LIBRARY 0
2 March 2011 2011.167 AbLibrary LIB Base BS AB_LIBRARY 0
3 April 2011 2011.250 AbLibrary LIB Base BS AB_LIBRARY 0
4 May 2011 2011.333 AbLibrary LIB Base BS AB_LIBRARY 0
5 June 2011 2011.417 AbLibrary LIB Base BS AB_LIBRARY 0
3000 January 2011 2011.000 Vector VEC Base BS VECTOR 0
3001 February 2011 2011.083 Vector VEC Base BS VECTOR 0
3002 March 2011 2011.167 Vector VEC Base BS VECTOR 0
3003 April 2011 2011.250 Vector VEC Base BS VECTOR 569
3004 May 2011 2011.333 Vector VEC Base BS VECTOR 664
3005 June 2011 2011.417 Vector VEC Base BS VECTOR 775
I'm using a shiny app to display the page in a browser, and the relevant code is:
# render the plot, filtering for entities within the module minus any entities selected from the exclude panel
plot <- reactive({
if (input$filter==1){
data <- dplyr::filter(.data=melted, module_entry_key %in% input$module)
}
else{
data <- dplyr::filter(.data=melted, entity_name == input$entity)
}
data <- dplyr::filter(.data=data, !entity_name %in% input$excluded)
data$entity_name <- factor(data$entity_name)
data %>%
ggvis(x = ~date, y = ~count, fill = ~entity_name, key := ~id, fillOpacity := 0.5, fillOpacity.hover := 0.9) %>%
add_legend("fill", title="Entities") %>%
layer_points() %>%
add_tooltip(tooltipText, "hover") %>%
add_axis("y", title = "Count", title_offset = 50) %>%
add_axis("x", title="Date", title_offset=50, subdivide=6, tick_size_minor=3, format=parseDate(~year, ~month))
})
the filter is creating the subset of "melted" as "data" based on the filters in the UI (see picture)
since as far as I can tell there is no way to associate a fill color to a factor (the entity name) explicitly and the color is chosen by alphabetical order of the factors, whenever I make a new subset of data the colors are changed.
Is there any way to work around this?
(full shiny code)
server.R
library(ggvis)
library(shiny)
library(dplyr)
shinyServer(function(input, output, session){
modules_list <- as.character(c("Base" = "BS",
"Screening" = "SC",
"Protein Engineering" = "EN",
"Protein Production" = "PP",
"CD",
"PT",
"PD"))
#melted <- read.table(file="~/dataOut.txt", sep="\t", strip.white=TRUE, row.names=1, header=TRUE);
modules <- as.character(as.vector(unique(melted$module_entry_key)))
modules <- modules[modules != "null"]
entities <- as.character(as.vector(unique(melted$entity_name)))
entities <- entities[entities != "null"]
for (i in entities){
melted <- rbind(melted, data.frame(month=NA, year=NA, date=NA, entity_name=i, prefix=NA, module=NA, module_entry_key=NA, entity_table_name=NA, count=NA))
}
melted$id <- 1:nrow(melted)
#create ui checkbox for modules in the data
output$module_list <- renderUI({
checkboxGroupInput(inputId = "module",
label = "Module",
choices = modules,
selected = "BS")
})
#create the ui list for entities
output$entity_list <- renderUI({
checkboxGroupInput(
inputId = "entity",
label = "Entity",
choices = entities,
selected = "Vector"
)
})
#ex <- entities
#create the checkboxGroupInput with entities to 'exclude'
output$exclusion_entities <- renderUI({
checkboxGroupInput(inputId = "excluded", label = "Exclude",
choices = entities)
})
#update the excluded entities list with entities within a particular module
observe({
if (input$filter==1)
ex1 <- as.character(as.vector(unique(dplyr::filter(.data=melted, module_entry_key %in% input$module)$entity_name)))
updateCheckboxGroupInput(session, inputId = "excluded", "Exclude", choices=ex1, selected = input$excluded )
})
# render the plot, filtering for entities within the module minus any entities selected from the exclude panel
plot <- reactive({
if (input$filter==1){
data <- dplyr::filter(.data=melted, module_entry_key %in% input$module)
}
else{
data <- dplyr::filter(.data=melted, entity_name == input$entity)
}
data <- dplyr::filter(.data=data, !entity_name %in% input$excluded)
data$entity_name <- factor(data$entity_name)
data %>%
ggvis(x = ~date, y = ~count, fill = ~entity_name, key := ~id, fillOpacity := 0.5, fillOpacity.hover := 0.9) %>%
add_legend("fill", title="Entities") %>%
layer_points() %>%
add_tooltip(tooltipText, "hover") %>%
add_axis("y", title = "Count", title_offset = 50) %>%
add_axis("x", title="Date", title_offset=50, subdivide=6, tick_size_minor=3, format=parseDate(~year, ~month))
})
#function to add color and mouse-over effect to layer_points() (unused in this code)
points <- reactive({
layer_points(fillOpacity := 0.5, fillOpacity.hover := 1, fill.hover := "red")
})
#d3 date format for formatting x-axis text
parseDate <- function(year, month){
paste("d3.time.format(\"%Y\").parse(", year, ")", sep="")
}
#function for what to display in mouse-hover tooltip
tooltipText <- function(x) {
if(is.null(x)) return(NULL)
row <- melted[melted$id == x$id, ]
paste(row$entity_name, ": ", row$count, sep="")
}
#bind the plot to the UI
plot %>% #layer_points(fill = ~factor(entity_name)) %>%
bind_shiny("ggvis")
#select all button for modules
observe({
if (input$selectall ==0){
return(NULL)
}
else if ((input$selectall%%2)==0){
updateCheckboxGroupInput(session, inputId = "module", "Module", choices = modules)
}
else{
updateCheckboxGroupInput(session, inputId = "module", "Module", choices=modules, selected=modules)
}
})
#select all button for excluded entities
observe({
list <- as.character(as.vector(unique(dplyr::filter(.data=melted, module_entry_key %in% input$module)$entity_name)))
if (input$exclude_all ==0){
return(NULL)
}
else if ((input$exclude_all%%2)==0){
updateCheckboxGroupInput(session, inputId = "excluded", "Exclude", choices=list )
}
else{
updateCheckboxGroupInput(session, inputId = "excluded", "Exclude", choices=list, selected=list )
}
})
#---general output / debugging stuff ----#
output$table <- renderTable({dataInput()})
output$entity_selected = renderPrint({
list <- as.character(as.vector(unique(dplyr::filter(.data=melted, module_entry_key %in% input$module)$entity_name)))
entities[!entities %in% input$excluded & entities %in% list]
})
output$filter_value = renderPrint({input$filter})
output$modules = renderPrint({input$module})
output$link = renderPrint(input$selectall%%2)
#----------------------------------------#
})
ui.R
library(shiny)
shinyUI(fluidPage(
titlePanel("DB Analysis"),
sidebarLayout(
sidebarPanel(
width=3,
radioButtons(inputId="filter",
label="Filter",
choices = list("By Module" = 1, "By Entity" = 2),
selected = 1),
conditionalPanel(condition = "input.filter == 1",
uiOutput("module_list"),
actionButton("selectall", "Select All"),
uiOutput("exclusion_entities"),
actionButton("exclude_all", "Select All")
),
conditionalPanel(condition = "input.filter == 2",
uiOutput("entity_list")
)
),
mainPanel(
h2("Cumulative Entity Counts over Time (years)", align="center"),
#verbatimTextOutput("value"),
#verbatimTextOutput("filter_value"),
#verbatimTextOutput("modules"),
#tableOutput("table"),
ggvisOutput("ggvis"),
verbatimTextOutput("link"),
verbatimTextOutput("entity_selected")
#textOutput("entities_plot")
)
)
)
)
This is probably the best way to do it. Try something like this:
df[which(df$entity_name == "AbLibrary"),]$color <- "FF0000"
df[which(df$entity_name == "Vector"),]$color <- "#FFB90F"
For each one in your data frame. Set your fill then to color each time. The only problem is trying to make a legend. (I have been trying to figure that out, so if I find it I will edit this post.

Resources