ggplot stat_ecdf() with a Shiny reactive expression - r

I'm hoping to implement this ggplotly bug fix offered here:
https://community.plot.ly/t/bug-with-ggplot2-stat-ecdf-function/1187/4
into a Shiny reactive expression. The top plot below shows the ggplot() call results within Shiny (as expected), the bottom is from ggplotly().
When I try to insert data <- data[order(data$val), ] inside the reactive expression, I'm unable to subset as suggested by the fix: Error in data$val : object of type 'closure' is not subsettable and I can't seem to find any other place for it to work.
reproducible app.r:
library(tidyverse)
library(shiny)
library(shinydashboard)
library(plotly)
# generate sample p & t observation data
zone <- c(rep("a", 6), rep("b", 6), rep("c", 6), rep("d", 6))
set.seed(1)
val <- rnorm(24, 12, 18)
param <- rep(c("p", "t"), 12)
p_t <- data.frame(zone, val, param, stringsAsFactors = FALSE)
# sample elevation frequency data - too many obs to uncount all at once
set.seed(2)
val <- sample(50, 24)
count <- sample(200000, 24)
e_countcsv <- data.frame(zone, val, count, stringsAsFactors = FALSE) %>%
mutate(param = "elev")
shinyApp(
ui = fluidPage(
sidebarLayout(sidebarPanel(
selectizeInput(
"zone", "zone", choices = unique(p_t$zone),
selected = c("a"),
multiple = TRUE),
checkboxGroupInput("param", "parameter",
choices = c("elev", "p", "t"), selected =c("elev", "p"))
),
mainPanel(
tabsetPanel(position=c("right"),
tabPanel(strong("static cdf"),
br(),
plotOutput("reg_plot", height = "750px")) ,
tabPanel(strong("interactive cdf"),
br(),
plotlyOutput("plotlyPlot", height = "750px")) )))
),
server = function(input, output) {
data <- reactive({
p_t %>%
filter(param %in% input$param,
zone %in% input$zone) %>%
bind_rows({e_countcsv %>%
filter(param %in% input$param,
zone %in% input$zone) %>%
uncount(count)})
})
output$reg_plot <- renderPlot({
ggplot(data(), aes(val, color = param, linetype = zone)) +
labs(y = "proportion of total", x = NULL) +
stat_ecdf(pad = FALSE) + coord_flip()
})
output$plotlyPlot <- renderPlotly({
p <- ggplot(data(), aes(val, color = param, linetype = zone)) +
labs(y = "proportion of total", x = NULL) +
stat_ecdf(pad = FALSE) + coord_flip()
p <- ggplotly(p)
p
})
}
)
Any ideas? Thank you!

Like #MrGumble suggested you should not use data as a name because it points to a function (try to print data in your console and you will see the function).
Just give your dataset in the reactive expression another name and it will work:
data <- reactive({
dataset <- p_t %>%
filter(param %in% input$param,
zone %in% input$zone) %>%
bind_rows({e_countcsv %>%
filter(param %in% input$param,
zone %in% input$zone) %>%
uncount(count)})
dataset[order(dataset$val), ]
})

Related

Flexdashboard Shiny - output not showing the complete output after knitting

When I knitting the following code in Flexdashboard in R Markdown file, the entire file is not giving output on the entire page, however when I run the code chunk individually it is showing the correct output.
I have tried adjusting Column {width } as well, but nothing is happening.
title: "By sachin"
output:
flexdashboard::flex_dashboard:
orientation: columns
vertical_layout: fill
library(flexdashboard)
Page 1
Column {data-width=650}
Chart A
library(dplyr)
library(tidyverse)
library(ggplot2)
df <- read.csv("data.csv")
#view(df)
df1 <- subset(df, select = c("year","dem","all_pass"))
#str(df1)
df1$dem <- as.character(df1$dem)
df1$dem = factor(df1$dem, levels = c(0,1),
labels = c("Democrat","Republic"))
#view(df2)
#colnames(df2)<-c("Year","Party","All Bills Passed")
df2 <-df1 %>% group_by(year,dem) %>% summarise_at(vars(all_pass),funs(sum(. , na.rm = TRUE)))
#df2 <-df1 %>% group_by(year,dem ) %>% summarise_at(vars(all_pass),funs(sum(. , na.rm = TRUE)))
ggplot(df2, aes(x=year, fill = dem )) + geom_area(aes(y = all_pass))+labs(y = "All Bills Passed", x = "Year", title = "Number of bills passed since 1980")
Page 2
Column {data-width=500}
Chart B
library(dplyr)
library(tidyverse)
library(broom)
library(ggplot2)
library(plotly)
#install.packages("jtools")
library(jtools)
df <- read.csv("data.csv")
df <- filter(df, df$congress==110)
#view(df)
df3 <- subset(df, select = c(dem, all_pass,votepct))
#view(df3)
#df3 <- filter(df3, dem ==0 & dem ==1)
#view(df3)
df3$dem <- as.character(df3$dem)
df3$dem = factor(df3$dem, levels = c(0,1),
labels = c("Democrat","Republic"))
#view(df3)
#fit<- lm(formula = votepct~dem,df3)
ggplot(df3, aes(x=votepct,y = all_pass, fill = dem,colour = dem )) + geom_point(aes(y = all_pass),size=3)+labs(y = "All Pass", x = "votepct", title = "Passage and Vote Pct , 110th Congress")+ geom_smooth(method="lm")
#df4 <-df3 %>% group_by(dem) %>% summarise_at(vars(all_pass),funs(sum(. , na.rm = TRUE)))
#view(df4)
#abline(fit)
#effect_plot(fit, pred = "dem",interval = TRUE, plot.points = TRUE)
#(fit, pred = votepct, interval = TRUE, plot.points = TRUE)
Column {data-width=500}
Chart C
library(dplyr)
library(tidyverse)
library(broom)
library(ggplot2)
library(plotly)
#install.packages("jtools")
library(jtools)
df <- read.csv("data.csv")
df <- filter(df, df$congress==110)
#view(df)
df5 <- subset(df, select = c(dem, all_pass,dwnom1))
#view(df5)
#df3 <- filter(df3, dem ==0 & dem ==1)
#view(df3)
df5$dem <- as.character(df5$dem)
df5$dem = factor(df5$dem, levels = c(0,1),
labels = c("Democrat","Republic"))
#view(df5)
fit<- lm(formula = all_pass~dwnom1,df5)
ggplot(df5, aes(x=dwnom1,y = all_pass, fill = dem,colour = dem )) + geom_point(aes(y = all_pass),size=3)+labs(y = "All Pass", x = "DW Nominate", title = "Passage and Ideology , 110th Congress")+geom_smooth(method="lm")
Page 3
Column {data-width=650}
Chart D
library(ggplot2)
library(plotly)
library(dplyr)
library(shiny)
ui <- basicPage(
h1("Total bills passed by state delegation, 110th Congress"),
selectizeInput(inputId = "bins",
label = "Choose State",
choices = state.abb,
multiple = TRUE),
plotOutput("plot")
)
server <- function(input, output) {
df <-
tibble(all_pass = sample(1:500, 350),
st_name = rep(state.abb, 7))
output$plot <- renderPlot({
req(input$bins)
df |>
filter(st_name %in% input$bins) |>
ggplot(aes(y = all_pass,x=st_name )) +
geom_bar(stat = "sum")
})
}
shinyApp(ui = ui, server = server)

Shiny failed to read column based on selectInput from uploaded csv

Problem:
I was trying to build a shiny app that plot frequency of n-grams based on a user specified column from a user uploaded csv. In addition, a function was added to plot the senetiment over time, based on a date column specified by the user as well.
The app was working okay locally, with Warning, but failed work after published. Please see the following for a reproducible example.
Preparation: libraries and example data
# Load R packages
library(shiny)
library(tidyverse)
library(shinythemes)
library(lubridate)
library(tidytext)
library(textdata)
# Creating a example csv file for upload
Sample_csv <-
data.frame(text = janeaustenr::emma,
id = 1:length(janeaustenr::emma),
date = sample(seq(as.Date('1900/01/01'), as.Date('1920/01/01'), by="day"),
replace = T,
length(janeaustenr::emma)))
write.csv(Sample_csv, "Sample_csv.csv", row.names = F)
UI
ui <- fluidPage(theme = shinytheme("united"),
titlePanel("Text glancer"),
sidebarLayout(
sidebarPanel(
# Input: Select a file ----
fileInput("csv_file", "Feed csv here",
multiple = FALSE,
accept = c(".csv")),
#Conditional panel
conditionalPanel(
# use a server side condition
condition = "output$fileUploaded",
# Input: Select ----
uiOutput("text_select"),
# Input: Select ----
uiOutput("date_select"),
# Input: Simple integer interval ----
sliderInput("top_frequency", "Top n ngrams to be plotted:",
min = 5, max = 20, value = 10),
# Input: Select ----
selectInput("ngrams", "Ngrams of your choice:",
c("Single word" = 1,
"Bigram" = 2,
"Trigram" = 3)
)
),
# Submit bottom
submitButton("Update View", icon("refresh"))
),
# sidebarPanel
mainPanel(
tabsetPanel(
tabPanel(h2("Most frequenlty used n-grams"),
plotOutput("frequency_plot", height = 900, width = 1200)),
tabPanel(h2("Sentiment of the months"),
plotOutput("sentiment_plot", height = 900, width = 1200))
)
)
)
)
server
server <- function(input, output, session) {
# create reactive version of the dataset (a data.frame object)
LOAD_DATA <- reactive({
infile <- input$csv_file
if (is.null(infile))
{return(NULL)}
{read_csv(infile$datapath)}
})
# inform conditionalPanel wheter dropdowns sohould be hidden
output$fileUploaded <- reactive({
return(!is.null(LOAD_DATA()))
})
outputOptions(output, 'fileUploaded', suspendWhenHidden=FALSE)
## update 'column' selectors
output$text_select <- renderUI({
if(is.null(LOAD_DATA()))
{return(NULL)}
else
selectInput("text_col", "Select the text column:", colnames(LOAD_DATA()))
})
output$date_select <- renderUI({
if(is.null(LOAD_DATA()))
{return(NULL)}
else
selectInput("date_col", "Select the date column (ymd):", colnames(LOAD_DATA()))
})
# Create reactive parameters
TOP_FREQUENCY <- reactive({
input$top_frequency
})
N_GRAMS <- reactive({
as.numeric(as.character(input$ngrams))
})
# Output frequency of ngrams
output$frequency_plot <- renderPlot( {
if(is.null(LOAD_DATA()))
{return(NULL)}
else{
WORK_DATA <- LOAD_DATA()[,c(input$text_col,
input$date_col)]
names(WORK_DATA) <- c("TEXTS", "DATES")
CSV_DOC_N_Grams <-
WORK_DATA %>%
# LOAD_DATA() %>%
# select(TEXTS = TEXT_COL(), DATES = DATE_COL()) %>%
mutate(TEXTS = gsub("http.*", " ", TEXTS)) %>%
# mutate(text = gsub("\\#.* |\\#.* .|\\#.* ,", " ", text)) %>%
unnest_tokens(words, TEXTS, token = "ngrams", n = N_GRAMS()) %>%
select(words) %>%
filter(str_detect(words, "[a-zA-Z]")) %>%
separate(words, c("word1","word2","word3"),sep = " ", remove = F) %>%
filter(! word1 %in% stop_words$word &
! word2 %in% stop_words$word&
! word3 %in% stop_words$word)
#Counting ngrams
CSV_DOC_N_Gramss_Count <-
CSV_DOC_N_Grams %>%
count(words, sort=T) %>%
select(N_Gram_Text = words,
N_Gram_Count = n)
#Plotting ngram frequency
CSV_DOC_N_Gramss_Count_freq <-
CSV_DOC_N_Gramss_Count %>%
mutate(N_Gram_Text = fct_reorder(N_Gram_Text, N_Gram_Count)) %>%
top_n(TOP_FREQUENCY(), N_Gram_Count) %>%
ggplot(aes(x = N_Gram_Text,
y = N_Gram_Count,
fill = N_Gram_Count)) +
geom_col()+
coord_flip() +
scale_fill_gradient2()+
labs(title = paste0("Top ", TOP_FREQUENCY(), " ngrams used in csv doc"),
x = "ngrams",
y = "frequency") +
theme_bw()+
theme(legend.position = "none",
axis.text.x = element_text(face='bold',size=12),
axis.text.y = element_text(face='bold',size=12),
axis.title.x = element_text(face='bold',size=18),
axis.title.y = element_blank())
print(CSV_DOC_N_Gramss_Count_freq)
}
})
output$sentiment_plot <- renderPlot( {
if(is.null(LOAD_DATA())){return(NULL)}
else{
WORK_DATA <- LOAD_DATA()[,c(input$text_col,
input$date_col)]
names(WORK_DATA) <- c("TEXTS", "DATES")
tk_afinn <-
WORK_DATA %>%
mutate(TEXTS = gsub("http.*", " ", TEXTS)) %>%
unnest_tokens(word, TEXTS) %>%
filter(! word %in% stop_words$word) %>%
filter(str_detect(word, "[a-zA-Z]")) %>%
filter(! DATES %in% NA) %>%
inner_join(get_sentiments("afinn")) %>%
mutate(YEAR_Month = ymd(paste(year(DATES),
month(DATES),
"1", sep="-"))) %>%
group_by(index = YEAR_Month) %>%
summarise(sentiment = sum(value))
tk_afinn_plot <-
tk_afinn %>%
ggplot(aes(x = index, y = sentiment)) +
geom_line()+
labs(x = "date (year-month)",
y = "sentiment of the month") +
theme_bw()+
theme(legend.position = "none",
axis.text.x = element_text(face='bold',size=12),
axis.text.y = element_text(face='bold',size=12),
axis.title.x = element_text(face='bold',size=18),
axis.title.y = element_blank())
print(tk_afinn_plot)
}
})
}
Fuse
shinyApp(ui = ui, server = server)
Warnings:
After loading the csv file, the local app reports :
"Problem with mutate() input TEXTS.
object 'TEXTS' not found
Input TEXTS is gsub("http.*", " ", TEXTS)."
After specify the text column and date column, both tab showed plots. However, after publishing it to shinyapp.io, it reports error and would not run.
Can anybody help with this issue? I have consulted the other thread includin this>https://stackoverflow.com/questions/47248534/dynamically-list-choices-for-selectinput-from-a-user-selected-column, but still no luck.
Any insight would be greatly appreciated!

RShiny: why does ggplot geom_rect fail with reactive faceting?

I am trying to create interactive plots with Shiny where the user can select faceting variables. I also want to plot temperature data underneath the point/line data. This all works fine until I try to incorporate a reactive faceting function AND add a geom_rect call, when I get the error:
Warning: Error in : Assigned data `layout$PANEL[match(keys$x, keys$y)]` must be compatible with existing data.
x Existing data has 1094 rows.
x Assigned data has 32 rows.
i Only vectors of size 1 are recycled.
I'm assuming that I've done something wrong with my faceting function, but I'm on week 2 of being unable to solve this issue, so it's time to ask for help!
Here is a simplified mock-up of the app. I can add two facets, OR I can add the temperature underlay, but trying both results in the error above.
library(shiny)
library(shinydashboard)
library(lubridate)
library(tidyr)
library(readr)
{ # Setup ----
# Create a dummy data frame
sitename <- rep(c("A", "B", "C", "D", "E", "F", "G", "H"), times = 4)
region <- rep(c("North", "South", "East", "West"), times = 8)
elevation <- rep(c("High", "Low"), each = 4, length.out = 32)
date <- as.Date(rep(c("2015-01-01", "2016-01-01", "2017-01-01", "2018-01-01"), each = 8))
affected <- runif(32, min = 0, max = 1)
sitedata <- data.frame(date, sitename, region, elevation, affected)
# Load and process external temperature data
noaacrw <- read_table2("http://coralreefwatch.noaa.gov/product/vs/data/guam.txt", skip = 21)
noaacrw <- noaacrw %>%
mutate(DateStart = as.Date(ISOdate(noaacrw$YYYY, noaacrw$MM, noaacrw$DD))) %>%
mutate(DateEnd = as.Date(DateStart + (as.Date(DateStart) - lag(as.Date(DateStart), default = first(DateStart))))) %>%
mutate(SST_AVG = `SST#90th_HS`) %>%
select(DateStart, DateEnd, SST_AVG) %>%
filter(DateStart > as.Date("2015-01-01")) %>%
filter(DateEnd < as.Date("2018-01-01"))
}
# UI ----
ui <- fluidPage(
fluidRow(
box(
title = "Choose your data", width = 3, solidHeader = TRUE,
selectInput("facet_select", "Select faceting variable:",
choices = list("None" = "none",
"Region" = "region",
"Elevation" = "elevation"),
selected = c("None")),
selectInput("facet2_select", "Select second faceting variable",
choices = list("None" = "none",
"Region" = "region",
"Elevation" = "elevation")),
checkboxInput("show_temp", "Show temperature data", FALSE)
),
box(
title = "See your data output", width = 9, solidHeader = TRUE,
plotOutput("siteplot", height = 500)
)
)
)
And the server side:
server <- function(input, output) {
facet1 <- reactive({
if(input$facet_select == "region"){return(region)}
if(input$facet_select == "elevation"){return(elevation)}
})
facet2 <- reactive({
if(input$facet_select == "region"){return(region)}
if(input$facet_select == "elevation"){return(elevation)}
})
faceter <- reactive({
if(input$facet_select == "none"){return(NULL)}
else if(input$facet_select != "none" & input$facet2_select == "none")
{return(list(facet_grid(facet1() ~ .)))}
else if(input$facet_select != "none" & input$facet2_select != "none")
{return(list(facet_grid(facet1() ~ facet2())))}
})
temperature <- reactive({
if(input$show_temp == FALSE){return(NULL)}
else if(input$show_temp == TRUE){return(list(
geom_rect(data = noaacrw,
aes(xmin = DateStart, xmax = DateEnd, ymin = 0, ymax = Inf, fill = SST_AVG),
position = "identity", show.legend = TRUE, alpha = 0.5),
scale_fill_gradient2(high = "red3", mid = "white", low = "blue3", midpoint = 28)))}
})
output$siteplot <- renderPlot({
ggplot()+
temperature()+
geom_point(data = sitedata, aes(x = date, y = affected, group = sitename, color = sitename), size = 3)+
geom_line(data = sitedata, aes(x = date, y = affected, group = sitename, color = sitename), size = 3)+
#facet_grid(elevation ~ region) <-- this works!
faceter() # <- but this does not!
})
}
# Run the application
shinyApp(ui = ui, server = server)
Here is my take (I used syms(...)). It works under R4.0, at least:
library(shiny)
library(shinydashboard)
library(lubridate)
library(tidyr)
library(readr)
library(ggplot2)
library(dplyr)
{ # Setup ----
# Create a dummy data frame
sitename <- rep(c("A", "B", "C", "D", "E", "F", "G", "H"), times = 4)
region <- rep(c("North", "South", "East", "West"), times = 8)
elevation <- rep(c("High", "Low"), each = 4, length.out = 32)
date <- as.Date(rep(c("2015-01-01", "2016-01-01", "2017-01-01", "2018-01-01"), each = 8))
affected <- runif(32, min = 0, max = 1)
sitedata <- data.frame(date, sitename, region, elevation, affected)
# Load and process external temperature data
noaacrw <- read_table2("http://coralreefwatch.noaa.gov/product/vs/data/guam.txt", skip = 21)
noaacrw <- noaacrw %>%
mutate(DateStart = as.Date(ISOdate(noaacrw$YYYY, noaacrw$MM, noaacrw$DD))) %>%
mutate(DateEnd = as.Date(DateStart + (as.Date(DateStart) - lag(as.Date(DateStart), default = first(DateStart))))) %>%
mutate(SST_AVG = `SST#90th_HS`) %>%
select(DateStart, DateEnd, SST_AVG) %>%
filter(DateStart > as.Date("2015-01-01")) %>%
filter(DateEnd < as.Date("2018-01-01"))
}
# UI ----
ui <- fluidPage(
fluidRow(
box(
title = "Choose your data", width = 3, solidHeader = TRUE,
selectInput("facet_select", "Select faceting variable:",
choices = list("None" = NULL,
"Region" = "region",
"Elevation" = "elevation"),
selected = c("None"),
multiple = TRUE),
checkboxInput("show_temp", "Show temperature data", FALSE)
),
box(
title = "See your data output", width = 9, solidHeader = TRUE,
plotOutput("siteplot", height = 500)
)
)
)
server <- function(input, output) {
temperature <- reactive({
if(!input$show_temp){return(NULL)}
else if(input$show_temp){return(list(
geom_rect(data = noaacrw,
aes(xmin = DateStart, xmax = DateEnd, ymin = 0, ymax = Inf, fill = SST_AVG),
position = "identity", show.legend = TRUE, alpha = 0.5),
scale_fill_gradient2(high = "red3", mid = "white", low = "blue3", midpoint = 28)))}
})
makePlot <- function(...){
p <- ggplot()+
temperature()+
geom_point(data = sitedata, aes(x = date, y = affected, group = sitename, color = sitename), size = 3)+
geom_line(data = sitedata, aes(x = date, y = affected, group = sitename, color = sitename), size = 3)
if(length(eval(substitute(alist(...)))) > 0){
p <- p + facet_grid(syms(...))
}
return(p)
}
output$siteplot <- renderPlot({
makePlot(input$facet_select)
})
}
# Run the application
shinyApp(ui = ui, server = server)

R Shiny application for comparing two chronologies

I am providing here an executable simple R shiny application to plot two lines based on column names.
library(shiny)
library(reshape2)
library(ggplot2)
library(dplyr)
ui <- shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
uiOutput("moreControls")
),
mainPanel(
tabsetPanel(type = "tabs",
tabPanel("Cross dating", plotOutput("plot1"))
)
)
)
))
server <- shinyServer(function(input, output) {
datasetInput <- data.frame(chrono_A = rnorm(16,0),chrono_B = rnorm(16,0))
row.names(datasetInput) <- c(seq(2000, 2015))
col_names <- colnames(datasetInput)
output$moreControls <- renderUI({
checkboxGroupInput("variable", "Filter Options", col_names)
})
# Plot data
output$plot1 <- renderPlot({
datasetInput_short <- mutate(datasetInput, year = as.numeric(row.names(datasetInput)))
datasetInput_short <- melt(datasetInput_short, id = c("year"))
datasetInput_short <- dplyr::filter(datasetInput_short, variable %in% input$variable)
ggplot(datasetInput_short, aes(x = year, y = value, group = variable, col = variable)) +
geom_line() + theme_bw() + ylim(-3, 3)
})
})
shinyApp(ui = ui, server = server)
I would like to add two features, which would allow me to move the plotted lines in two ways:
By adding a window where I can directly add the final year for the curve (ideally, the current final year would be entered automatically)
By adding two additional buttons (+ and -), and by clicking them I move each line by one year
Please, see the image below:
Any suggestion is highly appreciated.
I reread your description, maybe this might be helpful, though not entirely sure this is what you have in mind.
You can add two textInput widgets and then add filters to your data so that the data displayed for A and B have years less than these values.
In addition, you can have reactiveValues that include an offsets for A and B that increase/decrease when the buttons are pressed. These offsets will change the year column from the filtered data for A and/or B.
server <- shinyServer(function(input, output) {
datasetInput <- data.frame(chrono_A = rnorm(16,0),chrono_B = rnorm(16,0))
row.names(datasetInput) <- c(seq(2000, 2015))
col_names <- colnames(datasetInput)
rv <- reactiveValues(offset_A = 0, offset_B = 0)
observeEvent(input$but_plus_A, {
rv$offset_A <- rv$offset_A + 1
})
observeEvent(input$but_minus_A, {
rv$offset_A <- rv$offset_A - 1
})
observeEvent(input$but_plus_B, {
rv$offset_B <- rv$offset_B + 1
})
observeEvent(input$but_minus_B, {
rv$offset_B <- rv$offset_B - 1
})
datasetInput_short <- reactive({
datasetInput %>%
mutate(year = as.numeric(row.names(.))) %>%
pivot_longer(cols = starts_with("chrono_"), names_to = "variable", values_to = "value") %>%
dplyr::filter(variable %in% input$variable,
(variable == "chrono_A" & year < input$sel_A) | (variable == "chrono_B" & year < input$sel_B)) %>%
mutate(year = if_else(variable == "chrono_A", year + rv$offset_A, year),
year = if_else(variable == "chrono_B", year + rv$offset_B, year))
})
output$moreControls <- renderUI({
list(
checkboxGroupInput("variable", "Filter Options", col_names),
textInput("sel_A", "Year A", 2015),
actionButton("but_plus_A", "", icon = icon("plus")),
actionButton("but_minus_A", "", icon = icon("minus")),
textInput("sel_B", "Year B", 2015),
actionButton("but_plus_B", "", icon = icon("plus")),
actionButton("but_minus_B", "", icon = icon("minus"))
)
})
# Plot data
output$plot1 <- renderPlot({
ggplot(datasetInput_short(), aes(x = year, y = value, group = variable, col = variable)) +
geom_line() + theme_bw() + ylim(-3, 3)
})
})
Edit:
Based on OP comment below, say you do not know the column names, but there are always 2 columns to work with, you can do the following. You can use the column names vector col_names when filtering.
datasetInput_short <- reactive({
datasetInput %>%
mutate(year = as.numeric(row.names(.))) %>%
pivot_longer(cols = all_of(col_names), names_to = "variable", values_to = "value") %>%
dplyr::filter(variable %in% input$variable,
(variable == col_names[1] & year < input$sel_A) | (variable == col_names[2] & year < input$sel_B)) %>%
mutate(year = if_else(variable == col_names[1], year + rv$offset_A, year),
year = if_else(variable == col_names[2], year + rv$offset_B, year))
})
It is possible to dynamically generate more than 2 sets of inputs (for example, using 3: A, B, and C) but that would be a bit more complex.

R Shiny how to get ggplot to do color/shapes by dplyr filters

the following code works(without any color/shape inputs), however trying to make the points different shapes/colors has proved difficult, I'm not sure what the problem is.
I'm trying to have:
year/range have a yellow outline around the shape
Product/inpt is to be different shapes
status/Role be different colors
library(shiny)
library(dplyr)
library(shinydashboard)
library(tidyverse)
ui <- dashboardPage(
dashboardHeader(title="Membership Satisfaction"),
dashboardSidebar(
sidebarMenu(
menuItem("Demographics Dashboard", tabName = "demos", icon =
icon("dashboard"))
)
),
dashboardBody(
tabItems(
tabItem(tabName = "demos",
sidebarPanel(
checkboxGroupInput("inpt","Select variables to plot", choices =
c("Web" = 1,"Huddle" = 3, "Other" = 5,
"Test" = 7)),
checkboxGroupInput("role",
"Select Primary Role of Interest",
choices = c("Student" = 1, "Not" = 2)),
checkboxGroupInput("range",
"Select year(S) of Interest",
choices = c("2016"=2,"July 2017"=1))),
fluidPage(
plotOutput("plot")
# tableOutput("test")
)))))
My server:
server <- function(input,output){
library(tidyverse)
xPre <- reactive({
inpt <- as.double(input$inpt)
role <- as.double(input$role)
range <- as.double(input$range)
GapAnalysis_LongFormB %>%
filter(Product %in% inpt,
year %in% range)
})
yPre <- reactive({
inpt <- as.double(input$inpt)+1
role <- as.double(input$role)
range <- as.double(input$range)
GapAnalysis_LongFormB %>%
filter(Product %in% inpt,
year %in% range)
})
xPost<- reactive({
xPre<- xPre()
inpt <- as.double(input$inpt)
role <- as.double(input$role)
range <- as.double(input$range)
xPre %>%
filter(year %in% range,
Product %in% inpt,
status %in% role)%>%
group_by(Product, status,year)%>%
summarize(avg = mean(Score, na.rm = TRUE)) %>%
pull(-1)
})
yPost<- reactive({
yPre <- yPre()
inpt <- as.double(input$inpt)+1
role <- as.double(input$role)
range <- as.double(input$range)
yPre %>%
filter(year %in% range,
Product %in% inpt,
status %in% role)%>%
group_by(Product, status,year)%>%
summarize(avg = mean(Score, na.rm = TRUE)) %>%
pull(-1)
})
ySum <- reactive({
yPre <- yPre()
inpt <- as.double(input$inpt)+1
role <- as.double(input$role)
range <- as.double(input$range)
yPre %>%
filter(year %in% range,
Product %in% inpt)%>%
group_by(Product,year)%>%
summarize(avg = mean(Score, na.rm = TRUE)) %>%
pull(-1)
})
xSum <- reactive({
xPre <- xPre()
inpt <- as.double(input$inpt)
role <- as.double(input$role)
range <- as.double(input$range)
xPre %>%
filter(year %in% range,
Product %in% inpt)%>%
group_by(Product,year)%>%
summarize(avg = mean(Score, na.rm = TRUE)) %>%
pull(-1)
})
xyCoords<- reactive({
xPost <- xPost()
yPost <- yPost()
xSum <- xSum()
ySum <- ySum()
as.data.frame(matrix(c(xPost,xSum,yPost,ySum),ncol = 2))
})
output$test<- renderTable({
xyCoords <- xyCoords()
})
output$plot <- renderPlot({
xyCoords <- xyCoords()
xyCoords %>%
ggplot(aes(x=V1, y =V2 )) +
geom_point(colour = "blue", shape = 17, size = 5 )+
labs(x = "Mean Satisfaction", y = "Mean Importance") +
xlim(0,5) + ylim(0,5) +
geom_vline(xintercept=2.5) +
geom_hline(yintercept = 2.5)
})
}
shinyApp (ui = ui, server = server)
variable structure for GapAnalysis_LongFormB:
structure(list(status = c(1, 5, 5, 1, 1, 5), year = c(1, 1, 1,
1, 1, 1), Product = structure(c(1L, 1L, 1L, 1L, 1L, 1L), .Label = c("1",
"2", "3", "4"), class = "factor"), Score = c(2, 5, 3, 5, 4, 4
)), .Names = c("status", "year", "Product", "Score"), row.names = c(NA,
6L), class = "data.frame")
when I try doing color = input$inpt or shape = input$inpt I get an error "Aesthetics must be either length 1 or the same as the data (3): shape, colour, size"
Any ideas?? THANKS!!

Resources